diff options
402 files changed, 20939 insertions, 12228 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index f802040a1d..06a733be45 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -240,8 +240,7 @@ azure-pipelines.yml @coq/ci-maintainers /theories/QArith/ @herbelin -/theories/Reals/ @silene -# Secondary maintainer @ppedrot +/theories/Reals/ @coq/reals-library-maintainers /theories/Relations/ @mattam82 # Secondary maintainer @ppedrot diff --git a/.gitignore b/.gitignore index 4e02e7617c..8fd9fc614c 100644 --- a/.gitignore +++ b/.gitignore @@ -64,6 +64,8 @@ time-of-build.log time-of-build-pretty.log time-of-build-before.log time-of-build-after.log +time-of-build-pretty.log2 +time-of-build-pretty.log3 .csdp.cache test-suite/.lia.cache test-suite/.nra.cache @@ -150,6 +152,8 @@ kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe kernel/copcodes.ml kernel/uint63.ml +ide/default.bindings +ide/default_bindings_src.exe ide/index_urls.txt .lia.cache .nia.cache diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 58be1e4524..ec3702b360 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -65,6 +65,8 @@ after_script: - config/coq_config.py - test-suite/misc/universes/all_stdlib.v expire_in: 1 week + variables: + timeout: "" script: - set -e @@ -77,8 +79,8 @@ after_script: - echo 'end:coq.config' - echo 'start:coq.build' - - make -j "$NJOBS" byte - - make -j "$NJOBS" world $EXTRA_TARGET + - $timeout make -j "$NJOBS" byte + - $timeout make -j "$NJOBS" world $EXTRA_TARGET - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' @@ -154,12 +156,14 @@ after_script: - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ - export OCAMLPATH=$(readlink -f ../_install_ci/lib/):"$OCAMLPATH" - - make -j "$NJOBS" BIN="$BIN" COQLIB="$LIB" COQFLAGS="${COQFLAGS}" all + - $timeout make -j "$NJOBS" BIN="$BIN" COQLIB="$LIB" COQFLAGS="${COQFLAGS}" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure paths: - test-suite/logs + variables: + timeout: "" # set dependencies when using .validate-template: @@ -252,6 +256,7 @@ build:base+async: variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" + timeout: "timeout 100m" allow_failure: true # See https://github.com/coq/coq/issues/9658 only: variables: @@ -262,6 +267,7 @@ build:quick: variables: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" + timeout: "timeout 100m" allow_failure: true # See https://github.com/coq/coq/issues/9637 only: variables: @@ -359,7 +365,7 @@ pkg:nix:deploy:channel: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null - git fetch --unshallow - git branch -v - - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"${CI_COMMIT_REF_NAME}" + - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"refs/heads/${CI_COMMIT_REF_NAME}" pkg:nix: extends: .nix-template @@ -516,7 +522,8 @@ test-suite:base+async: dependencies: - build:base variables: - COQFLAGS: "-async-proofs on" + COQFLAGS: "-async-proofs on -async-proofs-cache force" + timeout: "timeout 100m" allow_failure: true only: variables: @@ -553,6 +560,9 @@ validate:quick: # Libraries are by convention the projects that depend on Coq # but not on its ML API +library:ci-argosy: + extends: .ci-template + library:ci-bedrock2: extends: .ci-template @@ -45,7 +45,8 @@ Julien Forest <julien.forest@ensiie.fr> forest <jforest@mourvedre.ens Julien Forest <julien.forest@ensiie.fr> jforest <jforest@thune> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@daneel.lan.home> Julien Forest <julien.forest@ensiie.fr> Julien Forest <forest@ensiie.fr> -Emilio Jesus Gallego Arias <e+git@x80.org> Emilio Jesús Gallego Arias <e+git@x80.org> +Emilio Jesús Gallego Arias <e@x80.org> Emilio Jesus Gallego Arias <e+git@x80.org> +Emilio Jesús Gallego Arias <e@x80.org> Emilio Jesús Gallego Arias <e+git@x80.org> Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@ens-lyon.fr> Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@skyskimmer.net> Stéphane Glondu <steph@glondu.net> glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7> diff --git a/CHANGES.md b/CHANGES.md index dcf321c7ff..fc7272da65 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,5 @@ -Changes from 8.9 to 8.10 -======================== +Unreleased changes +================== OCaml and dependencies @@ -46,6 +46,11 @@ Specification language, type inference solved by writing an explicit `return` clause, sometimes even simply an explicit `return _` clause. +- Using non-projection values with the projection syntax is not + allowed. For instance "0.(S)" is not a valid way to write "S 0". + Projections from non-primitive (emulated) records are allowed with + warning "nonprimitive-projection-syntax". + Kernel - Added primitive integers @@ -67,9 +72,34 @@ Notations - New command `String Notation` to register string syntax for custom inductive types. +- Numeral notations now parse decimal constants such as 1.02e+01 or + 10.2. Parsers added for Q and R. This should be considered as an + experimental feature currently. + Note: in -- the rare -- case when such numeral notations were used + in a development along with Q or R, they may have to be removed or + deconflicted through explicit scope annotations (1.23%Q, + 45.6%R,...). + - Various bugs have been fixed (e.g. PR #9214 on removing spurious parentheses on abbreviations shortening a strict prefix of an application). +- Numeral Notations now support inductive types in the input to + printing functions (e.g., numeral notations can be defined for terms + containing things like `@cons nat O O`), and parsing functions now + fully normalize terms including parameters of constructors (so that, + e.g., a numeral notation whose parsing function outputs a proof of + `Nat.gcd x y = 1` will no longer fail to parse due to containing the + constant `Nat.gcd` in the parameter-argument of `eq_refl`). See + #9840 for more details. + +- Deprecated compatibility notations have actually been removed. Uses + of these notations are generally easy to fix thanks to the hint + contained in the deprecation warnings. For projects that require + more than a handful of such fixes, there is [a + script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) + that will do it automatically, using the output of coqc. The script + contains documentation on its usage in a comment at the top. + Plugins - The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) @@ -109,6 +139,8 @@ Tactics - The syntax of the `autoapply` tactic was fixed to conform with preexisting documentation: it now takes a `with` clause instead of a `using` clause. + + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -153,6 +185,16 @@ Vernacular commands - The `Show Script` command has been deprecated. +- Option `Refine Instance Mode` has been deprecated and will be removed in + the next version. + +- `Coercion` does not warn ambiguous paths which are obviously convertible with + existing ones. + +- A new flag `Fast Name Printing` has been introduced. It changes the + algorithm used for allocating bound variable names for a faster but less + clever one. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -177,6 +219,18 @@ Tools priorities, so that prefixes resolve to the most convenient bindings. The documentation pages for CoqIDE provides further details. +- The pretty timing diff scripts (flag `TIMING=1` to a + `coq_makefile`-made `Makefile`, also + `tools/make-both-single-timing-files.py`, + `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) + now correctly support non-UTF-8 characters in the output of + `coqc`/`make` as well as printing to stdout, on both python2 and + python3. + +- Coq options can be set on the command line, eg `-set "Universe Polymorphism=true"` + +- coq_makefile's install target now errors if any file to install is missing. + Standard Library - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about @@ -200,6 +254,9 @@ Standard Library - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. +- Moved the `auto` hints of the `FSet` library into a new + `fset` database. + Universes - Added `Print Universes Subgraph` variant of `Print Universes`. @@ -256,4021 +313,3 @@ Diffs - Some error messages that show problems with a pair of non-matching values will now highlight the differences. - - -Changes from 8.8.2 to 8.9+beta1 -=============================== - -Kernel - -- Mutually defined records are now supported. - -Notations - -- New support for autonomous grammars of terms, called "custom - entries" (see chapter "Syntax extensions" of the reference manual). - -- Deprecated compatibility notations will actually be removed in the - next version of Coq. Uses of these notations are generally easy to - fix thanks to the hint contained in the deprecation warnings. For - projects that require more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script - contains documentation on its usage in a comment at the top. - -- When several notations are available for the same expression, - priority is given to latest notations defined in the scopes being - opened, in order, rather than to the latest notations defined - independently of whether they are in an opened scope or not. - -Tactics - -- Added toplevel goal selector `!` which expects a single focused goal. - Use with `Set Default Goal Selector` to force focusing before tactics - are called. - -- The undocumented "nameless" forms `fix N`, `cofix` that were - deprecated in 8.8 have been removed from Ltac's syntax; please use - `fix ident N/cofix ident` to explicitly name the (co)fixpoint - hypothesis to be introduced. - -- Introduction tactics `intro`/`intros` on a goal that is an - existential variable now force a refinement of the goal into a - dependent product rather than failing. - -- Support for `fix`/`cofix` added in Ltac `match` and `lazymatch`. - -- Ltac backtraces now include trace information about tactics - called by OCaml-defined tactics. - -- Option `Ltac Debug` now applies also to terms built using Ltac functions. - -- Deprecated the `Implicit Tactic` family of commands. - -- The default program obligation tactic uses a bounded proof search - instead of an unbounded and potentially non-terminating one now - (source of incompatibility). - -- The `simple apply` tactic now respects the `Opaque` flag when called from - Ltac (`auto` still does not respect it). - -- Tactic `constr_eq` now adds universe constraints needed for the - identity to the context (it used to ignore them). New tactic - `constr_eq_strict` checks that the required constraints already hold - without adding new ones. Preexisting tactic `constr_eq_nounivs` can - still be used if you really want to ignore universe constraints. - -- Tactics and tactic notations now understand the `deprecated` attribute. -- The `fourier` tactic has been removed. Please now use `lra` instead. You - may need to add `Require Import Lra` to your developments. For compatibility, - we now define `fourier` as a deprecated alias of `lra`. - -- The `romega` tactics have been deprecated; please use `lia` instead. - -Focusing - -- Focusing bracket `{` now supports named goal selectors, - e.g. `[x]: {` will focus on a goal (existential variable) named `x`. - As usual, unfocus with `}` once the sub-goal is fully solved. - -Specification language - -- A fix to unification (which was sensitive to the ascii name of - variables) may occasionally change type inference in incompatible - ways, especially regarding the inference of the return clause of `match`. - -Standard Library - -- Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, - and proved some lemmas about them. Note that this might cause - incompatibilities if you have, e.g., `string_scope` and `Z_scope` both - open with `string_scope` on top, and expect `=?` to refer to `Z.eqb`. - Solution: wrap `_ =? _` in `(_ =? _)%Z` (or whichever scope you - want). - -- Added `Ndigits.N2Bv_sized`, and proved some lemmas about it. - Deprecated `Ndigits.N2Bv_gen`. - -- The scopes `int_scope` and `uint_scope` have been renamed to - `dec_int_scope` and `dec_uint_scope`, to clash less with ssreflect - and other packages. They are still delimited by `%int` and `%uint`. - -- Syntax notations for `string`, `ascii`, `Z`, `positive`, `N`, `R`, - and `int31` are no longer available merely by `Require`ing the files - that define the inductives. You must `Import` `Coq.Strings.String.StringSyntax` - (after `Require` `Coq.Strings.String`), `Coq.Strings.Ascii.AsciiSyntax` (after - `Require` `Coq.Strings.Ascii`), `Coq.ZArith.BinIntDef`, `Coq.PArith.BinPosDef`, - `Coq.NArith.BinNatDef`, `Coq.Reals.Rdefinitions`, and - `Coq.Numbers.Cyclic.Int31.Int31`, respectively, to be able to use - these notations. Note that passing `-compat 8.8` or issuing - `Require Import Coq.Compat.Coq88` will make these notations - available. Users wishing to port their developments automatically - may download `fix.py` from - <https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169> - and run a command like `while true; do make -Okj 2>&1 | - /path/to/fix.py; done` and get a cup of coffee. (This command must - be manually interrupted once the build finishes all the way though. - Note also that this method is not fail-proof; you may have to adjust - some scopes if you were relying on string notations not being - available even when `string_scope` was open.) - -- Numeral syntax for `nat` is no longer available without loading the - entire prelude (`Require Import Coq.Init.Prelude`). This only - impacts users running Coq without the init library (`-nois` or - `-noinit`) and also issuing `Require Import Coq.Init.Datatypes`. - -Tools - -- Coq_makefile lets one override or extend the following variables from - the command line: `COQFLAGS`, `COQCHKFLAGS`, `COQDOCFLAGS`. - `COQFLAGS` is now entirely separate from `COQLIBS`, so in custom Makefiles - `$(COQFLAGS)` should be replaced by `$(COQFLAGS) $(COQLIBS)`. - -- Removed the `gallina` utility (extracts specification from Coq vernacular files). - If you would like to maintain this tool externally, please contact us. - -- Removed the Emacs modes distributed with Coq. You are advised to - use [Proof-General](https://proofgeneral.github.io/) (and optionally - [Company-Coq](https://github.com/cpitclaudel/company-coq)) instead. - If your use case is not covered by these alternative Emacs modes, - please open an issue. We can help set up external maintenance as part - of Proof-General, or independently as part of coq-community. - -Vernacular Commands - -- Removed deprecated commands `Arguments Scope` and `Implicit Arguments` - (not the option). Use the `Arguments` command instead. -- Nested proofs may be enabled through the option `Nested Proofs Allowed`. - By default, they are disabled and produce an error. The deprecation - warning which used to occur when using nested proofs has been removed. -- Added option `Uniform Inductive Parameters` which abstracts over parameters - before typechecking constructors, allowing to write for example - `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` -- New `Set Hint Variables/Constants Opaque/Transparent` commands for setting - globally the opacity flag of variables and constants in hint databases, - overwritting the opacity set of the hint database. -- Added generic syntax for "attributes", as in: - `#[local] Lemma foo : bar.` -- Added the `Numeral Notation` command for registering decimal numeral - notations for custom types -- The `Set SsrHave NoTCResolution` command no longer has special global - scope. If you want the previous behavior, use `Global Set SsrHave - NoTCResolution`. -- Multiple sections with the same name are allowed. - -Coq binaries and process model - -- Before 8.9, Coq distributed a single `coqtop` binary and a set of - dynamically loadable plugins that used to take over the main loop - for tasks such as IDE language server or parallel proof checking. - - These plugins have been turned into full-fledged binaries so each - different process has associated a particular binary now, in - particular `coqidetop` is the CoqIDE language server, and - `coq{proof,tactic,query}worker` are in charge of task-specific and - parallel proof checking. - -SSReflect - -- The implementation of delayed clear switches in intro patterns - is now simpler to explain: - 1. The immediate effect of a clear switch like `{x}` is to rename the - variable `x` to `_x_` (i.e. a reserved identifier that cannot be mentioned - explicitly) - 2. The delayed effect of `{x}` is that `_x_` is cleared at the end of the intro - pattern - 3. A clear switch immediately before a view application like `{x}/v` is - translated to `/v{x}`. - - In particular, the third rule lets one write `{x}/v` even if `v` uses the variable `x`: - indeed the view is executed before the renaming. - -- An empty clear switch is now accepted in intro patterns before a - view application whenever the view is a variable. - One can now write `{}/v` to mean `{v}/v`. Remark that `{}/x` is very similar - to the idiom `{}e` for the rewrite tactic (the equation `e` is used for - rewriting and then discarded). - -Standard Library - -- There are now conversions between `string` and `positive`, `Z`, - `nat`, and `N` in binary, octal, and hex. - -Display diffs between proof steps - -- `coqtop` and `coqide` can now highlight the differences between proof steps - in color. This can be enabled from the command line or the - `Set Diffs "on"/"off"/"removed"` command. Please see the documentation for - details. Showing diffs in Proof General requires small changes to PG - (under discussion). - -Notations - -- Added `++` infix for `VectorDef.append`. - Note that this might cause incompatibilities if you have, e.g., `list_scope` - and `vector_scope` both open with `vector_scope` on top, and expect `++` to - refer to `app`. - Solution: wrap `_ ++ _` in `(_ ++ _)%list` (or whichever scope you want). - -Changes from 8.8.1 to 8.8.2 -=========================== - -Documentation - -- A PDF version of the reference manual is available once again. - -Tools - -- The coq-makefile targets `print-pretty-timed`, `print-pretty-timed-diff`, - and `print-pretty-single-time-diff` now correctly label the "before" and - "after" columns, rather than swapping them. - -Kernel - -- The kernel does not tolerate capture of global universes by - polymorphic universe binders, fixing a soundness break (triggered - only through custom plugins) - -Windows installer - -- The Windows installer now includes many more external packages that can be - individually selected for installation. - -Many other bug fixes and lots of documentation improvements (for details, -see the 8.8.2 milestone at https://github.com/coq/coq/milestone/15?closed=1). - -Changes from 8.8.0 to 8.8.1 -=========================== - -Kernel - -- Fix a critical bug with cofixpoints and `vm_compute`/`native_compute` (#7333). -- Fix a critical bug with modules and algebraic universes (#7695) -- Fix a critical bug with inlining of polymorphic constants (#7615). -- Fix a critical bug with universe polymorphism and `vm_compute` (#7723). Was - present since 8.5. - -Notations - -- Fixed unexpected collision between only-parsing and only-printing - notations (issue #7462). - -Windows installer - -- The Windows installer now includes external packages Ltac2 and Equations - (it included the Bignums package since 8.8+beta1). - -Many other bug fixes, documentation improvements (including fixes of -regressions due to the Sphinx migration), and user message improvements -(for details, see the 8.8.1 milestone at -https://github.com/coq/coq/milestone/13?closed=1). - -Changes from 8.8+beta1 to 8.8.0 -=============================== - -Tools - -- Asynchronous proof delegation policy was fixed. Since version 8.7 - Coq was ignoring previous runs and the `-async-proofs-delegation-threshold` - option did not have the expected behavior. - -Tactic language - -- The undocumented "nameless" forms `fix N`, `cofix` have been - deprecated; please use `fix ident N /cofix ident` to explicitely - name the (co)fixpoint hypothesis to be introduced. - -Documentation - -- The reference manual is now fully ported to Sphinx. - -Other small deprecations and bug fixes. - -Changes from 8.7.2 to 8.8+beta1 -=============================== - -Kernel - -- Support for template polymorphism for definitions was removed. May trigger - more "universe inconsistency" errors in rare occasions. -- Fixpoints are no longer allowed on non-recursive inductive types. - -Notations - -- Recursive notations with the recursive pattern repeating on the - right (e.g. "( x ; .. ; y ; z )") now supported. -- Notations with a specific level for the leftmost nonterminal, - when printing-only, are supported. -- Notations can now refer to the syntactic category of patterns (as in - "fun 'pat =>" or "match p with pat => ... end"). Two variants are - available, depending on whether a single variable is considered as a - pattern or not. -- Recursive notations now support ".." patterns with several - occurrences of the recursive term or binder, possibly mixing terms - and binders, possibly in reverse left-to-right order. -- "Locate" now working also on notations of the form "x + y" (rather - than "_ + _"). - -Specification language - -- When printing clauses of a "match", clauses with same right-hand - side are factorized and the last most factorized clause with no - variables, if it exists, is turned into a default clause. - Use "Unset Printing Allow Default Clause" do deactivate printing - of a default clause. - Use "Unset Printing Factorizable Match Patterns" to deactivate - factorization of clauses with same right-hand side. - -Tactics - -- On Linux, "native_compute" calls can be profiled using the "perf" - utility. The command "Set NativeCompute Profiling" enables - profiling, and "Set NativeCompute Profile Filename" customizes - the profile filename. -- The tactic "omega" is now aware of the bodies of context variables - such as "x := 5 : Z" (see #1362). This could be disabled via - Unset Omega UseLocalDefs. -- The tactic "romega" is also aware now of the bodies of context variables. -- The tactic "zify" resp. "omega with N" is now aware of N.pred. -- Tactic "decide equality" now able to manage constructors which - contain proofs. -- Added tactics reset ltac profile, show ltac profile (and variants) -- Added tactics restart_timer, finish_timing, and time_constr as an - experimental way of timing Ltac's evaluation phase -- Added tactic optimize_heap, analogous to the Vernacular Optimize - Heap, which performs a major garbage collection and heap compaction - in the OCaml run-time system. -- The tactics "dtauto", "dintuition", "firstorder" now handle inductive types - with let bindings in the parameters. -- The tactic "dtauto" now handles some inductives such as - "@sigT A (fun _ => B)" as non-dependent conjunctions. -- A bug fixed in "rewrite H in *" and "rewrite H in * |-" may cause a - few rare incompatibilities (it was unintendedly recursively - rewriting in the side conditions generated by H). -- Added tactics "assert_succeeds tac" and "assert_fails tac" to ensure - properties of the executation of a tactic without keeping the effect - of the execution. -- `vm_compute` now supports existential variables. -- Calls to `shelve` and `give_up` within calls to tactic `refine` now working. -- Deprecated tactic `appcontext` was removed. - -Focusing - -- Focusing bracket `{` now supports single-numbered goal selector, - e.g. `2: {` will focus on the second sub-goal. As usual, unfocus - with `}` once the sub-goal is fully solved. - The `Focus` and `Unfocus` commands are now deprecated. - -Vernacular Commands - -- Proofs ending in "Qed exporting ident, .., ident" are not supported - anymore. Constants generated during `abstract` are kept private to the - local environment. -- The deprecated Coercion Local, Open Local Scope, Notation Local syntax - was removed. Use Local as a prefix instead. -- For the Extraction Language command, "OCaml" is spelled correctly. - The older "Ocaml" is still accepted, but deprecated. -- Using “Require†inside a section is deprecated. -- An experimental command "Show Extraction" allows to extract the content - of the current ongoing proof (grant wish #4129). -- Coercion now accepts the type of its argument to be "Prop" or "Type". -- The "Export" modifier can now be used when setting and unsetting options, and - will result in performing the same change when the module corresponding the - command is imported. -- The `Axiom` command does not automatically declare axioms as instances when - their type is a class. Previous behavior can be restored using `Set - Typeclasses Axioms Are Instances`. - -Universes - -- Qualified naming of global universes now works like other namespaced - objects (e.g. constants), with a separate namespace, inside and across - module and library boundaries. Global universe names introduced in an - inductive / constant / Let declaration get qualified with the name of - the declaration. -- Universe cumulativity for inductive types is now specified as a - variance for each polymorphic universe. See the reference manual for - more information. -- Inference of universe constraints with cumulative inductive types - produces more general constraints. Unsetting new option Cumulativity - Weak Constraints produces even more general constraints (but may - produce too many universes to be practical). -- Fix #5726: Notations that start with `Type` now support universe instances - with `@{u}`. -- `with Definition` now understands universe declarations - (like `@{u| Set < u}`). - -Tools - -- Coq can now be run with the option -mangle-names to change the auto-generated - name scheme. This is intended to function as a linter for developments that - want to be robust to changes in auto-generated names. This feature is experimental, - and may change or disappear without warning. -- GeoProof support was removed. - -Checker - -- The checker now accepts filenames in addition to logical paths. - -CoqIDE - -- Find and Replace All report the number of occurrences found; Find indicates - when it wraps. - -coqdep - -- Learned to read -I, -Q, -R and filenames from _CoqProject files. - This is used by coq_makefile when generating dependencies for .v - files (but not other files). - -Documentation - -- The Coq FAQ, formerly located at https://coq.inria.fr/faq, has been - moved to the GitHub wiki section of this repository; the main entry - page is https://github.com/coq/coq/wiki/The-Coq-FAQ. -- Documentation: a large community effort resulted in the migration - of the reference manual to the Sphinx documentation tool. The result - is partially integrated in this version. - -Standard Library - -- New libraries Coq.Init.Decimal, Coq.Numbers.DecimalFacts, - Coq.Numbers.DecimalNat, Coq.Numbers.DecimalPos, - Coq.Numbers.DecimalN, Coq.Numbers.DecimalZ, - Coq.Numbers.DecimalString providing a type of decimal numbers, some - facts about them, and conversions between decimal numbers and nat, - positive, N, Z, and string. -- Added [Coq.Strings.String.concat] to concatenate a list of strings - inserting a separator between each item -- Notation `'` for Zpos in QArith was removed. - -- Some deprecated aliases are now emitting warnings when used. - -Compatibility support - -- Support for compatibility with versions before 8.6 was dropped. - -Options - -- The following deprecated options have been removed: - - + `Refolding Reduction` - + `Standard Proposition Elimination` - + `Dependent Propositions Elimination` - + `Discriminate Introduction` - + `Shrink Abstract` - + `Tactic Pattern Unification` - + `Intuition Iff Unfolding` - + `Injection L2R Pattern Order` - + `Record Elimination Schemes` - + `Match Strict` - + `Tactic Compat Context` - + `Typeclasses Legacy Resolution` - + `Typeclasses Module Eta` - + `Typeclass Resolution After Apply` - -Changes from 8.7.1 to 8.7.2 -=========================== - -Fixed a critical bug in the VM handling of universes (#6677). This bug -affected all releases since 8.5. - -Improved support for building with OCaml 4.06.0 and external num package. - -Many other bug fixes, documentation improvements, and user -message improvements (for details, see the 8.7.2 milestone at -https://github.com/coq/coq/milestone/11?closed=1). - -Changes from 8.7.0 to 8.7.1 -=========================== - -Compatibility with OCaml 4.06.0. - -Many bug fixes, documentation improvements, and user message improvements (for -details see the 8.7.1 milestone at https://github.com/coq/coq/milestone/10?closed=1). - -Changes from 8.7+beta2 to 8.7.0 -=============================== - -OCaml - -- Users can pass specific flags to the OCaml optimizing compiler by - -using the flambda-opts configure-time option. - - Beware that compiling Coq with a flambda-enabled compiler is - experimental and may require large amounts of RAM and CPU, see - INSTALL for more details. - -Changes from 8.7+beta1 to 8.7+beta2 -=================================== - -Tools - -- In CoqIDE, the "Compile Buffer" command takes account of flags in - _CoqProject or other project file. - -Improvements around some error messages. - -Many bug fixes including two important ones: - -- Bug #5730: CoqIDE becomes unresponsive on file open. -- coq_makefile: make sure compile flags for Coq and coq_makefile are in sync - (in particular, make sure the `-safe-string` option is used to compile plugins). - -Changes from 8.6.1 to 8.7+beta1 -=============================== - -Tactics - -- New tactic "extensionality in H" which applies (possibly dependent) - functional extensionality in H supposed to be a quantified equality - until giving a bare equality. -- New tactic "inversion_sigma" which turns equalities of dependent - pairs (e.g., "existT P x p = existT P y q", frequently left over by - "inversion" on a dependent type family) into pairs of equalities - (e.g., a hypothesis "H : x = y" and a hypothesis of type "rew H in p - = q"); these hypotheses can subsequently be simplified using - "subst", without ever invoking any kind of axiom asserting - uniqueness of identity proofs. If you want to explicitly specify the - hypothesis to be inverted, or name the generated hypotheses, you can - invoke "induction H as [H1 H2] using eq_sigT_rect". The tactic also - works for "sig", "sigT2", and "sig2", and there are similar - "eq_sig*_rect" induction lemmas. -- Tactic "specialize with ..." now accepts any partial bindings. - Missing bindings are either solved by unification or left quantified - in the hypothesis. -- New representation of terms that statically ensure stability by - evar-expansion. This has several consequences. - * In terms of performance, this adds a cost to every term destructuration, - but at the same time most eager evar normalizations were removed, which - couterbalances this drawback and even sometimes outperforms the old - implementation. For instance, many operations that would require O(n) - normalization of the term are now O(1) in tactics. YMMV. - * This triggers small changes in unification, which was not evar-insensitive. - Most notably, the new implementation recognizes Miller patterns that were - missed before because of a missing normalization step. Hopefully this should - be fairly uncommon. -- Tactic "auto with real" can now discharge comparisons of literals. -- The types of variables in patterns of "match" are now - beta-iota-reduced after type-checking. This has an impact on the - type of the variables that the tactic "refine" introduces in the - context, producing types a priori closer to the expectations. -- In "Tactic Notation" or "TACTIC EXTEND", entry "constr_with_bindings" - now uses type classes and rejects terms with unresolved holes, like - entry "constr" does. To get the former behavior use - "open_constr_with_bindings" (possible source of incompatibility). -- New e-variants eassert, eenough, epose proof, eset, eremember, epose - which behave like the corresponding variants with no "e" but turn - unresolved implicit arguments into existential variables, on the - shelf, rather than failing. -- Tactic injection has become more powerful (closes bug #4890) and its - documentation has been updated. -- New variants of the `first` and `solve` tacticals that do not rely - on parsing rules, meant to define tactic notations. -- Added support for side effects hooks in `cbv`, `cbn` and `simpl`. - The side effects are provided via a plugin: - https://github.com/herbelin/reduction-effects/ -- It is now possible to take hint database names as parameters in a - Ltac definition or a Tactic Notation. -- New option `Set Ltac Batch Debug` on top of `Set Ltac Debug` for - non-interactive Ltac debug output. - -Gallina - -- Now supporting all kinds of binders, including 'pat, in syntax of record fields. - -Vernacular Commands - -- Goals context can be printed in a more compact way when `Set - Printing Compact Contexts` is activated. -- Unfocused goals can be printed with the `Set Printing Unfocused` - option. -- `Print` now shows the types of let-bindings. -- The compatibility options for printing primitive projections - (`Set Printing Primitive Projection Parameters` and - `Set Printing Primitive Projection Compatibility`) are now off by default. -- Possibility to unset the printing of notations in a more fine grained - fashion than `Unset Printing Notations` is provided without any - user-syntax. The goal is that someone creates a plugin to experiment - such a user-syntax, to be later integrated in Coq when stabilized. -- `About` now tells if a reference is a coercion. -- The deprecated `Save` vernacular and its form `Save Theorem id` to - close proofs have been removed from the syntax. Please use `Qed`. -- `Search` now sorts results by relevance (the relevance metric is a - weighted sum of number of distinct symbols and size of the term). - -Standard Library - -- New file PropExtensionality.v to explicitly work in the axiomatic - context of propositional extensionality. -- New file SetoidChoice.v axiomatically providing choice over setoids, - and, consequently, choice of representatives in equivalence classes. - Various proof-theoretic characterizations of choice over setoids in - file ChoiceFacts.v. -- New lemmas about iff and about orders on positive and Z. -- New lemmas on powerRZ. -- Strengthened statement of JMeq_eq_dep (closes bug #4912). -- The BigN, BigZ, BigZ libraries are no longer part of the Coq standard - library, they are now provided by a separate repository - https://github.com/coq/bignums - The split has been done just after the Int31 library. - -- IZR (Reals) has been changed to produce a compact representation of - integers. As a consequence, IZR is no longer convertible to INR and - lemmas such as INR_IZR_INZ should be used instead. -- Real constants are now represented using IZR rather than R0 and R1; - this might cause rewriting rules to fail to apply to constants. -- Added new notation {x & P} for sigT (without a type for x) - -Plugins - -- The Ssreflect plugin is now distributed with Coq. Its documentation has - been integrated as a chapter of the reference manual. This chapter is - work in progress so feedback is welcome. -- The mathematical proof language (also known as declarative mode) was removed. -- A new command Extraction TestCompile has been introduced, not meant - for the general user but instead for Coq's test-suite. -- The extraction plugin is no longer loaded by default. It must be - explicitly loaded with [Require Extraction], which is backwards - compatible. -- The functional induction plugin (which provides the [Function] - vernacular) is no longer loaded by default. It must be explicitly - loaded with [Require FunInd], which is backwards compatible. - - -Dependencies - -- Support for camlp4 has been removed. - -Tools - -- coq_makefile was completely redesigned to improve its maintainability and - the extensibility of generated Makefiles, and to make _CoqProject files - more palatable to IDEs. Overview: - * _CoqProject files contain only Coq specific data (i.e. the list of - files, -R options, ...) - * coq_makefile translates _CoqProject to Makefile.conf and copies in the - desired location a standard Makefile (that reads Makefile.conf) - * Makefile extensions can be implemented in a Makefile.local file (read - by the main Makefile) by installing a hook in the extension points - provided by the standard Makefile - The current version contains code for retro compatibility that prints - warnings when a deprecated feature is used. Please upgrade your _CoqProject - accordingly. - * Additionally, coq_makefile-made Makefiles now support experimental timing - targets `pretty-timed`, `pretty-timed-before`, `pretty-timed-after`, - `print-pretty-timed-diff`, `print-pretty-single-time-diff`, - `all.timing.diff`, and the variable `TIMING=1` (or `TIMING=before` or - `TIMING=after`); see the documentation for more details. - -Build Infrastructure - -- Note that 'make world' does not build the bytecode binaries anymore. - For that, you can use 'make byte' (and 'make install-byte' afterwards). - Warning: native and byte compilations should *not* be mixed in the same - instance of 'make -j', otherwise both ocamlc and ocamlopt might race for - access to the same .cmi files. In short, use "make -j && make -j byte" - instead of "make -j world byte". - -Universes - -- Cumulative inductive types. see prefixes "Cumulative", "NonCumulative" - for inductive definitions and the option "Set Polymorphic Inductive Cumulativity" - in the reference manual. -- New syntax `foo@{_}` to instantiate a polymorphic definition with - anonymous universes (can also be used with `Type`). - -XML Protocol and internal changes - -See dev/doc/changes.txt - -Many bugfixes including #1859, #2884, #3613, #3943, #3994, -#4250, #4709, #4720, #4824, #4844, #4911, #5026, #5233, -#5275, #5315, #5336, #5360, #5390, #5414, #5417, #5420, -#5439, #5449, #5475, #5476, #5482, #5501, #5507, #5520, -#5523, #5524, #5553, #5577, #5578, #5589, #5597, #5598, -#5607, #5618, #5619, #5620, #5641, #5648, #5651, #5671. - -Many bugfixes on OS X and Windows (now the test-suite passes on these -platforms too). - -Many optimizations. - -Many documentation improvements. - -Changes from 8.6 to 8.6.1 -========================= - -- Fix #5380: Default colors for CoqIDE are actually applied. -- Fix plugin warnings -- Document named evars (including Show ident) -- Fix Bug #5574, document function scope -- Adding a test case as requested in bug 5205. -- Fix Bug #5568, no dup notation warnings on repeated module imports -- Fix documentation of Typeclasses eauto := -- Refactor documentation of records. -- Protecting from warnings while compiling 8.6 -- Fixing an inconsistency between configure and configure.ml -- Add test-suite checks for coqchk with constraints -- Fix bug #5019 (looping zify on dependent types) -- Fix bug 5550: "typeclasses eauto with" does not work with section variables. -- Bug 5546, qualify datatype constructors when needed in Show Match -- Bug #5535, test for Show with -emacs -- Fix bug #5486, don't reverse ids in tuples -- Fixing #5522 (anomaly with free vars of pat) -- Fix bug #5526, don't check for nonlinearity in notation if printing only -- Fix bug #5255 -- Fix bug #3659: -time should understand multibyte encodings. -- FIx bug #5300: Anomaly: Uncaught exception Not_found" in "Print Assumptions". -- Fix outdated description in RefMan. -- Repairing `Set Rewriting Schemes` -- Fixing #5487 (v8.5 regression on ltac-matching expressions with evars). -- Fix description of command-line arguments for Add (Rec) LoadPath -- Fix bug #5377: @? patterns broken. -- add XML protocol doc -- Fix anomaly when doing [all:Check _.] during a proof. -- Correction of bug #4306 -- Fix #5435: [Eval native_compute in] raises anomaly. -- Instances should obey universe binders even when defined by tactics. -- Intern names bound in match patterns -- funind: Ignore missing info for current function -- Do not typecheck twice the type of opaque constants. -- show unused intro pattern warning -- [future] Be eager when "chaining" already resolved future values. -- Opaque side effects -- Fix #5132: coq_makefile generates incorrect install goal -- Run non-tactic comands without resilient_command -- Univs: fix bug #5365, generation of u+k <= v constraints -- make `emit' tail recursive -- Don't require printing-only notation to be productive -- Fix the way setoid_rewrite handles bindings. -- Fix for bug 5244 - set printing width ignored when given enough space -- Fix bug 4969, autoapply was not tagging shelved subgoals correctly - -Changes from V8.6beta1 to V8.6 -============================== - -Kernel - -- Fixed critical bug #5248 in VM long multiplication on 32-bit - architectures. Was there only since 8.6beta1, so no stable release impacted. - -Other bug fixes in universes, type class shelving,... - -Changes from V8.5 to V8.6beta1 -============================== - -Kernel - -- A new, faster state-of-the-art universe constraint checker. - -Specification language - -- Giving implicit arguments explicitly to a constant with multiple - choices of implicit arguments does not break any more insertion of - further maximal implicit arguments. -- Ability to put any pattern in binders, prefixed by quote, e.g. - "fun '(a,b) => ...", "λ '(a,(b,c)), ...", "Definition foo '(x,y) := ...". - It expands into a "let 'pattern := ..." - -Tactics - -- Flag "Bracketing Last Introduction Pattern" is now on by default. -- Flag "Regular Subst Tactic" is now on by default: it respects the - initial order of hypothesis, it contracts cycles, it unfolds no - local definitions (common source of incompatibilities, fixable by - "Unset Regular Subst Tactic"). -- New flag "Refolding Reduction", now disabled by default, which turns - on refolding of constants/fixpoints (as in cbn) during the reductions - done during type inference and tactic retyping. Can be extremely - expensive. When set off, this recovers the 8.4 behaviour of unification - and type inference. Potential source of incompatibility with 8.5 developments - (the option is set on in Compat/Coq85.v). -- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract - tactical w.r.t. variables appearing in the body of the proof. - On by default and deprecated. Minor source of incompatibility - for code relying on the precise arguments of abstracted proofs. -- Serious bugs are fixed in tactic "double induction" (source of - incompatibilities as soon as the inductive types have dependencies in - the type of their constructors; "double induction" remains however - deprecated). -- In introduction patterns of the form (pat1,...,patn), n should match - the exact number of hypotheses introduced (except for local definitions - for which pattern can be omitted, as in regular pattern-matching). -- Tactic scopes in Ltac like constr: and ltac: now require parentheses around - their argument. -- Every generic argument type declares a tactic scope of the form "name:(...)" - where name is the name of the argument. This generalizes the constr: and ltac: - instances. -- When in strict mode (i.e. in a Ltac definition), if the "intro" tactic is - given a free identifier, it is not bound in subsequent tactics anymore. - In order to introduce a binding, use e.g. the "fresh" primitive instead - (potential source of incompatibilities). -- New tactics is_ind, is_const, is_proj, is_constructor for use in Ltac. -- New goal selectors. Sets of goals can be selected by listing integers - ranges. Example: "1,4-7,24: tac" focuses "tac" on goals 1,4,5,6,7,24. -- For uniformity with "destruct"/"induction" and for a more natural - behavior, "injection" can now work in place by activating option - "Structural Injection". In this case, hypotheses are also put in the - context in the natural left-to-right order and the hypothesis on - which injection applies is cleared. -- Tactic "contradiction" (hence "easy") now also solve goals with - hypotheses of the form "~True" or "t<>t" (possible source of - incompatibilities because of more successes in automation, but - generally a more intuitive strategy). -- Option "Injection On Proofs" was renamed "Keep Proof Equalities". When - enabled, injection and inversion do not drop equalities between objects - in Prop. Still disabled by default. -- New tactics "notypeclasses refine" and "simple notypeclasses refine" that - disallow typeclass resolution when typechecking their argument, for use - in typeclass hints. -- Integration of LtacProf, a profiler for Ltac. -- Reduction tactics now accept more fine-grained flags: iota is now a shorthand - for the new flags match, fix and cofix. -- The ssreflect subterm selection algorithm is now accessible to tactic writers - through the ssrmatching plugin. -- When used as an argument of an ltac function, "auto" without "with" - nor "using" clause now correctly uses only the core hint database by - default. - -Hints - -- Revised the syntax of [Hint Cut] to follow standard notation for regexps. -- Hint Mode now accepts "!" which means that the mode matches only if the - argument's head is not an evar (it goes under applications, casts, and - scrutinees of matches and projections). -- Hints can now take an optional user-given pattern, used only by - [typeclasses eauto] with the [Filtered Unification] option on. - -Typeclasses - -- Many new options and new engine based on the proof monad. The - [typeclasses eauto] tactic is now a multi-goal, multi-success tactic. - See reference manual for more information. It is planned to - replace auto and eauto in the following version. The 8.5 resolution - engine is still available to help solve compatibility issues. - -Program - -- The "Shrink Obligations" flag now applies to all obligations, not only - those solved by the automatic tactic. -- "Shrink Obligations" is on by default and deprecated. Minor source of - incompatibility for code relying on the precise arguments of - obligations. - -Notations - -- "Bind Scope" can once again bind "Funclass" and "Sortclass". - -General infrastructure - -- New configurable warning system which can be controlled with the vernacular - command "Set Warnings", or, under coqc/coqtop, with the flag "-w". In - particular, the default is now that warnings are printed by coqc. -- In asynchronous mode, Coq is now capable of recovering from errors and - continue processing the document. - -Tools - -- coqc accepts a -o option to specify the output file name -- coqtop accepts --print-version to print Coq and OCaml versions in - easy to parse format -- Setting [Printing Dependent Evars Line] can be unset to disable the - computation associated with printing the "dependent evars: " line in - -emacs mode -- Removed the -verbose-compat-notations flag and the corresponding Set - Verbose Compat vernacular, since these warnings can now be silenced or - turned into errors using "-w". - -XML protocol - -- message format has changed, see dev/doc/changes.txt for more details. - -Many bug fixes, minor changes and documentation improvements are not mentioned -here. - -Changes from V8.5pl2 to V8.5pl3 -=============================== - -Critical bugfix - -- #4876: Guard checker incompleteness when using primitive projections - -Other bugfixes - -- #4780: Induction with universe polymorphism on was creating ill-typed terms. -- #4673: regression in setoid_rewrite, unfolding let-ins for type unification. -- #4754: Regression in setoid_rewrite, allow postponed unification problems to remain. -- #4769: Anomaly with universe polymorphic schemes defined inside sections. -- #3886: Program: duplicate obligations of mutual fixpoints. -- #4994: Documentation typo. -- #5008: Use the "md5" command on OpenBSD. -- #5007: Do not assume the "TERM" environment variable is always set. -- #4606: Output a break before a list only if there was an empty line. -- #5001: metas not cleaned properly in clenv_refine_in. -- #2336: incorrect glob data for module symbols (bug #2336). -- #4832: Remove extraneous dot in error message. -- Anomaly in printing a unification error message. -- #4947: Options which take string arguments are not backwards compatible. -- #4156: micromega cache files are now hidden files. -- #4871: interrupting par:abstract kills coqtop. -- #5043: [Admitted] lemmas pick up section variables. -- Fix name of internal refine ("simple refine"). -- #5062: probably a typo in Strict Proofs mode. -- #5065: Anomaly: Not a proof by induction. -- Restore native compiler optimizations, they were disabled since 8.5! -- #5077: failure on typing a fixpoint with evars in its type. -- Fix recursive notation bug. -- #5095: non relevant too strict test in let-in abstraction. -- Ensuring that the evar name is preserved by "rename". -- #4887: confusion between using and with in documentation of firstorder. -- Bug in subst with let-ins. -- #4762: eauto weaker than auto. -- Remove if_then_else (was buggy). Use tryif instead. -- #4970: confusion between special "{" and non special "{{" in notations. -- #4529: primitive projections unfolding. -- #4416: Incorrect "Error: Incorrect number of goals". -- #4863: abstract in typeclass hint fails. -- #5123: unshelve can impact typeclass resolution -- Fix a collision about the meta-variable ".." in recursive notations. -- Fix printing of info_auto. -- #3209: Not_found due to an occur-check cycle. -- #5097: status of evars refined by "clear" in ltac: closed wrt evars. -- #5150: Missing dependency of the test-suite subsystems in prerequisite. -- Fix a bug in error printing of unif constraints -- #3941: Do not stop propagation of signals when Coq is busy. -- #4822: Incorrect assertion in cbn. -- #3479 parsing of "{" and "}" when a keyword starts with "{" or "}". -- #5127: Memory corruption with the VM. -- #5102: bullets parsing broken by calls to parse_entry. - -Various documentation improvements - - -Changes from V8.5pl1 to V8.5pl2 -=============================== - -Critical bugfix -- Checksums of .vo files dependencies were not correctly checked. -- Unicode-to-ASCII translation was not injective, leading in a soundness bug in - the native compiler. - -Other bugfixes - -- #4097: more efficient occur-check in presence of primitive projections -- #4398: type_scope used consistently in "match goal". -- #4450: eauto does not work with polymorphic lemmas -- #4677: fix alpha-conversion in notations needing eta-expansion. -- Fully preserve initial order of hypotheses in "Regular Subst Tactic" mode. -- #4644: a regression in unification. -- #4725: Function (Error: Conversion test raised an anomaly) and Program - (Error: Cannot infer this placeholder of type) -- #4747: Problem building Coq 8.5pl1 with OCaml 4.03.0: Fatal warnings -- #4752: CoqIDE crash on files not ended by ".v". -- #4777: printing inefficiency with implicit arguments -- #4818: "Admitted" fails due to undefined universe anomaly after calling - "destruct" -- #4823: remote counter: avoid thread race on sockets -- #4841: -verbose flag changed semantics in 8.5, is much harder to use -- #4851: [nsatz] cannot handle duplicated hypotheses -- #4858: Anomaly: Uncaught exception Failure("hd"). Please report. in variant - of nsatz -- #4880: [nsatz_compute] generates invalid certificates if given redundant - hypotheses -- #4881: synchronizing "Declare Implicit Tactic" with backtrack. -- #4882: anomaly with Declare Implicit Tactic on hole of type with evars -- Fix use of "Declare Implicit Tactic" in refine. - triggered by CoqIDE -- #4069, #4718: congruence fails when universes are involved. - -Universes -- Disallow silently dropping universe instances applied to variables - (forward compatible) -- Allow explicit universe instances on notations, when they can apply - to the head reference of their expansion. - -Build infrastructure -- New update on how to find camlp5 binary and library at configure time. - -Changes from V8.5 to V8.5pl1 -============================ - -Critical bugfix -- The subterm relation for the guard condition was incorrectly defined on - primitive projections (#4588) - -Plugin development tools -- add a .merlin target to the makefile - -Various performance improvements (time, space used by .vo files) - -Other bugfixes - -- Fix order of arguments to Big.compare_case in ExtrOcamlZBigInt.v -- Added compatibility coercions from Specif.v which were present in Coq 8.4. -- Fixing a source of inefficiency and an artificial dependency in the printer in the congruence tactic. -- Allow to unset the refinement mode of Instance in ML -- Fixing an incorrect use of prod_appvect on a term which was not a product in setoid_rewrite. -- Add -compat 8.4 econstructor tactics, and tests -- Add compatibility Nonrecursive Elimination Schemes -- Fixing the "No applicable tactic" non informative error message regression on apply. -- Univs: fix get_current_context (bug #4603, part I) -- Fix a bug in Program coercion code -- Fix handling of arity of definitional classes. -- #4630: Some tactics are 20x slower in 8.5 than 8.4. -- #4627: records with no declared arity can be template polymorphic. -- #4623: set tactic too weak with universes (regression) -- Fix incorrect behavior of CS resolution -- #4591: Uncaught exception in directory browsing. -- CoqIDE is more resilient to initialization errors. -- #4614: "Fully check the document" is uninterruptable. -- Try eta-expansion of records only on non-recursive ones -- Fix bug when a sort is ascribed to a Record -- Primitive projections: protect kernel from erroneous definitions. -- Fixed bug #4533 with previous Keyed Unification commit -- Win: kill unreliable hence do not waitpid after kill -9 (Close #4369) -- Fix strategy of Keyed Unification -- #4608: Anomaly "output_value: abstract value (outside heap)". -- #4607: do not read native code files if native compiler was disabled. -- #4105: poor escaping in the protocol between CoqIDE and coqtop. -- #4596: [rewrite] broke in the past few weeks. -- #4533 (partial): respect declared global transparency of projections in unification.ml -- #4544: Backtrack on using full betaiota reduction during keyed unification. -- #4540: CoqIDE bottom progress bar does not update. -- Fix regression from 8.4 in reflexivity -- #4580: [Set Refine Instance Mode] also used for Program Instance. -- #4582: cannot override notation [ x ]. MAY CREATE INCOMPATIBILITIES, see #4683. -- STM: Print/Extraction have to be skipped if -quick -- #4542: CoqIDE: STOP button also stops workers -- STM: classify some variants of Instance as regular `Fork nodes. -- #4574: Anomaly: Uncaught exception Invalid_argument("splay_arity"). -- Do not give a name to anonymous evars anymore. See bug #4547. -- STM: always stock in vio files the first node (state) of a proof -- STM: not delegate proofs that contain Vernac(Module|Require|Import), #4530 -- Don't fail fatally if PATH is not set. -- #4537: Coq 8.5 is slower in typeclass resolution. -- #4522: Incorrect "Warning..." on windows. -- #4373: coqdep does not know about .vio files. -- #3826: "Incompatible module types" is uninformative. -- #4495: Failed assertion in metasyntax.ml. -- #4511: evar tactic can create non-typed evars. -- #4503: mixing universe polymorphic and monomorphic variables and definitions in sections is unsupported. -- #4519: oops, global shadowed local universe level bindings. -- #4506: Anomaly: File "pretyping/indrec.ml", line 169, characters 14-20: Assertion failed. -- #4548: Coqide crashes when going back one command - -Changes from V8.5beta3 to V8.5 -============================== - -Tools - -- Flag "-compat 8.4" now loads Coq.Compat.Coq84. The standard way of - putting Coq in v8.4 compatibility mode is to pass the command line flag - "-compat 8.4". It can be followed by "-require Coq.Compat.AdmitAxiom" - if the 8.4 behavior of admit is needed, in which case it uses an axiom. - -Specification language - -- Syntax "$(tactic)$" changed to "ltac:(tactic)". - -Tactics - -- Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly - for induction (rare source of incompatibilities easily solvable by - removing parentheses around "hyp" when not for the purpose of keeping - the hypothesis). -- Syntax "p/c" for on-the-fly application of a lemma c before - introducing along pattern p changed to p%c1..%cn. The feature and - syntax are in experimental stage. -- "Proof using" does not clear unused section variables. -- Tactic "refine" has been changed back to the 8.4 behavior of shelving subgoals - that occur in other subgoals. The "refine" tactic of 8.5beta3 has been - renamed "simple refine"; it does not shelve any subgoal. -- New tactical "unshelve tac" which grab existential variables put on - the tactic shelve by the execution of "tac". - -Changes from V8.5beta2 to V8.5beta3 -=================================== - -Vernacular commands - -- New command "Redirect" to redirect the output of a command to a file. -- New command "Undelimit Scope" to remove the delimiter of a scope. -- New option "Strict Universe Declaration", set by default. It enforces the - declaration of all polymorphic universes appearing in a definition when - introducing it. -- New command "Show id" to show goal named id. -- Option "Virtual Machine" removed. - -Tactics - -- New flag "Regular Subst Tactic" which fixes "subst" in situations where - it failed to substitute all substitutable equations or failed to simplify - cycles, or accidentally unfolded local definitions (flag is off by default). -- New flag "Loose Hint Behavior" to handle hints loaded but not imported in a - special way. It accepts three distinct flags: - * "Lax", which is the default one, sets the old behavior, i.e. a non-imported - hint behaves the same as an imported one. - * "Warn" outputs a warning when a non-imported hint is used. Note that this is - an over-approximation, because a hint may be triggered by an eauto run that - will eventually fail and backtrack. - * "Strict" changes the behavior of an unloaded hint to the one of the fail - tactic, allowing to emulate the hopefully future import-scoped hint mechanism. -- New compatibility flag "Universal Lemma Under Conjunction" which - let tactics working under conjunctions apply sublemmas of the form - "forall A, ... -> A". -- New compatibility flag "Bracketing Last Introduction Pattern" which can be - set so that the last disjunctive-conjunctive introduction pattern given to - "intros" automatically complete the introduction of its subcomponents, as the - the disjunctive-conjunctive introduction patterns in non-terminal position - already do. -- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract - tactical w.r.t. variables appearing in the body of the proof. - -Program - -- The "Shrink Obligations" flag now applies to all obligations, not only those -solved by the automatic tactic. -- Importing Program no longer overrides the "exists" tactic (potential source - of incompatibilities). -- Hints costs are now correctly taken into account (potential source of - incompatibilities). -- Documented the Hint Cut command that allows control of the - proof-search during typeclass resolution (see reference manual). - -API - -- Some functions from pretyping/typing.ml and their derivatives were potential - source of evarmap leaks, as they dropped their resulting evarmap. The - situation was clarified by renaming them according to a unsafe_* scheme. Their - sound variant is likewise renamed to their old name. The following renamings - were made. - * Typing.type_of -> unsafe_type_of - * Typing.e_type_of -> type_of - * A new e_type_of function that matches the e_ prefix policy - * Tacmach.pf_type_of -> pf_unsafe_type_of - * A new safe pf_type_of function. - All uses of unsafe_* functions should be eventually eliminated. - -Tools - -- Added an option -w to control the output of coqtop warnings. -- Configure now takes an optional -native-compiler (yes|no) flag replacing - -no-native-compiler. The new flag is set to no by default under Windows. -- Flag -no-native-compiler was removed and became the default for coqc. If - precompilation of files for native conversion test is desired, use - -native-compiler. -- The -compile command-line option now takes the full path of the considered - file, including the ".v" extension, and outputs a warning if such an extension - is lacking. -- The -require and -load-vernac-object command-line options now take a logical - path of a given library rather than a physical path, thus they behave like - Require [Import] path. -- The -vm command-line option has been removed. - -Standard Library - - - There is now a Coq.Compat.Coq84 library, which sets the various compatibility - options and does a few redefinitions to make Coq behave more like Coq v8.4. - The standard way of putting Coq in v8.4 compatibility mode is to pass the command - line flags "-require Coq.Compat.Coq84 -compat 8.4". - -Changes from V8.5beta1 to V8.5beta2 -=================================== - -Logic - -- The VM now supports inductive types with up to 8388851 non-constant - constructors and up to 8388607 constant ones. - -Specification language - -- Syntax "$(tactic)$" changed to "ltac: tactic". - -Tactics - -- A script using the admit tactic can no longer be concluded by either - Qed or Defined. In the first case, Admitted can be used instead. In - the second case, a subproof should be used. -- The easy tactic and the now tactical now have a more predictable - behavior, but they might now discharge some previously unsolved goals. - -Extraction - -- Definitions extracted to Haskell GHC should no longer randomly - segfault when some Coq types cannot be represented by Haskell types. -- Definitions can now be extracted to Json for post-processing. - -Tools - -- Option -I -as has been removed, and option -R -as has been - deprecated. In both cases, option -R can be used instead. -- coq_makefile now generates double-colon rules for rules such as clean. - -API - -- The interface of [change] has changed to take a [change_arg], which - can be built from a [constr] using [make_change_arg]. - -Changes from V8.4 to V8.5beta1 -============================== - -Logic - -- Primitive projections for records allow for a compact representation - of projections, without parameters and avoid the behavior of defined - projections that can unfold to a case expression. To turn the use of - native projections on, use [Set Primitive Projections]. Record, - Class and Structure types defined while this option is set will be - defined with primitive projections instead of the usual encoding as - a case expression. For compatibility, when p is a primitive - projection, @p can be used to refer to the projection with explicit - parameters, i.e. [@p] is definitionally equal to [λ params r. r.(p)]. - Records with primitive projections have eta-conversion, the - canonical form being [mkR pars (p1 t) ... (pn t)]. -- New universe polymorphism (see reference manual) -- New option -type-in-type to collapse the universe hierarchy (this makes the - logic inconsistent). -- The guard condition for fixpoints is now a bit stricter. Propagation - of subterm value through pattern matching is restricted according to - the return predicate. Restores compatibility of Coq's logic with the - propositional extensionality axiom. May create incompatibilities in - recursive programs heavily using dependent types. -- Trivial inductive types are no longer defined in Type but in Prop, which - leads to a non-dependent induction principle being generated in place of - the dependent one. To recover the old behavior, explicitly define your - inductive types in Set. - -Vernacular commands - -- A command "Variant" allows to define non-recursive variant types. -- The command "Record foo ..." does not generate induction principles - (foo_rect, foo_rec, foo_ind) anymore by default (feature wish - #2693). The command "Variant foo ..." does not either. A flag - "Set/Unset Nonrecursive Elimination Schemes" allows changing this. - The tactic "induction" on a "Record" or a "Variant" is now actually - doing "destruct". -- The "Open Scope" command can now be given also a delimiter (e.g. Z). -- The "Definition" command now allows the "Local" modifier, allowing - for non-importable definitions. The same goes for "Axiom" and "Parameter". -- Section-specific commands such as "Let" (resp. "Variable", "Hypothesis") used - out of a section now behave like the corresponding "Local" command, i.e. - "Local Definition" (resp. "Local Parameter", "Local Axiom"). (potential source - of rare incompatibilities). -- The "Let" command can now define local (co)fixpoints. -- Command "Search" has been renamed into "SearchHead". The command - name "Search" now behaves like former "SearchAbout". The latter name - is deprecated. -- "Search", "About", "SearchHead", "SearchRewrite" and "SearchPattern" - now search for hypothesis (of the current goal by default) first. - They now also support the goal selector prefix to specify another - goal to search: e.g. "n:Search id". This is also true for - SearchAbout although it is deprecated. -- The coq/user-contrib directory and the XDG directories are no longer - recursively added to the load path, so files from installed libraries - now need to be fully qualified for the "Require" command to find them. - The tools/update-require script can be used to convert a development. -- A new Print Strategies command allows visualizing the opacity status - of the whole engine. -- The "Locate" command now searches through all sorts of qualified namespaces of - Coq: terms, modules, tactics, etc. The old behavior of the command can be - retrieved using the "Locate Term" command. -- New "Derive" command to help writing program by derivation. -- New "Refine Instance Mode" option that allows to deactivate the generation of - obligations in incomplete typeclass instances, raising an error instead. -- "Collection" command to name sets of section hypotheses. Named collections - can be used in the syntax of "Proof using" to assert which section variables - are used in a proof. -- The "Optimize Proof" command can be placed in the middle of a proof to - force the compaction of the data structure used to represent the ongoing - proof (evar map). This may result in a lower memory footprint and speed up - the execution of the following tactics. -- "Optimize Heap" command to tell the OCaml runtime to perform a major - garbage collection step and heap compaction. -- "Instance" no longer treats the {|...|} syntax specially; it handles it - in the same way as other commands, e.g. "Definition". Use the {...} - syntax (no pipe symbols) to recover the old behavior. - -Specification Language - -- Slight changes in unification error messages. -- Added a syntax $(...)$ that allows putting tactics in terms (may - break user notations using "$(", fixable by inserting a space or - rewriting the notation). -- Constructors in pattern-matching patterns now respect the same rules - regarding implicit arguments as in applicative position. The old - behavior can be recovered by the command "Set Asymmetric - Patterns". As a side effect, notations for constructors explicitly - mentioning non-implicit parameters can now be used in patterns. - Considering that the pattern language is already rich enough, binding - local definitions is however now forbidden in patterns (source of - incompatibilities for local definitions that delta-reduce to a constructor). -- Type inference algorithm now granting opacity of constants. This might also - affect behavior of tactics (source of incompatibilities, solvable by - re-declaring transparent constants which were set opaque). -- Existential variables are now referred to by an identifier and the - relevant part of their instance is displayed by default. They can be - reparsed. The naming policy is yet unstable and subject to changes - in future releases. - -Tactics - -- New tactic engine allowing dependent subgoals, fully backtracking - (also known as multiple success) tactics, as well as tactics which - can consider multiple goals together. In the new tactic engine, - instantiation information of existential variables is always - propagated to tactics, removing the need to manually use the - "instantiate" tactics to mark propagation points. - * New tactical (a+b) inserts a backtracking point. When (a+b);c fails - during the execution of c, it can backtrack and try b instead of a. - * New tactical (once a) removes all the backtracking points from a - (i.e. it selects the first success of a). - * Tactic "constructor" is now fully backtracking. In case of - incompatibilities (e.g. combinatoric explosion), the former - behavior of "constructor" can be retrieved by using instead - "[> once constructor ..]". Thanks to backtracking, undocumented - "constructor <tac>" syntax is now equivalent to - "[> once (constructor; tac) ..]". - * New "multimatch" variant of "match" tactic which backtracks to - new branches in case of a later failure. The "match" tactic is - equivalent to "once multimatch". - * New selector "all:" such that "all:tac" applies tactic "tac" to - all the focused goals, instead of just the first one as is the - default. - * A corresponding new option Set Default Goal Selector "all" makes - the tactics in scripts be applied to all the focused goal by default - * New selector "par:" such that "par:tac" applies the (terminating) - tactic "tac" to all the focused goal in parallel. The number of worker - can be selected with -async-proofs-tac-j and also limited using the - coqworkmgr utility. - * New tactics "revgoals", "cycle" and "swap" to reorder goals. - * The semantics of recursive tactics (introduced with "Ltac t := ..." - or "let rec t := ... in ...") changed slightly as t is now - applied to every goal, not each goal independently. In particular - it may be applied when no goals are left. This may cause tactics - such as "let rec t := constructor;t" to loop indefinitely. The - simple fix is to rewrite the recursive calls as follows: - "let rec t := constructor;[t..]" which recovers the earlier behavior - (source of rare incompatibilities). - * New tactic language feature "numgoals" to count number of goals. It is - accompanied by a "guard" tactic which fails if a Boolean test over - integers does not pass. - * New tactical "[> ... ]" to apply tactics to individual goals. - * New tactic "gfail" which works like "fail" except it will also - fail if every goal has been solved. - * The refine tactic is changed not to use an ad hoc typing algorithm - to generate subgoals. It also uses the dependent subgoal feature - to generate goals to materialize every existential variable which - is introduced by the refinement (source of incompatibilities). - * A tactic shelve is introduced to manage the subgoals which may be - solved by unification: shelve removes every goal it is applied to - from focus. These goals can later be called back into focus by the - Unshelve command. - * A variant shelve_unifiable only removes those goals which appear - as existential variables in other goals. To emulate the old - refine, use "refine c;shelve_unifiable". This can still cause - incompatibilities in rare occasions. - * New "give_up" tactic to skip over a goal. A proof containing - given up goals cannot be closed with "Qed", but only with "Admitted". -- The implementation of the admit tactic has changed: no axiom is - generated for the admitted sub proof. "admit" is now an alias for - "give_up". Code relying on this specific behavior of "admit" - can be made to work by: - * Adding an "Axiom" for each admitted subproof. - * Adding a single "Axiom proof_admitted : False." and the Ltac definition - "Ltac admit := case proof_admitted.". -- Matching using "lazymatch" was fundamentally modified. It now behaves - like "match" (immediate execution of the matching branch) but without - the backtracking mechanism in case of failure. -- New "tryif t then u else v" tactical which executes "u" in case of success - of "t" and "v" in case of failure. -- New conversion tactic "native_compute": evaluates the goal (or an hypothesis) - with a call-by-value strategy, using the OCaml native compiler. Useful on - very intensive computations. -- New "cbn" tactic, a well-behaved simpl. -- Repeated identical calls to omega should now produce identical proof terms. -- Tactics btauto, a reflexive Boolean tautology solver. -- Tactic "tauto" was exceptionally able to destruct other connectives - than the binary connectives "and", "or", "prod", "sum", "iff". This - non-uniform behavior has been fixed (bug #2680) and tauto is - slightly weaker (possible source of incompatibilities). On the - opposite side, new tactic "dtauto" is able to destruct any - record-like inductive types, superseding the old version of "tauto". -- Similarly, "intuition" has been made more uniform and, where it now - fails, "dintuition" can be used (possible source of incompatibilities). -- New option "Unset Intuition Negation Unfolding" for deactivating automatic - unfolding of "not" in intuition. -- Tactic notations can now be defined locally to a module (use "Local" prefix). -- Tactic "red" now reduces head beta-iota redexes (potential source of - rare incompatibilities). -- Tactic "hnf" now reduces inner beta-iota redexes - (potential source of rare incompatibilities). -- Tactic "intro H" now reduces beta-iota redexes if these hide a product - (potential source of rare incompatibilities). -- In Ltac matching on patterns of the form "_ pat1 ... patn" now - behaves like if matching on "?X pat1 ... patn", i.e. accepting "_" - to be instantiated by an applicative term (experimental at this - stage, potential source of incompatibilities). -- In Ltac matching on goal, types of hypotheses are now interpreted in - the %type scope (possible source of incompatibilities). -- "change ... in ..." and "simpl ... in ..." now properly consider nested - occurrences (possible source of incompatibilities since this alters - the numbering of occurrences), but do not support nested occurrences. -- Tactics simpl, vm_compute and native_compute can be given a notation string - to a constant as argument. -- When given a reference as argument, simpl, vm_compute and - native_compute now strictly interpret it as the head of a pattern - starting with this reference. -- The "change p with c" tactic semantics changed, now type-checking - "c" at each matching occurrence "t" of the pattern "p", and - converting "t" with "c". -- Now "appcontext" and "context" behave the same. The old buggy behavior of - "context" can be retrieved at parse time by setting the - "Tactic Compat Context" flag (possible source of incompatibilities). -- New introduction pattern p/c which applies lemma c on the fly on the - hypothesis under consideration before continuing with introduction pattern p. -- New introduction pattern [= x1 .. xn] applies "injection as [x1 .. xn]" - on the fly if injection is applicable to the hypothesis under consideration - (idea borrowed from Georges Gonthier). Introduction pattern [=] applies - "discriminate" if a discriminable equality. -- New introduction patterns * and ** to respectively introduce all forthcoming - dependent variables and all variables/hypotheses dependent or not. -- Tactic "injection c as ipats" now clears c if c refers to an - hypothesis and moves the resulting equations in the hypotheses - independently of the number of ipats, which has itself to be less - than the number of new hypotheses (possible source of incompatibilities; - former behavior obtainable by "Unset Injection L2R Pattern Order"). -- Tactic "injection" now automatically simplifies subgoals - "existT n p = existT n p'" into "p = p'" when "n" is in an inductive type for - which a decidable equality scheme has been generated with "Scheme Equality" - (possible source of incompatibilities). -- New tactic "rewrite_strat" for generalized rewriting with user-defined - strategies, subsuming autorewrite. -- Injection can now also deduce equality of arguments of sort Prop, by using - the option "Set Injection On Proofs" (disabled by default). Also improved the - error messages. -- Tactic "subst id" now supports id occurring in dependent local definitions. -- Bugs fixed about intro-pattern "*" might lead to some rare incompatibilities. -- New tactical "time" to display time spent executing its argument. -- Tactics referring or using a constant dependent in a section variable which - has been cleared or renamed in the current goal context now fail - (possible source of incompatibilities solvable by avoiding clearing - the relevant hypotheses). -- New construct "uconstr:c" and "type_term c" to build untyped terms. -- Binders in terms defined in Ltac (either "constr" or "uconstr") can - now take their names from identifiers defined in Ltac. As a - consequence, a name cannot be used in a binder "constr:(fun x => - ...)" if an Ltac variable of that name already exists and does not - contain an identifier. Source of occasional incompatibilities. -- The "refine" tactic now accepts untyped terms built with "uconstr" - so that terms with holes can be constructed piecewise in Ltac. -- New bullets --, ++, **, ---, +++, ***, ... made available. -- More informative messages when wrong bullet is used. -- Bullet suggestion when a subgoal is solved. -- New tactic "enough", symmetric to "assert", but with subgoals - swapped, as a more friendly replacement of "cut". -- In destruct/induction, experimental modifier "!" prefixing the - hypothesis name to tell not erasing the hypothesis. -- Bug fixes in "inversion as" may occasionally lead to incompatibilities. -- Behavior of introduction patterns -> and <- made more uniform - (hypothesis is cleared, rewrite in hypotheses and conclusion and - erasing the variable when rewriting a variable). -- New experimental option "Set Standard Proposition Elimination Names" - so that case analysis or induction on schemes in Type containing - propositions now produces "H"-based names. -- Tactics from plugins are now active only when the corresponding module - is imported (source of incompatibilities, solvable by adding an "Import"; - in the particular case of Omega, use "Require Import OmegaTactic"). -- Semantics of destruct/induction has been made more regular in some - edge cases, possibly leading to incompatibilities: - - new goals are now opened when the term does not match a subterm of - the goal and has unresolved holes, while in 8.4 these holes were - turned into existential variables - - when no "at" option is given, the historical semantics which - selects all subterms syntactically identical to the first subterm - matching the given pattern is used - - non-dependent destruct/induction on an hypothesis with premises in - an inductive type with indices is fixed - - residual local definitions are now correctly removed. -- The rename tactic may now replace variables in parallel. -- A new "Info" command replaces the "info" tactical discontinued in - v8.4. It still gives informative results in many cases. -- The "info_auto" tactic is known to be broken and does not print a - trace anymore. Use "Info 1 auto" instead. The same goes for - "info_trivial". On the other hand "info_eauto" still works fine, - while "Info 1 eauto" prints a trivial trace. -- When using a lemma of the prototypical form "forall A, {a:A & P a}", - "apply" and "apply in" do not instantiate anymore "A" with the - current goal and use "a" as the proof, as they were sometimes doing, - now considering that it is a too powerful decision. - -Program - -- "Solve Obligations using" changed to "Solve Obligations with", - consistent with "Proof with". -- Program Lemma, Definition now respect automatic introduction. -- Program Lemma, Definition, etc.. now interpret "->" like Lemma and - Definition as a non-dependent arrow (potential source of - incompatibility). -- Add/document "Set Hide Obligations" (to hide obligations in the final - term inside an implicit argument) and "Set Shrink Obligations" (to - minimize dependencies of obligations defined by tactics). - -Notations - -- The syntax "x -> y" is now declared at level 99. In particular, it has - now a lower priority than "<->": "A -> B <-> C" is now "A -> (B <-> C)" - (possible source of incompatibilities) -- Notations accept term-providing tactics using the $(...)$ syntax. -- "Bind Scope" can no longer bind "Funclass" and "Sortclass". -- A notation can be given a (compat "8.x") annotation, making it behave - like a "only parsing" notation, but the annotation may lead to eventually - issue warnings or errors in further versions when this notation is used. -- More systematic insertion of spaces as a default for printing - notations ("format" still available to override the default). -- In notations, a level modifier referring to a non-existent variable is - now considered an error rather than silently ignored. - -Tools - -- Option -I now only adds directories to the ml path. -- Option -Q behaves as -R, except that the logical path of any loaded file has - to be fully qualified. -- Option -R no longer adds recursively to the ml path; only the root - directory is added. (Behavior with respect to the load path is - unchanged.) -- Option -nois prevents coq/theories and coq/plugins to be recursively - added to the load path. (Same behavior as with coq/user-contrib.) -- coqdep accepts a -dumpgraph option generating a dot file. -- Makefiles generated through coq_makefile have three new targets "quick" - "checkproofs" and "vio2vo", allowing respectively to asynchronously compile - the files without playing the proof scripts, asynchronously checking - that the quickly generated proofs are correct and generating the object - files from the quickly generated proofs. -- The XML plugin was discontinued and removed from the source. -- A new utility called coqworkmgr can be used to limit the number of - concurrent workers started by independent processes, like make and CoqIDE. - This is of interest for users of the par: goal selector. - -Interfaces - -- CoqIDE supports asynchronous edition of the document, ongoing tasks and - errors are reported in the bottom right window. The number of workers - taking care of processing proofs can be selected with -async-proofs-j. -- CoqIDE highlights in yellow "unsafe" commands such as axiom - declarations, and tactics like "give_up". -- CoqIDE supports Proof General like key bindings; - to activate the PG mode go to Edit -> Preferences -> Editor. - For the documentation see Help -> Help for PG mode. -- CoqIDE automatically retracts the locked area when one edits the - locked text. -- CoqIDE search and replace got regular expressions power. See the - documentation of OCaml's Str module for the supported syntax. -- Many CoqIDE windows, including the query one, are now detachable to - improve usability on multi screen work stations. -- Coqtop/coqc outputs highlighted syntax. Colors can be configured thanks - to the COQ_COLORS environment variable, and their current state can - be displayed with the -list-tags command line option. -- Third party user interfaces can install their main loop in $COQLIB/toploop - and call coqtop with the -toploop flag to select it. - -Internal Infrastructure - -- Many reorganizations in the ocaml source files. For instance, - many internal a.s.t. of Coq are now placed in mli files in - a new directory intf/, for instance constrexpr.mli or glob_term.mli. - More details in dev/doc/changes. -- The file states/initial.coq does not exist anymore. Instead, coqtop - initially does a "Require" of Prelude.vo (or nothing when given - the options -noinit or -nois). -- The format of vo files has slightly changed: cf final comments in - checker/cic.mli. -- The build system does not produce anymore programs named coqtop.opt - and a symbolic link to coqtop. Instead, coqtop is now directly - an executable compiled with the best OCaml compiler available. - The bytecode program coqtop.byte is still produced. Same for other - utilities. -- Some options of the ./configure script slightly changed: - * The -coqrunbyteflags and its blank-separated argument is replaced - by option -vmbyteflags which expects a comma-separated argument. - * The -coqtoolsbyteflags option is discontinued, see -no-custom instead. - -Miscellaneous - -- ML plugins now require a "DECLARE PLUGIN \"foo\"" statement. The "foo" name - must be exactly the name of the ML module that will be loaded through a - "Declare ML \"foo\"" command. - -Changes from V8.4beta2 to V8.4 -============================== - -Vernacular commands - -- The "Reset" command is now supported again in files given to coqc or Load. -- "Show Script" now indents again the displayed scripts. It can also work - correctly across Load'ed files if the option "Unset Atomic Load" is used. -- "Open Scope" can now be given the delimiter (e.g. Z) instead of the full - scope name (e.g. Z_scope). - -Notations - -- Most compatibility notations of the standard library are now tagged as - (compat xyz), where xyz is a former Coq version, for instance "8.3". - These notations behave as (only parsing) notations, except that they may - triggers warnings (or errors) when used while Coq is not in a corresponding - -compat mode. -- To activate these compatibility warnings, use "Set Verbose Compat Notations" - or the command-line flag -verbose-compat-notations. -- For a strict mode without these compatibility notations, use - "Unset Compat Notations" or the command-line flag -no-compat-notations. - -Tactics - -- An annotation "eqn:H" or "eqn:?" can be added to a "destruct" - or "induction" to make it generate equations in the spirit of "case_eq". - The former syntax "_eqn" is discontinued. -- The name of the hypothesis introduced by tactic "remember" can be - set via the new syntax "remember t as x eqn:H" (wish #2489). - -Libraries - -- Reals: changed definition of PI, no more axiom about sin(PI/2). -- SetoidPermutation: a notion of permutation for lists modulo a setoid equality. -- BigN: fixed the ocaml code doing the parsing/printing of big numbers. -- List: a couple of lemmas added especially about no-duplication, partitions. -- Init: Removal of the coercions between variants of sigma-types and - subset types (possible source of incompatibility). - -Changes from V8.4beta to V8.4beta2 -================================== - -Vernacular commands - -- Commands "Back" and "BackTo" are now handling the proof states. They may - perform some extra steps of backtrack to avoid states where the proof - state is unavailable (typically a closed proof). -- The commands "Suspend" and "Resume" have been removed. -- A basic Show Script has been reintroduced (no indentation). -- New command "Set Parsing Explicit" for deactivating parsing (and printing) - of implicit arguments (useful for teaching). -- New command "Grab Existential Variables" to transform the unresolved evars - at the end of a proof into goals. - -Tactics - -- Still no general "info" tactical, but new specific tactics info_auto, - info_eauto, info_trivial which provides information on the proofs found - by auto/eauto/trivial. Display of these details could also be activated by - "Set Info Auto"/"Set Info Eauto"/"Set Info Trivial". -- Details on everything tried by auto/eauto/trivial during a proof search - could be obtained by "debug auto", "debug eauto", "debug trivial" or by a - global "Set Debug Auto"/"Set Debug Eauto"/"Set Debug Trivial". -- New command "r string" in Ltac debugger that interprets "idtac - string" in Ltac code as a breakpoint and jumps to its next use. -- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl, - harvey, zenon, gwhy) have been removed, since Why2 has not been - maintained for the last few years. The Why3 plugin should be a suitable - replacement in most cases. - -Libraries - -- MSetRBT: a new implementation of MSets via Red-Black trees (initial - contribution by Andrew Appel). -- MSetAVL: for maximal sharing with the new MSetRBT, the argument order - of Node has changed (this should be transparent to regular MSets users). - -Module System - -- The names of modules (and module types) are now in a fully separated - namespace from ordinary definitions: "Definition E:=0. Module E. End E." - is now accepted. - -CoqIDE - -- Coqide now supports the "Restart" command, and "Undo" (with a warning). - Better support for "Abort". - -Changes from V8.3 to V8.4beta -============================= - -Logic - -- Standard eta-conversion now supported (dependent product only). -- Guard condition improvement: subterm property is propagated through beta-redex - blocked by pattern-matching, as in "(match v with C .. => fun x => u end) x"; - this allows for instance to use "rewrite ... in ..." without breaking - the guard condition. - -Specification language and notations - -- Maximal implicit arguments can now be set locally by { }. The registration - traverses fixpoints and lambdas. Because there is conversion in types, - maximal implicit arguments are not taken into account in partial - applications (use eta expanded form with explicit { } instead). -- Added support for recursive notations with binders (allows for instance - to write "exists x y z, P"). -- Structure/Record printing can be disable by "Unset Printing Records". - In addition, it can be controlled on type by type basis using - "Add Printing Record" or "Add Printing Constructor". -- Pattern-matching compilation algorithm: in "match x, y with ... end", - possible dependencies of x (or of the indices of its type) in the type - of y are now taken into account. - -Tactics - -- New proof engine. -- Scripts can now be structured thanks to bullets - * + and to subgoal - delimitation via { }. Note: for use with Proof General, a cvs version of - Proof General no older than mid-July 2011 is currently required. -- Support for tactical "info" is suspended. -- Support for command "Show Script" is suspended. -- New tactics constr_eq, is_evar and has_evar for use in Ltac (DOC TODO). -- Removed the two-argument variant of "decide equality". -- New experimental tactical "timeout <n> <tac>". Since <n> is a time - in second for the moment, this feature should rather be avoided - in scripts meant to be machine-independent. -- Fix in "destruct": removal of unexpected local definitions in context might - result in some rare incompatibilities (solvable by adapting name hypotheses). -- Introduction pattern "_" made more robust. -- Tactic (and Eval command) vm_compute can now be interrupted via Ctrl-C. -- Unification in "apply" supports unification of patterns of the form - ?f x y = g(x,y) (compatibility ensured by using - "Unset Tactic Pattern Unification"). It also supports (full) betaiota. -- Tactic autorewrite does no longer instantiate pre-existing - existential variables (theoretical source of possible incompatibilities). -- Tactic "dependent rewrite" now supports equality in "sig". -- Tactic omega now understands Zpred (wish #1912) and can prove any goal - from a context containing an arithmetical contradiction (wish #2236). -- Using "auto with nocore" disables the use of the "core" database (wish #2188). - This pseudo-database "nocore" can also be used with trivial and eauto. -- Tactics "set", "destruct" and "induction" accepts incomplete terms and - use the goal to complete the pattern assuming it is non ambiguous. -- When used on arguments with a dependent type, tactics such as - "destruct", "induction", "case", "elim", etc. now try to abstract - automatically the dependencies over the arguments of the types - (based on initial ideas from Chung-Kil Hur, extension to nested - dependencies suggested by Dan Grayson) -- Tactic "injection" now failing on an equality showing no constructors while - it was formerly generalizing again the goal over the given equality. -- In Ltac, the "context [...]" syntax has now a variant "appcontext [...]" - allowing to match partial applications in larger applications. -- When applying destruct or inversion on a fixpoint hiding an inductive - type, recursive calls to the fixpoint now remain folded by default (rare - source of incompatibility generally solvable by adding a call to simpl). -- In an ltac pattern containing a "match", a final "| _ => _" branch could be - used now instead of enumerating all remaining constructors. Moreover, the - pattern "match _ with _ => _ end" now allows to match any "match". A "in" - annotation can also be added to restrict to a precise inductive type. -- The behavior of "simpl" can be tuned using the "Arguments" vernacular. - In particular constants can be marked so that they are always/never unfolded - by "simpl", or unfolded only when a set of arguments evaluates to a - constructor. Last one can mark a constant so that it is unfolded only if the - simplified term does not expose a match in head position. - -Vernacular commands - -- It is now mandatory to have a space (or tabulation or newline or end-of-file) - after a "." ending a sentence. -- In SearchAbout, the [ ] delimiters are now optional. -- New command "Add/Remove Search Blacklist <substring> ...": - a Search or SearchAbout or similar query will never mention lemmas - whose qualified names contain any of the declared substrings. - The default blacklisted substrings are "_subproof" "Private_". -- When the output file of "Print Universes" ends in ".dot" or ".gv", - the universe graph is printed in the DOT language, and can be - processed by Graphviz tools. -- New command "Print Sorted Universes". -- The undocumented and obsolete option "Set/Unset Boxed Definitions" has - been removed, as well as syntaxes like "Boxed Fixpoint foo". -- A new option "Set Default Timeout n / Unset Default Timeout". -- Qed now uses information from the reduction tactics used in proof script - to avoid conversion at Qed time to go into a very long computation. -- New command "Show Goal ident" to display the statement of a goal, even - a closed one (available from Proof General). -- Command "Proof" accept a new modifier "using" to force generalization - over a given list of section variables at section ending (DOC TODO). -- New command "Arguments" generalizing "Implicit Arguments" and - "Arguments Scope" and that also allows to rename the parameters of a - definition and to tune the behavior of the tactic "simpl". - -Module System - -- During subtyping checks, an opaque constant in a module type could now - be implemented by anything of the right type, even if bodies differ. - Said otherwise, with respect to subtyping, an opaque constant behaves - just as a parameter. Coqchk was already implementing this, but not coqtop. -- The inlining done during application of functors can now be controlled - more precisely, by the annotations (no inline) or (inline at level XX). - With the latter annotation, only functor parameters whose levels - are lower or equal than XX will be inlined. - The level of a parameter can be fixed by "Parameter Inline(30) foo". - When levels aren't given, the default value is 100. One can also use - the flag "Set Inline Level ..." to set a level (DOC TODO). -- Print Assumptions should now handle correctly opaque modules (#2168). -- Print Module (Type) now tries to print more details, such as types and - bodies of the module elements. Note that Print Module Type could be - used on a module to display only its interface. The option - "Set Short Module Printing" could be used to switch back to the earlier - behavior were only field names were displayed. - -Libraries - -- Extension of the abstract part of Numbers, which now provide axiomatizations - and results about many more integer functions, such as pow, gcd, lcm, sqrt, - log2 and bitwise functions. These functions are implemented for nat, N, BigN, - Z, BigZ. See in particular file NPeano for new functions about nat. -- The definition of types positive, N, Z is now in file BinNums.v -- Major reorganization of ZArith. The initial file ZArith/BinInt.v now contains - an internal module Z implementing the Numbers interface for integers. - This module Z regroups: - * all functions over type Z : Z.add, Z.mul, ... - * the minimal proofs of specifications for these functions : Z.add_0_l, ... - * an instantation of all derived properties proved generically in Numbers : - Z.add_comm, Z.add_assoc, ... - A large part of ZArith is now simply compatibility notations, for instance - Zplus_comm is an alias for Z.add_comm. The direct use of module Z is now - recommended instead of relying on these compatibility notations. -- Similar major reorganization of NArith, via a module N in NArith/BinNat.v -- Concerning the positive datatype, BinPos.v is now in a specific directory - PArith, and contains an internal submodule Pos. We regroup there functions - such as Pos.add Pos.mul etc as well as many results about them. These results - are here proved directly (no Number interface for strictly positive numbers). -- Note that in spite of the compatibility layers, all these reorganizations - may induce some marginal incompatibilies in scripts. In particular: - * the "?=" notation for positive now refers to a binary function Pos.compare, - instead of the infamous ternary Pcompare (now Pos.compare_cont). - * some hypothesis names generated by the system may changed (typically for - a "destruct Z_le_gt_dec") since naming is done after the short name of - the head predicate (here now "le" in module Z instead of "Zle", etc). - * the internals of Z.add has changed, now relying of Z.pos_sub. -- Also note these new notations: - * "<?" "<=?" "=?" for boolean tests such as Z.ltb Z.leb Z.eqb. - * "÷" for the alternative integer division Z.quot implementing the Truncate - convention (former ZOdiv), while the notation for the Coq usual division - Z.div implementing the Flooring convention remains "/". Their corresponding - modulo functions are Z.rem (no notations) for Z.quot and Z.modulo (infix - "mod" notation) for Z.div. -- Lemmas about conversions between these datatypes are also organized - in modules, see for instance modules Z2Nat, N2Z, etc. -- When creating BigN, the macro-generated part NMake_gen is much smaller. - The generic part NMake has been reworked and improved. Some changes - may introduce incompatibilities. In particular, the order of the arguments - for BigN.shiftl and BigN.shiftr is now reversed: the number to shift now - comes first. By default, the power function now takes two BigN. -- Creation of Vector, an independent library for lists indexed by their length. - Vectors' names overwrite lists' one so you should not "Import" the library. - All old names changed: function names follow the ocaml ones and, for example, - Vcons becomes Vector.cons. You can get [..;..;..]-style notations by importing - Vector.VectorNotations. -- Removal of TheoryList. Requiring List instead should work most of the time. -- New syntax "rew Heq in H" and "rew <- Heq in H" for eq_rect and - eq_rect_r (available by importing module EqNotations). -- Wf.iter_nat is now Peano.nat_iter (with an implicit type argument). - -Internal infrastructure - -- Opaque proofs are now loaded lazily by default. This allows to be almost as - fast as -dont-load-proofs, while being safer (no creation of axioms) and - avoiding feature restrictions (Print and Print Assumptions work ok). -- Revised hash-consing code allowing more sharing of memory -- Experimental support added for camlp4 (the one provided alongside ocaml), - simply pass option -usecamlp4 to ./configure. By default camlp5 is used. -- Revised build system: no more stages in Makefile thanks to some recursive - aspect of recent gnu make, use of vo.itarget files containing .v to compile - for both make and ocamlbuild, etc. -- Support of cross-compilation via mingw from unix toward Windows, - contact P. Letouzey for more informations. -- New Makefile rules mli-doc to make html of mli in dev/doc/html and - full-stdlib to get a (huge) pdf reflecting the whole standard library. - -Extraction - -- By default, opaque terms are now truly considered opaque by extraction: - instead of accessing their body, they are now considered as axioms. - The previous behaviour can be reactivated via the option - "Set Extraction AccessOpaque". -- The pretty-printer for Haskell now produces layout-independent code -- A new command "Separate Extraction cst1 cst2 ..." that mixes a - minimal extracted environment a la "Recursive Extraction" and the - production of several files (one per coq source) a la "Extraction Library" - (DOC TODO). -- New option "Set/Unset Extraction KeepSingleton" for preventing the - extraction to optimize singleton container types (DOC TODO). -- The extraction now identifies and properly rejects a particular case of - universe polymorphism it cannot handle yet (the pair (I,I) being Prop). -- Support of anonymous fields in record (#2555). - -CoqIDE - -- Coqide now runs coqtop as separated process, making it more robust: - coqtop subprocess can be interrupted, or even killed and relaunched - (cf button "Restart Coq", ex-"Go to Start"). For allowing such - interrupts, the Windows version of coqide now requires Windows >= XP - SP1. -- The communication between CoqIDE and Coqtop is now done via a dialect - of XML (DOC TODO). -- The backtrack engine of CoqIDE has been reworked, it now uses the - "Backtrack" command similarly to Proof General. -- The Coqide parsing of sentences has be reworked and now supports - tactic delimitation via { }. -- Coqide now accepts the Abort command (wish #2357). -- Coqide can read coq_makefile files as "project file" and use it to - set automatically options to send to coqtop. -- Preference files have moved to $XDG_CONFIG_HOME/coq and accelerators - are not stored as a list anymore. - -Tools - -- Coq now searches directories specified in COQPATH, $XDG_DATA_HOME/coq, - $XDG_DATA_DIRS/coq, and user-contribs before the standard library. -- Coq rc file has moved to $XDG_CONFIG_HOME/coq. -- Major changes to coq_makefile: - * mli/mlpack/mllib taken into account, ml not preproccessed anymore, ml4 work; - * mlihtml generates doc of mli, install-doc install the html doc in DOCDIR - with the same policy as vo in COQLIB; - * More variables are given by coqtop -config, others are defined only if the - users doesn't have defined them elsewhere. Consequently, generated makefile - should work directly on any architecture; - * Packagers can take advantage of $(DSTROOT) introduction. Installation can - be made in $XDG_DATA_HOME/coq; - * -arg option allows to send option as argument to coqc. - -Changes from V8.2 to V8.3 -========================= - -Rewriting tactics - -- Tactic "rewrite" now supports rewriting on ad hoc equalities such as eq_true. -- "Hint Rewrite" now checks that the lemma looks like an equation. -- New tactic "etransitivity". -- Support for heterogeneous equality (JMeq) in "injection" and "discriminate". -- Tactic "subst" now supports heterogeneous equality and equality - proofs that are dependent (use "simple subst" for preserving compatibility). -- Added support for Leibniz-rewriting of dependent hypotheses. -- Renamed "Morphism" into "Proper" and "respect" into "proper_prf" - (possible source of incompatibility). A partial fix is to define - "Notation Morphism R f := (Proper (R%signature) f)." -- New tactic variants "rewrite* by" and "autorewrite*" that rewrite - respectively the first and all matches whose side-conditions are - solved. -- "Require Import Setoid" does not export all of "Morphisms" and - "RelationClasses" anymore (possible source of incompatibility, fixed - by importing "Morphisms" too). -- Support added for using Chung-Kil Hur's Heq library for rewriting over - heterogeneous equality (courtesy of the library's author). -- Tactic "replace" supports matching terms with holes. - -Automation tactics - -- Tactic "intuition" now preserves inner "iff" and "not" (exceptional - source of incompatibilities solvable by redefining "intuition" as - "unfold iff, not in *; intuition", or, for iff only, by using - "Set Intuition Iff Unfolding".) -- Tactic "tauto" now proves classical tautologies as soon as classical logic - (i.e. library Classical_Prop or Classical) is loaded. -- Tactic "gappa" has been removed from the Dp plugin. -- Tactic "firstorder" now supports the combination of its "using" and - "with" options. -- New "Hint Resolve ->" (or "<-") for declaring iff's as oriented - hints (wish #2104). -- An inductive type as argument of the "using" option of "auto/eauto/firstorder" - is interpreted as using the collection of its constructors. -- New decision tactic "nsatz" to prove polynomial equations - by computation of Groebner bases. - -Other tactics - -- Tactic "discriminate" now performs intros before trying to discriminate an - hypothesis of the goal (previously it applied intro only if the goal - had the form t1<>t2) (exceptional source of incompatibilities - former - behavior can be obtained by "Unset Discriminate Introduction"). -- Tactic "quote" now supports quotation of arbitrary terms (not just the - goal). -- Tactic "idtac" now displays its "list" arguments. -- New introduction patterns "*" for introducing the next block of dependent - variables and "**" for introducing all quantified variables and hypotheses. -- Pattern Unification for existential variables activated in tactics and - new option "Unset Tactic Evars Pattern Unification" to deactivate it. -- Resolution of canonical structure is now part of the tactic's unification - algorithm. -- New tactic "decide lemma with hyp" for rewriting decidability lemmas - when one knows which side is true. -- Improved support of dependent goals over objects in dependent types for - "destruct" (rare source of incompatibility that can be avoided by unsetting - option "Dependent Propositions Elimination"). -- Tactic "exists", "eexists", "destruct" and "edestruct" supports iteration - using comma-separated arguments. -- Tactic names "case" and "elim" now support clauses "as" and "in" and become - then synonymous of "destruct" and "induction" respectively. -- A new tactic name "exfalso" for the use of 'ex-falso quodlibet' principle. - This tactic is simply a shortcut for "elimtype False". -- Made quantified hypotheses get the name they would have if introduced in - the context (possible but rare source of incompatibilities). -- When applying a component of a conjunctive lemma, "apply in" (and - sequences of "apply in") now leave the side conditions of the lemmas - uniformly after the main goal (possible source of rare incompatibilities). -- In "simpl c" and "change c with d", c can be a pattern. -- Tactic "revert" now preserves let-in's making it the exact inverse of - "intro". -- New tactics "clear dependent H" and "revert dependent H" that - clears (resp. reverts) H and all the hypotheses that depend on H. -- Ltac's pattern-matching now supports matching metavariables that - depend on variables bound upwards in the pattern. - -Tactic definitions - -- Ltac definitions support Local option for non-export outside modules. -- Support for parsing non-empty lists with separators in tactic notations. -- New command "Locate Ltac" to get the full name of an Ltac definition. - -Notations - -- Record syntax "{|x=...; y=...|}" now works inside patterns too. -- Abbreviations from non-imported module now invisible at printing time. -- Abbreviations now use implicit arguments and arguments scopes for printing. -- Abbreviations to pure names now strictly behave like the name they refer to - (make redirections of qualified names easier). -- Abbreviations for applied constant now propagate the implicit arguments - and arguments scope of the underlying reference (possible source of - incompatibilities generally solvable by changing such abbreviations from - e.g. "Notation foo' := (foo x)" to "Notation foo' y := (foo x (y:=y))"). -- The "where" clause now supports multiple notations per defined object. -- Recursive notations automatically expand one step on the left for better - factorization; recursion notations inner separators now ensured being tokens. -- Added "Reserved Infix" as a specific shortcut of the corresponding - "Reserved Notation". -- Open/Close Scope command supports Global option in sections. - -Specification language - -- New support for local binders in the syntax of Record/Structure fields. -- Fixpoint/CoFixpoint now support building part or all of bodies using tactics. -- Binders given before ":" in lemmas and in definitions built by tactics are - now automatically introduced (possible source of incompatibility that can - be resolved by invoking "Unset Automatic Introduction"). -- New support for multiple implicit arguments signatures per reference. - -Module system - -- Include Type is now deprecated since Include now accept both modules and - module types. -- Declare ML Module supports Local option. -- The sharing between non-logical object and the management of the - name-space has been improved by the new "Delta-equivalence" on - qualified name. -- The include operator has been extended to high-order structures -- Sequences of Include can be abbreviated via new syntax "<+". -- A module (or module type) can be given several "<:" signatures. -- Interactive proofs are now permitted in module type. Functors can hence - be declared as Module Type and be used later to type themselves. -- A functor application can be prefixed by a "!" to make it ignore any - "Inline" annotation in the type of its argument(s) (for examples of - use of the new features, see libraries Structures and Numbers). -- Coercions are now active only when modules are imported (use "Set Automatic - Coercions Import" to get the behavior of the previous versions of Coq). - -Extraction - -- When using (Recursive) Extraction Library, the filenames are directly the - Coq ones with new appropriate extensions : we do not force anymore - uncapital first letters for Ocaml and capital ones for Haskell. -- The extraction now tries harder to avoid code transformations that can be - dangerous for the complexity. In particular many eta-expansions at the top - of functions body are now avoided, clever partial applications will likely - be preserved, let-ins are almost always kept, etc. -- In the same spirit, auto-inlining is now disabled by default, except for - induction principles, since this feature was producing more frequently - weird code than clear gain. The previous behavior can be restored via - "Set Extraction AutoInline". -- Unicode characters in identifiers are now transformed into ascii strings - that are legal in Ocaml and other languages. -- Harsh support of module extraction to Haskell and Scheme: module hierarchy - is flattened, module abbreviations and functor applications are expanded, - module types and unapplied functors are discarded. -- Less unsupported situations when extracting modules to Ocaml. In particular - module parameters might be alpha-renamed if a name clash is detected. -- Extract Inductive is now possible toward non-inductive types (e.g. nat => int) -- Extraction Implicit: this new experimental command allows to mark - some arguments of a function or constructor for removed during - extraction, even if these arguments don't fit the usual elimination - principles of extraction, for instance the length n of a vector. -- Files ExtrOcaml*.v in plugins/extraction try to provide a library of common - extraction commands: mapping of basics types toward Ocaml's counterparts, - conversions from/to int and big_int, or even complete mapping of nat,Z,N - to int or big_int, or mapping of ascii to char and string to char list - (in this case recognition of ascii constants is hard-wired in the extraction). - -Program - -- Streamlined definitions using well-founded recursion and measures so - that they can work on any subset of the arguments directly (uses currying). -- Try to automatically clear structural fixpoint prototypes in - obligations to avoid issues with opacity. -- Use return type clause inference in pattern-matching as in the standard - typing algorithm. -- Support [Local Obligation Tactic] and [Next Obligation with tactic]. -- Use [Show Obligation Tactic] to print the current default tactic. -- [fst] and [snd] have maximal implicit arguments in Program now (possible - source of incompatibility). - -Type classes - -- Declaring axiomatic type class instances in Module Type should be now - done via new command "Declare Instance", while the syntax "Instance" - now always provides a concrete instance, both in and out of Module Type. -- Use [Existing Class foo] to declare foo as a class a posteriori. - [foo] can be an inductive type or a constant definition. No - projections or instances are defined. -- Various bug fixes and improvements: support for defined fields, - anonymous instances, declarations giving terms, better handling of - sections and [Context]. - -Vernacular commands - -- New command "Timeout <n> <command>." interprets a command and a timeout - interrupts the interpretation after <n> seconds. -- New command "Compute <expr>." is a shortcut for "Eval vm_compute in <expr>". -- New command "Fail <command>." interprets a command and is successful iff - the command fails on an error (but not an anomaly). Handy for tests and - illustration of wrong commands. -- Most commands referring to constant (e.g. Print or About) now support - referring to the constant by a notation string. -- New option "Boolean Equality Schemes" to make generation of boolean - equality automatic for datatypes (together with option "Decidable - Equality Schemes", this replaces deprecated option "Equality Scheme"). -- Made support for automatic generation of case analysis schemes available - to user (governed by option "Set Case Analysis Schemes"). -- New command "(Global?) Generalizable [All|No] Variable(s)? ident(s)?" to - declare which identifiers are generalizable in `{} and `() binders. -- New command "Print Opaque Dependencies" to display opaque constants in - addition to all variables, parameters or axioms a theorem or - definition relies on. -- New command "Declare Reduction <id> := <conv_expr>", allowing to write - later "Eval <id> in ...". This command accepts a Local variant. -- Syntax of Implicit Type now supports more than one block of variables of - a given type. -- Command "Canonical Structure" now warns when it has no effects. -- Commands of the form "Set X" or "Unset X" now support "Local" and "Global" - prefixes. - -Library - -- Use "standard" Coq names for the properties of eq and identity - (e.g. refl_equal is now eq_refl). Support for compatibility is provided. -- The function Compare_dec.nat_compare is now defined directly, - instead of relying on lt_eq_lt_dec. The earlier version is still - available under the name nat_compare_alt. -- Lemmas in library Relations and Reals have been homogenized a bit. -- The implicit argument of Logic.eq is now maximally inserted, allowing - to simply write "eq" instead of "@eq _" in morphism signatures. -- Wrongly named lemmas (Zlt_gt_succ and Zlt_succ_gt) fixed (potential source - of incompatibilities) -- List library: - - Definitions of list, length and app are now in Init/Datatypes. - Support for compatibility is provided. - - Definition of Permutation is now in Sorting/Permtation.v - - Some other light revisions and extensions (possible source - of incompatibilities solvable by qualifying names accordingly). -- In ListSet, set_map has been fixed (source of incompatibilities if used). -- Sorting library: - - new mergesort of worst-case complexity O(n*ln(n)) made available in - Mergesort.v; - - former notion of permutation up to setoid from Permutation.v is - deprecated and moved to PermutSetoid.v; - - heapsort from Heap.v of worst-case complexity O(n*n) is deprecated; - - new file Sorted.v for some definitions of being sorted. -- Structure library. This new library is meant to contain generic - structures such as types with equalities or orders, either - in Module version (for now) or Type Classes (still to do): - - DecidableType.v and OrderedType.v: initial notions for FSets/FMaps, - left for compatibility but considered as deprecated. - - Equalities.v and Orders.v: evolutions of the previous files, - with fine-grain Module architecture, many variants, use of - Equivalence and other relevant Type Classes notions. - - OrdersTac.v: a generic tactic for solving chains of (in)equalities - over variables. See {Nat,N,Z,P}OrderedType.v for concrete instances. - - GenericMinMax.v: any ordered type can be equipped with min and max. - We derived here all the generic properties of these functions. -- MSets library: an important evolution of the FSets library. - "MSets" stands for Modular (Finite) Sets, by contrast with a forthcoming - library of Class (Finite) Sets contributed by S. Lescuyer which will be - integrated with the next release of Coq. The main features of MSets are: - - The use of Equivalence, Proper and other Type Classes features - easing the handling of setoid equalities. - - The interfaces are now stated in iff-style. Old specifications - are now derived properties. - - The compare functions are now pure, and return a "comparison" value. - Thanks to the CompSpec inductive type, reasoning on them remains easy. - - Sets structures requiring invariants (i.e. sorted lists) are - built first as "Raw" sets (pure objects and separate proofs) and - attached with their proofs thanks to a generic functor. "Raw" sets - have now a proper interface and can be manipulated directly. - Note: No Maps yet in MSets. The FSets library is still provided - for compatibility, but will probably be considered as deprecated in the - next release of Coq. -- Numbers library: - - The abstract layer (NatInt, Natural/Abstract, Integer/Abstract) has - been simplified and enhance thanks to new features of the module - system such as Include (see above). It has been extended to Euclidean - division (three flavors for integers: Trunc, Floor and Math). - - The arbitrary-large efficient numbers (BigN, BigZ, BigQ) has also - been reworked. They benefit from the abstract layer improvements - (especially for div and mod). Note that some specifications have - slightly changed (compare, div, mod, shift{r,l}). Ring/Field should - work better (true recognition of constants). - -Tools - -- Option -R now supports binding Coq root read-only. -- New coqtop/coqc option -beautify to reformat .v files (usable - e.g. to globally update notations). -- New tool beautify-archive to beautify a full archive of developments. -- New coqtop/coqc option -compat X.Y to simulate the general behavior - of previous versions of Coq (provides e.g. support for 8.2 compatibility). - -Coqdoc - -- List have been revamped. List depth and scope is now determined by - an "offside" whitespace rule. -- Text may be italicized by placing it in _underscores_. -- The "--index <string>" flag changes the filename of the index. -- The "--toc-depth <int>" flag limits the depth of headers which are - included in the table of contents. -- The "--lib-name <string>" flag prints "<string> Foo" instead of - "Library Foo" where library titles are called for. The - "--no-lib-name" flag eliminates the extra title. -- New option "--parse-comments" to allow parsing of regular "(* *)" - comments. -- New option "--plain-comments" to disable interpretation inside comments. -- New option "--interpolate" to try and typeset identifiers in Coq escapings - using the available globalization information. -- New option "--external url root" to refer to external libraries. -- Links to section variables and notations now supported. - -Internal infrastructure - -- To avoid confusion with the repository of user's contributions, - the subdirectory "contrib" has been renamed into "plugins". - On platforms supporting ocaml native dynlink, code located there - is built as loadable plugins for coqtop. -- An experimental build mechanism via ocamlbuild is provided. - From the top of the archive, run ./configure as usual, and - then ./build. Feedback about this build mechanism is most welcome. - Compiling Coq on platforms such as Windows might be simpler - this way, but this remains to be tested. -- The Makefile system has been simplified and factorized with - the ocamlbuild system. In particular "make" takes advantage - of .mllib files for building .cma/.cmxa. The .vo files to - compile are now listed in several vo.itarget files. - -Changes from V8.1 to V8.2 -========================= - -Language - -- If a fixpoint is not written with an explicit { struct ... }, then - all arguments are tried successively (from left to right) until one is - found that satisfies the structural decreasing condition. -- New experimental typeclass system giving ad-hoc polymorphism and - overloading based on dependent records and implicit arguments. -- New syntax "let 'pat := b in c" for let-binding using irrefutable patterns. -- New syntax "forall {A}, T" for specifying maximally inserted implicit - arguments in terms. -- Sort of Record/Structure, Inductive and CoInductive defaults to Type - if omitted. -- (Co)Inductive types can be defined as records - (e.g. "CoInductive stream := { hd : nat; tl : stream }.") -- New syntax "Theorem id1:t1 ... with idn:tn" for proving mutually dependent - statements. -- Support for sort-polymorphism on constants denoting inductive types. -- Several evolutions of the module system (handling of module aliases, - functorial module types, an Include feature, etc). -- Prop now a subtype of Set (predicative and impredicative forms). -- Recursive inductive types in Prop with a single constructor of which - all arguments are in Prop is now considered to be a singleton - type. It consequently supports all eliminations to Prop, Set and Type. - As a consequence, Acc_rect has now a more direct proof [possible source - of easily fixed incompatibility in case of manual definition of a recursor - in a recursive singleton inductive type]. - -Vernacular commands - -- Added option Global to "Arguments Scope" for section surviving. -- Added option "Unset Elimination Schemes" to deactivate the automatic - generation of elimination schemes. -- Modification of the Scheme command so you can ask for the name to be - automatically computed (e.g. Scheme Induction for nat Sort Set). -- New command "Combined Scheme" to build combined mutual induction - principles from existing mutual induction principles. -- New command "Scheme Equality" to build a decidable (boolean) equality - for simple inductive datatypes and a decision property over this equality - (e.g. Scheme Equality for nat). -- Added option "Set Equality Scheme" to make automatic the declaration - of the boolean equality when possible. -- Source of universe inconsistencies now printed when option - "Set Printing Universes" is activated. -- New option "Set Printing Existential Instances" for making the display of - existential variable instances explicit. -- Support for option "[id1 ... idn]", and "-[id1 ... idn]", for the - "compute"/"cbv" reduction strategy, respectively meaning reduce only, or - everything but, the constants id1 ... idn. "lazy" alone or followed by - "[id1 ... idn]", and "-[id1 ... idn]" also supported, meaning apply - all of beta-iota-zeta-delta, possibly restricting delta. -- New command "Strategy" to control the expansion of constants during - conversion tests. It generalizes commands Opaque and Transparent by - introducing a range of levels. Lower levels are assigned to constants - that should be expanded first. -- New options Global and Local to Opaque and Transparent. -- New command "Print Assumptions" to display all variables, parameters - or axioms a theorem or definition relies on. -- "Add Rec LoadPath" now provides references to libraries using partially - qualified names (this holds also for coqtop/coqc option -R). -- SearchAbout supports negated search criteria, reference to logical objects - by their notation, and more generally search of subterms. -- "Declare ML Module" now allows to import .cmxs files when Coq is - compiled in native code with a version of OCaml that supports native - Dynlink (>= 3.11). -- Specific sort constraints on Record now taken into account. -- "Print LoadPath" supports a path argument to filter the display. - -Libraries - -- Several parts of the libraries are now in Type, in particular FSets, - SetoidList, ListSet, Sorting, Zmisc. This may induce a few - incompatibilities. In case of trouble while fixing existing development, - it may help to simply declare Set as an alias for Type (see file - SetIsType). -- New arithmetical library in theories/Numbers. It contains: - * an abstract modular development of natural and integer arithmetics - in Numbers/Natural/Abstract and Numbers/Integer/Abstract - * an implementation of efficient computational bounded and unbounded - integers that can be mapped to processor native arithmetics. - See Numbers/Cyclic/Int31 for 31-bit integers and Numbers/Natural/BigN - for unbounded natural numbers and Numbers/Integer/BigZ for unbounded - integers. - * some proofs that both older libraries Arith, ZArith and NArith and - newer BigN and BigZ implement the abstract modular development. - This allows in particular BigN and BigZ to already come with a - large database of basic lemmas and some generic tactics (ring), - This library has still an experimental status, as well as the - processor-acceleration mechanism, but both its abstract and its - concrete parts are already quite usable and could challenge the use - of nat, N and Z in actual developments. Moreover, an extension of - this framework to rational numbers is ongoing, and an efficient - Q structure is already provided (see Numbers/Rational/BigQ), but - this part is currently incomplete (no abstract layer and generic - lemmas). -- Many changes in FSets/FMaps. In practice, compatibility with earlier - version should be fairly good, but some adaptations may be required. - * Interfaces of unordered ("weak") and ordered sets have been factorized - thanks to new features of Coq modules (in particular Include), see - FSetInterface. Same for maps. Hints in these interfaces have been - reworked (they are now placed in a "set" database). - * To allow full subtyping between weak and ordered sets, a field - "eq_dec" has been added to OrderedType. The old version of OrderedType - is now called MiniOrderedType and functor MOT_to_OT allow to - convert to the new version. The interfaces and implementations - of sets now contain also such a "eq_dec" field. - * FSetDecide, contributed by Aaron Bohannon, contains a decision - procedure allowing to solve basic set-related goals (for instance, - is a point in a particular set ?). See FSetProperties for examples. - * Functors of properties have been improved, especially the ones about - maps, that now propose some induction principles. Some properties - of fold need less hypothesis. - * More uniformity in implementations of sets and maps: they all use - implicit arguments, and no longer export unnecessary scopes (see - bug #1347) - * Internal parts of the implementations based on AVL have evolved a - lot. The main files FSetAVL and FMapAVL are now much more - lightweight now. In particular, minor changes in some functions - has allowed to fully separate the proofs of operational - correctness from the proofs of well-balancing: well-balancing is - critical for efficiency, but not anymore for proving that these - trees implement our interfaces, hence we have moved these proofs - into appendix files FSetFullAVL and FMapFullAVL. Moreover, a few - functions like union and compare have been modified in order to be - structural yet efficient. The appendix files also contains - alternative versions of these few functions, much closer to the - initial Ocaml code and written via the Function framework. -- Library IntMap, subsumed by FSets/FMaps, has been removed from - Coq Standard Library and moved into a user contribution Cachan/IntMap -- Better computational behavior of some constants (eq_nat_dec and - le_lt_dec more efficient, Z_lt_le_dec and Positive_as_OT.compare - transparent, ...) (exceptional source of incompatibilities). -- Boolean operators moved from module Bool to module Datatypes (may need - to rename qualified references in script and force notations || and && - to be at levels 50 and 40 respectively). -- The constructors xI and xO of type positive now have postfix notations - "~1" and "~0", allowing to write numbers in binary form easily, for instance - 6 is 1~1~0 and 4*p is p~0~0 (see BinPos.v). -- Improvements to NArith (Nminus, Nmin, Nmax), and to QArith (in particular - a better power function). -- Changes in ZArith: several additional lemmas (used in theories/Numbers), - especially in Zdiv, Znumtheory, Zpower. Moreover, many results in - Zdiv have been generalized: the divisor may simply be non-null - instead of strictly positive (see lemmas with name ending by - "_full"). An alternative file ZOdiv proposes a different behavior - (the one of Ocaml) when dividing by negative numbers. -- Changes in Arith: EqNat and Wf_nat now exported from Arith, some - constructions on nat that were outside Arith are now in (e.g. iter_nat). -- In SetoidList, eqlistA now expresses that two lists have similar elements - at the same position, while the predicate previously called eqlistA - is now equivlistA (this one only states that the lists contain the same - elements, nothing more). -- Changes in Reals: - * Most statement in "sigT" (including the - completeness axiom) are now in "sig" (in case of incompatibility, - use proj1_sig instead of projT1, sig instead of sigT, etc). - * More uniform naming scheme (identifiers in French moved to English, - consistent use of 0 -- zero -- instead of O -- letter O --, etc). - * Lemma on prod_f_SO is now on prod_f_R0. - * Useless hypothesis of ln_exists1 dropped. - * New Rlogic.v states a few logical properties about R axioms. - * RIneq.v extended and made cleaner. -- Slight restructuration of the Logic library regarding choice and classical - logic. Addition of files providing intuitionistic axiomatizations of - descriptions: Epsilon.v, Description.v and IndefiniteDescription.v. -- Definition of pred and minus made compatible with the structural - decreasing criterion for use in fixpoints. -- Files Relations/Rstar.v and Relations/Newman.v moved out to the user - contribution repository (contribution CoC_History). New lemmas about - transitive closure added and some bound variables renamed (exceptional - risk of incompatibilities). -- Syntax for binders in terms (e.g. for "exists") supports anonymous names. - -Notations, coercions, implicit arguments and type inference - -- More automation in the inference of the return clause of dependent - pattern-matching problems. -- Experimental allowance for omission of the clauses easily detectable as - impossible in pattern-matching problems. -- Improved inference of implicit arguments. -- New options "Set Maximal Implicit Insertion", "Set Reversible Pattern - Implicit", "Set Strongly Strict Implicit" and "Set Printing Implicit - Defensive" for controlling inference and use of implicit arguments. -- New modifier in "Implicit Arguments" to force an implicit argument to - be maximally inserted. -- New modifier of "Implicit Arguments" to enrich the set of implicit arguments. -- New options Global and Local to "Implicit Arguments" for section - surviving or non export outside module. -- Level "constr" moved from 9 to 8. -- Structure/Record now printed as Record (unless option Printing All is set). -- Support for parametric notations defining constants. -- Insertion of coercions below product types refrains to unfold - constants (possible source of incompatibility). -- New support for fix/cofix in notations. - -Tactic Language - -- Second-order pattern-matching now working in Ltac "match" clauses - (syntax for second-order unification variable is "@?X"). -- Support for matching on let bindings in match context using syntax - "H := body" or "H := body : type". -- Ltac accepts integer arguments (syntax is "ltac:nnn" for nnn an integer). -- The general sequence tactical "expr_0 ; [ expr_1 | ... | expr_n ]" - is extended so that at most one expr_i may have the form "expr .." - or just "..". Also, n can be different from the number of subgoals - generated by expr_0. In this case, the value of expr (or idtac in - case of just "..") is applied to the intermediate subgoals to make - the number of tactics equal to the number of subgoals. -- A name used as the name of the parameter of a lemma (like f in - "apply f_equal with (f:=t)") is now interpreted as a ltac variable - if such a variable exists (this is a possible source of - incompatibility and it can be fixed by renaming the variables of a - ltac function into names that do not clash with the lemmas - parameter names used in the tactic). -- New syntax "Ltac tac ::= ..." to rebind a tactic to a new expression. -- "let rec ... in ... " now supported for expressions without explicit - parameters; interpretation is lazy to the contrary of "let ... in ..."; - hence, the "rec" keyword can be used to turn the argument of a - "let ... in ..." into a lazy one. -- Patterns for hypotheses types in "match goal" are now interpreted in - type_scope. -- A bound variable whose name is not used elsewhere now serves as - metavariable in "match" and it gets instantiated by an identifier - (allow e.g. to extract the name of a statement like "exists x, P x"). -- New printing of Ltac call trace for better debugging. - -Tactics - -- New tactics "apply -> term", "apply <- term", "apply -> term in - ident", "apply <- term in ident" for applying equivalences (iff). -- Slight improvement of the hnf and simpl tactics when applied on - expressions with explicit occurrences of match or fix. -- New tactics "eapply in", "erewrite", "erewrite in". -- New tactics "ediscriminate", "einjection", "esimplify_eq". -- Tactics "discriminate", "injection", "simplify_eq" now support any - term as argument. Clause "with" is also supported. -- Unfoldable references can be given by notation's string rather than by name - in unfold. -- The "with" arguments are now typed using informations from the current goal: - allows support for coercions and more inference of implicit arguments. -- Application of "f_equal"-style lemmas works better. -- Tactics elim, case, destruct and induction now support variants eelim, - ecase, edestruct and einduction. -- Tactics destruct and induction now support the "with" option and the - "in" clause option. If the option "in" is used, an equality is added - to remember the term to which the induction or case analysis applied - (possible source of parsing incompatibilities when destruct or induction is - part of a let-in expression in Ltac; extra parentheses are then required). -- New support for "as" clause in tactics "apply in" and "eapply in". -- Some new intro patterns: - * intro pattern "?A" genererates a fresh name based on A. - Caveat about a slight loss of compatibility: - Some intro patterns don't need space between them. In particular - intros ?a?b used to be legal and equivalent to intros ? a ? b. Now it - is still legal but equivalent to intros ?a ?b. - * intro pattern "(A & ... & Y & Z)" synonym to "(A,....,(Y,Z)))))" - for right-associative constructs like /\ or exists. -- Several syntax extensions concerning "rewrite": - * "rewrite A,B,C" can be used to rewrite A, then B, then C. These rewrites - occur only on the first subgoal: in particular, side-conditions of the - "rewrite A" are not concerned by the "rewrite B,C". - * "rewrite A by tac" allows to apply tac on all side-conditions generated by - the "rewrite A". - * "rewrite A at n" allows to select occurrences to rewrite: rewrite only - happen at the n-th exact occurrence of the first successful matching of - A in the goal. - * "rewrite 3 A" or "rewrite 3!A" is equivalent to "rewrite A,A,A". - * "rewrite !A" means rewriting A as long as possible (and at least once). - * "rewrite 3?A" means rewriting A at most three times. - * "rewrite ?A" means rewriting A as long as possible (possibly never). - * many of the above extensions can be combined with each other. -- Introduction patterns better respect the structure of context in presence of - missing or extra names in nested disjunction-conjunction patterns [possible - source of rare incompatibilities]. -- New syntax "rename a into b, c into d" for "rename a into b; rename c into d" -- New tactics "dependent induction/destruction H [ generalizing id_1 .. id_n ]" - to do induction-inversion on instantiated inductive families à la BasicElim. -- Tactics "apply" and "apply in" now able to reason modulo unfolding of - constants (possible source of incompatibility in situations where apply - may fail, e.g. as argument of a try or a repeat and in a ltac function); - versions that do not unfold are renamed into "simple apply" and - "simple apply in" (usable for compatibility or for automation). -- Tactics "apply" and "apply in" now able to traverse conjunctions and to - select the first matching lemma among the components of the conjunction; - tactic "apply" also able to apply lemmas of conclusion an empty type. -- Tactic "apply" now supports application of several lemmas in a row. -- Tactics "set" and "pose" can set functions using notation "(f x1..xn := c)". -- New tactic "instantiate" (without argument). -- Tactic firstorder "with" and "using" options have their meaning swapped for - consistency with auto/eauto (source of incompatibility). -- Tactic "generalize" now supports "at" options to specify occurrences - and "as" options to name the quantified hypotheses. -- New tactic "specialize H with a" or "specialize (H a)" allows to transform - in-place a universally-quantified hypothesis (H : forall x, T x) into its - instantiated form (H : T a). Nota: "specialize" was in fact there in earlier - versions of Coq, but was undocumented, and had a slightly different behavior. -- New tactic "contradict H" can be used to solve any kind of goal as long as - the user can provide afterwards a proof of the negation of the hypothesis H. - If H is already a negation, say ~T, then a proof of T is asked. - If the current goal is a negation, say ~U, then U is saved in H afterwards, - hence this new tactic "contradict" extends earlier tactic "swap", which is - now obsolete. -- Tactics f_equal is now done in ML instead of Ltac: it now works on any - equality of functions, regardless of the arity of the function. -- New options "before id", "at top", "at bottom" for tactics "move"/"intro". -- Some more debug of reflexive omega (romega), and internal clarifications. - Moreover, romega now has a variant "romega with *" that can be also used - on non-Z goals (nat, N, positive) via a call to a translation tactic named - zify (its purpose is to Z-ify your goal...). This zify may also be used - independently of romega. -- Tactic "remember" now supports an "in" clause to remember only selected - occurrences of a term. -- Tactic "pose proof" supports name overwriting in case of specialization of an - hypothesis. -- Semi-decision tactic "jp" for first-order intuitionistic logic moved to user - contributions (subsumed by "firstorder"). - -Program - -- Moved useful tactics in theories/Program and documented them. -- Add Program.Basics which contains standard definitions for functional - programming (id, apply, flip...) -- More robust obligation handling, dependent pattern-matching and - well-founded definitions. -- New syntax " dest term as pat in term " for destructing objects using - an irrefutable pattern while keeping equalities (use this instead of - "let" in Programs). -- Program CoFixpoint is accepted, Program Fixpoint uses the new way to infer - which argument decreases structurally. -- Program Lemma, Axiom etc... now permit to have obligations in the statement - iff they can be automatically solved by the default tactic. -- Renamed "Obligations Tactic" command to "Obligation Tactic". -- New command "Preterm [ of id ]" to see the actual term fed to Coq for - debugging purposes. -- New option "Transparent Obligations" to control the declaration of - obligations as transparent or opaque. All obligations are now transparent - by default, otherwise the system declares them opaque if possible. -- Changed the notations "left" and "right" to "in_left" and "in_right" to hide - the proofs in standard disjunctions, to avoid breaking existing scripts when - importing Program. Also, put them in program_scope. - -Type Classes - -- New "Class", "Instance" and "Program Instance" commands to define - classes and instances documented in the reference manual. -- New binding construct " [ Class_1 param_1 .. param_n, Class_2 ... ] " - for binding type classes, usable everywhere. -- New command " Print Classes " and " Print Instances some_class " to - print tables for typeclasses. -- New default eauto hint database "typeclass_instances" used by the default - typeclass instance search tactic. -- New theories directory "theories/Classes" for standard typeclasses - declarations. Module Classes.RelationClasses is a typeclass port of - Relation_Definitions plus a generic development of algebra on - n-ary heterogeneous predicates. - -Setoid rewriting - -- Complete (and still experimental) rewrite of the tactic - based on typeclasses. The old interface and semantics are - almost entirely respected, except: - - - Import Setoid is now mandatory to be able to call setoid_replace - and declare morphisms. - - - "-->", "++>" and "==>" are now right associative notations - declared at level 55 in scope signature_scope. - Their introduction may break existing scripts that defined - them as notations with different levels. - - - One needs to use [Typeclasses unfold [cst]] if [cst] is used - as an abbreviation hiding products in types of morphisms, - e.g. if ones redefines [relation] and declares morphisms - whose type mentions [relation]. - - - The [setoid_rewrite]'s semantics change when rewriting with - a lemma: it can rewrite two different instantiations of the lemma - at once. Use [setoid_rewrite H at 1] for (almost) the usual semantics. - [setoid_rewrite] will also try to rewrite under binders now, and can - succeed on different terms than before. In particular, it will unify under - let-bound variables. When called through [rewrite], the semantics are - unchanged though. - - - [Add Morphism term : id] has different semantics when used with - parametric morphism: it will try to find a relation on the parameters - too. The behavior has also changed with respect to default relations: - the most recently declared Setoid/Relation will be used, the documentation - explains how to customize this behavior. - - - Parametric Relation and Morphism are declared differently, using the - new [Add Parametric] commands, documented in the manual. - - - Setoid_Theory is now an alias to Equivalence, scripts building objects - of type Setoid_Theory need to unfold (or "red") the definitions - of Reflexive, Symmetric and Transitive in order to get the same goals - as before. Scripts which introduced variables explicitely will not break. - - - The order of subgoals when doing [setoid_rewrite] with side-conditions - is always the same: first the new goal, then the conditions. - -- New standard library modules Classes.Morphisms declares - standard morphisms on refl/sym/trans relations. - Classes.Morphisms_Prop declares morphisms on propositional - connectives and Classes.Morphisms_Relations on generalized predicate - connectives. Classes.Equivalence declares notations and tactics - related to equivalences and Classes.SetoidTactics defines the - setoid_replace tactics and some support for the "Add *" interface, - notably the tactic applied automatically before each "Add Morphism" - proof. - -- User-defined subrelations are supported, as well as higher-order morphisms - and rewriting under binders. The tactic is also extensible entirely in Ltac. - The documentation has been updated to cover these features. - -- [setoid_rewrite] and [rewrite] now support the [at] modifier to select - occurrences to rewrite, and both use the [setoid_rewrite] code, even when - rewriting with leibniz equality if occurrences are specified. - -Extraction - -- Improved behavior of the Caml extraction of modules: name clashes should - not happen anymore. -- The command Extract Inductive has now a syntax for infix notations. This - allows in particular to map Coq lists and pairs onto Caml ones: - Extract Inductive list => list [ "[]" "(::)" ]. - Extract Inductive prod => "(*)" [ "(,)" ]. -- In pattern matchings, a default pattern "| _ -> ..." is now used whenever - possible if several branches are identical. For instance, functions - corresponding to decidability of equalities are now linear instead of - quadratic. -- A new instruction Extraction Blacklist id1 .. idn allows to prevent filename - conflits with existing code, for instance when extracting module List - to Ocaml. - -CoqIDE - -- CoqIDE font defaults to monospace so as indentation to be meaningful. -- CoqIDE supports nested goals and any other kind of declaration in the middle - of a proof. -- Undoing non-tactic commands in CoqIDE works faster. -- New CoqIDE menu for activating display of various implicit informations. -- Added the possibility to choose the location of tabs in coqide: - (in Edit->Preferences->Misc) -- New Open and Save As dialogs in CoqIDE which filter *.v files. - -Tools - -- New stand-alone .vo files verifier "coqchk". -- Extended -I coqtop/coqc option to specify a logical dir: "-I dir -as coqdir". -- New coqtop/coqc option -exclude-dir to exclude subdirs for option -R. -- The binary "parser" has been renamed to "coq-parser". -- Improved coqdoc and dump of globalization information to give more - meta-information on identifiers. All categories of Coq definitions are - supported, which makes typesetting trivial in the generated documentation. - Support for hyperlinking and indexing developments in the tex output - has been implemented as well. - -Miscellaneous - -- Coq installation provides enough files so that Ocaml's extensions need not - the Coq sources to be compiled (this assumes O'Caml 3.10 and Camlp5). -- New commands "Set Whelp Server" and "Set Whelp Getter" to customize the - Whelp search tool. -- Syntax of "Test Printing Let ref" and "Test Printing If ref" changed into - "Test Printing Let for ref" and "Test Printing If for ref". -- An overhauled build system (new Makefiles); see dev/doc/build-system.txt. -- Add -browser option to configure script. -- Build a shared library for the C part of Coq, and use it by default on - non-(Windows or MacOS) systems. Bytecode executables are now pure. The - behaviour is configurable with -coqrunbyteflags, -coqtoolsbyteflags and - -custom configure options. -- Complexity tests can be skipped by setting the environment variable - COQTEST_SKIPCOMPLEXITY. - -Changes from V8.1gamma to V8.1 -============================== - -Bug fixes - -- Many bugs have been fixed (cf coq-bugs web page) - -Tactics - -- New tactics ring, ring_simplify and new tactic field now able to manage - power to a positive integer constant. Tactic ring on Z and R, and - field on R manage power (may lead to incompatibilities with V8.1gamma). -- Tactic field_simplify now applicable in hypotheses. -- New field_simplify_eq for simplifying field equations into ring equations. -- Tactics ring, ring_simplify, field, field_simplify and field_simplify_eq - all able to apply user-given equations to rewrite monoms on the fly - (see documentation). - -Libraries - -- New file ConstructiveEpsilon.v defining an epsilon operator and - proving the axiom of choice constructively for a countable domain - and a decidable predicate. - -Changes from V8.1beta to V8.1gamma -================================== - -Syntax - -- changed parsing precedence of let/in and fun constructions of Ltac: - let x := t in e1; e2 is now parsed as let x := t in (e1;e2). - -Language and commands - -- Added sort-polymorphism for definitions in Type (but finally abandonned). -- Support for implicit arguments in the types of parameters in - (co-)fixpoints and (co-)inductive declarations. -- Improved type inference: use as much of possible general information. - before applying irreversible unification heuristics (allow e.g. to - infer the predicate in "(exist _ 0 (refl_equal 0) : {n:nat | n=0 })"). -- Support for Miller-Pfenning's patterns unification in type synthesis - (e.g. can infer P such that P x y = phi(x,y)). -- Support for "where" clause in cofixpoint definitions. -- New option "Set Printing Universes" for making Type levels explicit. - -Tactics - -- Improved implementation of the ring and field tactics. For compatibility - reasons, the previous tactics are renamed as legacy ring and legacy field, - but should be considered as deprecated. -- New declarative mathematical proof language. -- Support for argument lists of arbitrary length in Tactic Notation. -- [rewrite ... in H] now fails if [H] is used either in an hypothesis - or in the goal. -- The semantics of [rewrite ... in *] has been slightly modified (see doc). -- Support for "as" clause in tactic injection. -- New forward-reasoning tactic "apply in". -- Ltac fresh operator now builds names from a concatenation of its arguments. -- New ltac tactic "remember" to abstract over a subterm and keep an equality -- Support for Miller-Pfenning's patterns unification in apply/rewrite/... - (may lead to few incompatibilities - generally now useless tactic calls). - -Bug fixes - -- Fix for notations involving basic "match" expressions. -- Numerous other bugs solved (a few fixes may lead to incompatibilities). - - -Changes from V8.0 to V8.1beta -============================= - -Logic - -- Added sort-polymorphism on inductive families -- Allowance for recursively non uniform parameters in inductive types - -Syntax - -- No more support for version 7 syntax and for translation to version 8 syntax. -- In fixpoints, the { struct ... } annotation is not mandatory any more when - only one of the arguments has an inductive type -- Added disjunctive patterns in match-with patterns -- Support for primitive interpretation of string literals -- Extended support for Unicode ranges - -Vernacular commands - -- Added "Print Ltac qualid" to print a user defined tactic. -- Added "Print Rewrite HintDb" to print the content of a DB used by - autorewrite. -- Added "Print Canonical Projections". -- Added "Example" as synonym of "Definition". -- Added "Proposition" and "Corollary" as extra synonyms of "Lemma". -- New command "Whelp" to send requests to the Helm database of proofs - formalized in the Calculus of Inductive Constructions. -- Command "functional induction" has been re-implemented from the new - "Function" command. - -Ltac and tactic syntactic extensions - -- New primitive "external" for communication with tool external to Coq -- New semantics for "match t with": if a clause returns a - tactic, it is now applied to the current goal. If it fails, the next - clause or next matching subterm is tried (i.e. it behaves as "match - goal with" does). The keyword "lazymatch" can be used to delay the - evaluation of tactics occurring in matching clauses. -- Hint base names can be parametric in auto and trivial. -- Occurrence values can be parametric in unfold, pattern, etc. -- Added entry constr_may_eval for tactic extensions. -- Low-priority term printer made available in ML-written tactic extensions. -- "Tactic Notation" extended to allow notations of tacticals. - -Tactics - -- New implementation and generalization of [setoid_]* (setoid_rewrite, - setoid_symmetry, setoid_transitivity, setoid_reflexivity and autorewite). - New syntax for declaring relations and morphisms (old syntax still working - with minor modifications, but deprecated). -- New implementation (still experimental) of the ring tactic with a built-in - notion of coefficients and a better usage of setoids. -- New conversion tactic "vm_compute": evaluates the goal (or an hypothesis) - with a call-by-value strategy, using the compiled version of terms. -- When rewriting H where H is not directly a Coq equality, search first H for - a registered setoid equality before starting to reduce in H. This is unlikely - to break any script. Should this happen nonetheless, one can insert manually - some "unfold ... in H" before rewriting. -- Fixed various bugs about (setoid) rewrite ... in ... (in particular bug #5941) -- "rewrite ... in" now accepts a clause as place where to rewrite instead of - juste a simple hypothesis name. For instance: - rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H - rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H. -- Added "dependent rewrite term" and "dependent rewrite term in hyp". -- Added "autorewrite with ... in hyp [using ...]". -- Tactic "replace" now accepts a "by" tactic clause. -- Added "clear - id" to clear all hypotheses except the ones depending in id. -- The argument of Declare Left Step and Declare Right Step is now a term - (it used to be a reference). -- Omega now handles arbitrary precision integers. -- Several bug fixes in Reflexive Omega (romega). -- Idtac can now be left implicit in a [...|...] construct: for instance, - [ foo | | bar ] stands for [ foo | idtac | bar ]. -- Fixed a "fold" bug (non critical but possible source of incompatibilities). -- Added classical_left and classical_right which transforms |- A \/ B into - ~B |- A and ~A |- B respectively. -- Added command "Declare Implicit Tactic" to set up a default tactic to be - used to solve unresolved subterms of term arguments of tactics. -- Better support for coercions to Sortclass in tactics expecting type - arguments. -- Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses. -- New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns. -- New introduction pattern "?" for letting Coq choose a name. -- Introduction patterns now support side hypotheses (e.g. intros [|] on - "(nat -> nat) -> nat" works). -- New introduction patterns "->" and "<-" for immediate rewriting of - introduced hypotheses. -- Introduction patterns coming after non trivial introduction patterns now - force full introduction of the first pattern (e.g. "intros [[|] p]" on - "nat->nat->nat" now behaves like "intros [[|?] p]") -- Added "eassumption". -- Added option 'using lemmas' to auto, trivial and eauto. -- Tactic "congruence" is now complete for its intended scope (ground - equalities and inequalities with constructors). Furthermore, it - tries to equates goal and hypotheses. -- New tactic "rtauto" solves pure propositional logic and gives a - reflective version of the available proof. -- Numbering of "pattern", "unfold", "simpl", ... occurrences in "match - with" made consistent with the printing of the return clause after - the term to match in the "match-with" construct (use "Set Printing All" - to see hidden occurrences). -- Generalization of induction "induction x1...xn using scheme" where - scheme is an induction principle with complex predicates (like the - ones generated by function induction). -- Some small Ltac tactics has been added to the standard library - (file Tactics.v): - * f_equal : instead of using the different f_equalX lemmas - * case_eq : a "case" without loss of information. An equality - stating the current situation is generated in every sub-cases. - * swap : for a negated goal ~B and a negated hypothesis H:~A, - swap H asks you to prove A from hypothesis B - * revert : revert H is generalize H; clear H. - -Extraction - -- All type parts should now disappear instead of sometimes producing _ - (for instance in Map.empty). -- Haskell extraction: types of functions are now printed, better - unsafeCoerce mechanism, both for hugs and ghc. -- Scheme extraction improved, see http://www.pps.jussieu.fr/~letouzey/scheme. -- Many bug fixes. - -Modules - -- Added "Locate Module qualid" to get the full path of a module. -- Module/Declare Module syntax made more uniform. -- Added syntactic sugar "Declare Module Export/Import" and - "Module Export/Import". -- Added syntactic sugar "Module M(Export/Import X Y: T)" and - "Module Type M(Export/Import X Y: T)" - (only for interactive definitions) -- Construct "with" generalized to module paths: - T with (Definition|Module) M1.M2....Mn.l := l'. - -Notations - -- Option "format" aware of recursive notations. -- Added insertion of spaces by default in recursive notations w/o separators. -- No more automatic printing box in case of user-provided printing "format". -- New notation "exists! x:A, P" for unique existence. -- Notations for specific numerals now compatible with generic notations of - numerals (e.g. "1" can be used to denote the unit of a group without - hiding 1%nat) - -Libraries - -- New library on String and Ascii characters (contributed by L. Thery). -- New library FSets+FMaps of finite sets and maps. -- New library QArith on rational numbers. -- Small extension of Zmin.V, new Zmax.v, new Zminmax.v. -- Reworking and extension of the files on classical logic and - description principles (possible incompatibilities) -- Few other improvements in ZArith potentially exceptionally breaking the - compatibility (useless hypothesys of Zgt_square_simpl and - Zlt_square_simpl removed; fixed names mentioning letter O instead of - digit 0; weaken premises in Z_lt_induction). -- Restructuration of Eqdep_dec.v and Eqdep.v: more lemmas in Type. -- Znumtheory now contains a gcd function that can compute within Coq. -- More lemmas stated on Type in Wf.v, removal of redundant Acc_iter and - Acc_iter2. -- Change of the internal names of lemmas in OmegaLemmas. -- Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on - the allowance for recursively non uniform parameters (possible - source of incompatibilities: explicit pattern-matching on these - types may require to remove the occurrence associated to their - recursively non uniform parameter). -- Coq.List.In_dec has been set transparent (this may exceptionally break - proof scripts, set it locally opaque for compatibility). -- More on permutations of lists in List.v and Permutation.v. -- List.v has been much expanded. -- New file SetoidList.v now contains results about lists seen with - respect to a setoid equality. -- Library NArith has been expanded, mostly with results coming from - Intmap (for instance a bitwise xor), plus also a bridge between N and - Bitvector. -- Intmap has been reorganized. In particular its address type "addr" is - now N. User contributions known to use Intmap have been adapted - accordingly. If you're using this library please contact us. - A wrapper FMapIntMap now presents Intmap as a particular implementation - of FMaps. New developments are strongly encouraged to use either this - wrapper or any other implementations of FMap instead of using directly - this obsolete Intmap. - -Tools - -- New semantics for coqtop options ("-batch" expects option "-top dir" - for loading vernac file that contains definitions). -- Tool coq_makefile now removes custom targets that are file names in - "make clean" -- New environment variable COQREMOTEBROWSER to set the command invoked - to start the remote browser both in Coq and coqide. Standard syntax: - "%s" is the placeholder for the URL. - - -Changes from V8.0beta to V8.0 -============================= - -Vernacular commands - -- New option "Set Printing All" to deactivate all high-level forms of - printing (implicit arguments, coercions, destructing let, - if-then-else, notations, projections) -- "Functional Scheme" and "Functional Induction" extended to polymorphic - types and dependent types -- Notation now allows recursive patterns, hence recovering parts of the - fonctionalities of pre-V8 Grammar/Syntax commands -- Command "Print." discontinued. -- Redundant syntax "Implicit Arguments On/Off" discontinued - -New syntax - -- Semantics change of the if-then-else construction in new syntax: - "if c then t1 else t2" now stands for - "match c with c1 _ ... _ => t1 | c2 _ ... _ => t2 end" - with no dependency of t1 and t2 in the arguments of the constructors; - this may cause incompatibilities for files translated using coq 8.0beta - -Interpretation scopes - -- Delimiting key %bool for bool_scope added -- Import no more needed to activate argument scopes from a module - -Tactics and the tactic Language - -- Semantics of "assert" is now consistent with the reference manual -- New tactics stepl and stepr for chaining transitivity steps -- Tactic "replace ... with ... in" added -- Intro patterns now supported in Ltac (parsed with prefix "ipattern:") - -Executables and tools - -- Added option -top to change the name of the toplevel module "Top" -- Coqdoc updated to new syntax and now part of Coq sources -- XML exportation tool now exports the structure of vernacular files - (cf chapter 13 in the reference manual) - -User contributions - -- User contributions have been updated to the new syntax - -Bug fixes - -- Many bugs have been fixed (cf coq-bugs web page) - -Changes from V8.0beta old syntax to V8.0beta -============================================ - -New concrete syntax - -- A completely new syntax for terms -- A more uniform syntax for tactics and the tactic language -- A few syntactic changes for vernacular commands -- A smart automatic translator translating V8.0 files in old syntax to - files valid for V8.0 - -Syntax extensions - -- "Grammar" for terms disappears -- "Grammar" for tactics becomes "Tactic Notation" -- "Syntax" disappears -- Introduction of a notion of interpretation scope allowing to use the - same notations in various contexts without using specific delimiters - (e.g the same expression "4<=3+x" is interpreted either in "nat", - "positive", "N" (previously "entier"), "Z", "R", depending on which - interpretation scope is currently open) [see documentation for details] -- Notation now mandatorily requires a precedence and associativity - (default was to set precedence to 1 and associativity to none) - -Revision of the standard library - -- Many lemmas and definitions names have been made more uniform mostly - in Arith, NArith, ZArith and Reals (e.g : "times" -> "Pmult", - "times_sym" -> "Pmult_comm", "Zle_Zmult_pos_right" -> - "Zmult_le_compat_r", "SUPERIEUR" -> "Gt", "ZERO" -> "Z0") -- Order and names of arguments of basic lemmas on nat, Z, positive and R - have been made uniform. -- Notions of Coq initial state are declared with (strict) implicit arguments -- eq merged with eqT: old eq disappear, new eq (written =) is old eqT - and new eqT is syntactic sugar for new eq (notation == is an alias - for = and is written as it, exceptional source of incompatibilities) -- Similarly, ex, ex2, all, identity are merged with exT, exT2, allT, identityT -- Arithmetical notations for nat, positive, N, Z, R, without needing - any backquote or double-backquotes delimiters. -- In Lists: new concrete notations; argument of nil is now implicit -- All changes in the library are taken in charge by the translator - -Semantical changes during translation - -- Recursive keyword set by default (and no longer needed) in Tactic Definition -- Set Implicit Arguments is strict by default in new syntax -- reductions in hypotheses of the form "... in H" now apply to the type - also if H is a local definition -- etc - -Gallina - -- New syntax of the form "Inductive bool : Set := true, false : bool." for - enumerated types -- Experimental syntax of the form p.(fst) for record projections - (activable with option "Set Printing Projections" which is - recognized by the translator) - -Known problems of the automatic translation - -- iso-latin-1 characters are no longer supported: move your files to - 7-bits ASCII or unicode before translation (swith to unicode is - automatically done if a file is loaded and saved again by coqide) -- Renaming in ZArith: incompatibilities in Coq user contribs due to - merging names INZ, from Reals, and inject_nat. -- Renaming and new lemmas in ZArith: may clash with names used by users -- Restructuration of ZArith: replace requirement of specific modules - in ZArith by "Require Import ZArith_base" or "Require Import ZArith" -- Some implicit arguments must be made explicit before translation: typically - for "length nil", the implicit argument of length must be made explicit -- Grammar rules, Infix notations and V7.4 Notations must be updated wrt the - new scheme for syntactic extensions (see translator documentation) -- Unsafe for annotation Cases when constructors coercions are used or when - annotations are eta-reduced predicates - - -Changes from V7.4 to V8.0beta old syntax -======================================== - -Logic - -- Set now predicative by default -- New option -impredicative-set to set Set impredicative -- The standard library doesn't need impredicativity of Set and is - compatible with the classical axioms which contradict Set impredicativity - -Syntax for arithmetic - -- Notation "=" and "<>" in Z and R are no longer implicitly in Z or R - (with possible introduction of a coercion), use <Z>...=... or - <Z>...<>... instead -- Locate applied to a simple string (e.g. "+") searches for all - notations containing this string - -Vernacular commands - -- "Declare ML Module" now allows to import .cma files. This avoids to use a - bunch of "Declare ML Module" statements when using several ML files. -- "Set Printing Width n" added, allows to change the size of width printing. -- "Implicit Variables Type x,y:t" (new syntax: "Implicit Types x y:t") - assigns default types for binding variables. -- Declarations of Hints and Notation now accept a "Local" flag not to - be exported outside the current file even if not in section -- "Print Scopes" prints all notations -- New command "About name" for light printing of type, implicit arguments, etc. -- New command "Admitted" to declare incompletely proven statement as axioms -- New keyword "Conjecture" to declare an axiom intended to be provable -- SearchAbout can now search for lemmas referring to more than one constant - and on substrings of the name of the lemma -- "Print Implicit" displays the implicit arguments of a constant -- Locate now searches for all names having a given suffix -- New command "Functional Scheme" for building an induction principle - from a function defined by case analysis and fix. - -Commands - -- new coqtop/coqc option -dont-load-proofs not to load opaque proofs in memory - -Implicit arguments - -- Inductive in sections declared with implicits now "discharged" with - implicits (like constants and variables) -- Implicit Arguments flags are now synchronous with reset -- New switch "Unset/Set Printing Implicits" (new syntax: "Unset/Set Printing - Implicit") to globally control printing of implicits - -Grammar extensions - -- Many newly supported UTF-8 encoded unicode blocks - - Greek letters (0380-03FF), Hebrew letters (U05D0-05EF), letter-like - symbols (2100-214F, that includes double N,Z,Q,R), prime - signs (from 2080-2089) and characters from many written languages - are valid in identifiers - - mathematical operators (2200-22FF), supplemental mathematical - operators (2A00-2AFF), miscellaneous technical (2300-23FF that - includes sqrt symbol), miscellaneous symbols (2600-26FF), arrows - (2190-21FF and 2900-297F), invisible mathematical operators (from - 2080-2089), ... are valid symbols - -Library - -- New file about the factorial function in Arith -- An additional elimination Acc_iter for Acc, simplier than Acc_rect. - This new elimination principle is used for definition well_founded_induction. -- New library NArith on binary natural numbers -- R is now of type Set -- Restructuration in ZArith library - - "true_sub" used in Zplus now a definition, not a local one (source - of incompatibilities in proof referring to true_sub, may need extra Unfold) - - Some lemmas about minus moved from fast_integer to Arith/Minus.v - (le_minus, lt_mult_left) (theoretical source of incompatibilities) - - Several lemmas moved from auxiliary.v and zarith_aux.v to - fast_integer.v (theoretical source of incompatibilities) - - Variables names of iff_trans changed (source of incompatibilities) - - ZArith lemmas named OMEGA something or fast_ something, and lemma new_var - are now out of ZArith (except OMEGA2) - - Redundant ZArith lemmas have been renamed: for the following pairs, - use the second name (Zle_Zmult_right2, Zle_mult_simpl), (OMEGA2, - Zle_0_plus), (Zplus_assoc_l, Zplus_assoc), (Zmult_one, Zmult_1_n), - (Zmult_assoc_l, Zmult_assoc), (Zmult_minus_distr, Zmult_Zminus_distr_l) - (add_un_double_moins_un_xO, is_double_moins_un), - (Rlt_monotony_rev,Rlt_monotony_contra) (source of incompatibilities) -- Few minor changes (no more implicit arguments in - Zmult_Zminus_distr_l and Zmult_Zminus_distr_r, lemmas moved from - Zcomplements to other files) (rare source of incompatibilities) -- New lemmas provided by users added - -Tactic language - -- Fail tactic now accepts a failure message -- Idtac tactic now accepts a message -- New primitive tactic "FreshId" (new syntax: "fresh") to generate new names -- Debugger prints levels of calls - -Tactics - -- Replace can now replace proofs also -- Fail levels are now decremented at "Match Context" blocks only and - if the right-hand-side of "Match term With" are tactics, these - tactics are never evaluated immediately and do not induce - backtracking (in contrast with "Match Context") -- Quantified names now avoid global names of the current module (like - Intro names did) [source of rare incompatibilities: 2 changes in the set of - user contribs] -- NewDestruct/NewInduction accepts intro patterns as introduction names -- NewDestruct/NewInduction now work for non-inductive type using option "using" -- A NewInduction naming bug for inductive types with functional - arguments (e.g. the accessibility predicate) has been fixed (source - of incompatibilities) -- Symmetry now applies to hypotheses too -- Inversion now accept option "as [ ... ]" to name the hypotheses -- Contradiction now looks also for contradictory hypotheses stating ~A and A - (source of incompatibility) -- "Contradiction c" try to find an hypothesis in context which - contradicts the type of c -- Ring applies to new library NArith (require file NArithRing) -- Field now works on types in Set -- Auto with reals now try to replace le by ge (Rge_le is no longer an - immediate hint), resulting in shorter proofs -- Instantiate now works in hyps (syntax : Instantiate in ...) -- Some new tactics : EConstructor, ELeft, Eright, ESplit, EExists -- New tactic "functional induction" to perform case analysis and - induction following the definition of a function. -- Clear now fails when trying to remove a local definition used by - a constant appearing in the current goal - -Extraction (See details in plugins/extraction/CHANGES) - -- The old commands: (Recursive) Extraction Module M. - are now: (Recursive) Extraction Library M. - To use these commands, M should come from a library M.v -- The other syntax Extraction & Recursive Extraction now accept - module names as arguments. - -Bugs - -- see coq-bugs server for the complete list of fixed bugs - -Miscellaneous - -- Implicit parameters of inductive types definition now taken into - account for infering other implicit arguments - -Incompatibilities - -- Persistence of true_sub (4 incompatibilities in Coq user contributions) -- Variable names of some constants changed for a better uniformity (2 changes - in Coq user contributions) -- Naming of quantified names in goal now avoid global names (2 occurrences) -- NewInduction naming for inductive types with functional arguments - (no incompatibility in Coq user contributions) -- Contradiction now solve more goals (source of 2 incompatibilities) -- Merge of eq and eqT may exceptionally result in subgoals now - solved automatically -- Redundant pairs of ZArith lemmas may have different names: it may - cause "Apply/Rewrite with" to fail if using the first name of a pair - of redundant lemmas (this is solved by renaming the variables bound by - "with"; 3 incompatibilities in Coq user contribs) -- ML programs referring to constants from fast_integer.v must use - "Coqlib.gen_constant_modules Coqlib.zarith_base_modules" instead - -Changes from V7.3.1 to V7.4 -=========================== - -Symbolic notations - -- Introduction of a notion of scope gathering notations in a consistent set; - a notation sets has been developed for nat, Z and R (undocumented) -- New command "Notation" for declaring notations simultaneously for - parsing and printing (see chap 10 of the reference manual) -- Declarations with only implicit arguments now handled (e.g. the - argument of nil can be set implicit; use !nil to refer to nil - without arguments) -- "Print Scope sc" and "Locate ntn" allows to know to what expression a - notation is bound -- New defensive strategy for printing or not implicit arguments to ensure - re-type-checkability of the printed term -- In Grammar command, the only predefined non-terminal entries are ident, - global, constr and pattern (e.g. nvar, numarg disappears); the only - allowed grammar types are constr and pattern; ast and ast list are no - longer supported; some incompatibilities in Grammar: when a syntax is a - initial segment of an other one, Grammar does not work, use Notation - -Library - -- Lemmas in Set from Compare_dec.v (le_lt_dec, ...) and Wf_nat.v - (lt_wf_rec, ...) are now transparent. This may be source of - incompatibilities. -- Syntactic Definitions Fst, Snd, Ex, All, Ex2, AllT, ExT, ExT2, - ProjS1, ProjS2, Error, Value and Except are turned to - notations. They now must be applied (incompatibilities only in - unrealistic cases). -- More efficient versions of Zmult and times (30% faster) -- Reals: the library is now divided in 6 parts (Rbase, Rfunctions, - SeqSeries, Rtrigo, Ranalysis, Integration). New tactics: Sup and - RCompute. See Reals.v for details. - -Modules - -- Beta version, see doc chap 2.5 for commands and chap 5 for theory - -Language - -- Inductive definitions now accept ">" in constructor types to declare - the corresponding constructor as a coercion. -- Idem for assumptions declarations and constants when the type is mentionned. -- The "Coercion" and "Canonical Structure" keywords now accept the - same syntax as "Definition", i.e. "hyps :=c (:t)?" or "hyps :t". -- Theorem-like declaration now accepts the syntax "Theorem thm [x:t;...] : u". -- Remark's and Fact's now definitively behave as Theorem and Lemma: when - sections are closed, the full name of a Remark or a Fact has no longer a - section part (source of incompatibilities) -- Opaque Local's (i.e. built by tactics and ended by Qed), do not - survive section closing any longer; as a side-effect, Opaque Local's - now appear in the local context of proofs; their body is hidden - though (source of incompatibilities); use one of Remark/Fact/Lemma/Theorem - instead to simulate the old behaviour of Local (the section part of - the name is not kept though) - -ML tactic and vernacular commands - -- "Grammar tactic" and "Grammar vernac" of type "ast" are no longer - supported (only "Grammar tactic simple_tactic" of type "tactic" - remains available). -- Concrete syntax for ML written vernacular commands and tactics is - now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC - COMMAND EXTEND. -- "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..." -- "Proof with T" (* no documentation *) -- SearchAbout id - prints all theorems which contain id in their type - -Tactic definitions - -- Static globalisation of identifiers and global references (source of - incompatibilities, especially, Recursive keyword is required for - mutually recursive definitions). -- New evaluation semantics: no more partial evaluation at definition time; - evaluation of all Tactic/Meta Definition, even producing terms, expect - a proof context to be evaluated (especially "()" is no longer needed). -- Debugger now shows the nesting level and the reasons of failure - -Tactics - -- Equality tactics (Rewrite, Reflexivity, Symmetry, Transitivity) now - understand JM equality -- Simpl and Change now apply to subterms also -- "Simpl f" reduces subterms whose head constant is f -- Double Induction now referring to hypotheses like "Intros until" -- "Inversion" now applies also on quantified hypotheses (naming as - for Intros until) -- NewDestruct now accepts terms with missing hypotheses -- NewDestruct and NewInduction now accept user-provided elimination scheme -- NewDestruct and NewInduction now accept user-provided introduction names -- Omega could solve goals such as ~`x<y` |- `x>=y` but failed when the - hypothesis was unfolded to `x < y` -> False. This is fixed. In addition, - it can also recognize 'False' in the hypothesis and use it to solve the - goal. -- Coercions now handled in "with" bindings -- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses - when an hypothesis x=t or x:=t or t=x exists -- Fresh names for Assert and Pose now based on collision-avoiding - Intro naming strategy (exceptional source of incompatibilities) -- LinearIntuition (* no documentation *) -- Unfold expects a correct evaluable argument -- Clear expects existing hypotheses - -Extraction (See details in plugins/extraction/CHANGES and README): - -- An experimental Scheme extraction is provided. -- Concerning Ocaml, extracted code is now ensured to always type-check, - thanks to automatic inserting of Obj.magic. -- Experimental extraction of Coq new modules to Ocaml modules. - -Proof rendering in natural language - -- Export of theories to XML for publishing and rendering purposes now - includes proof-trees (see http://www.cs.unibo.it/helm) - -Miscellaneous - -- Printing Coercion now used through the standard keywords Set/Add, Test, Print -- "Print Term id" is an alias for "Print id" -- New switch "Unset/Set Printing Symbols" to control printing of - symbolic notations -- Two new variants of implicit arguments are available - - "Unset/Set Contextual Implicits" tells to consider implicit also the - arguments inferable from the context (e.g. for nil or refl_eq) - - "Unset/Set Strict Implicits" tells to consider implicit only the - arguments that are inferable in any case (i.e. arguments that occurs - as argument of rigid constants in the type of the remaining arguments; - e.g. the witness of an existential is not strict since it can vanish when - applied to a predicate which does not use its argument) - -Incompatibilities - -- "Grammar tactic ... : ast" and "Grammar vernac ... : ast" are no - longer supported, use TACTIC EXTEND and VERNAC COMMAND EXTEND on the - ML-side instead -- Transparency of le_lt_dec and co (leads to some simplification in - proofs; in some cases, incompatibilites is solved by declaring locally - opaque the relevant constant) -- Opaque Local do not now survive section closing (rename them into - Remark/Lemma/... to get them still surviving the sections; this - renaming allows also to solve incompatibilites related to now - forbidden calls to the tactic Clear) -- Remark and Fact have no longer (very) long names (use Local instead in case - of name conflict) - -Bugs - -- Improved localisation of errors in Syntactic Definitions -- Induction principle creation failure in presence of let-in fixed (#1459) -- Inversion bugs fixed (#1427 and #1437) -- Omega bug related to Set fixed (#1384) -- Type-checking inefficiency of nested destructuring let-in fixed (#1435) -- Improved handling of let-in during holes resolution phase (#1460) - -Efficiency - -- Implementation of a memory sharing strategy reducing memory - requirements by an average ratio of 3. - -Changes from V7.3 to V7.3.1 -=========================== - -Bug fixes - - - Corrupted Field tactic and Match Context tactic construction fixed - - Checking of names already existing in Assert added (#1386) - - Invalid argument bug in Exact tactic solved (#1387) - - Colliding bound names bug fixed (#1412) - - Wrong non-recursivity test for Record fixed (#1394) - - Out of memory/seg fault bug related to parametric inductive fixed (#1404) - - Setoid_replace/Setoid_rewrite bug wrt "==" fixed - -Misc - - - Ocaml version >= 3.06 is needed to compile Coq from sources - - Simplification of fresh names creation strategy for Assert, Pose and - LetTac (#1402) - -Changes from V7.2 to V7.3 -========================= - -Language - -- Slightly improved compilation of pattern-matching (slight source of - incompatibilities) -- Record's now accept anonymous fields "_" which does not build projections -- Changes in the allowed elimination sorts for certain class of inductive - definitions : an inductive definition without constructors - of Sort Prop can be eliminated on sorts Set and Type A "singleton" - inductive definition (one constructor with arguments in the sort Prop - like conjunction of two propositions or equality) can be eliminated - directly on sort Type (In V7.2, only the sorts Prop and Set were allowed) - -Tactics - -- New tactic "Rename x into y" for renaming hypotheses -- New tactics "Pose x:=u" and "Pose u" to add definitions to local context -- Pattern now working on partially applied subterms -- Ring no longer applies irreversible congruence laws of mult but - better applies congruence laws of plus (slight source of incompatibilities). -- Field now accepts terms to be simplified as arguments (as for Ring). This - extension has been also implemented using the toplevel tactic language. -- Intuition does no longer unfold constants except "<->" and "~". It - can be parameterized by a tactic. It also can introduce dependent - product if needed (source of incompatibilities) -- "Match Context" now matching more recent hypotheses first and failing only - on user errors and Fail tactic (possible source of incompatibilities) -- Tactic Definition's without arguments now allowed in Coq states -- Better simplification and discrimination made by Inversion (source - of incompatibilities) - -Bugs - -- "Intros H" now working like "Intro H" trying first to reduce if not a product -- Forward dependencies in Cases now taken into account -- Known bugs related to Inversion and let-in's fixed -- Bug unexpected Delta with let-in now fixed - -Extraction (details in plugins/extraction/CHANGES or documentation) - -- Signatures of extracted terms are now mostly expunged from dummy arguments. -- Haskell extraction is now operational (tested & debugged). - -Standard library - -- Some additions in [ZArith]: three files (Zcomplements.v, Zpower.v - and Zlogarithms.v) moved from plugins/omega in order to be more - visible, one Zsgn function, more induction principles (Wf_Z.v and - tail of Zcomplements.v), one more general Euclid theorem -- Peano_dec.v and Compare_dec.v now part of Arith.v - -Tools - -- new option -dump-glob to coqtop to dump globalizations (to be used by the - new documentation tool coqdoc; see http://www.lri.fr/~filliatr/coqdoc) - -User Contributions - -- CongruenceClosure (congruence closure decision procedure) - [Pierre Corbineau, ENS Cachan] -- MapleMode (an interface to embed Maple simplification procedures over - rational fractions in Coq) - [David Delahaye, Micaela Mayero, Chalmers University] -- Presburger: A formalization of Presburger's algorithm - [Laurent Thery, INRIA Sophia Antipolis] -- Chinese has been rewritten using Z from ZArith as datatype - ZChinese is the new version, Chinese the obsolete one - [Pierre Letouzey, LRI Orsay] - -Incompatibilities - -- Ring: exceptional incompatibilities (1 above 650 in submitted user - contribs, leading to a simplification) -- Intuition: does not unfold any definition except "<->" and "~" -- Cases: removal of some extra Cases in configurations of the form - "Cases ... of C _ => ... | _ D => ..." (effects on 2 definitions of - submitted user contributions necessitating the removal of now superfluous - proof steps in 3 different proofs) -- Match Context, in case of incompatibilities because of a now non - trapped error (e.g. Not_found or Failure), use instead tactic Fail - to force Match Context trying the next clause -- Inversion: better simplification and discrimination may occasionally - lead to less subgoals and/or hypotheses and different naming of hypotheses -- Unification done by Apply/Elim has been changed and may exceptionally lead - to incompatible instantiations -- Peano_dec.v and Compare_dec.v parts of Arith.v make Auto more - powerful if these files were not already required (1 occurrence of - this in submitted user contribs) - -Changes from V7.1 to V7.2 -========================= - -Language - -- Automatic insertion of patterns for local definitions in the type of - the constructors of an inductive types (for compatibility with V6.3 - let-in style) -- Coercions allowed in Cases patterns -- New declaration "Canonical Structure id = t : I" to help resolution of - equations of the form (proj ?)=a; if proj(e)=a then a is canonically - equipped with the remaining fields in e, i.e. ? is instantiated by e - -Tactics - -- New tactic "ClearBody H" to clear the body of definitions in local context -- New tactic "Assert H := c" for forward reasoning -- Slight improvement in naming strategy for NewInduction/NewDestruct -- Intuition/Tauto do not perform useless unfolding and work up to conversion - -Extraction (details in plugins/extraction/CHANGES or documentation) - -- Syntax changes: there are no more options inside the extraction commands. - New commands for customization and options have been introduced instead. -- More optimizations on extracted code. -- Extraction tests are now embedded in 14 user contributions. - -Standard library - -- In [Relations], Rstar.v and Newman.v now axiom-free. -- In [Sets], Integers.v now based on nat -- In [Arith], more lemmas in Min.v, new file Max.v, tail-recursive - plus and mult added to Plus.v and Mult.v respectively -- New directory [Sorting] with a proof of heapsort (dragged from 6.3.1 lib) -- In [Reals], more lemmas in Rbase.v, new lemmas on square, square root and - trigonometric functions (R_sqr.v - Rtrigo.v); a complementary approach - and new theorems about continuity and derivability in Ranalysis.v; some - properties in plane geometry such as translation, rotation or similarity - in Rgeom.v; finite sums and Chasles property in Rsigma.v - -Bugs - -- Confusion between implicit args of locals and globals of same base name fixed -- Various incompatibilities wrt inference of "?" in V6.3.1 fixed -- Implicits in infix section variables bug fixed -- Known coercions bugs fixed - -- Apply "universe anomaly" bug fixed -- NatRing now working -- "Discriminate 1", "Injection 1", "Simplify_eq 1" now working -- NewInduction bugs with let-in and recursively dependent hypotheses fixed -- Syntax [x:=t:T]u now allowed as mentioned in documentation - -- Bug with recursive inductive types involving let-in fixed -- Known pattern-matching bugs fixed -- Known Cases elimination predicate bugs fixed -- Improved errors messages for pattern-matching and projections -- Better error messages for ill-typed Cases expressions - -Incompatibilities - -- New naming strategy for NewInduction/NewDestruct may affect 7.1 compatibility -- Extra parentheses may exceptionally be needed in tactic definitions. -- Coq extensions written in Ocaml need to be updated (see dev/changements.txt - for a description of the main changes in the interface files of V7.2) -- New behaviour of Intuition/Tauto may exceptionally lead to incompatibilities - ----------------------------------------------------------------------------- -Changes from V6.3.1 and V7.0 to V7.1 -==================================== - -Notes: - -- items followed by (**) are important sources of incompatibilities -- items followed by (*) may exceptionally be sources of incompatibilities -- items followed by (+) have been introduced in version 7.0 - - -Main novelties -============== - -References are to Coq V7.1 reference manual - -- New primitive let-in construct (see sections 1.2.8 and ) -- Long names (see sections 2.6 and 2.7) -- New high-level tactic language (see chapter 10) -- Improved search facilities (see section 5.2) -- New extraction algorithm managing the Type level (see chapter 17) -- New rewriting tactic for arbitrary equalities (see chapter 19) -- New tactic Field to decide equalities on commutative fields (see 7.11) -- New tactic Fourier to solve linear inequalities on reals numbers (see 7.11) -- New tactics for induction/case analysis in "natural" style (see 7.7) -- Deep restructuration of the code (safer, simpler and more efficient) -- Export of theories to XML for publishing and rendering purposes - (see http://www.cs.unibo.it/helm) - - -Details of changes -================== - -Language: new "let-in" construction ------------------------------------ - -- New construction for local definitions (let-in) with syntax [x:=u]t (*)(+) - -- Local definitions allowed in Record (a.k.a. record à la Randy Pollack) - - -Language: long names --------------------- - -- Each construction has a unique absolute names built from a base - name, the name of the module in which they are defined (Top if in - coqtop), and possibly an arbitrary long sequence of directory (e.g. - "Coq.Lists.PolyList.flat_map" where "Coq" means that "flat_map" is part - of Coq standard library, "Lists" means it is defined in the Lists - library and "PolyList" means it is in the file Polylist) (+) - -- Constructions can be referred by their base name, or, in case of - conflict, by a "qualified" name, where the base name is prefixed - by the module name (and possibly by a directory name, and so - on). A fully qualified name is an absolute name which always refer - to the construction it denotes (to preserve the visibility of - all constructions, no conflict is allowed for an absolute name) (+) - -- Long names are available for modules with the possibility of using - the directory name as a component of the module full name (with - option -R to coqtop and coqc, or command Add LoadPath) (+) - -- Improved conflict resolution strategy (the Unix PATH model), - allowing more constructions to be referred just by their base name - - -Language: miscellaneous ------------------------ - -- The names of variables for Record projections _and_ for induction principles - (e.g. sum_ind) is now based on the first letter of their type (main - source of incompatibility) (**)(+) - -- Most typing errors have now a precise location in the source (+) - -- Slightly different mechanism to solve "?" (*)(+) - -- More arguments may be considered implicit at section closing (*)(+) - -- Bug with identifiers ended by a number greater than 2^30 fixed (+) - -- New visibility discipline for Remark, Fact and Local: Remark's and - Fact's now survive at the end of section, but are only accessible using a - qualified names as soon as their strength expires; Local's disappear and - are moved into local definitions for each construction persistent at - section closing - - -Language: Cases ---------------- - -- Cases no longer considers aliases inferable from dependencies in types (*)(+) - -- A redundant clause in Cases is now an error (*) - - -Reduction ---------- - -- New reduction flags "Zeta" and "Evar" in Eval Compute, for inlining of - local definitions and instantiation of existential variables - -- Delta reduction flag does not perform Zeta and Evar reduction any more (*) - -- Constants declared as opaque (using Qed) can no longer become - transparent (a constant intended to be alternatively opaque and - transparent must be declared as transparent (using Defined)); a risk - exists (until next Coq version) that Simpl and Hnf reduces opaque - constants (*) - - -New tactics ------------ - -- New set of tactics to deal with types equipped with specific - equalities (a.k.a. Setoids, e.g. nat equipped with eq_nat) [by C. Renard] - -- New tactic Assert, similar to Cut but expected to be more user-friendly - -- New tactic NewDestruct and NewInduction intended to replace Elim - and Induction, Case and Destruct in a more user-friendly way (see - restrictions in the reference manual) - -- New tactic ROmega: an experimental alternative (based on reflexion) to Omega - [by P. Crégut] - -- New tactic language Ltac (see reference manual) (+) - -- New versions of Tauto and Intuition, fully rewritten in the new Ltac - language; they run faster and produce more compact proofs; Tauto is - fully compatible but, in exchange of a better uniformity, Intuition - is slightly weaker (then use Tauto instead) (**)(+) - -- New tactic Field to decide equalities on commutative fields (as a - special case, it works on real numbers) (+) - -- New tactic Fourier to solve linear inequalities on reals numbers - [by L. Pottier] (+) - -- New tactics dedicated to real numbers: DiscrR, SplitRmult, SplitAbsolu (+) - - -Changes in existing tactics ---------------------------- - -- Reduction tactics in local definitions apply only to the body - -- New syntax of the form "Compute in Type of H." to require a reduction on - the types of local definitions - -- Inversion, Injection, Discriminate, ... apply also on the - quantified premises of a goal (using the "Intros until" syntax) - -- Decompose has been fixed but hypotheses may get different names (*)(+) - -- Tauto now manages uniformly hypotheses and conclusions of the form - "t=t" which all are considered equivalent to "True". Especially, - Tauto now solves goals of the form "H : ~ t = t |- A". - -- The "Let" tactic has been renamed "LetTac" and is now based on the - primitive "let-in" (+) - -- Elim can no longer be used with an elimination schema different from - the one defined at definition time of the inductive type. To overload - an elimination schema, use "Elim <hyp> using <name of the new schema>" - (*)(+) - -- Simpl no longer unfolds the recursive calls of a mutually defined - fixpoint (*)(+) - -- Intro now fails if the hypothesis name already exists (*)(+) - -- "Require Prolog" is no longer needed (i.e. it is available by default) (*)(+) - -- Unfold now fails on a non unfoldable identifier (*)(+) - -- Unfold also applies on definitions of the local context - -- AutoRewrite now deals only with the main goal and it is the purpose of - Hint Rewrite to deal with generated subgoals (+) - -- Redundant or incompatible instantiations in Apply ... with ... are now - correctly managed (+) - - -Efficiency ----------- - -- Excessive memory uses specific to V7.0 fixed - -- Sizes of .vo files vary a lot compared to V6.3 (from -30% to +300% - depending on the developments) - -- An improved reduction strategy for lazy evaluation - -- A more economical mechanism to ensure logical consistency at the Type level; - warning: this is experimental and may produce "universes" anomalies - (please report) - - -Concrete syntax of constructions --------------------------------- - -- Only identifiers starting with "_" or a letter, and followed by letters, - digits, "_" or "'" are allowed (e.g. "$" and "@" are no longer allowed) (*) - -- A multiple binder like (a:A)(a,b:(P a))(Q a) is no longer parsed as - (a:A)(a0:(P a))(b:(P a))(Q a0) but as (a:A)(a0:(P a))(b:(P a0))(Q a0) (*)(+) - -- A dedicated syntax has been introduced for Reals (e.g ``3+1/x``) (+) - -- Pretty-printing of Infix notations fixed. (+) - - -Parsing and grammar extension ------------------------------ - -- More constraints when writing ast - - - "{...}" and the macros $LIST, $VAR, etc. now expect a metavariable - (an identifier starting with $) (*) - - identifiers should starts with a letter or "_" and be followed - by letters, digits, "_" or "'" (other characters are still - supported but it is not advised to use them) (*)(+) - -- Entry "command" in "Grammar" and quotations (<<...>> stuff) is - renamed "constr" as in "Syntax" (+) - -- New syntax "[" sentence_1 ... sentence_n"]." to group sentences (useful - for Time and to write grammar rules abbreviating several commands) (+) - -- The default parser for actions in the grammar rules (and for - patterns in the pretty-printing rules) is now the one associated to - the grammar (i.e. vernac, tactic or constr); no need then for - quotations as in <:vernac:<...>>; to return an "ast", the grammar - must be explicitly typed with tag ": ast" or ": ast list", or if a - syntax rule, by using <<...>> in the patterns (expression inside - these angle brackets are parsed as "ast"); for grammars other than - vernac, tactic or constr, you may explicitly type the action with - tags ": constr", ": tactic", or ":vernac" (**)(+) - -- Interpretation of names in Grammar rule is now based on long names, - which allows to avoid problems (or sometimes tricks;) related to - overloaded names (+) - - -New commands ------------- - -- New commands "Print XML All", "Show XML Proof", ... to show or - export theories to XML to be used with Helm's publishing and rendering - tools (see http://www.cs.unibo.it/helm) (by Claudio Sacerdoti Coen) (+) - -- New commands to manually set implicit arguments (+) - - - "Implicits ident." to activate the implicit arguments mode just for ident - - "Implicits ident [num1 num2 ...]." to explicitly give which - arguments have to be considered as implicit - -- New SearchPattern/SearchRewrite (by Yves Bertot) (+) - -- New commands "Debug on"/"Debug off" to activate/deactivate the tactic - language debugger (+) - -- New commands to map physical paths to logical paths (+) - - Add LoadPath physical_dir as logical_dir - - Add Rec LoadPath physical_dir as logical_dir - - -Changes in existing commands ----------------------------- - -- Generalization of the usage of qualified identifiers in tactics - and commands about globals, e.g. Decompose, Eval Delta; - Hints Unfold, Transparent, Require - -- Require synchronous with Reset; Require's scope stops at Section ending (*) - -- For a module indirectly loaded by a "Require" but not exported, - the command "Import module" turns the constructions defined in the - module accessible by their short name, and activates the Grammar, - Syntax, Hint, ... declared in the module (+) - -- The scope of the "Search" command can be restricted to some modules (+) - -- Final dot in command (full stop/period) must be followed by a blank - (newline, tabulation or whitespace) (+) - -- Slight restriction of the syntax for Cbv Delta: if present, option [-myconst] - must immediately follow the Delta keyword (*)(+) - -- SearchIsos currently not supported - -- Add ML Path is now implied by Add LoadPath (+) - -- New names for the following commands (+) - - AddPath -> Add LoadPath - Print LoadPath -> Print LoadPath - DelPath -> Remove LoadPath - AddRecPath -> Add Rec LoadPath - Print Path -> Print Coercion Paths - - Implicit Arguments On -> Set Implicit Arguments - Implicit Arguments Off -> Unset Implicit Arguments - - Begin Silent -> Set Silent - End Silent -> Unset Silent. - - -Tools ------ - -- coqtop (+) - - - Two executables: coqtop.byte and coqtop.opt (if supported by the platform) - - coqtop is a link to the more efficient executable (coqtop.opt if present) - - option -full is obsolete (+) - -- do_Makefile renamed into coq_makefile (+) - -- New option -R to coqtop and coqc to map a physical directory to a logical - one (+) - -- coqc no longer needs to create a temporary file - -- No more warning if no initialization file .coqrc exists - - -Extraction ----------- - -- New algorithm for extraction able to deal with "Type" (+) - (by J.-C. Filliâtre and P. Letouzey) - - -Standard library ----------------- - -- New library on maps on integers (IntMap, contributed by Jean Goubault) - -- New lemmas about integer numbers [ZArith] - -- New lemmas and a "natural" syntax for reals [Reals] (+) - -- Exc/Error/Value renamed into Option/Some/None (*) - - -New user contributions ----------------------- - -- Constructive complex analysis and the Fundamental Theorem of Algebra [FTA] - (Herman Geuvers, Freek Wiedijk, Jan Zwanenburg, Randy Pollack, - Henk Barendregt, Nijmegen) - -- A new axiomatization of ZFC set theory [Functions_in_ZFC] - (C. Simpson, Sophia-Antipolis) - -- Basic notions of graph theory [GRAPHS-BASICS] (Jean Duprat, Lyon) - -- A library for floating-point numbers [Float] (Laurent Théry, Sylvie Boldo, - Sophia-Antipolis) - -- Formalisation of CTL and TCTL temporal logic [CtlTctl] (Carlos - Daniel Luna,Montevideo) - -- Specification and verification of the Railroad Crossing Problem - in CTL and TCTL [RailroadCrossing] (Carlos Daniel Luna,Montevideo) - -- P-automaton and the ABR algorithm [PAutomata] - (Christine Paulin, Emmanuel Freund, Orsay) - -- Semantics of a subset of the C language [MiniC] - (Eduardo Giménez, Emmanuel Ledinot, Suresnes) - -- Correctness proofs of the following imperative algorithms: - Bresenham line drawing algorithm [Bresenham], Marché's minimal edition - distance algorithm [Diff] (Jean-Christophe Filliâtre, Orsay) - -- Correctness proofs of Buchberger's algorithm [Buchberger] and RSA - cryptographic algorithm [Rsa] (Laurent Théry, Sophia-Antipolis) - -- Correctness proof of Stalmarck tautology checker algorithm - [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis) diff --git a/Makefile.ci b/Makefile.ci index 9180d51bee..000725b6b1 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -10,6 +10,7 @@ CI_TARGETS= \ ci-aac_tactics \ + ci-argosy \ ci-bedrock2 \ ci-bignums \ ci-color \ diff --git a/Makefile.doc b/Makefile.doc index 5ac3ecb63d..e89a20393c 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -31,7 +31,13 @@ DVIPS:=dvips HTMLSTYLE:=coqremote # Sphinx-related variables +OSNAME:=$(shell uname -o) +ifeq ($(OSNAME),Cygwin) +WIN_CURDIR:=$(shell cygpath -w $(CURDIR)) +SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(WIN_CURDIR)" +else SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(CURDIR)" +endif SPHINXOPTS= -j4 SPHINXWARNERROR ?= 1 ifeq ($(SPHINXWARNERROR),1) diff --git a/Makefile.dune b/Makefile.dune index 4609c563d9..ebf74978a9 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -42,8 +42,10 @@ help: @echo " - help: show this message" # We need to bootstrap with a dummy coq.plugins.ltac so install targets do work. -voboot: +plugins/ltac/dune: @echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune + +voboot: plugins/ltac/dune dune build $(DUNEOPT) @vodeps dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d diff --git a/Makefile.ide b/Makefile.ide index 908f5f6648..8f9088a04a 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -66,7 +66,7 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ GTKSHARE=$(shell pkg-config --variable=prefix gtk+-3.0)/share GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) -PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-3.0)/bin +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share ########################################################################### @@ -244,15 +244,15 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk3.sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents $(MKDIR) $@/coq/ $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(IDEBINDINGS) $@/coq/ - $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ + $(MKDIR) $@/gtksourceview-3.0/{language-specs,styles} + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-3.0/language-specs/ + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/styles/{styles.rng,classic.xml} $@/gtksourceview-3.0/styles/ cp -R "$(GTKSHARE)/"locale $@ cp -R "$(GTKSHARE)/"themes $@ @@ -262,20 +262,20 @@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-2.0/2.10.0/immodules/"*.so $@ + $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.so $@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(MKDIR) $@/xdg/coq $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys - $(MKDIR) $@/gtk-2.0 + $(MKDIR) $@/gtk-3.0 { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\ + > $@/gtk-3.0/gdk-pixbuf.loaders + { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.so |\ sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gtk-immodules.loaders + > $@/gtk-3.0/gtk-immodules.loaders $(MKDIR) $@/pango echo "[Pango]" > $@/pango/pangorc diff --git a/azure-pipelines.yml b/azure-pipelines.yml index a8b42cc722..6fcc64f77e 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -42,6 +42,9 @@ jobs: pool: vmImage: 'macOS-10.13' + variables: + MACOSX_DEPLOYMENT_TARGET: '10.12' + steps: - checkout: self fetchDepth: 10 @@ -49,16 +52,20 @@ jobs: - script: | set -e brew update - brew unlink python - brew install gnu-time opam + brew install gnu-time opam pkg-config gtksourceview3 + pip3 install macpack + displayName: 'Install system dependencies' + - script: | + set -e + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig opam init -a -j "$NJOBS" --compiler=$COMPILER opam switch set $COMPILER eval $(opam env) opam update - opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit + opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 opam list - displayName: 'Install dependencies' + displayName: 'Install OCaml dependencies' env: COMPILER: "4.07.1" FINDLIB_VER: ".1.8.0" @@ -68,11 +75,30 @@ jobs: set -e eval $(opam env) - ./configure -local -warn-error yes -native-compiler no + ./configure -prefix '$(Build.BinariesDirectory)' -warn-error yes -native-compiler no -coqide opt make -j "$NJOBS" displayName: 'Build Coq' - script: | eval $(opam env) - make -j "$NJOBS" test-suite + make -j "$NJOBS" test-suite PRINT_LOGS=1 displayName: 'Run Coq Test Suite' + + - script: | + make install + displayName: 'Install Coq' + + - script: | + set -e + eval $(opam env) + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig + ./dev/build/osx/make-macos-dmg.sh + mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" + displayName: 'Create the dmg bundle' + env: + OUTDIR: '$(Build.BinariesDirectory)' + + - task: PublishBuildArtifacts@1 + inputs: + pathtoPublish: '$(Build.ArtifactStagingDirectory)' + artifactName: coq-macOS-installer diff --git a/checker/check.ml b/checker/check.ml index b2930d9535..a2c8a0f25d 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -56,7 +56,7 @@ type library_t = { library_name : compilation_unit_name; library_filename : CUnix.physical_path; library_compiled : Safe_typing.compiled_library; - library_opaques : seg_proofs; + library_opaques : seg_proofs option; library_deps : (compilation_unit_name * Safe_typing.vodigest) array; library_digest : Safe_typing.vodigest; library_extra_univs : Univ.ContextSet.t } @@ -292,6 +292,8 @@ let name_clash_message dir mdir f = pr_dirpath mdir ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir +type intern_mode = Rec | Root | Dep (* Rec = standard, Root = -norec, Dep = dependency of norec *) + (* Dependency graph *) let depgraph = ref LibraryMap.empty @@ -304,18 +306,40 @@ let marshal_in_segment f ch = with _ -> user_err (str "Corrupted file " ++ quote (str f)) -let intern_from_file (dir, f) = +let skip_in_segment f ch = + try + let stop = (input_binary_int ch : int) in + seek_in ch stop; + let digest = Digest.input ch in + stop, digest + with _ -> + user_err (str "Corrupted file " ++ quote (str f)) + +let marshal_or_skip ~intern_mode f ch = + if intern_mode <> Dep then + let v, pos, digest = marshal_in_segment f ch in + Some v, pos, digest + else + let pos, digest = skip_in_segment f ch in + None, pos, digest + +let intern_from_file ~intern_mode (dir, f) = + let validate a b c = if intern_mode <> Dep then Validate.validate a b c in Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try + let marshal_in_segment f ch = if intern_mode <> Dep + then marshal_in_segment f ch + else System.marshal_in_segment f ch + in let ch = System.with_magic_number_check raw_intern_library f in let (sd:summary_disk), _, digest = marshal_in_segment f ch in let (md:library_disk), _, digest = marshal_in_segment f ch in let (opaque_csts:'a option), _, udg = marshal_in_segment f ch in let (discharging:'a option), _, _ = marshal_in_segment f ch in let (tasks:'a option), _, _ = marshal_in_segment f ch in - let (table:seg_proofs), pos, checksum = - marshal_in_segment f ch in + let (table:seg_proofs option), pos, checksum = + marshal_or_skip ~intern_mode f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in @@ -334,12 +358,12 @@ let intern_from_file (dir, f) = user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; - Validate.validate !Flags.debug Values.v_univopaques opaque_csts; + validate !Flags.debug Values.v_univopaques opaque_csts; end; (* Verification of the unmarshalled values *) - Validate.validate !Flags.debug Values.v_libsum sd; - Validate.validate !Flags.debug Values.v_lib md; - Validate.validate !Flags.debug Values.v_opaques table; + validate !Flags.debug Values.v_libsum sd; + validate !Flags.debug Values.v_lib md; + validate !Flags.debug Values.(Opt v_opaques) table; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) @@ -347,7 +371,7 @@ let intern_from_file (dir, f) = sd,md,table,opaque_csts,digest with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; - opaque_tables := LibraryMap.add sd.md_name table !opaque_tables; + Option.iter (fun table -> opaque_tables := LibraryMap.add sd.md_name table !opaque_tables) table; Option.iter (fun (opaque_csts,_,_) -> opaque_univ_tables := LibraryMap.add sd.md_name opaque_csts !opaque_univ_tables) @@ -365,7 +389,7 @@ let get_deps (dir, f) = (* Read a compiled library and all dependencies, in reverse order. Do not include files that are already in the context. *) -let rec intern_library seen (dir, f) needed = +let rec intern_library ~intern_mode seen (dir, f) needed = if LibrarySet.mem dir seen then failwith "Recursive dependencies!"; (* Look if in the current logical environment *) try let _ = find_library dir in needed @@ -374,12 +398,13 @@ let rec intern_library seen (dir, f) needed = if List.mem_assoc_f DirPath.equal dir needed then needed else (* [dir] is an absolute name which matches [f] which must be in loadpath *) - let m = intern_from_file (dir,f) in + let m = intern_from_file ~intern_mode (dir,f) in let seen' = LibrarySet.add dir seen in let deps = Array.map (fun (d,_) -> try_locate_absolute_library d) m.library_deps in - (dir,m) :: Array.fold_right (intern_library seen') deps needed + let intern_mode = match intern_mode with Rec -> Rec | Root | Dep -> Dep in + (dir,m) :: Array.fold_right (intern_library ~intern_mode seen') deps needed (* Compute the reflexive transitive dependency closure *) let rec fold_deps seen ff (dir,f) (s,acc) = @@ -402,8 +427,9 @@ let recheck_library senv ~norec ~admit ~check = let ml = List.map try_locate_qualified_library check in let nrl = List.map try_locate_qualified_library norec in let al = List.map try_locate_qualified_library admit in - let needed = List.rev - (List.fold_right (intern_library LibrarySet.empty) (ml@nrl) []) in + let needed = List.fold_right (intern_library ~intern_mode:Rec LibrarySet.empty) ml [] in + let needed = List.fold_right (intern_library ~intern_mode:Root LibrarySet.empty) nrl needed in + let needed = List.rev needed in (* first compute the closure of norec, remove closure of check, add closure of admit, and finally remove norec and check *) let nochk = fold_deps_list LibrarySet.add nrl LibrarySet.empty in diff --git a/clib/cThread.ml b/clib/cThread.ml index 9e0319e8f8..5fa44b1eec 100644 --- a/clib/cThread.ml +++ b/clib/cThread.ml @@ -100,10 +100,10 @@ let thread_friendly_input_value ic = (* On the ocaml runtime used in some opam-for-windows version the * [Thread.sigmask] API raises Invalid_argument "not implemented", * hence we protect the call and turn the exception into a no-op *) -let protect_sigalrm f x = +let mask_sigalrm f x = begin try ignore(Thread.sigmask Unix.SIG_BLOCK [Sys.sigalrm]) with Invalid_argument _ -> () end; f x let create f x = - Thread.create (protect_sigalrm f) x + Thread.create (mask_sigalrm f) x diff --git a/clib/unicode.ml b/clib/unicode.ml index 1e45c0d250..a122e2c46a 100644 --- a/clib/unicode.ml +++ b/clib/unicode.ml @@ -86,6 +86,7 @@ let classify = Unicodetable.ll; (* Letter, lowercase. *) Unicodetable.lt; (* Letter, titlecase. *) Unicodetable.lo; (* Letter, others. *) + Unicodetable.lm; (* Letter, modifier. *) ]; mk_lookup_table_from_unicode_tables_for IdentPart [ @@ -21,6 +21,7 @@ license: "LGPL-2.1" depends: [ "ocaml" { >= "4.05.0" } "dune" { build & >= "1.4.0" } + "ocamlfind" { build } "num" ] diff --git a/coqpp/coqpp_ast.mli b/coqpp/coqpp_ast.mli index 8e10ec49ce..81109887ba 100644 --- a/coqpp/coqpp_ast.mli +++ b/coqpp/coqpp_ast.mli @@ -103,6 +103,7 @@ type classification = type vernac_rule = { vernac_atts : (string * string) list option; + vernac_state: string option; vernac_toks : ext_token list; vernac_class : code option; vernac_depr : bool; diff --git a/coqpp/coqpp_lex.mll b/coqpp/coqpp_lex.mll index c38755943a..81ba8ad98c 100644 --- a/coqpp/coqpp_lex.mll +++ b/coqpp/coqpp_lex.mll @@ -130,6 +130,7 @@ rule extend = parse | space { extend lexbuf } | '\"' { string lexbuf } | '\n' { newline lexbuf; extend lexbuf } +| "![" { BANGBRACKET } | "#[" { HASHBRACKET } | '[' { LBRACKET } | ']' { RBRACKET } diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index d33eef135f..26e1e25fb9 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -161,27 +161,33 @@ let is_token s = match string_split s with | [s] -> is_uident s | _ -> false -let rec parse_tokens = function +let rec parse_tokens ?(in_anon=false) = +let err_anon () = + if in_anon then + fatal (Printf.sprintf "'SELF' or 'NEXT' illegal in anonymous entry level") in +function | [GSymbString s] -> SymbToken ("", Some s) -| [GSymbQualid ("SELF", None)] -> SymbSelf -| [GSymbQualid ("NEXT", None)] -> SymbNext +| [GSymbQualid ("QUOTATION", None); GSymbString s] -> + SymbToken ("QUOTATION", Some s) +| [GSymbQualid ("SELF", None)] -> err_anon (); SymbSelf +| [GSymbQualid ("NEXT", None)] -> err_anon (); SymbNext | [GSymbQualid ("LIST0", None); tkn] -> - SymbList0 (parse_token tkn, None) + SymbList0 (parse_token ~in_anon tkn, None) | [GSymbQualid ("LIST1", None); tkn] -> - SymbList1 (parse_token tkn, None) + SymbList1 (parse_token ~in_anon tkn, None) | [GSymbQualid ("LIST0", None); tkn; GSymbQualid ("SEP", None); tkn'] -> - SymbList0 (parse_token tkn, Some (parse_token tkn')) + SymbList0 (parse_token ~in_anon tkn, Some (parse_token ~in_anon tkn')) | [GSymbQualid ("LIST1", None); tkn; GSymbQualid ("SEP", None); tkn'] -> - SymbList1 (parse_token tkn, Some (parse_token tkn')) + SymbList1 (parse_token ~in_anon tkn, Some (parse_token ~in_anon tkn')) | [GSymbQualid ("OPT", None); tkn] -> - SymbOpt (parse_token tkn) + SymbOpt (parse_token ~in_anon tkn) | [GSymbQualid (e, None)] when is_token e -> SymbToken (e, None) | [GSymbQualid (e, None); GSymbString s] when is_token e -> SymbToken (e, Some s) | [GSymbQualid (e, lvl)] when not (is_token e) -> SymbEntry (e, lvl) -| [GSymbParen tkns] -> parse_tokens tkns +| [GSymbParen tkns] -> parse_tokens ~in_anon tkns | [GSymbProd prds] -> let map p = - let map (pat, tkns) = (pat, parse_tokens tkns) in + let map (pat, tkns) = (pat, parse_tokens ~in_anon:true tkns) in (List.map map p.gprod_symbs, p.gprod_body) in SymbRules (List.map map prds) @@ -197,7 +203,7 @@ let rec parse_tokens = function in fatal (Printf.sprintf "Invalid token: %s" (db_tokens t)) -and parse_token tkn = parse_tokens [tkn] +and parse_token ~in_anon tkn = parse_tokens ~in_anon [tkn] let print_fun fmt (vars, body) = let vars = List.rev vars in @@ -212,16 +218,20 @@ let print_fun fmt (vars, body) = (** Meta-program instead of calling Tok.of_pattern here because otherwise violates value restriction *) -let print_tok fmt = function -| "", s -> fprintf fmt "Tok.KEYWORD %a" print_string s -| "IDENT", s -> fprintf fmt "Tok.IDENT %a" print_string s -| "PATTERNIDENT", s -> fprintf fmt "Tok.PATTERNIDENT %a" print_string s -| "FIELD", s -> fprintf fmt "Tok.FIELD %a" print_string s -| "INT", s -> fprintf fmt "Tok.INT %a" print_string s -| "STRING", s -> fprintf fmt "Tok.STRING %a" print_string s -| "LEFTQMARK", _ -> fprintf fmt "Tok.LEFTQMARK" -| "BULLET", s -> fprintf fmt "Tok.BULLET %a" print_string s -| "EOI", _ -> fprintf fmt "Tok.EOI" +let print_tok fmt = +let print_pat fmt = print_opt fmt print_string in +function +| "", Some s -> fprintf fmt "Tok.PKEYWORD (%a)" print_string s +| "IDENT", s -> fprintf fmt "Tok.PIDENT (%a)" print_pat s +| "PATTERNIDENT", s -> fprintf fmt "Tok.PPATTERNIDENT (%a)" print_pat s +| "FIELD", s -> fprintf fmt "Tok.PFIELD (%a)" print_pat s +| "NUMERAL", None -> fprintf fmt "Tok.PNUMERAL None" +| "NUMERAL", Some s -> fprintf fmt "Tok.PNUMERAL (Some (NumTok.int %a))" print_string s +| "STRING", s -> fprintf fmt "Tok.PSTRING (%a)" print_pat s +| "LEFTQMARK", None -> fprintf fmt "Tok.PLEFTQMARK" +| "BULLET", s -> fprintf fmt "Tok.PBULLET (%a)" print_pat s +| "QUOTATION", Some s -> fprintf fmt "Tok.PQUOTATION %a" print_string s +| "EOI", None -> fprintf fmt "Tok.PEOI" | _ -> failwith "Tok.of_pattern: not a constructor" let rec print_prod fmt p = @@ -231,16 +241,16 @@ let rec print_prod fmt p = and print_extrule fmt (tkn, vars, body) = let tkn = List.rev tkn in - fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" print_symbols tkn print_fun (vars, body) + fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" (print_symbols ~norec:false) tkn print_fun (vars, body) -and print_symbols fmt = function +and print_symbols ~norec fmt = function | [] -> fprintf fmt "Extend.Stop" | tkn :: tkns -> - fprintf fmt "Extend.Next @[(%a,@ %a)@]" print_symbols tkns print_symbol tkn + let c = if norec then "Extend.NextNoRec" else "Extend.Next" in + fprintf fmt "%s @[(%a,@ %a)@]" c (print_symbols ~norec) tkns print_symbol tkn and print_symbol fmt tkn = match tkn with | SymbToken (t, s) -> - let s = match s with None -> "" | Some s -> s in fprintf fmt "(Extend.Atoken (%a))" print_tok (t, s) | SymbEntry (e, None) -> fprintf fmt "(Extend.Aentry %s)" e @@ -264,7 +274,7 @@ and print_symbol fmt tkn = match tkn with let pr fmt (r, body) = let (vars, tkn) = List.split r in let tkn = List.rev tkn in - fprintf fmt "Extend.Rules @[({ Extend.norec_rule = %a },@ (%a))@]" print_symbols tkn print_fun (vars, body) + fprintf fmt "Extend.Rules @[(%a,@ (%a))@]" (print_symbols ~norec:true) tkn print_fun (vars, body) in let pr fmt rules = print_list fmt pr rules in fprintf fmt "(Extend.Arules %a)" pr (List.rev rules) @@ -347,9 +357,18 @@ let print_atts_right fmt = function let nota = match atts with [_] -> "" | _ -> "Attributes.Notations." in fprintf fmt "(Attributes.parse %s%a atts)" nota aux atts +let print_body_wrapper fmt r = + match r.vernac_state with + | Some "proof" -> + fprintf fmt "let proof = (%a) ~pstate:st.Vernacstate.proof in { st with Vernacstate.proof }" print_code r.vernac_body + | None -> + fprintf fmt "let () = %a in st" print_code r.vernac_body + | Some x -> + fatal ("unsupported state specifier: " ^ x) + let print_body_fun fmt r = - fprintf fmt "let coqpp_body %a%a ~st = let () = %a in st in " - print_binders r.vernac_toks print_atts_left r.vernac_atts print_code r.vernac_body + fprintf fmt "let coqpp_body %a%a ~st = @[%a@] in " + print_binders r.vernac_toks print_atts_left r.vernac_atts print_body_wrapper r let print_body fmt r = fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" @@ -445,7 +464,10 @@ end = struct let terminal s = - let c = Printf.sprintf "Extend.Atoken (CLexer.terminal \"%s\")" s in + let p = + if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_numeral" + else "CLexer.terminal" in + let c = Printf.sprintf "Extend.Atoken (%s \"%s\")" p s in SymbQuote c let rec parse_symb self = function diff --git a/coqpp/coqpp_parse.mly b/coqpp/coqpp_parse.mly index abe52ab46b..43ba990f6a 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -65,7 +65,7 @@ let parse_user_entry s sep = %token VERNAC TACTIC GRAMMAR EXTEND END DECLARE PLUGIN DEPRECATED ARGUMENT %token RAW_PRINTED GLOB_PRINTED %token COMMAND CLASSIFIED PRINTED TYPED INTERPRETED GLOBALIZED SUBSTITUTED BY AS -%token HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR +%token BANGBRACKET HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR %token LPAREN RPAREN COLON SEMICOLON %token GLOBAL FIRST LAST BEFORE AFTER LEVEL LEFTA RIGHTA NONA %token EOF @@ -209,13 +209,14 @@ vernac_rules: ; vernac_rule: -| PIPE vernac_attributes_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE +| PIPE vernac_attributes_opt vernac_state_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE { { vernac_atts = $2; - vernac_toks = $4; - vernac_depr = $6; - vernac_class= $7; - vernac_body = $9; + vernac_state= $3; + vernac_toks = $5; + vernac_depr = $7; + vernac_class= $8; + vernac_body = $10; } } ; @@ -235,6 +236,14 @@ vernac_attribute: | qualid_or_ident { ($1, $1) } ; +vernac_state_opt: +| { None } +| BANGBRACKET vernac_state RBRACKET { Some $2 } +; + +vernac_state: +| qualid_or_ident { $1 } + rule_deprecation: | { false } | DEPRECATED { true } diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index c450e8157a..3a096fec06 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -4,7 +4,6 @@ set -e # Configuration setup -OUTDIR=$PWD/_install DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app @@ -13,7 +12,7 @@ APP=bin/CoqIDE_${VERSION}.app make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" # Add Coq to the .app file -make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources/" install-coq install-ide-toploop +make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop # Create the dmg bundle mkdir -p "$DMGDIR" diff --git a/dev/ci/ci-argosy.sh b/dev/ci/ci-argosy.sh new file mode 100755 index 0000000000..6137526bf4 --- /dev/null +++ b/dev/ci/ci-argosy.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +FORCE_GIT=1 +git_download argosy + +( cd "${CI_BUILD_DIR}/argosy" && git submodule update --init --recursive && make ) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index deeec3942d..0c89809ee9 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -24,9 +24,9 @@ ######################################################################## # UniMath ######################################################################## -: "${UniMath_CI_REF:=master}" -: "${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath}" -: "${UniMath_CI_ARCHIVEURL:=${UniMath_CI_GITURL}/archive}" +: "${unimath_CI_REF:=master}" +: "${unimath_CI_GITURL:=https://github.com/UniMath/UniMath}" +: "${unimath_CI_ARCHIVEURL:=${unimath_CI_GITURL}/archive}" ######################################################################## # Unicoq + Mtac2 @@ -104,15 +104,8 @@ ######################################################################## # Coquelicot ######################################################################## -# The URL for downloading a tgz snapshot of the master branch is -# https://scm.gforge.inria.fr/anonscm/gitweb?p=coquelicot/coquelicot.git;a=snapshot;h=refs/heads/master;sf=tgz -# See https://gforge.inria.fr/scm/browser.php?group_id=3599 -# Since this URL doesn't fit to our standard mechanism and since Coquelicot doesn't seem to change frequently, -# we use a fixed version, which has a download path which does fit to our standard mechanism. -# ATTENTION: The archive URL might depend on the version! -: "${Coquelicot_CI_REF:=coquelicot-3.0.2}" -: "${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" -: "${Coquelicot_CI_ARCHIVEURL:=https://gforge.inria.fr/frs/download.php/file/37523}" +: "${coquelicot_CI_REF:=master}" +: "${coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" ######################################################################## # CompCert @@ -296,3 +289,10 @@ : "${stdlib2_CI_REF:=master}" : "${stdlib2_CI_GITURL:=https://github.com/coq/stdlib2}" : "${stdlib2_CI_ARCHIVEURL:=${stdlib2_CI_GITURL}/archive}" + +######################################################################## +# argosy +######################################################################## +: "${argosy_CI_REF:=master}" +: "${argosy_CI_GITURL:=https://github.com/mit-pdos/argosy}" +: "${argosy_CI_ARCHIVEURL:=${argosy_CI_GITURL}/archive}" diff --git a/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 2d242d80a4..2ac78d3c2b 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make | iconv -t UTF-8 -c `#9767` ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index b4d2a9ca4e..7aa265cf90 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -108,10 +108,9 @@ install_ssreflect() git_download mathcomp - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && \ - make Makefile.coq && \ - make -f Makefile.coq ssreflect/all_ssreflect.vo && \ - make -f Makefile.coq install ) + ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp/ssreflect" && \ + make && \ + make install ) } @@ -123,8 +122,11 @@ install_ssralg() git_download mathcomp ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && \ - make Makefile.coq && \ - make -f Makefile.coq algebra/all_algebra.vo && \ - make -f Makefile.coq install ) + make -C ssreflect && \ + make -C ssreflect install && \ + make -C fingroup && \ + make -C fingroup install && \ + make -C algebra && \ + make -C algebra install ) } diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 5d8817491d..33627fd8ef 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -6,6 +6,6 @@ ci_dir="$(dirname "$0")" install_ssreflect FORCE_GIT=1 -git_download Coquelicot +git_download coquelicot -( cd "${CI_BUILD_DIR}/Coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) +( cd "${CI_BUILD_DIR}/coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index a7644fee23..704e278a4b 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download UniMath +git_download unimath -( cd "${CI_BUILD_DIR}/UniMath" && make BUILD_COQ=no ) +( cd "${CI_BUILD_DIR}/unimath" && make BUILD_COQ=no ) diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 5f819f31f9..cc1931d13d 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -49,9 +49,9 @@ IF "%WINDOWS%" == "enabled_all_addons" ( -addon=compcert ^
-addon=extlib ^
-addon=quickchick ^
- -addon=coquelicot ^
-addon=vst ^
-addon=aactactics
+REM -addon=coquelicot ^
) ELSE (
SET "EXTRA_ADDONS= "
)
diff --git a/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh b/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh new file mode 100644 index 0000000000..67f6f8610a --- /dev/null +++ b/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "8764" ] || [ "$CI_BRANCH" = "master-parsing-decimal" ]; then + + ltac2_CI_REF=master-parsing-decimal + ltac2_CI_GITURL=https://github.com/proux01/ltac2 + + quickchick_CI_REF=master-parsing-decimal + quickchick_CI_GITURL=https://github.com/proux01/QuickChick + + Corn_CI_REF=master-parsing-decimal + Corn_CI_GITURL=https://github.com/proux01/corn + + HoTT_CI_REF=master-parsing-decimal + HoTT_CI_GITURL=https://github.com/proux01/HoTT + + stdlib2_CI_REF=master-parsing-decimal + stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 + +fi diff --git a/dev/ci/user-overlays/08829-proj-syntax-check.sh b/dev/ci/user-overlays/08829-proj-syntax-check.sh new file mode 100644 index 0000000000..c04621114f --- /dev/null +++ b/dev/ci/user-overlays/08829-proj-syntax-check.sh @@ -0,0 +1,5 @@ +if [ "$CI_PULL_REQUEST" = "8829" ] || [ "$CI_BRANCH" = "proj-syntax-check" ]; then + lambdaRust_CI_REF=proj-syntax-check + lambdaRust_CI_GITURL=https://github.com/SkySkimmer/lambda-rust + lambdaRust_CI_ARCHIVEURL=$lambdaRust_CI_GITURL/archive +fi diff --git a/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh b/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh new file mode 100644 index 0000000000..12be1b676a --- /dev/null +++ b/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "8984" ] || [ "$CI_BRANCH" = "rm-hardwired-hint-db" ]; then + + HoTT_CI_REF=rm-hardwired-hint-db + HoTT_CI_GITURL=https://github.com/vbgl/HoTT + + ltac2_CI_REF=rm-hardwired-hint-db + ltac2_CI_GITURL=https://github.com/vbgl/ltac2 + + UniMath_CI_REF=rm-hardwired-hint-db + UniMath_CI_GITURL=https://github.com/vbgl/UniMath + +fi diff --git a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh new file mode 100644 index 0000000000..c09d1b8929 --- /dev/null +++ b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh @@ -0,0 +1,30 @@ +if [ "$CI_PULL_REQUEST" = "9129" ] || [ "$CI_BRANCH" = "proof+no_global_partial" ]; then + + aac_tactics_CI_REF=proof+no_global_partial + aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics + + # coqhammer_CI_REF=proof+no_global_partial + # coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer + + elpi_CI_REF=proof+no_global_partial + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + equations_CI_REF=proof+no_global_partial + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + ltac2_CI_REF=proof+no_global_partial + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + # unicoq_CI_REF=proof+no_global_partial + # unicoq_CI_GITURL=https://github.com/ejgallego/unicoq + + mtac2_CI_REF=proof+no_global_partial + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + + paramcoq_CI_REF=proof+no_global_partial + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + quickchick_CI_REF=proof+no_global_partial + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh new file mode 100644 index 0000000000..1e1d36d54a --- /dev/null +++ b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9165" ] || [ "$CI_BRANCH" = "recarg-cleanup" ]; then + + elpi_CI_REF=recarg-cleanup + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + quickchick_CI_REF=recarg-cleanup + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/09733-gares-quotations.sh b/dev/ci/user-overlays/09733-gares-quotations.sh new file mode 100644 index 0000000000..b17454fc4c --- /dev/null +++ b/dev/ci/user-overlays/09733-gares-quotations.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9733" ] || [ "$CI_BRANCH" = "quotations" ]; then + + ltac2_CI_REF=quotations + ltac2_CI_GITURL=https://github.com/gares/ltac2 + +fi diff --git a/dev/ci/user-overlays/09815-token-type.sh b/dev/ci/user-overlays/09815-token-type.sh new file mode 100644 index 0000000000..4b49011de3 --- /dev/null +++ b/dev/ci/user-overlays/09815-token-type.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "9815" ] || [ "$CI_BRANCH" = "token-type" ]; then + ltac2_CI_REF=token-type + ltac2_CI_GITURL=https://github.com/proux01/ltac2 +fi diff --git a/dev/ci/user-overlays/09870-vbgl-recordops.sh b/dev/ci/user-overlays/09870-vbgl-recordops.sh new file mode 100644 index 0000000000..bb14a8c204 --- /dev/null +++ b/dev/ci/user-overlays/09870-vbgl-recordops.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9870" ] || [ "$CI_BRANCH" = "doc-canonical" ]; then + + elpi_CI_REF=pr-9870 + elpi_CI_GITURL=https://github.com/vbgl/coq-elpi + +fi diff --git a/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh b/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh new file mode 100644 index 0000000000..01d3068591 --- /dev/null +++ b/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh @@ -0,0 +1,21 @@ +if [ "$CI_PULL_REQUEST" = "9909" ] || [ "$CI_BRANCH" = "pretyping-rm-global" ]; then + + elpi_CI_REF=pretyping-rm-global + elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi + + coqhammer_CI_REF=pretyping-rm-global + coqhammer_CI_GITURL=https://github.com/maximedenes/coqhammer + + equations_CI_REF=pretyping-rm-global + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + + ltac2_CI_REF=pretyping-rm-global + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + paramcoq_CI_REF=pretyping-rm-global + paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq + + mtac2_CI_REF=pretyping-rm-global + mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 + +fi diff --git a/dev/doc/archive/COMPATIBILITY b/dev/doc/archive/COMPATIBILITY index a81afca32d..35a7f608de 100644 --- a/dev/doc/archive/COMPATIBILITY +++ b/dev/doc/archive/COMPATIBILITY @@ -1,192 +1,6 @@ Note: this file isn't used anymore. Incompatibilities are documented as part of CHANGES. -Potential sources of incompatibilities between Coq V8.6 and V8.7 ----------------------------------------------------------------- - -- Extra superfluous names in introduction patterns may now raise an - error rather than a warning when the superfluous name is already in - use. The easy fix is to remove the superfluous name. - -Potential sources of incompatibilities between Coq V8.5 and V8.6 ----------------------------------------------------------------- - -Symptom: An obligation generated by Program or an abstracted subproof -has different arguments. -Cause: Set Shrink Abstract and Set Shrink Obligations are on by default -and the subproof does not use the argument. -Remedy: -- Adapt the script. -- Write an explicit lemma to prove the obligation/subproof and use it - instead (compatible with 8.4). -- Unset the option for the program/proof the obligation/subproof originates - from. - -Symptom: In a goal, order of hypotheses, or absence of an equality of -the form "x = t" or "t = x", or no unfolding of a local definition. -Cause: This might be connected to a number of fixes in the tactic -"subst". The former behavior can be reactivated by issuing "Unset -Regular Subst Tactic". - -Potential sources of incompatibilities between Coq V8.4 and V8.5 ----------------------------------------------------------------- - -* List of typical changes to be done to adapt files from Coq 8.4 * -* to Coq 8.5 when not using compatibility option "-compat 8.4". * - -Symptom: "The reference omega was not found in the current environment". -Cause: "Require Omega" does not import the tactic "omega" any more -Possible solutions: -- use "Require Import OmegaTactic" (not compatible with 8.4) -- use "Require Import Omega" (compatible with 8.4) -- add definition "Ltac omega := Coq.omega.Omega.omega." - -Symptom: "intuition" cannot solve a goal (not working anymore on non standard connective) -Cause: "intuition" had an accidental non uniform behavior fixed on non standard connectives -Possible solutions: -- use "dintuition" instead; it is stronger than "intuition" and works - uniformly on non standard connectives, such as n-ary conjunctions or disjunctions - (not compatible with 8.4) -- do the script differently - -Symptom: The constructor foo (in type bar) expects n arguments. -Cause: parameters must now be given in patterns -Possible solutions: -- use option "Set Asymmetric Patterns" (compatible with 8.4) -- add "_" for the parameters (not compatible with 8.4) -- turn the parameters into implicit arguments (compatible with 8.4) - -Symptom: "NPeano.Nat.foo" not existing anymore -Possible solutions: -- use "Nat.foo" instead - -Symptom: typing problems with proj1_sig or similar -Cause: coercion from sig to sigT and similar coercions have been - removed so as to make the initial state easier to understand for - beginners -Solution: change proj1_sig into projT1 and similarly (compatible with 8.4) - -* Other detailed changes * - -(see also file CHANGES) - -- options for *coq* compilation (see below for ocaml). - -** [-I foo] is now deprecated and will not add directory foo to the - coq load path (only for ocaml, see below). Just replace [-I foo] by - [-Q foo ""] in your project file and re-generate makefile. Or - perform the same operation directly in your makefile if you edit it - by hand. - -** Option -R Foo bar is the same in v8.5 than in v8.4 concerning coq - load path. - -** Option [-I foo -as bar] is unchanged but discouraged unless you - compile ocaml code. Use -Q foo bar instead. - - for more details: file CHANGES or section "Customization at launch - time" of the reference manual. - -- Command line options for ocaml Compilation of ocaml code (plugins) - -** [-I foo] is *not* deprecated to add foo to the ocaml load path. - -** [-I foo -as bar] adds foo to the ocaml load path *and* adds foo to - the coq load path with logical name bar (shortcut for -I foo -Q foo - bar). - - for more details: file CHANGES or section "Customization at launch - time" of the reference manual. - -- Universe Polymorphism. - -- Refinement, unification and tactics are now aware of universes, - resulting in more localized errors. Universe inconsistencies - should no more get raised at Qed time but during the proof. - Unification *always* produces well-typed substitutions, hence - some rare cases of unifications that succeeded while producing - ill-typed terms before will now fail. - -- The [change p with c] tactic semantics changed, now typechecking - [c] at each matching occurrence [t] of the pattern [p], and - converting [t] with [c]. - -- Template polymorphic inductive types: the partial application - of a template polymorphic type (e.g. list) is not polymorphic. - An explicit parameter application (e.g [fun A => list A]) or - [apply (list _)] will result in a polymorphic instance. - -- The type inference algorithm now takes opacity of constants into - account. This may have effects on tactics using type inference - (e.g. induction). Extra "Transparent" might have to be added to - revert opacity of constants. - -Type classes. - -- When writing an Instance foo : Class A := {| proj := t |} (note the - vertical bars), support for typechecking the projections using the - type information and switching to proof mode is no longer available. - Use { } (without the vertical bars) instead. - -Tactic abstract. - -- Auxiliary lemmas generated by the abstract tactic are removed from - the global environment and inlined in the proof term when a proof - is ended with Qed. The behavior of 8.4 can be obtained by ending - proofs with "Qed exporting" or "Qed exporting ident, .., ident". - -Potential sources of incompatibilities between Coq V8.3 and V8.4 ----------------------------------------------------------------- - -(see also file CHANGES) - -The main known incompatibilities between 8.3 and 8.4 are consequences -of the following changes: - -- The reorganization of the library of numbers: - - Several definitions have new names or are defined in modules of - different names, but a special care has been taken to have this - renaming transparent for the user thanks to compatibility notations. - - However some definitions have changed, what might require some - adaptations. The most noticeable examples are: - - The "?=" notation which now bind to Pos.compare rather than former - Pcompare (now Pos.compare_cont). - - Changes in names may induce different automatically generated - names in proof scripts (e.g. when issuing "destruct Z_le_gt_dec"). - - Z.add has a new definition, hence, applying "simpl" on subterms of - its body might give different results than before. - - BigN.shiftl and BigN.shiftr have reversed arguments order, the - power function in BigN now takes two BigN. - -- Other changes in libraries: - - - The definition of functions over "vectors" (list of fixed length) - have changed. - - TheoryList.v has been removed. - -- Slight changes in tactics: - - - Less unfolding of fixpoints when applying destruct or inversion on - a fixpoint hiding an inductive type (add an extra call to simpl to - preserve compatibility). - - Less unexpected local definitions when applying "destruct" - (incompatibilities solvable by adapting name hypotheses). - - Tactic "apply" might succeed more often, e.g. by now solving - pattern-matching of the form ?f x y = g(x,y) (compatibility - ensured by using "Unset Tactic Pattern Unification"), but also - because it supports (full) betaiota (using "simple apply" might - then help). - - Tactic autorewrite does no longer instantiate pre-existing - existential variables. - - Tactic "info" is now available only for auto, eauto and trivial. - -- Miscellaneous changes: - - - The command "Load" is now atomic for backtracking (use "Unset - Atomic Load" for compatibility). - Incompatibilities beyond 8.4... diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index b1bfac8cc9..49251d61a1 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -22,7 +22,7 @@ If you want to build the standard libraries and plugins you should call `make -f Makefile.dune voboot`. It is usually enough to do that once per-session. -More helper targets are availabe in `Makefile.dune`, `make -f +More helper targets are available in `Makefile.dune`, `make -f Makefile.dune` will display some help. Dune places build artifacts in a separate directory `_build`; it will diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 416253fad1..40c3c32e4f 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -83,6 +83,11 @@ Libobject * `Libobject.superglobal_object` * `Libobject.superglobal_object_nodischarge` +AST + +- Minor changes in the AST have been performed, for example + https://github.com/coq/coq/pull/9165 + Implicit Arguments - `Impargs.declare_manual_implicits` is restricted to only support declaration diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 8d78559c0d..f532e1b68f 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -63,8 +63,8 @@ Typing constructions impacted coqchk versions: ? fixed in: master/trunk (679801, r13450, 23 Sep 2010, Glondu), v8.3 (309a53f2, r13449, 22 Sep 2010, Glondu), v8.2 (41ea5f08, r14263, 6 Jul 2011, Herbelin, backport) found by: Georgi Guninski - exploit: test-suite/bugs/closed/4294.v - GH issue number: #4294 + exploit: test-suite/failure/prop_set_proof_irrelevance.v + GH issue number: none? risk: ? Module system @@ -77,7 +77,7 @@ Module system impacted coqchk versions: ? fixed in: master/trunk (d4869e059, 2 Oct 2015, Sozeau), v8.4 (40350ef3b, 9 Sep 2015, Sozeau) found by: Dénès - exploit: test-suite/bugs/closed/4294.v + exploit: test-suite/bugs/closed/bug_4294.v GH issue number: #4294 risk: ? @@ -105,7 +105,7 @@ Universes impacted coqchk versions: ? fixed in: trunk/master/v8.4 (8082d1faf, 5 Oct 2011, Herbelin), V8.3pl3 (bb582bca2, 5 Oct 2011, Herbelin), v8.2 branch (3333e8d3, 5 Oct 2011, Herbelin), v8.1 branch (a8fc2027, 5 Oct 2011, Herbelin), found by: Barras - exploit: test-suite/failure/inductive4.v + exploit: test-suite/failure/inductive.v GH issue number: none risk: unlikely to be activated by chance @@ -141,7 +141,7 @@ Primitive projections impacted coqchk versions: ? fixed in: trunk/master/v8.5 (120053a50, 4 Mar 2016, Dénès) found by: Dénès exploiting bug #4588 - exploit: test-suite/bugs/closed/4588.v + exploit: test-suite/bugs/closed/bug_4588.v GH issue number: #4588 risk: ? @@ -167,7 +167,7 @@ Conversion machines impacted coqchk versions: none (no virtual machine in coqchk) fixed in: master/trunk/v8.5 (00894adf6/596a4a525, 26-39 Mar 2015, Grégoire), v8.4 (cd2101a39, 1 Apr 2015, Grégoire), v8.3 (a0c7fc05b, 1 Apr 2015, Grégoire), v8.2 (2c6189f61, 1 Apr 2015, Grégoire), v8.1 (bb877e5b5, 29 Nov 2015, Herbelin, backport) found by: Dénès, Pédrot - exploit: test-suite/failure/vm-bug4157.v + exploit: test-suite/bugs/closed/bug_4157.v GH issue number: #4157 risk: @@ -179,7 +179,7 @@ Conversion machines impacted coqchk versions: none (no virtual machine in coqchk) fixed in: master (c9f3a6cbe, 12 Feb 2018, PR#6713, Dénès), v8.7 (c058a4182, 15 Feb 2018, Zimmermann, backport), v8.6 (a2cc54c64, 21 Feb 2018, Herbelin, backport), v8.5 (d4d550d0f, 21 Feb 2018, Herbelin, backport) found by: Dénès - exploit: test-suite/bugs/closed/6677.v + exploit: test-suite/bugs/closed/bug_6677.v GH issue number: #6677 risk: @@ -203,10 +203,19 @@ Conversion machines impacted coqchk versions: none (no native computation in coqchk) fixed in: master/trunk/v8.6 (244d7a9aa, 19 May 2016, letouzey), v8.5 (088b3161c, 19 May 2016, letouzey), found by: Letouzey, Dénès - exploit: lost? + exploit: see commit message for 244d7a9aa GH issue number: ? risk: + component: primitive projections, native_compute + summary: stuck primitive projections computed incorrectly by native_compute + introduced: 1 Jun 2018, e1e7888a, ppedrot + impacted released versions: 8.9.0 + impacted coqchk versions: none + found by: maximedenes exploiting bug #9684 + exploit: test-suite/bugs/closed/bug_9684.v + GH issue number: #9684 + Conflicts with axioms in library component: library of real numbers diff --git a/dev/incdir_dune b/dev/incdir_dune index 9d0fee1fa2..9ba31167b9 100644 --- a/dev/incdir_dune +++ b/dev/incdir_dune @@ -1,16 +1,17 @@ #cd".";; -#directory "_build/default/lib/.lib.objs/";; -#directory "_build/default/clib/.clib.objs/";; -#directory "_build/default/kernel/.kernel.objs/";; -#directory "_build/default/library/.library.objs/";; -#directory "_build/default/engine/.engine.objs/";; -#directory "_build/default/pretyping/.pretyping.objs/";; -#directory "_build/default/interp/.interp.objs/";; -#directory "_build/default/parsing/.parsing.objs/";; -#directory "_build/default/gramlib/.gramlib.objs/";; -#directory "_build/default/proofs/.proofs.objs/";; -#directory "_build/default/tactics/.tactics.objs/";; -#directory "_build/default/printing/.printing.objs/";; -#directory "_build/default/vernac/.vernac.objs/";; -#directory "_build/default/stm/.stm.objs/";; -#directory "_build/default/toplevel/.toplevel.objs/";; +#directory "_build/default/lib/.lib.objs/byte/";; +#directory "_build/default/clib/.clib.objs/byte/";; +#directory "_build/default/kernel/.kernel.objs/byte/";; +#directory "_build/default/library/.library.objs/byte/";; +#directory "_build/default/engine/.engine.objs/byte/";; +#directory "_build/default/pretyping/.pretyping.objs/byte/";; +#directory "_build/default/interp/.interp.objs/byte/";; +#directory "_build/default/parsing/.parsing.objs/byte/";; +#directory "_build/default/gramlib/.gramlib.objs/byte/";; +#directory "_build/default/proofs/.proofs.objs/byte/";; +#directory "_build/default/tactics/.tactics.objs/byte/";; +#directory "_build/default/printing/.printing.objs/byte/";; +#directory "_build/default/vernac/.vernac.objs/byte/";; +#directory "_build/default/stm/.stm.objs/byte/";; +#directory "_build/default/toplevel/.toplevel.objs/byte/";; +#directory "_build/default/plugins/ltac/.ltac_plugin.objs/byte/";; diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 4aa0f04964..f4786d9431 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/2923bd5d0669f1ec6ab03ddce052e9c5efb46d8f.tar.gz"; - sha256 = "16cn93rpxfql5idhigyjyhc013a3hwzyy2dl1xv7h2p78sk728vw"; + url = "https://github.com/NixOS/nixpkgs/archive/8471ab76242987b11afd4486b82888e1588f8307.tar.gz"; + sha256 = "06pp6b6x78jlinxifnphkbp79dx58jr990fkm4qziq0ay5klpxd7"; }) diff --git a/dev/shim/dune b/dev/shim/dune index 39b4ef492c..e307848292 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -7,7 +7,19 @@ (with-outputs-to coqtop-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \\$@") + (run chmod +x %{targets}))))) + +(rule + (targets coqc-prelude) + (deps + %{bin:coqc} + %{project_root}/theories/Init/Prelude.vo) + (action + (with-outputs-to coqc-prelude + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqc} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) (rule @@ -20,7 +32,7 @@ (with-outputs-to %{targets} (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) (rule @@ -36,5 +48,5 @@ (with-outputs-to coqide-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 499bbba37e..74be300134 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -60,19 +60,25 @@ let prrecarg = function str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) +let get_current_context () = + try Vernacstate.Proof_global.get_current_context () + with Vernacstate.Proof_global.NoCurrentProof -> + let env = Global.env() in + Evd.from_env env, env + (* term printers *) -let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma +let envpp pp = let sigma,env = get_current_context () in pp env sigma let rawdebug = ref false let ppevar evk = pp (Evar.print evk) let pr_constr t = - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_context () in Printer.pr_constr_env env sigma t let pr_econstr t = - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_context () in Printer.pr_econstr_env env sigma t let ppconstr x = pp (pr_constr x) let ppeconstr x = pp (pr_econstr x) -let ppconstr_expr x = let sigma,env = Pfedit.get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) +let ppconstr_expr x = let sigma,env = get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) @@ -500,7 +506,7 @@ let ppist ist = (* Vernac-level debugging commands *) let in_current_context f c = - let (evmap,sign) = Pfedit.get_current_context () in + let (evmap,sign) = get_current_context () in f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp5 diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 4df284d2d9..1d0aca1caf 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -145,10 +145,12 @@ END it gives an error message that is basically impossible to understand. *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| [ "Cmd9" ] -> - { let p = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in - let pprf = Proof.partial_proof p in - Feedback.msg_notice - (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } +| ![ proof ] [ "Cmd9" ] -> + { fun ~pstate -> + Option.iter (fun (pstate : Proof_global.t) -> + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in + Feedback.msg_notice + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf)) pstate; + pstate } END diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index e370d37fc4..23f8fbe888 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,5 +1,5 @@ (* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) -let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = +let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let sigma = Evd.minimize_universes sigma in let body = EConstr.to_constr sigma body in let tyopt = Option.map (EConstr.to_constr sigma) tyopt in @@ -13,13 +13,13 @@ let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let ubinders = Evd.universe_binders sigma in let ce = Declare.definition_entry ?types:tyopt ~univs body in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ident k ce ubinders imps ?hook_data + DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data let packed_declare_definition ~poly ident value_with_constraints = let body, ctx = value_with_constraints in let sigma = Evd.from_ctx ctx in let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ident k ~opaque:false sigma udecl body None []) + ignore (edeclare ~ontop:None ident k ~opaque:false sigma udecl body None []) (* But this definition cannot be undone by Reset ident *) diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index a9d894cab5..dd21ea09bd 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -92,7 +92,7 @@ and use the ``==`` notation on terms of this type. Derived Canonical Structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We know how to use ``== `` on base types, like ``nat``, ``bool``, ``Z``. Here we show +We know how to use ``==`` on base types, like ``nat``, ``bool``, ``Z``. Here we show how to deal with type constructors, i.e. how to make the following example work: diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 795fccbf08..d5523e8561 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -154,8 +154,10 @@ Declaring Coercions .. warn:: Ambiguous path. When the coercion :token:`qualid` is added to the inheritance graph, - invalid coercion paths are ignored; they are signaled by a warning - displaying these paths of the form :g:`[fâ‚;..;fâ‚™] : C >-> D`. + invalid coercion paths are ignored. The :cmd:`Coercion` command tries to check + that they are convertible with existing ones on the same classes. + The paths for which this check fails are displayed by a warning in the form + :g:`[fâ‚;..;fâ‚™] : C >-> D`. .. cmdv:: Local Coercion @qualid : @class >-> @class diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 56f84d0ff0..b410833d25 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -194,14 +194,14 @@ Program Fixpoint The optional order annotation follows the grammar: .. productionlist:: orderannot - order : measure `term` (`term`)? | wf `term` `term` + order : measure `term` [ `term` ] | wf `term` `ident` - + :g:`measure f ( R )` where :g:`f` is a value of type :g:`X` computed on - any subset of the arguments and the optional (parenthesised) term - ``(R)`` is a relation on ``X``. By default ``X`` defaults to ``nat`` and ``R`` - to ``lt``. + + :g:`measure f R` where :g:`f` is a value of type :g:`X` computed on + any subset of the arguments and the optional term + :g:`R` is a relation on :g:`X`. :g:`X` defaults to :g:`nat` and :g:`R` + to :g:`lt`. - + :g:`wf R x` which is equivalent to :g:`measure x (R)`. + + :g:`wf R x` which is equivalent to :g:`measure x R`. The structural fixpoint operator behaves just like the one of |Coq| (see :cmd:`Fixpoint`), except it may also generate obligations. It works diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 20e4c6a3d6..3b350d5dc0 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -323,7 +323,7 @@ The syntax for adding a new ring is decidable :n:`@term` declares the ring as computational. The expression :n:`@term` is the correctness proof of an equality test ``?=!`` - (which hould be evaluable). Its type should be of the form + (which should be evaluable). Its type should be of the form ``forall x y, x ?=! y = true → x == y``. morphism :n:`@term` diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 015b84c530..c0c8c2d79c 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -19,6 +19,9 @@ known as strict propositions). To use :math:`\SProp` you must pass initial value depends on whether you used the command line ``-allow-sprop``. +.. exn:: SProp not allowed, you need to Set Allow StrictProp or to use the -allow-sprop command-line-flag. + :undocumented: + .. coqtop:: none Set Allow StrictProp. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index e6a5b3972c..b069cf27f4 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -561,6 +561,8 @@ Settings .. flag:: Refine Instance Mode + .. deprecated:: 8.10 + This flag allows to switch the behavior of instance declarations made through the Instance command. @@ -573,18 +575,19 @@ Settings Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? {dfs | bfs}} depth +.. cmd:: Typeclasses eauto := {? debug} {? (dfs) | (bfs) } @num :name: Typeclasses eauto This command allows more global customization of the typeclass resolution tactic. The semantics of the options are: - + ``debug`` In debug mode, the trace of successfully applied tactics is - printed. This value can also be set with :flag:`Typeclasses Debug`. + + ``debug`` This sets the debug mode. In debug mode, the trace of + successfully applied tactics is printed. The debug mode can also + be set with :flag:`Typeclasses Debug`. - + ``dfs, bfs`` This sets the search strategy to depth-first search (the - default) or breadth-first search. This value can also be set with - :flag:`Typeclasses Iterative Deepening`. + + ``(dfs)``, ``(bfs)`` This sets the search strategy to depth-first + search (the default) or breadth-first search. The search strategy + can also be set with :flag:`Typeclasses Iterative Deepening`. - + ``depth`` This sets the depth limit of the search. This value can also be set with - :opt:`Typeclasses Depth`. + + :token:`num` This sets the depth limit of the search. The depth + limit can also be set with :opt:`Typeclasses Depth`. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst new file mode 100644 index 0000000000..57b9e45342 --- /dev/null +++ b/doc/sphinx/changes.rst @@ -0,0 +1,4892 @@ +-------------- +Recent changes +-------------- + +Version 8.9 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +|Coq| version 8.9 contains the result of refinements and stabilization +of features and deprecations or removals of deprecated features, +cleanups of the internals of the system and API along with a few new +features. This release includes many user-visible changes, including +deprecations that are documented in ``CHANGES.md`` and new features that +are documented in the reference manual. Here are the most important +changes: + +- Kernel: mutually recursive records are now supported, by Pierre-Marie + Pédrot. + +- Notations: + + - Support for autonomous grammars of terms called “custom entriesâ€, by + Hugo Herbelin (see Section :ref:`custom-entries` of the reference + manual). + + - Deprecated notations of the standard library will be removed in the + next version of |Coq|, see the ``CHANGES.md`` file for a script to + ease porting, by Jason Gross and Jean-Christophe Léchenet. + + - Added the :cmd:`Numeral Notation` command for registering decimal + numeral notations for custom types, by Daniel de Rauglaudre, Pierre + Letouzey and Jason Gross. + +- Tactics: Introduction tactics :tacn:`intro`/:tacn:`intros` on a goal that is an + existential variable now force a refinement of the goal into a + dependent product rather than failing, by Hugo Herbelin. + +- Decision procedures: deprecation of tactic ``romega`` in favor of + :tacn:`lia` and removal of ``fourier``, replaced by :tacn:`lra` which + subsumes it, by Frédéric Besson, Maxime Dénès, Vincent Laporte and + Laurent Théry. + +- Proof language: focusing bracket ``{`` now supports named + :ref:`goals <curly-braces>`, e.g. ``[x]:{`` will focus + on a goal (existential variable) named ``x``, by Théo Zimmermann. + +- SSReflect: the implementation of delayed clear was simplified by + Enrico Tassi: the variables are always renamed using inaccessible + names when the clear switch is processed and finally cleared at the + end of the intro pattern. In addition to that, the use-and-discard flag + ``{}`` typical of rewrite rules can now be also applied to views, + e.g. ``=> {}/v`` applies ``v`` and then clears ``v``. See Section + :ref:`introduction_ssr`. + +- Vernacular: + + - Experimental support for :ref:`attributes <gallina-attributes>` on + commands, by Vincent Laporte, as in ``#[local] Lemma foo : bar.`` + Tactics and tactic notations now support the ``deprecated`` + attribute. + + - Removed deprecated commands ``Arguments Scope`` and ``Implicit + Arguments`` in favor of :cmd:`Arguments`, with the help of Jasper + Hugunin. + + - New flag :flag:`Uniform Inductive Parameters` by Jasper Hugunin to + avoid repeating uniform parameters in constructor declarations. + + - New commands :cmd:`Hint Variables` and :cmd:`Hint Constants`, by + Matthieu Sozeau, for controlling the opacity status of variables and + constants in hint databases. It is recommended to always use these + commands after creating a hint databse with :cmd:`Create HintDb`. + + - Multiple sections with the same name are now allowed, by Jasper + Hugunin. + +- Library: additions and changes in the ``VectorDef``, ``Ascii``, and + ``String`` libraries. Syntax notations are now available only when using + ``Import`` of libraries and not merely ``Require``, by various + contributors (source of incompatibility, see ``CHANGES.md`` for details). + +- Toplevels: ``coqtop`` and ``coqide`` can now display diffs between proof + steps in color, using the :opt:`Diffs` option, by Jim Fehrle. + +- Documentation: we integrated a large number of fixes to the new Sphinx + documentation by various contributors, coordinated by Clément + Pit-Claudel and Théo Zimmermann. + +- Tools: removed the ``gallina`` utility and the homebrewed ``Emacs`` mode. + +- Packaging: as in |Coq| 8.8.2, the Windows installer now includes many + more external packages that can be individually selected for + installation, by Michael Soegtrop. + +Version 8.9 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system. Most +important ones are documented in the ``CHANGES.md`` file. + +On the implementation side, the ``dev/doc/changes.md`` file documents +the numerous changes to the implementation and improvements of +interfaces. The file provides guidelines on porting a plugin to the new +version and a plugin development tutorial kept in sync with Coq was +introduced by Yves Bertot http://github.com/ybertot/plugin_tutorials. +The new ``dev/doc/critical-bugs`` file documents the known critical bugs +of |Coq| and affected releases. + +The efficiency of the whole system has seen improvements thanks to +contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop, Théo Zimmermann worked on maintaining and improving the +continuous integration system. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many +users. A list of packages is available at https://coq.inria.fr/opam/www/. + +The 54 contributors for this version are Léo Andrès, Rin Arakaki, +Benjamin Barenblat, Langston Barrett, Siddharth Bhat, Martin Bodin, +Simon Boulier, Timothy Bourke, Joachim Breitner, Tej Chajed, Arthur +Charguéraud, Pierre Courtieu, Maxime Dénès, Andres Erbsen, Jim Fehrle, +Julien Forest, Emilio Jesus Gallego Arias, Gaëtan Gilbert, MatÄ›j +Grabovský, Jason Gross, Samuel Gruetter, Armaël Guéneau, Hugo Herbelin, +Jasper Hugunin, Ralf Jung, Sam Pablo Kuper, Ambroise Lafont, Leonidas +Lampropoulos, Vincent Laporte, Peter LeFanu Lumsdaine, Pierre Letouzey, +Jean-Christophe Léchenet, Nick Lewycky, Yishuai Li, Sven M. Hallberg, +Assia Mahboubi, Cyprien Mangin, Guillaume Melquiond, Perry E. Metzger, +Clément Pit-Claudel, Pierre-Marie Pédrot, Daniel R. Grayson, Kazuhiko +Sakaguchi, Michael Soegtrop, Matthieu Sozeau, Paul Steckler, Enrico +Tassi, Laurent Théry, Anton Trunov, whitequark, Théo Winterhalter, +Zeimer, Beta Ziliani, Théo Zimmermann. + +Many power users helped to improve the design of the new features via +the issue and pull request system, the |Coq| development mailing list or +the coq-club@inria.fr mailing list. It would be impossible to mention +exhaustively the names of everybody who to some extent influenced the +development. + +Version 8.9 is the fourth release of |Coq| developed on a time-based +development cycle. Its development spanned 7 months from the release of +|Coq| 8.8. The development moved to a decentralized merging process +during this cycle. Guillaume Melquiond was in charge of the release +process and is the maintainer of this release. This release is the +result of ~2,000 commits and ~500 PRs merged, closing 75+ issues. + +The |Coq| development team welcomed Vincent Laporte, a new |Coq| +engineer working with Maxime Dénès in the |Coq| consortium. + +| Paris, November 2018, +| Matthieu Sozeau for the |Coq| development team +| + +Details of changes +~~~~~~~~~~~~~~~~~~ + +Kernel + +- Mutually defined records are now supported. + +Notations + +- New support for autonomous grammars of terms, called "custom + entries" (see chapter "Syntax extensions" of the reference manual). + +- Deprecated compatibility notations will actually be removed in the + next version of Coq. Uses of these notations are generally easy to + fix thanks to the hint contained in the deprecation warnings. For + projects that require more than a handful of such fixes, there is [a + script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) + that will do it automatically, using the output of coqc. The script + contains documentation on its usage in a comment at the top. + +- When several notations are available for the same expression, + priority is given to latest notations defined in the scopes being + opened, in order, rather than to the latest notations defined + independently of whether they are in an opened scope or not. + +Tactics + +- Added toplevel goal selector `!` which expects a single focused goal. + Use with `Set Default Goal Selector` to force focusing before tactics + are called. + +- The undocumented "nameless" forms `fix N`, `cofix` that were + deprecated in 8.8 have been removed from Ltac's syntax; please use + `fix ident N/cofix ident` to explicitly name the (co)fixpoint + hypothesis to be introduced. + +- Introduction tactics `intro`/`intros` on a goal that is an + existential variable now force a refinement of the goal into a + dependent product rather than failing. + +- Support for `fix`/`cofix` added in Ltac `match` and `lazymatch`. + +- Ltac backtraces now include trace information about tactics + called by OCaml-defined tactics. + +- Option `Ltac Debug` now applies also to terms built using Ltac functions. + +- Deprecated the `Implicit Tactic` family of commands. + +- The default program obligation tactic uses a bounded proof search + instead of an unbounded and potentially non-terminating one now + (source of incompatibility). + +- The `simple apply` tactic now respects the `Opaque` flag when called from + Ltac (`auto` still does not respect it). + +- Tactic `constr_eq` now adds universe constraints needed for the + identity to the context (it used to ignore them). New tactic + `constr_eq_strict` checks that the required constraints already hold + without adding new ones. Preexisting tactic `constr_eq_nounivs` can + still be used if you really want to ignore universe constraints. + +- Tactics and tactic notations now understand the `deprecated` attribute. +- The `fourier` tactic has been removed. Please now use `lra` instead. You + may need to add `Require Import Lra` to your developments. For compatibility, + we now define `fourier` as a deprecated alias of `lra`. + +- The `romega` tactics have been deprecated; please use `lia` instead. + +Focusing + +- Focusing bracket `{` now supports named goal selectors, + e.g. `[x]: {` will focus on a goal (existential variable) named `x`. + As usual, unfocus with `}` once the sub-goal is fully solved. + +Specification language + +- A fix to unification (which was sensitive to the ascii name of + variables) may occasionally change type inference in incompatible + ways, especially regarding the inference of the return clause of `match`. + +Standard Library + +- Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, + and proved some lemmas about them. Note that this might cause + incompatibilities if you have, e.g., `string_scope` and `Z_scope` both + open with `string_scope` on top, and expect `=?` to refer to `Z.eqb`. + Solution: wrap `_ =? _` in `(_ =? _)%Z` (or whichever scope you + want). + +- Added `Ndigits.N2Bv_sized`, and proved some lemmas about it. + Deprecated `Ndigits.N2Bv_gen`. + +- The scopes `int_scope` and `uint_scope` have been renamed to + `dec_int_scope` and `dec_uint_scope`, to clash less with ssreflect + and other packages. They are still delimited by `%int` and `%uint`. + +- Syntax notations for `string`, `ascii`, `Z`, `positive`, `N`, `R`, + and `int31` are no longer available merely by `Require`ing the files + that define the inductives. You must `Import` `Coq.Strings.String.StringSyntax` + (after `Require` `Coq.Strings.String`), `Coq.Strings.Ascii.AsciiSyntax` (after + `Require` `Coq.Strings.Ascii`), `Coq.ZArith.BinIntDef`, `Coq.PArith.BinPosDef`, + `Coq.NArith.BinNatDef`, `Coq.Reals.Rdefinitions`, and + `Coq.Numbers.Cyclic.Int31.Int31`, respectively, to be able to use + these notations. Note that passing `-compat 8.8` or issuing + `Require Import Coq.Compat.Coq88` will make these notations + available. Users wishing to port their developments automatically + may download `fix.py` from + <https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169> + and run a command like `while true; do make -Okj 2>&1 | + /path/to/fix.py; done` and get a cup of coffee. (This command must + be manually interrupted once the build finishes all the way though. + Note also that this method is not fail-proof; you may have to adjust + some scopes if you were relying on string notations not being + available even when `string_scope` was open.) + +- Numeral syntax for `nat` is no longer available without loading the + entire prelude (`Require Import Coq.Init.Prelude`). This only + impacts users running Coq without the init library (`-nois` or + `-noinit`) and also issuing `Require Import Coq.Init.Datatypes`. + +Tools + +- Coq_makefile lets one override or extend the following variables from + the command line: `COQFLAGS`, `COQCHKFLAGS`, `COQDOCFLAGS`. + `COQFLAGS` is now entirely separate from `COQLIBS`, so in custom Makefiles + `$(COQFLAGS)` should be replaced by `$(COQFLAGS) $(COQLIBS)`. + +- Removed the `gallina` utility (extracts specification from Coq vernacular files). + If you would like to maintain this tool externally, please contact us. + +- Removed the Emacs modes distributed with Coq. You are advised to + use [Proof-General](https://proofgeneral.github.io/) (and optionally + [Company-Coq](https://github.com/cpitclaudel/company-coq)) instead. + If your use case is not covered by these alternative Emacs modes, + please open an issue. We can help set up external maintenance as part + of Proof-General, or independently as part of coq-community. + +Vernacular Commands + +- Removed deprecated commands `Arguments Scope` and `Implicit Arguments` + (not the option). Use the `Arguments` command instead. +- Nested proofs may be enabled through the option `Nested Proofs Allowed`. + By default, they are disabled and produce an error. The deprecation + warning which used to occur when using nested proofs has been removed. +- Added option `Uniform Inductive Parameters` which abstracts over parameters + before typechecking constructors, allowing to write for example + `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` +- New `Set Hint Variables/Constants Opaque/Transparent` commands for setting + globally the opacity flag of variables and constants in hint databases, + overwritting the opacity set of the hint database. +- Added generic syntax for "attributes", as in: + `#[local] Lemma foo : bar.` +- Added the `Numeral Notation` command for registering decimal numeral + notations for custom types +- The `Set SsrHave NoTCResolution` command no longer has special global + scope. If you want the previous behavior, use `Global Set SsrHave + NoTCResolution`. +- Multiple sections with the same name are allowed. + +Coq binaries and process model + +- Before 8.9, Coq distributed a single `coqtop` binary and a set of + dynamically loadable plugins that used to take over the main loop + for tasks such as IDE language server or parallel proof checking. + + These plugins have been turned into full-fledged binaries so each + different process has associated a particular binary now, in + particular `coqidetop` is the CoqIDE language server, and + `coq{proof,tactic,query}worker` are in charge of task-specific and + parallel proof checking. + +SSReflect + +- The implementation of delayed clear switches in intro patterns + is now simpler to explain: + + 1. The immediate effect of a clear switch like `{x}` is to rename the + variable `x` to `_x_` (i.e. a reserved identifier that cannot be mentioned + explicitly) + 2. The delayed effect of `{x}` is that `_x_` is cleared at the end of the intro + pattern + 3. A clear switch immediately before a view application like `{x}/v` is + translated to `/v{x}`. + + In particular, the third rule lets one write `{x}/v` even if `v` uses the variable `x`: + indeed the view is executed before the renaming. + +- An empty clear switch is now accepted in intro patterns before a + view application whenever the view is a variable. + One can now write `{}/v` to mean `{v}/v`. Remark that `{}/x` is very similar + to the idiom `{}e` for the rewrite tactic (the equation `e` is used for + rewriting and then discarded). + +Standard Library + +- There are now conversions between `string` and `positive`, `Z`, + `nat`, and `N` in binary, octal, and hex. + +Display diffs between proof steps + +- `coqtop` and `coqide` can now highlight the differences between proof steps + in color. This can be enabled from the command line or the + `Set Diffs "on"/"off"/"removed"` command. Please see the documentation for + details. Showing diffs in Proof General requires small changes to PG + (under discussion). + +Notations + +- Added `++` infix for `VectorDef.append`. + Note that this might cause incompatibilities if you have, e.g., `list_scope` + and `vector_scope` both open with `vector_scope` on top, and expect `++` to + refer to `app`. + Solution: wrap `_ ++ _` in `(_ ++ _)%list` (or whichever scope you want). + +Version 8.8 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +|Coq| version 8.8 contains the result of refinements and stabilization of +features and deprecations, cleanups of the internals of the system along +with a few new features. The main user visible changes are: + +- Kernel: fix a subject reduction failure due to allowing fixpoints + on non-recursive values, by Matthieu Sozeau. + Handling of evars in the VM (the kernel still does not accept evars) + by Pierre-Marie Pédrot. + +- Notations: many improvements on recursive notations and support for + destructuring patterns in the syntax of notations by Hugo Herbelin. + +- Proof language: tacticals for profiling, timing and checking success + or failure of tactics by Jason Gross. The focusing bracket ``{`` + supports single-numbered goal selectors, e.g. ``2:{``, by Théo + Zimmermann. + +- Vernacular: deprecation of commands and more uniform handling of the + ``Local`` flag, by Vincent Laporte and Maxime Dénès, part of a larger + attribute system overhaul. Experimental ``Show Extraction`` command by + Pierre Letouzey. Coercion now accepts ``Prop`` or ``Type`` as a source + by Arthur Charguéraud. ``Export`` modifier for options allowing to + export the option to modules that ``Import`` and not only ``Require`` + a module, by Pierre-Marie Pédrot. + +- Universes: many user-level and API level enhancements: qualified + naming and printing, variance annotations for cumulative inductive + types, more general constraints and enhancements of the minimization + heuristics, interaction with modules by Gaëtan Gilbert, Pierre-Marie + Pédrot and Matthieu Sozeau. + +- Library: Decimal Numbers library by Pierre Letouzey and various small + improvements. + +- Documentation: a large community effort resulted in the migration + of the reference manual to the Sphinx documentation tool. The result + is this manual. The new documentation infrastructure (based on Sphinx) + is by Clément Pit-Claudel. The migration was coordinated by Maxime Dénès + and Paul Steckler, with some help of Théo Zimmermann during the + final integration phase. The 14 people who ported the manual are + Calvin Beck, Heiko Becker, Yves Bertot, Maxime Dénès, Richard Ford, + Pierre Letouzey, Assia Mahboubi, Clément Pit-Claudel, + Laurence Rideau, Matthieu Sozeau, Paul Steckler, Enrico Tassi, + Laurent Théry, Nikita Zyuzin. + +- Tools: experimental ``-mangle-names`` option to ``coqtop``/``coqc`` for + linting proof scripts, by Jasper Hugunin. + +On the implementation side, the ``dev/doc/changes.md`` file +documents the numerous changes to the implementation and improvements of +interfaces. The file provides guidelines on porting a plugin to the new +version. + +Version 8.8 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system. +Most important ones are documented in the ``CHANGES.md`` file. + +The efficiency of the whole system has seen improvements thanks to +contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and +Matthieu Sozeau and performance issue tracking by Jason Gross and Paul +Steckler. + +The official wiki and the bugtracker of |Coq| migrated to the GitHub +platform, thanks to the work of Pierre Letouzey and Théo +Zimmermann. Gaëtan Gilbert, Emilio Jesús Gallego Arias worked on +maintaining and improving the continuous integration system. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many +users. A list of packages is available at https://coq.inria.fr/opam/www/. + +The 44 contributors for this version are Yves Bertot, Joachim Breitner, Tej +Chajed, Arthur Charguéraud, Jacques-Pascal Deplaix, Maxime Dénès, Jim Fehrle, +Julien Forest, Yannick Forster, Gaëtan Gilbert, Jason Gross, Samuel Gruetter, +Thomas Hebb, Hugo Herbelin, Jasper Hugunin, Emilio Jesus Gallego Arias, Ralf +Jung, Johannes Kloos, Matej KoÅ¡Ãk, Robbert Krebbers, Tony Beta Lambda, Vincent +Laporte, Peter LeFanu Lumsdaine, Pierre Letouzey, Farzon Lotfi, Cyprien Mangin, +Guillaume Melquiond, Raphaël Monat, Carl Patenaude Poulin, Pierre-Marie Pédrot, +Clément Pit-Claudel, Matthew Ryan, Matt Quinn, Sigurd Schneider, Bernhard +Schommer, Michael Soegtrop, Matthieu Sozeau, Arnaud Spiwack, Paul Steckler, +Enrico Tassi, Anton Trunov, Martin Vassor, Vadim Zaliva and Théo Zimmermann. + +Version 8.8 is the third release of |Coq| developed on a time-based +development cycle. Its development spanned 6 months from the release of +|Coq| 8.7 and was based on a public roadmap. The development process +was coordinated by Matthieu Sozeau. Maxime Dénès was in charge of the +release process. Théo Zimmermann is the maintainer of this release. + +Many power users helped to improve the design of the new features via +the bug tracker, the pull request system, the |Coq| development mailing +list or the coq-club@inria.fr mailing list. Special thanks to the users who +contributed patches and intensive brain-storming and code reviews, +starting with Jason Gross, Ralf Jung, Robbert Krebbers and Amin Timany. +It would however be impossible to mention exhaustively the names +of everybody who to some extent influenced the development. + +The |Coq| consortium, an organization directed towards users and +supporters of the system, is now running and employs Maxime Dénès. +The contacts of the Coq Consortium are Yves Bertot and Maxime Dénès. + +| Santiago de Chile, March 2018, +| Matthieu Sozeau for the |Coq| development team +| + +Details of changes in 8.8+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Kernel + +- Support for template polymorphism for definitions was removed. May trigger + more "universe inconsistency" errors in rare occasions. +- Fixpoints are no longer allowed on non-recursive inductive types. + +Notations + +- Recursive notations with the recursive pattern repeating on the + right (e.g. "( x ; .. ; y ; z )") now supported. +- Notations with a specific level for the leftmost nonterminal, + when printing-only, are supported. +- Notations can now refer to the syntactic category of patterns (as in + "fun 'pat =>" or "match p with pat => ... end"). Two variants are + available, depending on whether a single variable is considered as a + pattern or not. +- Recursive notations now support ".." patterns with several + occurrences of the recursive term or binder, possibly mixing terms + and binders, possibly in reverse left-to-right order. +- "Locate" now working also on notations of the form "x + y" (rather + than "_ + _"). + +Specification language + +- When printing clauses of a "match", clauses with same right-hand + side are factorized and the last most factorized clause with no + variables, if it exists, is turned into a default clause. + Use "Unset Printing Allow Default Clause" do deactivate printing + of a default clause. + Use "Unset Printing Factorizable Match Patterns" to deactivate + factorization of clauses with same right-hand side. + +Tactics + +- On Linux, "native_compute" calls can be profiled using the "perf" + utility. The command "Set NativeCompute Profiling" enables + profiling, and "Set NativeCompute Profile Filename" customizes + the profile filename. +- The tactic "omega" is now aware of the bodies of context variables + such as "x := 5 : Z" (see #1362). This could be disabled via + Unset Omega UseLocalDefs. +- The tactic "romega" is also aware now of the bodies of context variables. +- The tactic "zify" resp. "omega with N" is now aware of N.pred. +- Tactic "decide equality" now able to manage constructors which + contain proofs. +- Added tactics reset ltac profile, show ltac profile (and variants) +- Added tactics restart_timer, finish_timing, and time_constr as an + experimental way of timing Ltac's evaluation phase +- Added tactic optimize_heap, analogous to the Vernacular Optimize + Heap, which performs a major garbage collection and heap compaction + in the OCaml run-time system. +- The tactics "dtauto", "dintuition", "firstorder" now handle inductive types + with let bindings in the parameters. +- The tactic ``dtauto`` now handles some inductives such as + ``@sigT A (fun _ => B)`` as non-dependent conjunctions. +- A bug fixed in ``rewrite H in *`` and ``rewrite H in * |-`` may cause a + few rare incompatibilities (it was unintendedly recursively + rewriting in the side conditions generated by H). +- Added tactics "assert_succeeds tac" and "assert_fails tac" to ensure + properties of the executation of a tactic without keeping the effect + of the execution. +- `vm_compute` now supports existential variables. +- Calls to `shelve` and `give_up` within calls to tactic `refine` now working. +- Deprecated tactic `appcontext` was removed. + +Focusing + +- Focusing bracket `{` now supports single-numbered goal selector, + e.g. `2: {` will focus on the second sub-goal. As usual, unfocus + with `}` once the sub-goal is fully solved. + The `Focus` and `Unfocus` commands are now deprecated. + +Vernacular Commands + +- Proofs ending in "Qed exporting ident, .., ident" are not supported + anymore. Constants generated during `abstract` are kept private to the + local environment. +- The deprecated Coercion Local, Open Local Scope, Notation Local syntax + was removed. Use Local as a prefix instead. +- For the Extraction Language command, "OCaml" is spelled correctly. + The older "Ocaml" is still accepted, but deprecated. +- Using “Require†inside a section is deprecated. +- An experimental command "Show Extraction" allows to extract the content + of the current ongoing proof (grant wish #4129). +- Coercion now accepts the type of its argument to be "Prop" or "Type". +- The "Export" modifier can now be used when setting and unsetting options, and + will result in performing the same change when the module corresponding the + command is imported. +- The `Axiom` command does not automatically declare axioms as instances when + their type is a class. Previous behavior can be restored using `Set + Typeclasses Axioms Are Instances`. + +Universes + +- Qualified naming of global universes now works like other namespaced + objects (e.g. constants), with a separate namespace, inside and across + module and library boundaries. Global universe names introduced in an + inductive / constant / Let declaration get qualified with the name of + the declaration. +- Universe cumulativity for inductive types is now specified as a + variance for each polymorphic universe. See the reference manual for + more information. +- Inference of universe constraints with cumulative inductive types + produces more general constraints. Unsetting new option Cumulativity + Weak Constraints produces even more general constraints (but may + produce too many universes to be practical). +- Fix #5726: Notations that start with `Type` now support universe instances + with `@{u}`. +- `with Definition` now understands universe declarations + (like `@{u| Set < u}`). + +Tools + +- Coq can now be run with the option -mangle-names to change the auto-generated + name scheme. This is intended to function as a linter for developments that + want to be robust to changes in auto-generated names. This feature is experimental, + and may change or disappear without warning. +- GeoProof support was removed. + +Checker + +- The checker now accepts filenames in addition to logical paths. + +CoqIDE + +- Find and Replace All report the number of occurrences found; Find indicates + when it wraps. + +coqdep + +- Learned to read -I, -Q, -R and filenames from _CoqProject files. + This is used by coq_makefile when generating dependencies for .v + files (but not other files). + +Documentation + +- The Coq FAQ, formerly located at https://coq.inria.fr/faq, has been + moved to the GitHub wiki section of this repository; the main entry + page is https://github.com/coq/coq/wiki/The-Coq-FAQ. +- Documentation: a large community effort resulted in the migration + of the reference manual to the Sphinx documentation tool. The result + is partially integrated in this version. + +Standard Library + +- New libraries Coq.Init.Decimal, Coq.Numbers.DecimalFacts, + Coq.Numbers.DecimalNat, Coq.Numbers.DecimalPos, + Coq.Numbers.DecimalN, Coq.Numbers.DecimalZ, + Coq.Numbers.DecimalString providing a type of decimal numbers, some + facts about them, and conversions between decimal numbers and nat, + positive, N, Z, and string. +- Added [Coq.Strings.String.concat] to concatenate a list of strings + inserting a separator between each item +- Notation `'` for Zpos in QArith was removed. + +- Some deprecated aliases are now emitting warnings when used. + +Compatibility support + +- Support for compatibility with versions before 8.6 was dropped. + +Options + +- The following deprecated options have been removed: + + + `Refolding Reduction` + + `Standard Proposition Elimination` + + `Dependent Propositions Elimination` + + `Discriminate Introduction` + + `Shrink Abstract` + + `Tactic Pattern Unification` + + `Intuition Iff Unfolding` + + `Injection L2R Pattern Order` + + `Record Elimination Schemes` + + `Match Strict` + + `Tactic Compat Context` + + `Typeclasses Legacy Resolution` + + `Typeclasses Module Eta` + + `Typeclass Resolution After Apply` + +Details of changes in 8.8.0 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Tools + +- Asynchronous proof delegation policy was fixed. Since version 8.7 + Coq was ignoring previous runs and the `-async-proofs-delegation-threshold` + option did not have the expected behavior. + +Tactic language + +- The undocumented "nameless" forms `fix N`, `cofix` have been + deprecated; please use `fix ident N /cofix ident` to explicitely + name the (co)fixpoint hypothesis to be introduced. + +Documentation + +- The reference manual is now fully ported to Sphinx. + +Other small deprecations and bug fixes. + +Details of changes in 8.8.1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Kernel + +- Fix a critical bug with cofixpoints and `vm_compute`/`native_compute` (#7333). +- Fix a critical bug with modules and algebraic universes (#7695) +- Fix a critical bug with inlining of polymorphic constants (#7615). +- Fix a critical bug with universe polymorphism and `vm_compute` (#7723). Was + present since 8.5. + +Notations + +- Fixed unexpected collision between only-parsing and only-printing + notations (issue #7462). + +Windows installer + +- The Windows installer now includes external packages Ltac2 and Equations + (it included the Bignums package since 8.8+beta1). + +Many other bug fixes, documentation improvements (including fixes of +regressions due to the Sphinx migration), and user message improvements +(for details, see the 8.8.1 milestone at +https://github.com/coq/coq/milestone/13?closed=1). + +Details of changes in 8.8.2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Documentation + +- A PDF version of the reference manual is available once again. + +Tools + +- The coq-makefile targets `print-pretty-timed`, `print-pretty-timed-diff`, + and `print-pretty-single-time-diff` now correctly label the "before" and + "after" columns, rather than swapping them. + +Kernel + +- The kernel does not tolerate capture of global universes by + polymorphic universe binders, fixing a soundness break (triggered + only through custom plugins) + +Windows installer + +- The Windows installer now includes many more external packages that can be + individually selected for installation. + +Many other bug fixes and lots of documentation improvements (for details, +see the 8.8.2 milestone at https://github.com/coq/coq/milestone/15?closed=1). + +Version 8.7 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +|Coq| version 8.7 contains the result of refinements, stabilization of features +and cleanups of the internals of the system along with a few new features. The +main user visible changes are: + +- New tactics: variants of tactics supporting existential variables :tacn:`eassert`, + :tacn:`eenough`, etc... by Hugo Herbelin. Tactics ``extensionality in H`` and + :tacn:`inversion_sigma` by Jason Gross, ``specialize with ...`` accepting partial bindings + by Pierre Courtieu. + +- ``Cumulative Polymorphic Inductive`` types, allowing cumulativity of universes to + go through applied inductive types, by Amin Timany and Matthieu Sozeau. + +- Integration of the SSReflect plugin and its documentation in the reference + manual, by Enrico Tassi, Assia Mahboubi and Maxime Dénès. + +- The ``coq_makefile`` tool was completely redesigned to improve its maintainability + and the extensibility of generated Makefiles, and to make ``_CoqProject`` files + more palatable to IDEs by Enrico Tassi. + +|Coq| 8.7 involved a large amount of work on cleaning and speeding up the code +base, notably the work of Pierre-Marie Pédrot on making the tactic-level system +insensitive to existential variable expansion, providing a safer API to plugin +writers and making the code more robust. The ``dev/doc/changes.txt`` file +documents the numerous changes to the implementation and improvements of +interfaces. An effort to provide an official, streamlined API to plugin writers +is in progress, thanks to the work of Matej KoÅ¡Ãk. + +Version 8.7 also comes with a bunch of smaller-scale changes and improvements +regarding the different components of the system. We shall only list a few of +them. + +The efficiency of the whole system has been significantly improved thanks to +contributions from Pierre-Marie Pédrot, Maxime Dénès and Matthieu Sozeau and +performance issue tracking by Jason Gross and Paul Steckler. + +Thomas Sibut-Pinote and Hugo Herbelin added support for side effect hooks in +cbv, cbn and simpl. The side effects are provided via a plugin available at +https://github.com/herbelin/reduction-effects/. + +The BigN, BigZ, BigQ libraries are no longer part of the |Coq| standard library, +they are now provided by a separate repository https://github.com/coq/bignums, +maintained by Pierre Letouzey. + +In the Reals library, ``IZR`` has been changed to produce a compact representation +of integers and real constants are now represented using ``IZR`` (work by +Guillaume Melquiond). + +Standard library additions and improvements by Jason Gross, Pierre Letouzey and +others, documented in the ``CHANGES.md`` file. + +The mathematical proof language/declarative mode plugin was removed from the +archive. + +The OPAM repository for |Coq| packages has been maintained by Guillaume Melquiond, +Matthieu Sozeau, Enrico Tassi with contributions from many users. A list of +packages is available at https://coq.inria.fr/opam/www/. + +Packaging tools and software development kits were prepared by Michael Soegtrop +with the help of Maxime Dénès and Enrico Tassi for Windows, and Maxime Dénès for +MacOS X. Packages are regularly built on the Travis continuous integration +server. + +The contributors for this version are Abhishek Anand, C.J. Bell, Yves Bertot, +Frédéric Besson, Tej Chajed, Pierre Courtieu, Maxime Dénès, Julien Forest, +Gaëtan Gilbert, Jason Gross, Hugo Herbelin, Emilio Jesús Gallego Arias, Ralf +Jung, Matej KoÅ¡Ãk, Xavier Leroy, Pierre Letouzey, Assia Mahboubi, Cyprien +Mangin, Erik Martin-Dorel, Olivier Marty, Guillaume Melquiond, Sam Pablo Kuper, +Benjamin Pierce, Pierre-Marie Pédrot, Lars Rasmusson, Lionel Rieg, Valentin +Robert, Yann Régis-Gianas, Thomas Sibut-Pinote, Michael Soegtrop, Matthieu +Sozeau, Arnaud Spiwack, Paul Steckler, George Stelle, Pierre-Yves Strub, Enrico +Tassi, Hendrik Tews, Amin Timany, Laurent Théry, Vadim Zaliva and Théo +Zimmermann. + +The development process was coordinated by Matthieu Sozeau with the help of +Maxime Dénès, who was also in charge of the release process. Théo Zimmermann is +the maintainer of this release. + +Many power users helped to improve the design of the new features via the bug +tracker, the pull request system, the |Coq| development mailing list or the +Coq-Club mailing list. Special thanks to the users who contributed patches and +intensive brain-storming and code reviews, starting with Jason Gross, Ralf Jung, +Robbert Krebbers, Xavier Leroy, Clément Pit–Claudel and Gabriel Scherer. It +would however be impossible to mention exhaustively the names of everybody who +to some extent influenced the development. + +Version 8.7 is the second release of |Coq| developed on a time-based development +cycle. Its development spanned 9 months from the release of |Coq| 8.6 and was +based on a public road-map. It attracted many external contributions. Code +reviews and continuous integration testing were systematically used before +integration of new features, with an important focus given to compatibility and +performance issues, resulting in a hopefully more robust release than |Coq| 8.6 +while maintaining compatibility. + +|Coq| Enhancement Proposals (CEPs for short) and open pull request discussions +were used to discuss publicly the new features. + +The |Coq| consortium, an organization directed towards users and supporters of the +system, is now upcoming and will rely on Inria’s newly created Foundation. + +| Paris, August 2017, +| Matthieu Sozeau and the |Coq| development team +| + +Potential compatibility issues +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- Extra superfluous names in introduction patterns may now raise an + error rather than a warning when the superfluous name is already in + use. The easy fix is to remove the superfluous name. + +Details of changes in 8.7+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Tactics + +- New tactic "extensionality in H" which applies (possibly dependent) + functional extensionality in H supposed to be a quantified equality + until giving a bare equality. + +- New tactic ``inversion_sigma`` which turns equalities of dependent + pairs (e.g., ``existT P x p = existT P y q``, frequently left over by + ``inversion`` on a dependent type family) into pairs of equalities + (e.g., a hypothesis ``H : x = y`` and a hypothesis of type ``rew H in p = q``); + these hypotheses can subsequently be simplified using + ``subst``, without ever invoking any kind of axiom asserting + uniqueness of identity proofs. If you want to explicitly specify the + hypothesis to be inverted, or name the generated hypotheses, you can + invoke ``induction H as [H1 H2] using eq_sigT_rect``. The tactic also + works for ``sig``, ``sigT2``, and ``sig2``, and there are similar + ``eq_sig*_rect`` induction lemmas. + +- Tactic "specialize with ..." now accepts any partial bindings. + Missing bindings are either solved by unification or left quantified + in the hypothesis. + +- New representation of terms that statically ensure stability by + evar-expansion. This has several consequences. + + * In terms of performance, this adds a cost to every term destructuration, + but at the same time most eager evar normalizations were removed, which + couterbalances this drawback and even sometimes outperforms the old + implementation. For instance, many operations that would require O(n) + normalization of the term are now O(1) in tactics. YMMV. + + * This triggers small changes in unification, which was not evar-insensitive. + Most notably, the new implementation recognizes Miller patterns that were + missed before because of a missing normalization step. Hopefully this should + be fairly uncommon. + +- Tactic "auto with real" can now discharge comparisons of literals. + +- The types of variables in patterns of "match" are now + beta-iota-reduced after type-checking. This has an impact on the + type of the variables that the tactic "refine" introduces in the + context, producing types a priori closer to the expectations. + +- In "Tactic Notation" or "TACTIC EXTEND", entry "constr_with_bindings" + now uses type classes and rejects terms with unresolved holes, like + entry "constr" does. To get the former behavior use + "open_constr_with_bindings" (possible source of incompatibility). + +- New e-variants eassert, eenough, epose proof, eset, eremember, epose + which behave like the corresponding variants with no "e" but turn + unresolved implicit arguments into existential variables, on the + shelf, rather than failing. + +- Tactic injection has become more powerful (closes bug #4890) and its + documentation has been updated. + +- New variants of the `first` and `solve` tacticals that do not rely + on parsing rules, meant to define tactic notations. + +- Added support for side effects hooks in `cbv`, `cbn` and `simpl`. + The side effects are provided via a plugin: + https://github.com/herbelin/reduction-effects/ + +- It is now possible to take hint database names as parameters in a + Ltac definition or a Tactic Notation. + +- New option `Set Ltac Batch Debug` on top of `Set Ltac Debug` for + non-interactive Ltac debug output. + +Gallina + +- Now supporting all kinds of binders, including 'pat, in syntax of record fields. + +Vernacular Commands + +- Goals context can be printed in a more compact way when `Set + Printing Compact Contexts` is activated. +- Unfocused goals can be printed with the `Set Printing Unfocused` + option. +- `Print` now shows the types of let-bindings. +- The compatibility options for printing primitive projections + (`Set Printing Primitive Projection Parameters` and + `Set Printing Primitive Projection Compatibility`) are now off by default. +- Possibility to unset the printing of notations in a more fine grained + fashion than `Unset Printing Notations` is provided without any + user-syntax. The goal is that someone creates a plugin to experiment + such a user-syntax, to be later integrated in Coq when stabilized. +- `About` now tells if a reference is a coercion. +- The deprecated `Save` vernacular and its form `Save Theorem id` to + close proofs have been removed from the syntax. Please use `Qed`. +- `Search` now sorts results by relevance (the relevance metric is a + weighted sum of number of distinct symbols and size of the term). + +Standard Library + +- New file PropExtensionality.v to explicitly work in the axiomatic + context of propositional extensionality. +- New file SetoidChoice.v axiomatically providing choice over setoids, + and, consequently, choice of representatives in equivalence classes. + Various proof-theoretic characterizations of choice over setoids in + file ChoiceFacts.v. +- New lemmas about iff and about orders on positive and Z. +- New lemmas on powerRZ. +- Strengthened statement of JMeq_eq_dep (closes bug #4912). +- The BigN, BigZ, BigZ libraries are no longer part of the Coq standard + library, they are now provided by a separate repository + https://github.com/coq/bignums + The split has been done just after the Int31 library. + +- IZR (Reals) has been changed to produce a compact representation of + integers. As a consequence, IZR is no longer convertible to INR and + lemmas such as INR_IZR_INZ should be used instead. +- Real constants are now represented using IZR rather than R0 and R1; + this might cause rewriting rules to fail to apply to constants. +- Added new notation {x & P} for sigT (without a type for x) + +Plugins + +- The Ssreflect plugin is now distributed with Coq. Its documentation has + been integrated as a chapter of the reference manual. This chapter is + work in progress so feedback is welcome. +- The mathematical proof language (also known as declarative mode) was removed. +- A new command Extraction TestCompile has been introduced, not meant + for the general user but instead for Coq's test-suite. +- The extraction plugin is no longer loaded by default. It must be + explicitly loaded with [Require Extraction], which is backwards + compatible. +- The functional induction plugin (which provides the [Function] + vernacular) is no longer loaded by default. It must be explicitly + loaded with [Require FunInd], which is backwards compatible. + + +Dependencies + +- Support for camlp4 has been removed. + +Tools + +- coq_makefile was completely redesigned to improve its maintainability and + the extensibility of generated Makefiles, and to make _CoqProject files + more palatable to IDEs. Overview: + + * _CoqProject files contain only Coq specific data (i.e. the list of + files, -R options, ...) + * coq_makefile translates _CoqProject to Makefile.conf and copies in the + desired location a standard Makefile (that reads Makefile.conf) + * Makefile extensions can be implemented in a Makefile.local file (read + by the main Makefile) by installing a hook in the extension points + provided by the standard Makefile + + The current version contains code for retro compatibility that prints + warnings when a deprecated feature is used. Please upgrade your _CoqProject + accordingly. + + * Additionally, coq_makefile-made Makefiles now support experimental timing + targets `pretty-timed`, `pretty-timed-before`, `pretty-timed-after`, + `print-pretty-timed-diff`, `print-pretty-single-time-diff`, + `all.timing.diff`, and the variable `TIMING=1` (or `TIMING=before` or + `TIMING=after`); see the documentation for more details. + +Build Infrastructure + +- Note that 'make world' does not build the bytecode binaries anymore. + For that, you can use 'make byte' (and 'make install-byte' afterwards). + Warning: native and byte compilations should *not* be mixed in the same + instance of 'make -j', otherwise both ocamlc and ocamlopt might race for + access to the same .cmi files. In short, use "make -j && make -j byte" + instead of "make -j world byte". + +Universes + +- Cumulative inductive types. see prefixes "Cumulative", "NonCumulative" + for inductive definitions and the option "Set Polymorphic Inductive Cumulativity" + in the reference manual. +- New syntax `foo@{_}` to instantiate a polymorphic definition with + anonymous universes (can also be used with `Type`). + +XML Protocol and internal changes + +See dev/doc/changes.txt + +Many bugfixes including #1859, #2884, #3613, #3943, #3994, +#4250, #4709, #4720, #4824, #4844, #4911, #5026, #5233, +#5275, #5315, #5336, #5360, #5390, #5414, #5417, #5420, +#5439, #5449, #5475, #5476, #5482, #5501, #5507, #5520, +#5523, #5524, #5553, #5577, #5578, #5589, #5597, #5598, +#5607, #5618, #5619, #5620, #5641, #5648, #5651, #5671. + +Many bugfixes on OS X and Windows (now the test-suite passes on these +platforms too). + +Many optimizations. + +Many documentation improvements. + +Details of changes in 8.7+beta2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Tools + +- In CoqIDE, the "Compile Buffer" command takes account of flags in + _CoqProject or other project file. + +Improvements around some error messages. + +Many bug fixes including two important ones: + +- Bug #5730: CoqIDE becomes unresponsive on file open. +- coq_makefile: make sure compile flags for Coq and coq_makefile are in sync + (in particular, make sure the `-safe-string` option is used to compile plugins). + +Details of changes in 8.7.0 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +OCaml + +- Users can pass specific flags to the OCaml optimizing compiler by + -using the flambda-opts configure-time option. + + Beware that compiling Coq with a flambda-enabled compiler is + experimental and may require large amounts of RAM and CPU, see + INSTALL for more details. + +Details of changes in 8.7.1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Compatibility with OCaml 4.06.0. + +Many bug fixes, documentation improvements, and user message improvements (for +details see the 8.7.1 milestone at https://github.com/coq/coq/milestone/10?closed=1). + +Details of changes in 8.7.2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed a critical bug in the VM handling of universes (#6677). This bug +affected all releases since 8.5. + +Improved support for building with OCaml 4.06.0 and external num package. + +Many other bug fixes, documentation improvements, and user +message improvements (for details, see the 8.7.2 milestone at +https://github.com/coq/coq/milestone/11?closed=1). + +Version 8.6 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.6 contains the result of refinements, stabilization of +8.5’s features and cleanups of the internals of the system. Over the +year of (now time-based) development, about 450 bugs were resolved and +over 100 contributions integrated. The main user visible changes are: + +- A new, faster state-of-the-art universe constraint checker, by + Jacques-Henri Jourdan. + +- In |CoqIDE| and other asynchronous interfaces, more fine-grained + asynchronous processing and error reporting by Enrico Tassi, making + |Coq| capable of recovering from errors and continue processing the + document. + +- More access to the proof engine features from Ltac: goal management + primitives, range selectors and a :tacn:`typeclasses eauto` engine handling + multiple goals and multiple successes, by Cyprien Mangin, Matthieu + Sozeau and Arnaud Spiwack. + +- Tactic behavior uniformization and specification, generalization of + intro-patterns by Hugo Herbelin and others. + +- A brand new warning system allowing to control warnings, turn them + into errors or ignore them selectively by Maxime Dénès, Guillaume + Melquiond, Pierre-Marie Pédrot and others. + +- Irrefutable patterns in abstractions, by Daniel de Rauglaudre. + +- The ssreflect subterm selection algorithm by Georges Gonthier and + Enrico Tassi is now accessible to tactic writers through the + ssrmatching plugin. + +- Integration of LtacProf, a profiler for Ltac by Jason Gross, Paul + Steckler, Enrico Tassi and Tobias Tebbi. + +Coq 8.6 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system. We shall +only list a few of them. + +The iota reduction flag is now a shorthand for match, fix and cofix +flags controlling the corresponding reduction rules (by Hugo Herbelin +and Maxime Dénès). + +Maxime Dénès maintained the native compilation machinery. + +Pierre-Marie Pédrot separated the Ltac code from general purpose +tactics, and generalized and rationalized the handling of generic +arguments, allowing to create new versions of Ltac more easily in the +future. + +In patterns and terms, @, abbreviations and notations are now +interpreted the same way, by Hugo Herbelin. + +Name handling for universes has been improved by Pierre-Marie Pédrot and +Matthieu Sozeau. The minimization algorithm has been improved by +Matthieu Sozeau. + +The unifier has been improved by Hugo Herbelin and Matthieu Sozeau, +fixing some incompatibilities introduced in |Coq| 8.5. Unification +constraints can now be left floating around and be seen by the user +thanks to a new option. The Keyed Unification mode has been improved by +Matthieu Sozeau. + +The typeclass resolution engine and associated proof-search tactic have +been reimplemented on top of the proof-engine monad, providing better +integration in tactics, and new options have been introduced to control +it, by Matthieu Sozeau with help from Théo Zimmermann. + +The efficiency of the whole system has been significantly improved +thanks to contributions from Pierre-Marie Pédrot, Maxime Dénès and +Matthieu Sozeau and performance issue tracking by Jason Gross and Paul +Steckler. + +Standard library improvements by Jason Gross, Sébastien Hinderer, Pierre +Letouzey and others. + +Emilio Jesús Gallego Arias contributed many cleanups and refactorings of +the pretty-printing and user interface communication components. + +Frédéric Besson maintained the micromega tactic. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Claret, Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi and others. A +list of packages is now available at https://coq.inria.fr/opam/www/. + +Packaging tools and software development kits were prepared by Michael +Soegtrop with the help of Maxime Dénès and Enrico Tassi for Windows, and +Maxime Dénès and Matthieu Sozeau for MacOS X. Packages are now regularly +built on the continuous integration server. |Coq| now comes with a META +file usable with ocamlfind, contributed by Emilio Jesús Gallego Arias, +Gregory Malecha, and Matthieu Sozeau. + +Matej KoÅ¡Ãk maintained and greatly improved the continuous integration +setup and the testing of |Coq| contributions. He also contributed many API +improvements and code cleanups throughout the system. + +The contributors for this version are Bruno Barras, C.J. Bell, Yves +Bertot, Frédéric Besson, Pierre Boutillier, Tej Chajed, Guillaume +Claret, Xavier Clerc, Pierre Corbineau, Pierre Courtieu, Maxime Dénès, +Ricky Elrod, Emilio Jesús Gallego Arias, Jason Gross, Hugo Herbelin, +Sébastien Hinderer, Jacques-Henri Jourdan, Matej KoÅ¡Ãk, Xavier Leroy, +Pierre Letouzey, Gregory Malecha, Cyprien Mangin, Erik Martin-Dorel, +Guillaume Melquiond, Clément Pit–Claudel, Pierre-Marie Pédrot, Daniel de +Rauglaudre, Lionel Rieg, Gabriel Scherer, Thomas Sibut-Pinote, Matthieu +Sozeau, Arnaud Spiwack, Paul Steckler, Enrico Tassi, Laurent Théry, +Nickolai Zeldovich and Théo Zimmermann. The development process was +coordinated by Hugo Herbelin and Matthieu Sozeau with the help of Maxime +Dénès, who was also in charge of the release process. + +Many power users helped to improve the design of the new features via +the bug tracker, the pull request system, the |Coq| development mailing +list or the Coq-Club mailing list. Special thanks to the users who +contributed patches and intensive brain-storming and code reviews, +starting with Cyril Cohen, Jason Gross, Robbert Krebbers, Jonathan +Leivent, Xavier Leroy, Gregory Malecha, Clément Pit–Claudel, Gabriel +Scherer and Beta Ziliani. It would however be impossible to mention +exhaustively the names of everybody who to some extent influenced the +development. + +Version 8.6 is the first release of |Coq| developed on a time-based +development cycle. Its development spanned 10 months from the release of +Coq 8.5 and was based on a public roadmap. To date, it contains more +external contributions than any previous |Coq| system. Code reviews were +systematically done before integration of new features, with an +important focus given to compatibility and performance issues, resulting +in a hopefully more robust release than |Coq| 8.5. + +Coq Enhancement Proposals (CEPs for short) were introduced by Enrico +Tassi to provide more visibility and a discussion period on new +features, they are publicly available https://github.com/coq/ceps. + +Started during this period, an effort is led by Yves Bertot and Maxime +Dénès to put together a |Coq| consortium. + +| Paris, November 2016, +| Matthieu Sozeau and the |Coq| development team +| + +Potential sources of incompatibilities +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- Symptom: An obligation generated by Program or an abstracted subproof + has different arguments. + + Cause: Set Shrink Abstract and Set Shrink Obligations are on by default + and the subproof does not use the argument. + + Remedy: + + + Adapt the script. + + Write an explicit lemma to prove the obligation/subproof and use it + instead (compatible with 8.4). + + Unset the option for the program/proof the obligation/subproof originates + from. + +- Symptom: In a goal, order of hypotheses, or absence of an equality of + the form "x = t" or "t = x", or no unfolding of a local definition. + + Cause: This might be connected to a number of fixes in the tactic + "subst". The former behavior can be reactivated by issuing "Unset + Regular Subst Tactic". + +Details of changes in 8.6beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Kernel + +- A new, faster state-of-the-art universe constraint checker. + +Specification language + +- Giving implicit arguments explicitly to a constant with multiple + choices of implicit arguments does not break any more insertion of + further maximal implicit arguments. +- Ability to put any pattern in binders, prefixed by quote, e.g. + "fun '(a,b) => ...", "λ '(a,(b,c)), ...", "Definition foo '(x,y) := ...". + It expands into a "let 'pattern := ..." + +Tactics + +- Flag "Bracketing Last Introduction Pattern" is now on by default. +- Flag "Regular Subst Tactic" is now on by default: it respects the + initial order of hypothesis, it contracts cycles, it unfolds no + local definitions (common source of incompatibilities, fixable by + "Unset Regular Subst Tactic"). +- New flag "Refolding Reduction", now disabled by default, which turns + on refolding of constants/fixpoints (as in cbn) during the reductions + done during type inference and tactic retyping. Can be extremely + expensive. When set off, this recovers the 8.4 behaviour of unification + and type inference. Potential source of incompatibility with 8.5 developments + (the option is set on in Compat/Coq85.v). +- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract + tactical w.r.t. variables appearing in the body of the proof. + On by default and deprecated. Minor source of incompatibility + for code relying on the precise arguments of abstracted proofs. +- Serious bugs are fixed in tactic "double induction" (source of + incompatibilities as soon as the inductive types have dependencies in + the type of their constructors; "double induction" remains however + deprecated). +- In introduction patterns of the form (pat1,...,patn), n should match + the exact number of hypotheses introduced (except for local definitions + for which pattern can be omitted, as in regular pattern-matching). +- Tactic scopes in Ltac like constr: and ltac: now require parentheses around + their argument. +- Every generic argument type declares a tactic scope of the form "name:(...)" + where name is the name of the argument. This generalizes the constr: and ltac: + instances. +- When in strict mode (i.e. in a Ltac definition), if the "intro" tactic is + given a free identifier, it is not bound in subsequent tactics anymore. + In order to introduce a binding, use e.g. the "fresh" primitive instead + (potential source of incompatibilities). +- New tactics is_ind, is_const, is_proj, is_constructor for use in Ltac. +- New goal selectors. Sets of goals can be selected by listing integers + ranges. Example: "1,4-7,24: tac" focuses "tac" on goals 1,4,5,6,7,24. +- For uniformity with "destruct"/"induction" and for a more natural + behavior, "injection" can now work in place by activating option + "Structural Injection". In this case, hypotheses are also put in the + context in the natural left-to-right order and the hypothesis on + which injection applies is cleared. +- Tactic "contradiction" (hence "easy") now also solve goals with + hypotheses of the form "~True" or "t<>t" (possible source of + incompatibilities because of more successes in automation, but + generally a more intuitive strategy). +- Option "Injection On Proofs" was renamed "Keep Proof Equalities". When + enabled, injection and inversion do not drop equalities between objects + in Prop. Still disabled by default. +- New tactics "notypeclasses refine" and "simple notypeclasses refine" that + disallow typeclass resolution when typechecking their argument, for use + in typeclass hints. +- Integration of LtacProf, a profiler for Ltac. +- Reduction tactics now accept more fine-grained flags: iota is now a shorthand + for the new flags match, fix and cofix. +- The ssreflect subterm selection algorithm is now accessible to tactic writers + through the ssrmatching plugin. +- When used as an argument of an ltac function, "auto" without "with" + nor "using" clause now correctly uses only the core hint database by + default. + +Hints + +- Revised the syntax of [Hint Cut] to follow standard notation for regexps. +- Hint Mode now accepts "!" which means that the mode matches only if the + argument's head is not an evar (it goes under applications, casts, and + scrutinees of matches and projections). +- Hints can now take an optional user-given pattern, used only by + [typeclasses eauto] with the [Filtered Unification] option on. + +Typeclasses + +- Many new options and new engine based on the proof monad. The + [typeclasses eauto] tactic is now a multi-goal, multi-success tactic. + See reference manual for more information. It is planned to + replace auto and eauto in the following version. The 8.5 resolution + engine is still available to help solve compatibility issues. + +Program + +- The "Shrink Obligations" flag now applies to all obligations, not only + those solved by the automatic tactic. +- "Shrink Obligations" is on by default and deprecated. Minor source of + incompatibility for code relying on the precise arguments of + obligations. + +Notations + +- "Bind Scope" can once again bind "Funclass" and "Sortclass". + +General infrastructure + +- New configurable warning system which can be controlled with the vernacular + command "Set Warnings", or, under coqc/coqtop, with the flag "-w". In + particular, the default is now that warnings are printed by coqc. +- In asynchronous mode, Coq is now capable of recovering from errors and + continue processing the document. + +Tools + +- coqc accepts a -o option to specify the output file name +- coqtop accepts --print-version to print Coq and OCaml versions in + easy to parse format +- Setting [Printing Dependent Evars Line] can be unset to disable the + computation associated with printing the "dependent evars: " line in + -emacs mode +- Removed the -verbose-compat-notations flag and the corresponding Set + Verbose Compat vernacular, since these warnings can now be silenced or + turned into errors using "-w". + +XML protocol + +- message format has changed, see dev/doc/changes.txt for more details. + +Many bug fixes, minor changes and documentation improvements are not mentioned +here. + +Details of changes in 8.6 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Kernel + +- Fixed critical bug #5248 in VM long multiplication on 32-bit + architectures. Was there only since 8.6beta1, so no stable release impacted. + +Other bug fixes in universes, type class shelving,... + +Details of changes in 8.6.1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- Fix #5380: Default colors for CoqIDE are actually applied. +- Fix plugin warnings +- Document named evars (including Show ident) +- Fix Bug #5574, document function scope +- Adding a test case as requested in bug 5205. +- Fix Bug #5568, no dup notation warnings on repeated module imports +- Fix documentation of Typeclasses eauto := +- Refactor documentation of records. +- Protecting from warnings while compiling 8.6 +- Fixing an inconsistency between configure and configure.ml +- Add test-suite checks for coqchk with constraints +- Fix bug #5019 (looping zify on dependent types) +- Fix bug 5550: "typeclasses eauto with" does not work with section variables. +- Bug 5546, qualify datatype constructors when needed in Show Match +- Bug #5535, test for Show with -emacs +- Fix bug #5486, don't reverse ids in tuples +- Fixing #5522 (anomaly with free vars of pat) +- Fix bug #5526, don't check for nonlinearity in notation if printing only +- Fix bug #5255 +- Fix bug #3659: -time should understand multibyte encodings. +- FIx bug #5300: Anomaly: Uncaught exception Not_found" in "Print Assumptions". +- Fix outdated description in RefMan. +- Repairing `Set Rewriting Schemes` +- Fixing #5487 (v8.5 regression on ltac-matching expressions with evars). +- Fix description of command-line arguments for Add (Rec) LoadPath +- Fix bug #5377: @? patterns broken. +- add XML protocol doc +- Fix anomaly when doing [all:Check _.] during a proof. +- Correction of bug #4306 +- Fix #5435: [Eval native_compute in] raises anomaly. +- Instances should obey universe binders even when defined by tactics. +- Intern names bound in match patterns +- funind: Ignore missing info for current function +- Do not typecheck twice the type of opaque constants. +- show unused intro pattern warning +- [future] Be eager when "chaining" already resolved future values. +- Opaque side effects +- Fix #5132: coq_makefile generates incorrect install goal +- Run non-tactic comands without resilient_command +- Univs: fix bug #5365, generation of u+k <= v constraints +- make ``emit`` tail recursive +- Don't require printing-only notation to be productive +- Fix the way setoid_rewrite handles bindings. +- Fix for bug 5244 - set printing width ignored when given enough space +- Fix bug 4969, autoapply was not tagging shelved subgoals correctly + +Version 8.5 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.5 contains the result of five specific long-term projects: + +- A new asynchronous evaluation and compilation mode by Enrico Tassi + with help from Bruno Barras and Carst Tankink. + +- Full integration of the new proof engine by Arnaud Spiwack helped by + Pierre-Marie Pédrot, + +- Addition of conversion and reduction based on native compilation by + Maxime Dénès and Benjamin Grégoire. + +- Full universe polymorphism for definitions and inductive types by + Matthieu Sozeau. + +- An implementation of primitive projections with + :math:`\eta`\-conversion bringing significant performance improvements + when using records by Matthieu Sozeau. + +The full integration of the proof engine, by Arnaud Spiwack and +Pierre-Marie Pédrot, brings to primitive tactics and the user level Ltac +language dependent subgoals, deep backtracking and multiple goal +handling, along with miscellaneous features and an improved potential +for future modifications. Dependent subgoals allow statements in a goal +to mention the proof of another. Proofs of unsolved subgoals appear as +existential variables. Primitive backtracking makes it possible to write +a tactic with several possible outcomes which are tried successively +when subsequent tactics fail. Primitives are also available to control +the backtracking behavior of tactics. Multiple goal handling paves the +way for smarter automation tactics. It is currently used for simple goal +manipulation such as goal reordering. + +The way |Coq| processes a document in batch and interactive mode has been +redesigned by Enrico Tassi with help from Bruno Barras. Opaque proofs, +the text between Proof and Qed, can be processed asynchronously, +decoupling the checking of definitions and statements from the checking +of proofs. It improves the responsiveness of interactive development, +since proofs can be processed in the background. Similarly, compilation +of a file can be split into two phases: the first one checking only +definitions and statements and the second one checking proofs. A file +resulting from the first phase – with the .vio extension – can be +already Required. All .vio files can be turned into complete .vo files +in parallel. The same infrastructure also allows terminating tactics to +be run in parallel on a set of goals via the ``par:`` goal selector. + +|CoqIDE| was modified to cope with asynchronous checking of the document. +Its source code was also made separate from that of |Coq|, so that |CoqIDE| +no longer has a special status among user interfaces, paving the way for +decoupling its release cycle from that of |Coq| in the future. + +Carst Tankink developed a |Coq| back-end for user interfaces built on +Makarius Wenzel’s Prover IDE framework (PIDE), like PIDE/jEdit (with +help from Makarius Wenzel) or PIDE/Coqoon (with help from Alexander +Faithfull and Jesper Bengtson). The development of such features was +funded by the Paral-ITP French ANR project. + +The full universe polymorphism extension was designed by Matthieu +Sozeau. It conservatively extends the universes system and core calculus +with definitions and inductive declarations parameterized by universes +and constraints. It is based on a modification of the kernel +architecture to handle constraint checking only, leaving the generation +of constraints to the refinement/type inference engine. Accordingly, +tactics are now fully universe aware, resulting in more localized error +messages in case of inconsistencies and allowing higher-level algorithms +like unification to be entirely type safe. The internal representation +of universes has been modified but this is invisible to the user. + +The underlying logic has been extended with :math:`\eta`\-conversion for +records defined with primitive projections by Matthieu Sozeau. This +additional form of :math:`\eta`\-conversion is justified using the same +principle than the previously added :math:`\eta`\-conversion for function +types, based on formulations of the Calculus of Inductive Constructions +with typed equality. Primitive projections, which do not carry the +parameters of the record and are rigid names (not defined as a +pattern matching construct), make working with nested records more +manageable in terms of time and space consumption. This extension and +universe polymorphism were carried out partly while Matthieu Sozeau was +working at the IAS in Princeton. + +The guard condition has been made compliant with extensional equality +principles such as propositional extensionality and univalence, thanks +to Maxime Dénès and Bruno Barras. To ensure compatibility with the +univalence axiom, a new flag ``-indices-matter`` has been implemented, +taking into account the universe levels of indices when computing the +levels of inductive types. This supports using |Coq| as a tool to explore +the relations between homotopy theory and type theory. + +Maxime Dénès and Benjamin Grégoire developed an implementation of +conversion test and normal form computation using the OCaml native +compiler. It complements the virtual machine conversion offering much +faster computation for expensive functions. + +Coq 8.5 also comes with a bunch of many various smaller-scale changes +and improvements regarding the different components of the system. We +shall only list a few of them. + +Pierre Boutillier developed an improved tactic for simplification of +expressions called :tacn:`cbn`. + +Maxime Dénès maintained the bytecode-based reduction machine. Pierre +Letouzey maintained the extraction mechanism. + +Pierre-Marie Pédrot has extended the syntax of terms to, experimentally, +allow holes in terms to be solved by a locally specified tactic. + +Existential variables are referred to by identifiers rather than mere +numbers, thanks to Hugo Herbelin who also improved the tactic language +here and there. + +Error messages for universe inconsistencies have been improved by +Matthieu Sozeau. Error messages for unification and type inference +failures have been improved by Hugo Herbelin, Pierre-Marie Pédrot and +Arnaud Spiwack. + +Pierre Courtieu contributed new features for using |Coq| through Proof +General and for better interactive experience (bullets, Search, etc). + +The efficiency of the whole system has been significantly improved +thanks to contributions from Pierre-Marie Pédrot. + +A distribution channel for |Coq| packages using the OPAM tool has been +initiated by Thomas Braibant and developed by Guillaume Claret, with +contributions by Enrico Tassi and feedback from Hugo Herbelin. + +Packaging tools were provided by Pierre Letouzey and Enrico Tassi +(Windows), Pierre Boutillier, Matthieu Sozeau and Maxime Dénès (MacOS +X). Maxime Dénès improved significantly the testing and benchmarking +support. + +Many power users helped to improve the design of the new features via +the bug tracker, the coq development mailing list or the Coq-Club +mailing list. Special thanks are going to the users who contributed +patches and intensive brain-storming, starting with Jason Gross, +Jonathan Leivent, Greg Malecha, Clément Pit-Claudel, Marc Lasson, Lionel +Rieg. It would however be impossible to mention with precision all names +of people who to some extent influenced the development. + +Version 8.5 is one of the most important releases of |Coq|. Its development +spanned over about 3 years and a half with about one year of +beta-testing. General maintenance during part or whole of this period +has been done by Pierre Boutillier, Pierre Courtieu, Maxime Dénès, Hugo +Herbelin, Pierre Letouzey, Guillaume Melquiond, Pierre-Marie Pédrot, +Matthieu Sozeau, Arnaud Spiwack, Enrico Tassi as well as Bruno Barras, +Yves Bertot, Frédéric Besson, Xavier Clerc, Pierre Corbineau, +Jean-Christophe Filliâtre, Julien Forest, Sébastien Hinderer, Assia +Mahboubi, Jean-Marc Notin, Yann Régis-Gianas, François Ripault, Carst +Tankink. Maxime Dénès coordinated the release process. + +| Paris, January 2015, revised December 2015, +| Hugo Herbelin, Matthieu Sozeau and the |Coq| development team +| + +Potential sources of incompatibilities +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +List of typical changes to be done to adapt files from Coq 8.4 +to Coq 8.5 when not using compatibility option ``-compat 8.4``. + +- Symptom: "The reference omega was not found in the current environment". + + Cause: "Require Omega" does not import the tactic "omega" any more + + Possible solutions: + + + use "Require Import OmegaTactic" (not compatible with 8.4) + + use "Require Import Omega" (compatible with 8.4) + + add definition "Ltac omega := Coq.omega.Omega.omega." + +- Symptom: "intuition" cannot solve a goal (not working anymore on non standard connective) + + Cause: "intuition" had an accidental non uniform behavior fixed on non standard connectives + + Possible solutions: + + + use "dintuition" instead; it is stronger than "intuition" and works + uniformly on non standard connectives, such as n-ary conjunctions or disjunctions + (not compatible with 8.4) + + do the script differently + +- Symptom: The constructor foo (in type bar) expects n arguments. + + Cause: parameters must now be given in patterns + + Possible solutions: + + + use option "Set Asymmetric Patterns" (compatible with 8.4) + + add "_" for the parameters (not compatible with 8.4) + + turn the parameters into implicit arguments (compatible with 8.4) + +- Symptom: "NPeano.Nat.foo" not existing anymore\ + + Possible solutions: + + + use "Nat.foo" instead + + Symptom: typing problems with proj1_sig or similar + + Cause: coercion from sig to sigT and similar coercions have been + removed so as to make the initial state easier to understand for + beginners + + Solution: change proj1_sig into projT1 and similarly (compatible with 8.4) + +Other detailed changes + +- options for *coq* compilation (see below for ocaml). + + + [-I foo] is now deprecated and will not add directory foo to the + coq load path (only for ocaml, see below). Just replace [-I foo] by + [-Q foo ""] in your project file and re-generate makefile. Or + perform the same operation directly in your makefile if you edit it + by hand. + + + Option -R Foo bar is the same in v8.5 than in v8.4 concerning coq + load path. + + + Option [-I foo -as bar] is unchanged but discouraged unless you + compile ocaml code. Use -Q foo bar instead. + + for more details: see section "Customization at launch + time" of the reference manual. + +- Command line options for ocaml Compilation of ocaml code (plugins) + + + [-I foo] is *not* deprecated to add foo to the ocaml load path. + + + [-I foo -as bar] adds foo to the ocaml load path *and* adds foo to + the coq load path with logical name bar (shortcut for -I foo -Q foo + bar). + + for more details: section "Customization at launch + time" of the reference manual. + +- Universe Polymorphism. + +- Refinement, unification and tactics are now aware of universes, + resulting in more localized errors. Universe inconsistencies + should no more get raised at Qed time but during the proof. + Unification *always* produces well-typed substitutions, hence + some rare cases of unifications that succeeded while producing + ill-typed terms before will now fail. + +- The [change p with c] tactic semantics changed, now typechecking + [c] at each matching occurrence [t] of the pattern [p], and + converting [t] with [c]. + +- Template polymorphic inductive types: the partial application + of a template polymorphic type (e.g. list) is not polymorphic. + An explicit parameter application (e.g [fun A => list A]) or + [apply (list _)] will result in a polymorphic instance. + +- The type inference algorithm now takes opacity of constants into + account. This may have effects on tactics using type inference + (e.g. induction). Extra "Transparent" might have to be added to + revert opacity of constants. + +Type classes. + +- When writing an ``Instance foo : Class A := {| proj := t |}`` (note the + vertical bars), support for typechecking the projections using the + type information and switching to proof mode is no longer available. + Use ``{ }`` (without the vertical bars) instead. + +Tactic abstract. + +- Auxiliary lemmas generated by the abstract tactic are removed from + the global environment and inlined in the proof term when a proof + is ended with Qed. The behavior of 8.4 can be obtained by ending + proofs with "Qed exporting" or "Qed exporting ident, .., ident". + +Details of changes in 8.5beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Logic + +- Primitive projections for records allow for a compact representation + of projections, without parameters and avoid the behavior of defined + projections that can unfold to a case expression. To turn the use of + native projections on, use [Set Primitive Projections]. Record, + Class and Structure types defined while this option is set will be + defined with primitive projections instead of the usual encoding as + a case expression. For compatibility, when p is a primitive + projection, @p can be used to refer to the projection with explicit + parameters, i.e. [@p] is definitionally equal to [λ params r. r.(p)]. + Records with primitive projections have eta-conversion, the + canonical form being [mkR pars (p1 t) ... (pn t)]. +- New universe polymorphism (see reference manual) +- New option -type-in-type to collapse the universe hierarchy (this makes the + logic inconsistent). +- The guard condition for fixpoints is now a bit stricter. Propagation + of subterm value through pattern matching is restricted according to + the return predicate. Restores compatibility of Coq's logic with the + propositional extensionality axiom. May create incompatibilities in + recursive programs heavily using dependent types. +- Trivial inductive types are no longer defined in Type but in Prop, which + leads to a non-dependent induction principle being generated in place of + the dependent one. To recover the old behavior, explicitly define your + inductive types in Set. + +Vernacular commands + +- A command "Variant" allows to define non-recursive variant types. +- The command "Record foo ..." does not generate induction principles + (foo_rect, foo_rec, foo_ind) anymore by default (feature wish + #2693). The command "Variant foo ..." does not either. A flag + "Set/Unset Nonrecursive Elimination Schemes" allows changing this. + The tactic "induction" on a "Record" or a "Variant" is now actually + doing "destruct". +- The "Open Scope" command can now be given also a delimiter (e.g. Z). +- The "Definition" command now allows the "Local" modifier, allowing + for non-importable definitions. The same goes for "Axiom" and "Parameter". +- Section-specific commands such as "Let" (resp. "Variable", "Hypothesis") used + out of a section now behave like the corresponding "Local" command, i.e. + "Local Definition" (resp. "Local Parameter", "Local Axiom"). (potential source + of rare incompatibilities). +- The "Let" command can now define local (co)fixpoints. +- Command "Search" has been renamed into "SearchHead". The command + name "Search" now behaves like former "SearchAbout". The latter name + is deprecated. +- "Search", "About", "SearchHead", "SearchRewrite" and "SearchPattern" + now search for hypothesis (of the current goal by default) first. + They now also support the goal selector prefix to specify another + goal to search: e.g. "n:Search id". This is also true for + SearchAbout although it is deprecated. +- The coq/user-contrib directory and the XDG directories are no longer + recursively added to the load path, so files from installed libraries + now need to be fully qualified for the "Require" command to find them. + The tools/update-require script can be used to convert a development. +- A new Print Strategies command allows visualizing the opacity status + of the whole engine. +- The "Locate" command now searches through all sorts of qualified namespaces of + Coq: terms, modules, tactics, etc. The old behavior of the command can be + retrieved using the "Locate Term" command. +- New "Derive" command to help writing program by derivation. +- New "Refine Instance Mode" option that allows to deactivate the generation of + obligations in incomplete typeclass instances, raising an error instead. +- "Collection" command to name sets of section hypotheses. Named collections + can be used in the syntax of "Proof using" to assert which section variables + are used in a proof. +- The "Optimize Proof" command can be placed in the middle of a proof to + force the compaction of the data structure used to represent the ongoing + proof (evar map). This may result in a lower memory footprint and speed up + the execution of the following tactics. +- "Optimize Heap" command to tell the OCaml runtime to perform a major + garbage collection step and heap compaction. +- ``Instance`` no longer treats the ``{|...|}`` syntax specially; it handles it + in the same way as other commands, e.g. "Definition". Use the ``{...}`` + syntax (no pipe symbols) to recover the old behavior. + +Specification Language + +- Slight changes in unification error messages. +- Added a syntax $(...)$ that allows putting tactics in terms (may + break user notations using "$(", fixable by inserting a space or + rewriting the notation). +- Constructors in pattern-matching patterns now respect the same rules + regarding implicit arguments as in applicative position. The old + behavior can be recovered by the command "Set Asymmetric + Patterns". As a side effect, notations for constructors explicitly + mentioning non-implicit parameters can now be used in patterns. + Considering that the pattern language is already rich enough, binding + local definitions is however now forbidden in patterns (source of + incompatibilities for local definitions that delta-reduce to a constructor). +- Type inference algorithm now granting opacity of constants. This might also + affect behavior of tactics (source of incompatibilities, solvable by + re-declaring transparent constants which were set opaque). +- Existential variables are now referred to by an identifier and the + relevant part of their instance is displayed by default. They can be + reparsed. The naming policy is yet unstable and subject to changes + in future releases. + +Tactics + +- New tactic engine allowing dependent subgoals, fully backtracking + (also known as multiple success) tactics, as well as tactics which + can consider multiple goals together. In the new tactic engine, + instantiation information of existential variables is always + propagated to tactics, removing the need to manually use the + "instantiate" tactics to mark propagation points. + + * New tactical (a+b) inserts a backtracking point. When (a+b);c fails + during the execution of c, it can backtrack and try b instead of a. + * New tactical (once a) removes all the backtracking points from a + (i.e. it selects the first success of a). + * Tactic "constructor" is now fully backtracking. In case of + incompatibilities (e.g. combinatoric explosion), the former + behavior of "constructor" can be retrieved by using instead + "[> once constructor ..]". Thanks to backtracking, undocumented + "constructor <tac>" syntax is now equivalent to + "[> once (constructor; tac) ..]". + * New "multimatch" variant of "match" tactic which backtracks to + new branches in case of a later failure. The "match" tactic is + equivalent to "once multimatch". + * New selector "all:" such that "all:tac" applies tactic "tac" to + all the focused goals, instead of just the first one as is the + default. + * A corresponding new option Set Default Goal Selector "all" makes + the tactics in scripts be applied to all the focused goal by default + * New selector "par:" such that "par:tac" applies the (terminating) + tactic "tac" to all the focused goal in parallel. The number of worker + can be selected with -async-proofs-tac-j and also limited using the + coqworkmgr utility. + * New tactics "revgoals", "cycle" and "swap" to reorder goals. + * The semantics of recursive tactics (introduced with "Ltac t := ..." + or "let rec t := ... in ...") changed slightly as t is now + applied to every goal, not each goal independently. In particular + it may be applied when no goals are left. This may cause tactics + such as "let rec t := constructor;t" to loop indefinitely. The + simple fix is to rewrite the recursive calls as follows: + "let rec t := constructor;[t..]" which recovers the earlier behavior + (source of rare incompatibilities). + * New tactic language feature "numgoals" to count number of goals. It is + accompanied by a "guard" tactic which fails if a Boolean test over + integers does not pass. + * New tactical "[> ... ]" to apply tactics to individual goals. + * New tactic "gfail" which works like "fail" except it will also + fail if every goal has been solved. + * The refine tactic is changed not to use an ad hoc typing algorithm + to generate subgoals. It also uses the dependent subgoal feature + to generate goals to materialize every existential variable which + is introduced by the refinement (source of incompatibilities). + * A tactic shelve is introduced to manage the subgoals which may be + solved by unification: shelve removes every goal it is applied to + from focus. These goals can later be called back into focus by the + Unshelve command. + * A variant shelve_unifiable only removes those goals which appear + as existential variables in other goals. To emulate the old + refine, use "refine c;shelve_unifiable". This can still cause + incompatibilities in rare occasions. + * New "give_up" tactic to skip over a goal. A proof containing + given up goals cannot be closed with "Qed", but only with "Admitted". + +- The implementation of the admit tactic has changed: no axiom is + generated for the admitted sub proof. "admit" is now an alias for + "give_up". Code relying on this specific behavior of "admit" + can be made to work by: + + * Adding an "Axiom" for each admitted subproof. + * Adding a single "Axiom proof_admitted : False." and the Ltac definition + "Ltac admit := case proof_admitted.". + +- Matching using "lazymatch" was fundamentally modified. It now behaves + like "match" (immediate execution of the matching branch) but without + the backtracking mechanism in case of failure. + +- New "tryif t then u else v" tactical which executes "u" in case of success + of "t" and "v" in case of failure. + +- New conversion tactic "native_compute": evaluates the goal (or an hypothesis) + with a call-by-value strategy, using the OCaml native compiler. Useful on + very intensive computations. + +- New "cbn" tactic, a well-behaved simpl. + +- Repeated identical calls to omega should now produce identical proof terms. + +- Tactics btauto, a reflexive Boolean tautology solver. + +- Tactic "tauto" was exceptionally able to destruct other connectives + than the binary connectives "and", "or", "prod", "sum", "iff". This + non-uniform behavior has been fixed (bug #2680) and tauto is + slightly weaker (possible source of incompatibilities). On the + opposite side, new tactic "dtauto" is able to destruct any + record-like inductive types, superseding the old version of "tauto". + +- Similarly, "intuition" has been made more uniform and, where it now + fails, "dintuition" can be used (possible source of incompatibilities). + +- New option "Unset Intuition Negation Unfolding" for deactivating automatic + unfolding of "not" in intuition. + +- Tactic notations can now be defined locally to a module (use "Local" prefix). + +- Tactic "red" now reduces head beta-iota redexes (potential source of + rare incompatibilities). + +- Tactic "hnf" now reduces inner beta-iota redexes + (potential source of rare incompatibilities). + +- Tactic "intro H" now reduces beta-iota redexes if these hide a product + (potential source of rare incompatibilities). + +- In Ltac matching on patterns of the form "_ pat1 ... patn" now + behaves like if matching on "?X pat1 ... patn", i.e. accepting "_" + to be instantiated by an applicative term (experimental at this + stage, potential source of incompatibilities). + +- In Ltac matching on goal, types of hypotheses are now interpreted in + the %type scope (possible source of incompatibilities). + +- "change ... in ..." and "simpl ... in ..." now properly consider nested + occurrences (possible source of incompatibilities since this alters + the numbering of occurrences), but do not support nested occurrences. + +- Tactics simpl, vm_compute and native_compute can be given a notation string + to a constant as argument. + +- When given a reference as argument, simpl, vm_compute and + native_compute now strictly interpret it as the head of a pattern + starting with this reference. + +- The "change p with c" tactic semantics changed, now type-checking + "c" at each matching occurrence "t" of the pattern "p", and + converting "t" with "c". + +- Now "appcontext" and "context" behave the same. The old buggy behavior of + "context" can be retrieved at parse time by setting the + "Tactic Compat Context" flag (possible source of incompatibilities). + +- New introduction pattern p/c which applies lemma c on the fly on the + hypothesis under consideration before continuing with introduction pattern p. + +- New introduction pattern [= x1 .. xn] applies "injection as [x1 .. xn]" + on the fly if injection is applicable to the hypothesis under consideration + (idea borrowed from Georges Gonthier). Introduction pattern [=] applies + "discriminate" if a discriminable equality. + +- New introduction patterns * and ** to respectively introduce all forthcoming + dependent variables and all variables/hypotheses dependent or not. + +- Tactic "injection c as ipats" now clears c if c refers to an + hypothesis and moves the resulting equations in the hypotheses + independently of the number of ipats, which has itself to be less + than the number of new hypotheses (possible source of incompatibilities; + former behavior obtainable by "Unset Injection L2R Pattern Order"). + +- Tactic "injection" now automatically simplifies subgoals + "existT n p = existT n p'" into "p = p'" when "n" is in an inductive type for + which a decidable equality scheme has been generated with "Scheme Equality" + (possible source of incompatibilities). + +- New tactic "rewrite_strat" for generalized rewriting with user-defined + strategies, subsuming autorewrite. + +- Injection can now also deduce equality of arguments of sort Prop, by using + the option "Set Injection On Proofs" (disabled by default). Also improved the + error messages. + +- Tactic "subst id" now supports id occurring in dependent local definitions. + +- Bugs fixed about intro-pattern "*" might lead to some rare incompatibilities. + +- New tactical "time" to display time spent executing its argument. + +- Tactics referring or using a constant dependent in a section variable which + has been cleared or renamed in the current goal context now fail + (possible source of incompatibilities solvable by avoiding clearing + the relevant hypotheses). + +- New construct "uconstr:c" and "type_term c" to build untyped terms. + +- Binders in terms defined in Ltac (either "constr" or "uconstr") can + now take their names from identifiers defined in Ltac. As a + consequence, a name cannot be used in a binder "constr:(fun x => + ...)" if an Ltac variable of that name already exists and does not + contain an identifier. Source of occasional incompatibilities. + +- The "refine" tactic now accepts untyped terms built with "uconstr" + so that terms with holes can be constructed piecewise in Ltac. + +- New bullets --, ++, **, ---, +++, ***, ... made available. + +- More informative messages when wrong bullet is used. + +- Bullet suggestion when a subgoal is solved. + +- New tactic "enough", symmetric to "assert", but with subgoals + swapped, as a more friendly replacement of "cut". + +- In destruct/induction, experimental modifier "!" prefixing the + hypothesis name to tell not erasing the hypothesis. + +- Bug fixes in "inversion as" may occasionally lead to incompatibilities. + +- Behavior of introduction patterns -> and <- made more uniform + (hypothesis is cleared, rewrite in hypotheses and conclusion and + erasing the variable when rewriting a variable). + +- New experimental option "Set Standard Proposition Elimination Names" + so that case analysis or induction on schemes in Type containing + propositions now produces "H"-based names. + +- Tactics from plugins are now active only when the corresponding module + is imported (source of incompatibilities, solvable by adding an "Import"; + in the particular case of Omega, use "Require Import OmegaTactic"). + +- Semantics of destruct/induction has been made more regular in some + edge cases, possibly leading to incompatibilities: + + + new goals are now opened when the term does not match a subterm of + the goal and has unresolved holes, while in 8.4 these holes were + turned into existential variables + + when no "at" option is given, the historical semantics which + selects all subterms syntactically identical to the first subterm + matching the given pattern is used + + non-dependent destruct/induction on an hypothesis with premises in + an inductive type with indices is fixed + + residual local definitions are now correctly removed. + +- The rename tactic may now replace variables in parallel. + +- A new "Info" command replaces the "info" tactical discontinued in + v8.4. It still gives informative results in many cases. + +- The "info_auto" tactic is known to be broken and does not print a + trace anymore. Use "Info 1 auto" instead. The same goes for + "info_trivial". On the other hand "info_eauto" still works fine, + while "Info 1 eauto" prints a trivial trace. + +- When using a lemma of the prototypical form "forall A, {a:A & P a}", + "apply" and "apply in" do not instantiate anymore "A" with the + current goal and use "a" as the proof, as they were sometimes doing, + now considering that it is a too powerful decision. + +Program + +- "Solve Obligations using" changed to "Solve Obligations with", + consistent with "Proof with". +- Program Lemma, Definition now respect automatic introduction. +- Program Lemma, Definition, etc.. now interpret "->" like Lemma and + Definition as a non-dependent arrow (potential source of + incompatibility). +- Add/document "Set Hide Obligations" (to hide obligations in the final + term inside an implicit argument) and "Set Shrink Obligations" (to + minimize dependencies of obligations defined by tactics). + +Notations + +- The syntax "x -> y" is now declared at level 99. In particular, it has + now a lower priority than "<->": "A -> B <-> C" is now "A -> (B <-> C)" + (possible source of incompatibilities) +- Notations accept term-providing tactics using the $(...)$ syntax. +- "Bind Scope" can no longer bind "Funclass" and "Sortclass". +- A notation can be given a (compat "8.x") annotation, making it behave + like a "only parsing" notation, but the annotation may lead to eventually + issue warnings or errors in further versions when this notation is used. +- More systematic insertion of spaces as a default for printing + notations ("format" still available to override the default). +- In notations, a level modifier referring to a non-existent variable is + now considered an error rather than silently ignored. + +Tools + +- Option -I now only adds directories to the ml path. +- Option -Q behaves as -R, except that the logical path of any loaded file has + to be fully qualified. +- Option -R no longer adds recursively to the ml path; only the root + directory is added. (Behavior with respect to the load path is + unchanged.) +- Option -nois prevents coq/theories and coq/plugins to be recursively + added to the load path. (Same behavior as with coq/user-contrib.) +- coqdep accepts a -dumpgraph option generating a dot file. +- Makefiles generated through coq_makefile have three new targets "quick" + "checkproofs" and "vio2vo", allowing respectively to asynchronously compile + the files without playing the proof scripts, asynchronously checking + that the quickly generated proofs are correct and generating the object + files from the quickly generated proofs. +- The XML plugin was discontinued and removed from the source. +- A new utility called coqworkmgr can be used to limit the number of + concurrent workers started by independent processes, like make and CoqIDE. + This is of interest for users of the par: goal selector. + +Interfaces + +- CoqIDE supports asynchronous edition of the document, ongoing tasks and + errors are reported in the bottom right window. The number of workers + taking care of processing proofs can be selected with -async-proofs-j. +- CoqIDE highlights in yellow "unsafe" commands such as axiom + declarations, and tactics like "give_up". +- CoqIDE supports Proof General like key bindings; + to activate the PG mode go to Edit -> Preferences -> Editor. + For the documentation see Help -> Help for PG mode. +- CoqIDE automatically retracts the locked area when one edits the + locked text. +- CoqIDE search and replace got regular expressions power. See the + documentation of OCaml's Str module for the supported syntax. +- Many CoqIDE windows, including the query one, are now detachable to + improve usability on multi screen work stations. +- Coqtop/coqc outputs highlighted syntax. Colors can be configured thanks + to the COQ_COLORS environment variable, and their current state can + be displayed with the -list-tags command line option. +- Third party user interfaces can install their main loop in $COQLIB/toploop + and call coqtop with the -toploop flag to select it. + +Internal Infrastructure + +- Many reorganizations in the ocaml source files. For instance, + many internal a.s.t. of Coq are now placed in mli files in + a new directory intf/, for instance constrexpr.mli or glob_term.mli. + More details in dev/doc/changes. + +- The file states/initial.coq does not exist anymore. Instead, coqtop + initially does a "Require" of Prelude.vo (or nothing when given + the options -noinit or -nois). + +- The format of vo files has slightly changed: cf final comments in + checker/cic.mli. + +- The build system does not produce anymore programs named coqtop.opt + and a symbolic link to coqtop. Instead, coqtop is now directly + an executable compiled with the best OCaml compiler available. + The bytecode program coqtop.byte is still produced. Same for other + utilities. + +- Some options of the ./configure script slightly changed: + + * The -coqrunbyteflags and its blank-separated argument is replaced + by option -vmbyteflags which expects a comma-separated argument. + * The -coqtoolsbyteflags option is discontinued, see -no-custom instead. + +Miscellaneous + +- ML plugins now require a "DECLARE PLUGIN \"foo\"" statement. The "foo" name + must be exactly the name of the ML module that will be loaded through a + "Declare ML \"foo\"" command. + +Details of changes in 8.5beta2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Logic + +- The VM now supports inductive types with up to 8388851 non-constant + constructors and up to 8388607 constant ones. + +Specification language + +- Syntax "$(tactic)$" changed to "ltac: tactic". + +Tactics + +- A script using the admit tactic can no longer be concluded by either + Qed or Defined. In the first case, Admitted can be used instead. In + the second case, a subproof should be used. +- The easy tactic and the now tactical now have a more predictable + behavior, but they might now discharge some previously unsolved goals. + +Extraction + +- Definitions extracted to Haskell GHC should no longer randomly + segfault when some Coq types cannot be represented by Haskell types. +- Definitions can now be extracted to Json for post-processing. + +Tools + +- Option -I -as has been removed, and option -R -as has been + deprecated. In both cases, option -R can be used instead. +- coq_makefile now generates double-colon rules for rules such as clean. + +API + +- The interface of [change] has changed to take a [change_arg], which + can be built from a [constr] using [make_change_arg]. + +Details of changes in 8.5beta3 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Vernacular commands + +- New command "Redirect" to redirect the output of a command to a file. +- New command "Undelimit Scope" to remove the delimiter of a scope. +- New option "Strict Universe Declaration", set by default. It enforces the + declaration of all polymorphic universes appearing in a definition when + introducing it. +- New command "Show id" to show goal named id. +- Option "Virtual Machine" removed. + +Tactics + +- New flag "Regular Subst Tactic" which fixes "subst" in situations where + it failed to substitute all substitutable equations or failed to simplify + cycles, or accidentally unfolded local definitions (flag is off by default). +- New flag "Loose Hint Behavior" to handle hints loaded but not imported in a + special way. It accepts three distinct flags: + * "Lax", which is the default one, sets the old behavior, i.e. a non-imported + hint behaves the same as an imported one. + * "Warn" outputs a warning when a non-imported hint is used. Note that this is + an over-approximation, because a hint may be triggered by an eauto run that + will eventually fail and backtrack. + * "Strict" changes the behavior of an unloaded hint to the one of the fail + tactic, allowing to emulate the hopefully future import-scoped hint mechanism. +- New compatibility flag "Universal Lemma Under Conjunction" which + let tactics working under conjunctions apply sublemmas of the form + "forall A, ... -> A". +- New compatibility flag "Bracketing Last Introduction Pattern" which can be + set so that the last disjunctive-conjunctive introduction pattern given to + "intros" automatically complete the introduction of its subcomponents, as the + the disjunctive-conjunctive introduction patterns in non-terminal position + already do. +- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract + tactical w.r.t. variables appearing in the body of the proof. + +Program + +- The "Shrink Obligations" flag now applies to all obligations, not only those + solved by the automatic tactic. +- Importing Program no longer overrides the "exists" tactic (potential source + of incompatibilities). +- Hints costs are now correctly taken into account (potential source of + incompatibilities). +- Documented the Hint Cut command that allows control of the + proof-search during typeclass resolution (see reference manual). + +API + +- Some functions from pretyping/typing.ml and their derivatives were potential + source of evarmap leaks, as they dropped their resulting evarmap. The + situation was clarified by renaming them according to a ``unsafe_*`` scheme. Their + sound variant is likewise renamed to their old name. The following renamings + were made. + + * ``Typing.type_of`` -> ``unsafe_type_of`` + * ``Typing.e_type_of`` -> ``type_of`` + * A new ``e_type_of`` function that matches the ``e_`` prefix policy + * ``Tacmach.pf_type_of`` -> ``pf_unsafe_type_of`` + * A new safe ``pf_type_of`` function. + + All uses of ``unsafe_*`` functions should be eventually eliminated. + +Tools + +- Added an option -w to control the output of coqtop warnings. +- Configure now takes an optional -native-compiler (yes|no) flag replacing + -no-native-compiler. The new flag is set to no by default under Windows. +- Flag -no-native-compiler was removed and became the default for coqc. If + precompilation of files for native conversion test is desired, use + -native-compiler. +- The -compile command-line option now takes the full path of the considered + file, including the ".v" extension, and outputs a warning if such an extension + is lacking. +- The -require and -load-vernac-object command-line options now take a logical + path of a given library rather than a physical path, thus they behave like + Require [Import] path. +- The -vm command-line option has been removed. + +Standard Library + + - There is now a Coq.Compat.Coq84 library, which sets the various compatibility + options and does a few redefinitions to make Coq behave more like Coq v8.4. + The standard way of putting Coq in v8.4 compatibility mode is to pass the command + line flags "-require Coq.Compat.Coq84 -compat 8.4". + +Details of changes in 8.5 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Tools + +- Flag "-compat 8.4" now loads Coq.Compat.Coq84. The standard way of + putting Coq in v8.4 compatibility mode is to pass the command line flag + "-compat 8.4". It can be followed by "-require Coq.Compat.AdmitAxiom" + if the 8.4 behavior of admit is needed, in which case it uses an axiom. + +Specification language + +- Syntax "$(tactic)$" changed to "ltac:(tactic)". + +Tactics + +- Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly + for induction (rare source of incompatibilities easily solvable by + removing parentheses around "hyp" when not for the purpose of keeping + the hypothesis). +- Syntax "p/c" for on-the-fly application of a lemma c before + introducing along pattern p changed to p%c1..%cn. The feature and + syntax are in experimental stage. +- "Proof using" does not clear unused section variables. +- Tactic "refine" has been changed back to the 8.4 behavior of shelving subgoals + that occur in other subgoals. The "refine" tactic of 8.5beta3 has been + renamed "simple refine"; it does not shelve any subgoal. +- New tactical "unshelve tac" which grab existential variables put on + the tactic shelve by the execution of "tac". + +Details of changes in 8.5pl1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Critical bugfix + +- The subterm relation for the guard condition was incorrectly defined on + primitive projections (#4588) + +Plugin development tools + +- add a .merlin target to the makefile + +Various performance improvements (time, space used by .vo files) + +Other bugfixes + +- Fix order of arguments to Big.compare_case in ExtrOcamlZBigInt.v +- Added compatibility coercions from Specif.v which were present in Coq 8.4. +- Fixing a source of inefficiency and an artificial dependency in the printer in the congruence tactic. +- Allow to unset the refinement mode of Instance in ML +- Fixing an incorrect use of prod_appvect on a term which was not a product in setoid_rewrite. +- Add -compat 8.4 econstructor tactics, and tests +- Add compatibility Nonrecursive Elimination Schemes +- Fixing the "No applicable tactic" non informative error message regression on apply. +- Univs: fix get_current_context (bug #4603, part I) +- Fix a bug in Program coercion code +- Fix handling of arity of definitional classes. +- #4630: Some tactics are 20x slower in 8.5 than 8.4. +- #4627: records with no declared arity can be template polymorphic. +- #4623: set tactic too weak with universes (regression) +- Fix incorrect behavior of CS resolution +- #4591: Uncaught exception in directory browsing. +- CoqIDE is more resilient to initialization errors. +- #4614: "Fully check the document" is uninterruptable. +- Try eta-expansion of records only on non-recursive ones +- Fix bug when a sort is ascribed to a Record +- Primitive projections: protect kernel from erroneous definitions. +- Fixed bug #4533 with previous Keyed Unification commit +- Win: kill unreliable hence do not waitpid after kill -9 (Close #4369) +- Fix strategy of Keyed Unification +- #4608: Anomaly "output_value: abstract value (outside heap)". +- #4607: do not read native code files if native compiler was disabled. +- #4105: poor escaping in the protocol between CoqIDE and coqtop. +- #4596: [rewrite] broke in the past few weeks. +- #4533 (partial): respect declared global transparency of projections in unification.ml +- #4544: Backtrack on using full betaiota reduction during keyed unification. +- #4540: CoqIDE bottom progress bar does not update. +- Fix regression from 8.4 in reflexivity +- #4580: [Set Refine Instance Mode] also used for Program Instance. +- #4582: cannot override notation [ x ]. MAY CREATE INCOMPATIBILITIES, see #4683. +- STM: Print/Extraction have to be skipped if -quick +- #4542: CoqIDE: STOP button also stops workers +- STM: classify some variants of Instance as regular `` `Fork `` nodes. +- #4574: Anomaly: Uncaught exception Invalid_argument("splay_arity"). +- Do not give a name to anonymous evars anymore. See bug #4547. +- STM: always stock in vio files the first node (state) of a proof +- STM: not delegate proofs that contain Vernac(Module|Require|Import), #4530 +- Don't fail fatally if PATH is not set. +- #4537: Coq 8.5 is slower in typeclass resolution. +- #4522: Incorrect "Warning..." on windows. +- #4373: coqdep does not know about .vio files. +- #3826: "Incompatible module types" is uninformative. +- #4495: Failed assertion in metasyntax.ml. +- #4511: evar tactic can create non-typed evars. +- #4503: mixing universe polymorphic and monomorphic variables and definitions in sections is unsupported. +- #4519: oops, global shadowed local universe level bindings. +- #4506: Anomaly: File "pretyping/indrec.ml", line 169, characters 14-20: Assertion failed. +- #4548: Coqide crashes when going back one command + +Details of changes in 8.5pl2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Critical bugfix + +- Checksums of .vo files dependencies were not correctly checked. +- Unicode-to-ASCII translation was not injective, leading in a soundness bug in + the native compiler. + +Other bugfixes + +- #4097: more efficient occur-check in presence of primitive projections +- #4398: type_scope used consistently in "match goal". +- #4450: eauto does not work with polymorphic lemmas +- #4677: fix alpha-conversion in notations needing eta-expansion. +- Fully preserve initial order of hypotheses in "Regular Subst Tactic" mode. +- #4644: a regression in unification. +- #4725: Function (Error: Conversion test raised an anomaly) and Program + (Error: Cannot infer this placeholder of type) +- #4747: Problem building Coq 8.5pl1 with OCaml 4.03.0: Fatal warnings +- #4752: CoqIDE crash on files not ended by ".v". +- #4777: printing inefficiency with implicit arguments +- #4818: "Admitted" fails due to undefined universe anomaly after calling + "destruct" +- #4823: remote counter: avoid thread race on sockets +- #4841: -verbose flag changed semantics in 8.5, is much harder to use +- #4851: [nsatz] cannot handle duplicated hypotheses +- #4858: Anomaly: Uncaught exception Failure("hd"). Please report. in variant + of nsatz +- #4880: [nsatz_compute] generates invalid certificates if given redundant + hypotheses +- #4881: synchronizing "Declare Implicit Tactic" with backtrack. +- #4882: anomaly with Declare Implicit Tactic on hole of type with evars +- Fix use of "Declare Implicit Tactic" in refine. + triggered by CoqIDE +- #4069, #4718: congruence fails when universes are involved. + +Universes + +- Disallow silently dropping universe instances applied to variables + (forward compatible) +- Allow explicit universe instances on notations, when they can apply + to the head reference of their expansion. + +Build infrastructure + +- New update on how to find camlp5 binary and library at configure time. + +Details of changes in 8.5pl3 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Critical bugfix + +- #4876: Guard checker incompleteness when using primitive projections + +Other bugfixes + +- #4780: Induction with universe polymorphism on was creating ill-typed terms. +- #4673: regression in setoid_rewrite, unfolding let-ins for type unification. +- #4754: Regression in setoid_rewrite, allow postponed unification problems to remain. +- #4769: Anomaly with universe polymorphic schemes defined inside sections. +- #3886: Program: duplicate obligations of mutual fixpoints. +- #4994: Documentation typo. +- #5008: Use the "md5" command on OpenBSD. +- #5007: Do not assume the "TERM" environment variable is always set. +- #4606: Output a break before a list only if there was an empty line. +- #5001: metas not cleaned properly in clenv_refine_in. +- #2336: incorrect glob data for module symbols (bug #2336). +- #4832: Remove extraneous dot in error message. +- Anomaly in printing a unification error message. +- #4947: Options which take string arguments are not backwards compatible. +- #4156: micromega cache files are now hidden files. +- #4871: interrupting par:abstract kills coqtop. +- #5043: [Admitted] lemmas pick up section variables. +- Fix name of internal refine ("simple refine"). +- #5062: probably a typo in Strict Proofs mode. +- #5065: Anomaly: Not a proof by induction. +- Restore native compiler optimizations, they were disabled since 8.5! +- #5077: failure on typing a fixpoint with evars in its type. +- Fix recursive notation bug. +- #5095: non relevant too strict test in let-in abstraction. +- Ensuring that the evar name is preserved by "rename". +- #4887: confusion between using and with in documentation of firstorder. +- Bug in subst with let-ins. +- #4762: eauto weaker than auto. +- Remove if_then_else (was buggy). Use tryif instead. +- #4970: confusion between special "{" and non special "{{" in notations. +- #4529: primitive projections unfolding. +- #4416: Incorrect "Error: Incorrect number of goals". +- #4863: abstract in typeclass hint fails. +- #5123: unshelve can impact typeclass resolution +- Fix a collision about the meta-variable ".." in recursive notations. +- Fix printing of info_auto. +- #3209: Not_found due to an occur-check cycle. +- #5097: status of evars refined by "clear" in ltac: closed wrt evars. +- #5150: Missing dependency of the test-suite subsystems in prerequisite. +- Fix a bug in error printing of unif constraints +- #3941: Do not stop propagation of signals when Coq is busy. +- #4822: Incorrect assertion in cbn. +- #3479 parsing of "{" and "}" when a keyword starts with "{" or "}". +- #5127: Memory corruption with the VM. +- #5102: bullets parsing broken by calls to parse_entry. + +Various documentation improvements + +Version 8.4 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.4 contains the result of three long-term projects: a new +modular library of arithmetic by Pierre Letouzey, a new proof engine by +Arnaud Spiwack and a new communication protocol for |CoqIDE| by Vincent +Gross. + +The new modular library of arithmetic extends, generalizes and unifies +the existing libraries on Peano arithmetic (types nat, N and BigN), +positive arithmetic (type positive), integer arithmetic (Z and BigZ) and +machine word arithmetic (type Int31). It provides with unified notations +(e.g. systematic use of add and mul for denoting the addition and +multiplication operators), systematic and generic development of +operators and properties of these operators for all the types mentioned +above, including gcd, pcm, power, square root, base 2 logarithm, +division, modulo, bitwise operations, logical shifts, comparisons, +iterators, ... + +The most visible feature of the new proof engine is the support for +structured scripts (bullets and proof brackets) but, even if yet not +user-available, the new engine also provides the basis for refining +existential variables using tactics, for applying tactics to several +goals simultaneously, for reordering goals, all features which are +planned for the next release. The new proof engine forced Pierre Letouzey +to reimplement info and Show Script differently. + +Before version 8.4, |CoqIDE| was linked to |Coq| with the graphical +interface living in a separate thread. From version 8.4, |CoqIDE| is a +separate process communicating with |Coq| through a textual channel. This +allows for a more robust interfacing, the ability to interrupt |Coq| +without interrupting the interface, and the ability to manage several +sessions in parallel. Relying on the infrastructure work made by Vincent +Gross, Pierre Letouzey, Pierre Boutillier and Pierre-Marie Pédrot +contributed many various refinements of |CoqIDE|. + +Coq 8.4 also comes with a bunch of various smaller-scale changes +and improvements regarding the different components of the system. + +The underlying logic has been extended with :math:`\eta`-conversion +thanks to Hugo Herbelin, Stéphane Glondu and Benjamin Grégoire. The +addition of :math:`\eta`-conversion is justified by the confidence that +the formulation of the Calculus of Inductive Constructions based on +typed equality (such as the one considered in Lee and Werner to build a +set-theoretic model of CIC :cite:`LeeWerner11`) is +applicable to the concrete implementation of |Coq|. + +The underlying logic benefited also from a refinement of the guard +condition for fixpoints by Pierre Boutillier, the point being that it is +safe to propagate the information about structurally smaller arguments +through :math:`\beta`-redexes that are blocked by the “match†+construction (blocked commutative cuts). + +Relying on the added permissiveness of the guard condition, Hugo +Herbelin could extend the pattern matching compilation algorithm so that +matching over a sequence of terms involving dependencies of a term or of +the indices of the type of a term in the type of other terms is +systematically supported. + +Regarding the high-level specification language, Pierre Boutillier +introduced the ability to give implicit arguments to anonymous +functions, Hugo Herbelin introduced the ability to define notations with +several binders (e.g. ``exists x y z, P``), Matthieu Sozeau made the +typeclass inference mechanism more robust and predictable, Enrico +Tassi introduced a command Arguments that generalizes Implicit Arguments +and Arguments Scope for assigning various properties to arguments of +constants. Various improvements in the type inference algorithm were +provided by Matthieu Sozeau and Hugo Herbelin with contributions from +Enrico Tassi. + +Regarding tactics, Hugo Herbelin introduced support for referring to +expressions occurring in the goal by pattern in tactics such as set or +destruct. Hugo Herbelin also relied on ideas from Chung-Kil Hur’s Heq +plugin to introduce automatic computation of occurrences to generalize +when using destruct and induction on types with indices. Stéphane Glondu +introduced new tactics :tacn:`constr_eq`, :tacn:`is_evar`, and :tacn:`has_evar`, to be used +when writing complex tactics. Enrico Tassi added support to fine-tuning +the behavior of :tacn:`simpl`. Enrico Tassi added the ability to specify over +which variables of a section a lemma has to be exactly generalized. +Pierre Letouzey added a tactic timeout and the interruptibility of +:tacn:`vm_compute`. Bug fixes and miscellaneous improvements of the tactic +language came from Hugo Herbelin, Pierre Letouzey and Matthieu Sozeau. + +Regarding decision tactics, Loïc Pottier maintained nsatz, moving in +particular to a typeclass based reification of goals while Frédéric +Besson maintained Micromega, adding in particular support for division. + +Regarding vernacular commands, Stéphane Glondu provided new commands to +analyze the structure of type universes. + +Regarding libraries, a new library about lists of a given length (called +vectors) has been provided by Pierre Boutillier. A new instance of +finite sets based on Red-Black trees and provided by Andrew Appel has +been adapted for the standard library by Pierre Letouzey. In the library +of real analysis, Yves Bertot changed the definition of :math:`\pi` and +provided a proof of the long-standing fact yet remaining unproved in +this library, namely that :math:`sin \frac{\pi}{2} = +1`. + +Pierre Corbineau maintained the Mathematical Proof Language (C-zar). + +Bruno Barras and Benjamin Grégoire maintained the call-by-value +reduction machines. + +The extraction mechanism benefited from several improvements provided by +Pierre Letouzey. + +Pierre Letouzey maintained the module system, with contributions from +Élie Soubiran. + +Julien Forest maintained the Function command. + +Matthieu Sozeau maintained the setoid rewriting mechanism. + +Coq related tools have been upgraded too. In particular, coq\_makefile +has been largely revised by Pierre Boutillier. Also, patches from Adam +Chlipala for coqdoc have been integrated by Pierre Boutillier. + +Bruno Barras and Pierre Letouzey maintained the `coqchk` checker. + +Pierre Courtieu and Arnaud Spiwack contributed new features for using +Coq through Proof General. + +The Dp plugin has been removed. Use the plugin provided with Why 3 +instead (http://why3.lri.fr/). + +Under the hood, the |Coq| architecture benefited from improvements in +terms of efficiency and robustness, especially regarding universes +management and existential variables management, thanks to Pierre +Letouzey and Yann Régis-Gianas with contributions from Stéphane Glondu +and Matthias Puech. The build system is maintained by Pierre Letouzey +with contributions from Stéphane Glondu and Pierre Boutillier. + +A new backtracking mechanism simplifying the task of external interfaces +has been designed by Pierre Letouzey. + +The general maintenance was done by Pierre Letouzey, Hugo Herbelin, +Pierre Boutillier, Matthieu Sozeau and Stéphane Glondu with also +specific contributions from Guillaume Melquiond, Julien Narboux and +Pierre-Marie Pédrot. + +Packaging tools were provided by Pierre Letouzey (Windows), Pierre +Boutillier (MacOS), Stéphane Glondu (Debian). Releasing, testing and +benchmarking support was provided by Jean-Marc Notin. + +Many suggestions for improvements were motivated by feedback from users, +on either the bug tracker or the Coq-Club mailing list. Special thanks +are going to the users who contributed patches, starting with Tom +Prince. Other patch contributors include Cédric Auger, David Baelde, Dan +Grayson, Paolo Herms, Robbert Krebbers, Marc Lasson, Hendrik Tews and +Eelis van der Weegen. + +| Paris, December 2011 +| Hugo Herbelin +| + +Potential sources of incompatibilities +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The main known incompatibilities between 8.3 and 8.4 are consequences +of the following changes: + +- The reorganization of the library of numbers: + + Several definitions have new names or are defined in modules of + different names, but a special care has been taken to have this + renaming transparent for the user thanks to compatibility notations. + + However some definitions have changed, what might require some + adaptations. The most noticeable examples are: + + + The "?=" notation which now bind to Pos.compare rather than former + Pcompare (now Pos.compare_cont). + + Changes in names may induce different automatically generated + names in proof scripts (e.g. when issuing "destruct Z_le_gt_dec"). + + Z.add has a new definition, hence, applying "simpl" on subterms of + its body might give different results than before. + + BigN.shiftl and BigN.shiftr have reversed arguments order, the + power function in BigN now takes two BigN. + +- Other changes in libraries: + + + The definition of functions over "vectors" (list of fixed length) + have changed. + + TheoryList.v has been removed. + +- Slight changes in tactics: + + + Less unfolding of fixpoints when applying destruct or inversion on + a fixpoint hiding an inductive type (add an extra call to simpl to + preserve compatibility). + + Less unexpected local definitions when applying "destruct" + (incompatibilities solvable by adapting name hypotheses). + + Tactic "apply" might succeed more often, e.g. by now solving + pattern-matching of the form ?f x y = g(x,y) (compatibility + ensured by using "Unset Tactic Pattern Unification"), but also + because it supports (full) betaiota (using "simple apply" might + then help). + + Tactic autorewrite does no longer instantiate pre-existing + existential variables. + + Tactic "info" is now available only for auto, eauto and trivial. + +- Miscellaneous changes: + + + The command "Load" is now atomic for backtracking (use "Unset + Atomic Load" for compatibility). + +Details of changes in 8.4beta +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Logic + +- Standard eta-conversion now supported (dependent product only). +- Guard condition improvement: subterm property is propagated through beta-redex + blocked by pattern-matching, as in "(match v with C .. => fun x => u end) x"; + this allows for instance to use "rewrite ... in ..." without breaking + the guard condition. + +Specification language and notations + +- Maximal implicit arguments can now be set locally by { }. The registration + traverses fixpoints and lambdas. Because there is conversion in types, + maximal implicit arguments are not taken into account in partial + applications (use eta expanded form with explicit { } instead). +- Added support for recursive notations with binders (allows for instance + to write "exists x y z, P"). +- Structure/Record printing can be disable by "Unset Printing Records". + In addition, it can be controlled on type by type basis using + "Add Printing Record" or "Add Printing Constructor". +- Pattern-matching compilation algorithm: in "match x, y with ... end", + possible dependencies of x (or of the indices of its type) in the type + of y are now taken into account. + +Tactics + +- New proof engine. +- Scripts can now be structured thanks to bullets - * + and to subgoal + delimitation via { }. Note: for use with Proof General, a cvs version of + Proof General no older than mid-July 2011 is currently required. +- Support for tactical "info" is suspended. +- Support for command "Show Script" is suspended. +- New tactics constr_eq, is_evar and has_evar for use in Ltac (DOC TODO). +- Removed the two-argument variant of "decide equality". +- New experimental tactical "timeout <n> <tac>". Since <n> is a time + in second for the moment, this feature should rather be avoided + in scripts meant to be machine-independent. +- Fix in "destruct": removal of unexpected local definitions in context might + result in some rare incompatibilities (solvable by adapting name hypotheses). +- Introduction pattern "_" made more robust. +- Tactic (and Eval command) vm_compute can now be interrupted via Ctrl-C. +- Unification in "apply" supports unification of patterns of the form + ?f x y = g(x,y) (compatibility ensured by using + "Unset Tactic Pattern Unification"). It also supports (full) betaiota. +- Tactic autorewrite does no longer instantiate pre-existing + existential variables (theoretical source of possible incompatibilities). +- Tactic "dependent rewrite" now supports equality in "sig". +- Tactic omega now understands Zpred (wish #1912) and can prove any goal + from a context containing an arithmetical contradiction (wish #2236). +- Using "auto with nocore" disables the use of the "core" database (wish #2188). + This pseudo-database "nocore" can also be used with trivial and eauto. +- Tactics "set", "destruct" and "induction" accepts incomplete terms and + use the goal to complete the pattern assuming it is non ambiguous. +- When used on arguments with a dependent type, tactics such as + "destruct", "induction", "case", "elim", etc. now try to abstract + automatically the dependencies over the arguments of the types + (based on initial ideas from Chung-Kil Hur, extension to nested + dependencies suggested by Dan Grayson) +- Tactic "injection" now failing on an equality showing no constructors while + it was formerly generalizing again the goal over the given equality. +- In Ltac, the "context [...]" syntax has now a variant "appcontext [...]" + allowing to match partial applications in larger applications. +- When applying destruct or inversion on a fixpoint hiding an inductive + type, recursive calls to the fixpoint now remain folded by default (rare + source of incompatibility generally solvable by adding a call to simpl). +- In an ltac pattern containing a "match", a final "| _ => _" branch could be + used now instead of enumerating all remaining constructors. Moreover, the + pattern "match _ with _ => _ end" now allows to match any "match". A "in" + annotation can also be added to restrict to a precise inductive type. +- The behavior of "simpl" can be tuned using the "Arguments" vernacular. + In particular constants can be marked so that they are always/never unfolded + by "simpl", or unfolded only when a set of arguments evaluates to a + constructor. Last one can mark a constant so that it is unfolded only if the + simplified term does not expose a match in head position. + +Vernacular commands + +- It is now mandatory to have a space (or tabulation or newline or end-of-file) + after a "." ending a sentence. +- In SearchAbout, the [ ] delimiters are now optional. +- New command "Add/Remove Search Blacklist <substring> ...": + a Search or SearchAbout or similar query will never mention lemmas + whose qualified names contain any of the declared substrings. + The default blacklisted substrings are ``_subproof``, ``Private_``. +- When the output file of "Print Universes" ends in ".dot" or ".gv", + the universe graph is printed in the DOT language, and can be + processed by Graphviz tools. +- New command "Print Sorted Universes". +- The undocumented and obsolete option "Set/Unset Boxed Definitions" has + been removed, as well as syntaxes like "Boxed Fixpoint foo". +- A new option "Set Default Timeout n / Unset Default Timeout". +- Qed now uses information from the reduction tactics used in proof script + to avoid conversion at Qed time to go into a very long computation. +- New command "Show Goal ident" to display the statement of a goal, even + a closed one (available from Proof General). +- Command "Proof" accept a new modifier "using" to force generalization + over a given list of section variables at section ending (DOC TODO). +- New command "Arguments" generalizing "Implicit Arguments" and + "Arguments Scope" and that also allows to rename the parameters of a + definition and to tune the behavior of the tactic "simpl". + +Module System + +- During subtyping checks, an opaque constant in a module type could now + be implemented by anything of the right type, even if bodies differ. + Said otherwise, with respect to subtyping, an opaque constant behaves + just as a parameter. Coqchk was already implementing this, but not coqtop. +- The inlining done during application of functors can now be controlled + more precisely, by the annotations (no inline) or (inline at level XX). + With the latter annotation, only functor parameters whose levels + are lower or equal than XX will be inlined. + The level of a parameter can be fixed by "Parameter Inline(30) foo". + When levels aren't given, the default value is 100. One can also use + the flag "Set Inline Level ..." to set a level (DOC TODO). +- Print Assumptions should now handle correctly opaque modules (#2168). +- Print Module (Type) now tries to print more details, such as types and + bodies of the module elements. Note that Print Module Type could be + used on a module to display only its interface. The option + "Set Short Module Printing" could be used to switch back to the earlier + behavior were only field names were displayed. + +Libraries + +- Extension of the abstract part of Numbers, which now provide axiomatizations + and results about many more integer functions, such as pow, gcd, lcm, sqrt, + log2 and bitwise functions. These functions are implemented for nat, N, BigN, + Z, BigZ. See in particular file NPeano for new functions about nat. + +- The definition of types positive, N, Z is now in file BinNums.v + +- Major reorganization of ZArith. The initial file ZArith/BinInt.v now contains + an internal module Z implementing the Numbers interface for integers. + This module Z regroups: + + * all functions over type Z : Z.add, Z.mul, ... + * the minimal proofs of specifications for these functions : Z.add_0_l, ... + * an instantation of all derived properties proved generically in Numbers : + Z.add_comm, Z.add_assoc, ... + + A large part of ZArith is now simply compatibility notations, for instance + Zplus_comm is an alias for Z.add_comm. The direct use of module Z is now + recommended instead of relying on these compatibility notations. + +- Similar major reorganization of NArith, via a module N in NArith/BinNat.v + +- Concerning the positive datatype, BinPos.v is now in a specific directory + PArith, and contains an internal submodule Pos. We regroup there functions + such as Pos.add Pos.mul etc as well as many results about them. These results + are here proved directly (no Number interface for strictly positive numbers). + +- Note that in spite of the compatibility layers, all these reorganizations + may induce some marginal incompatibilies in scripts. In particular: + + * the "?=" notation for positive now refers to a binary function Pos.compare, + instead of the infamous ternary Pcompare (now Pos.compare_cont). + * some hypothesis names generated by the system may changed (typically for + a "destruct Z_le_gt_dec") since naming is done after the short name of + the head predicate (here now "le" in module Z instead of "Zle", etc). + * the internals of Z.add has changed, now relying of Z.pos_sub. + +- Also note these new notations: + + * "<?" "<=?" "=?" for boolean tests such as Z.ltb Z.leb Z.eqb. + * "÷" for the alternative integer division Z.quot implementing the Truncate + convention (former ZOdiv), while the notation for the Coq usual division + Z.div implementing the Flooring convention remains "/". Their corresponding + modulo functions are Z.rem (no notations) for Z.quot and Z.modulo (infix + "mod" notation) for Z.div. + +- Lemmas about conversions between these datatypes are also organized + in modules, see for instance modules Z2Nat, N2Z, etc. + +- When creating BigN, the macro-generated part NMake_gen is much smaller. + The generic part NMake has been reworked and improved. Some changes + may introduce incompatibilities. In particular, the order of the arguments + for BigN.shiftl and BigN.shiftr is now reversed: the number to shift now + comes first. By default, the power function now takes two BigN. + +- Creation of Vector, an independent library for lists indexed by their length. + Vectors' names overwrite lists' one so you should not "Import" the library. + All old names changed: function names follow the ocaml ones and, for example, + Vcons becomes Vector.cons. You can get [..;..;..]-style notations by importing + Vector.VectorNotations. + +- Removal of TheoryList. Requiring List instead should work most of the time. + +- New syntax "rew Heq in H" and "rew <- Heq in H" for eq_rect and + eq_rect_r (available by importing module EqNotations). + +- Wf.iter_nat is now Peano.nat_iter (with an implicit type argument). + +Internal infrastructure + +- Opaque proofs are now loaded lazily by default. This allows to be almost as + fast as -dont-load-proofs, while being safer (no creation of axioms) and + avoiding feature restrictions (Print and Print Assumptions work ok). +- Revised hash-consing code allowing more sharing of memory +- Experimental support added for camlp4 (the one provided alongside ocaml), + simply pass option -usecamlp4 to ./configure. By default camlp5 is used. +- Revised build system: no more stages in Makefile thanks to some recursive + aspect of recent gnu make, use of vo.itarget files containing .v to compile + for both make and ocamlbuild, etc. +- Support of cross-compilation via mingw from unix toward Windows, + contact P. Letouzey for more informations. +- New Makefile rules mli-doc to make html of mli in dev/doc/html and + full-stdlib to get a (huge) pdf reflecting the whole standard library. + +Extraction + +- By default, opaque terms are now truly considered opaque by extraction: + instead of accessing their body, they are now considered as axioms. + The previous behaviour can be reactivated via the option + "Set Extraction AccessOpaque". +- The pretty-printer for Haskell now produces layout-independent code +- A new command "Separate Extraction cst1 cst2 ..." that mixes a + minimal extracted environment a la "Recursive Extraction" and the + production of several files (one per coq source) a la "Extraction Library" + (DOC TODO). +- New option "Set/Unset Extraction KeepSingleton" for preventing the + extraction to optimize singleton container types (DOC TODO). +- The extraction now identifies and properly rejects a particular case of + universe polymorphism it cannot handle yet (the pair (I,I) being Prop). +- Support of anonymous fields in record (#2555). + +CoqIDE + +- Coqide now runs coqtop as separated process, making it more robust: + coqtop subprocess can be interrupted, or even killed and relaunched + (cf button "Restart Coq", ex-"Go to Start"). For allowing such + interrupts, the Windows version of coqide now requires Windows >= XP + SP1. +- The communication between CoqIDE and Coqtop is now done via a dialect + of XML (DOC TODO). +- The backtrack engine of CoqIDE has been reworked, it now uses the + "Backtrack" command similarly to Proof General. +- The Coqide parsing of sentences has be reworked and now supports + tactic delimitation via { }. +- Coqide now accepts the Abort command (wish #2357). +- Coqide can read coq_makefile files as "project file" and use it to + set automatically options to send to coqtop. +- Preference files have moved to $XDG_CONFIG_HOME/coq and accelerators + are not stored as a list anymore. + +Tools + +- Coq now searches directories specified in COQPATH, $XDG_DATA_HOME/coq, + $XDG_DATA_DIRS/coq, and user-contribs before the standard library. + +- Coq rc file has moved to $XDG_CONFIG_HOME/coq. + +- Major changes to coq_makefile: + + * mli/mlpack/mllib taken into account, ml not preproccessed anymore, ml4 work; + * mlihtml generates doc of mli, install-doc install the html doc in DOCDIR + with the same policy as vo in COQLIB; + * More variables are given by coqtop -config, others are defined only if the + users doesn't have defined them elsewhere. Consequently, generated makefile + should work directly on any architecture; + * Packagers can take advantage of $(DSTROOT) introduction. Installation can + be made in $XDG_DATA_HOME/coq; + * -arg option allows to send option as argument to coqc. + +Details of changes in 8.4beta2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Vernacular commands + +- Commands "Back" and "BackTo" are now handling the proof states. They may + perform some extra steps of backtrack to avoid states where the proof + state is unavailable (typically a closed proof). +- The commands "Suspend" and "Resume" have been removed. +- A basic Show Script has been reintroduced (no indentation). +- New command "Set Parsing Explicit" for deactivating parsing (and printing) + of implicit arguments (useful for teaching). +- New command "Grab Existential Variables" to transform the unresolved evars + at the end of a proof into goals. + +Tactics + +- Still no general "info" tactical, but new specific tactics info_auto, + info_eauto, info_trivial which provides information on the proofs found + by auto/eauto/trivial. Display of these details could also be activated by + "Set Info Auto"/"Set Info Eauto"/"Set Info Trivial". +- Details on everything tried by auto/eauto/trivial during a proof search + could be obtained by "debug auto", "debug eauto", "debug trivial" or by a + global "Set Debug Auto"/"Set Debug Eauto"/"Set Debug Trivial". +- New command "r string" in Ltac debugger that interprets "idtac + string" in Ltac code as a breakpoint and jumps to its next use. +- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl, + harvey, zenon, gwhy) have been removed, since Why2 has not been + maintained for the last few years. The Why3 plugin should be a suitable + replacement in most cases. + +Libraries + +- MSetRBT: a new implementation of MSets via Red-Black trees (initial + contribution by Andrew Appel). +- MSetAVL: for maximal sharing with the new MSetRBT, the argument order + of Node has changed (this should be transparent to regular MSets users). + +Module System + +- The names of modules (and module types) are now in a fully separated + namespace from ordinary definitions: "Definition E:=0. Module E. End E." + is now accepted. + +CoqIDE + +- Coqide now supports the "Restart" command, and "Undo" (with a warning). + Better support for "Abort". + +Details of changes in 8.4 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Vernacular commands + +- The "Reset" command is now supported again in files given to coqc or Load. +- "Show Script" now indents again the displayed scripts. It can also work + correctly across Load'ed files if the option "Unset Atomic Load" is used. +- "Open Scope" can now be given the delimiter (e.g. Z) instead of the full + scope name (e.g. Z_scope). + +Notations + +- Most compatibility notations of the standard library are now tagged as + (compat xyz), where xyz is a former Coq version, for instance "8.3". + These notations behave as (only parsing) notations, except that they may + triggers warnings (or errors) when used while Coq is not in a corresponding + -compat mode. +- To activate these compatibility warnings, use "Set Verbose Compat Notations" + or the command-line flag -verbose-compat-notations. +- For a strict mode without these compatibility notations, use + "Unset Compat Notations" or the command-line flag -no-compat-notations. + +Tactics + +- An annotation "eqn:H" or "eqn:?" can be added to a "destruct" + or "induction" to make it generate equations in the spirit of "case_eq". + The former syntax "_eqn" is discontinued. +- The name of the hypothesis introduced by tactic "remember" can be + set via the new syntax "remember t as x eqn:H" (wish #2489). + +Libraries + +- Reals: changed definition of PI, no more axiom about sin(PI/2). +- SetoidPermutation: a notion of permutation for lists modulo a setoid equality. +- BigN: fixed the ocaml code doing the parsing/printing of big numbers. +- List: a couple of lemmas added especially about no-duplication, partitions. +- Init: Removal of the coercions between variants of sigma-types and + subset types (possible source of incompatibility). + +Version 8.3 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.3 is before all a transition version with refinements or +extensions of the existing features and libraries and a new tactic nsatz +based on Hilbert’s Nullstellensatz for deciding systems of equations +over rings. + +With respect to libraries, the main evolutions are due to Pierre +Letouzey with a rewriting of the library of finite sets FSets and a new +round of evolutions in the modular development of arithmetic (library +Numbers). The reason for making FSets evolve is that the computational +and logical contents were quite intertwined in the original +implementation, leading in some cases to longer computations than +expected and this problem is solved in the new MSets implementation. As +for the modular arithmetic library, it was only dealing with the basic +arithmetic operators in the former version and its current extension +adds the standard theory of the division, min and max functions, all +made available for free to any implementation of :math:`\mathbb{N}`, +:math:`\mathbb{Z}` or :math:`\mathbb{Z}/n\mathbb{Z}`. + +The main other evolutions of the library are due to Hugo Herbelin who +made a revision of the sorting library (including a certified +merge-sort) and to Guillaume Melquiond who slightly revised and cleaned +up the library of reals. + +The module system evolved significantly. Besides the resolution of some +efficiency issues and a more flexible construction of module types, Élie +Soubiran brought a new model of name equivalence, the +:math:`\Delta`-equivalence, which respects as much as possible the names +given by the users. He also designed with Pierre Letouzey a new, +convenient operator ``<+`` for nesting functor application that +provides a light notation for inheriting the properties of cascading +modules. + +The new tactic nsatz is due to Loïc Pottier. It works by computing +Gröbner bases. Regarding the existing tactics, various improvements have +been done by Matthieu Sozeau, Hugo Herbelin and Pierre Letouzey. + +Matthieu Sozeau extended and refined the typeclasses and Program +features (the Russell language). Pierre Letouzey maintained and improved +the extraction mechanism. Bruno Barras and Élie Soubiran maintained the +Coq checker, Julien Forest maintained the Function mechanism for +reasoning over recursively defined functions. Matthieu Sozeau, Hugo +Herbelin and Jean-Marc Notin maintained coqdoc. Frédéric Besson +maintained the Micromega platform for deciding systems of inequalities. +Pierre Courtieu maintained the support for the Proof General Emacs +interface. Claude Marché maintained the plugin for calling external +provers (dp). Yves Bertot made some improvements to the libraries of +lists and integers. Matthias Puech improved the search functions. +Guillaume Melquiond usefully contributed here and there. Yann +Régis-Gianas grounded the support for Unicode on a more standard and +more robust basis. + +Though invisible from outside, Arnaud Spiwack improved the general +process of management of existential variables. Pierre Letouzey and +Stéphane Glondu improved the compilation scheme of the |Coq| archive. +Vincent Gross provided support to |CoqIDE|. Jean-Marc Notin provided +support for benchmarking and archiving. + +Many users helped by reporting problems, providing patches, suggesting +improvements or making useful comments, either on the bug tracker or on +the Coq-Club mailing list. This includes but not exhaustively Cédric +Auger, Arthur Charguéraud, François Garillot, Georges Gonthier, Robin +Green, Stéphane Lescuyer, Eelis van der Weegen, ... + +Though not directly related to the implementation, special thanks are +going to Yves Bertot, Pierre Castéran, Adam Chlipala, and Benjamin +Pierce for the excellent teaching materials they provided. + +| Paris, April 2010 +| Hugo Herbelin +| + +Details of changes +~~~~~~~~~~~~~~~~~~ + +Rewriting tactics + +- Tactic "rewrite" now supports rewriting on ad hoc equalities such as eq_true. +- "Hint Rewrite" now checks that the lemma looks like an equation. +- New tactic "etransitivity". +- Support for heterogeneous equality (JMeq) in "injection" and "discriminate". +- Tactic "subst" now supports heterogeneous equality and equality + proofs that are dependent (use "simple subst" for preserving compatibility). +- Added support for Leibniz-rewriting of dependent hypotheses. +- Renamed "Morphism" into "Proper" and "respect" into "proper_prf" + (possible source of incompatibility). A partial fix is to define + "Notation Morphism R f := (Proper (R%signature) f)." +- New tactic variants "rewrite* by" and "autorewrite*" that rewrite + respectively the first and all matches whose side-conditions are + solved. +- "Require Import Setoid" does not export all of "Morphisms" and + "RelationClasses" anymore (possible source of incompatibility, fixed + by importing "Morphisms" too). +- Support added for using Chung-Kil Hur's Heq library for rewriting over + heterogeneous equality (courtesy of the library's author). +- Tactic "replace" supports matching terms with holes. + +Automation tactics + +- Tactic ``intuition`` now preserves inner ``iff`` and ``not`` (exceptional + source of incompatibilities solvable by redefining ``intuition`` as + ``unfold iff, not in *; intuition``, or, for iff only, by using + ``Set Intuition Iff Unfolding``.) +- Tactic ``tauto`` now proves classical tautologies as soon as classical logic + (i.e. library ``Classical_Prop`` or ``Classical``) is loaded. +- Tactic ``gappa`` has been removed from the Dp plugin. +- Tactic ``firstorder`` now supports the combination of its ``using`` and + ``with`` options. +- New ``Hint Resolve ->`` (or ``<-``) for declaring iff's as oriented + hints (wish #2104). +- An inductive type as argument of the ``using`` option of ``auto`` / ``eauto`` / ``firstorder`` + is interpreted as using the collection of its constructors. +- New decision tactic "nsatz" to prove polynomial equations + by computation of Groebner bases. + +Other tactics + +- Tactic "discriminate" now performs intros before trying to discriminate an + hypothesis of the goal (previously it applied intro only if the goal + had the form t1<>t2) (exceptional source of incompatibilities - former + behavior can be obtained by "Unset Discriminate Introduction"). +- Tactic "quote" now supports quotation of arbitrary terms (not just the + goal). +- Tactic "idtac" now displays its "list" arguments. +- New introduction patterns "*" for introducing the next block of dependent + variables and "**" for introducing all quantified variables and hypotheses. +- Pattern Unification for existential variables activated in tactics and + new option "Unset Tactic Evars Pattern Unification" to deactivate it. +- Resolution of canonical structure is now part of the tactic's unification + algorithm. +- New tactic "decide lemma with hyp" for rewriting decidability lemmas + when one knows which side is true. +- Improved support of dependent goals over objects in dependent types for + "destruct" (rare source of incompatibility that can be avoided by unsetting + option "Dependent Propositions Elimination"). +- Tactic "exists", "eexists", "destruct" and "edestruct" supports iteration + using comma-separated arguments. +- Tactic names "case" and "elim" now support clauses "as" and "in" and become + then synonymous of "destruct" and "induction" respectively. +- A new tactic name "exfalso" for the use of 'ex-falso quodlibet' principle. + This tactic is simply a shortcut for "elimtype False". +- Made quantified hypotheses get the name they would have if introduced in + the context (possible but rare source of incompatibilities). +- When applying a component of a conjunctive lemma, "apply in" (and + sequences of "apply in") now leave the side conditions of the lemmas + uniformly after the main goal (possible source of rare incompatibilities). +- In "simpl c" and "change c with d", c can be a pattern. +- Tactic "revert" now preserves let-in's making it the exact inverse of + "intro". +- New tactics "clear dependent H" and "revert dependent H" that + clears (resp. reverts) H and all the hypotheses that depend on H. +- Ltac's pattern-matching now supports matching metavariables that + depend on variables bound upwards in the pattern. + +Tactic definitions + +- Ltac definitions support Local option for non-export outside modules. +- Support for parsing non-empty lists with separators in tactic notations. +- New command "Locate Ltac" to get the full name of an Ltac definition. + +Notations + +- Record syntax ``{|x=...; y=...|}`` now works inside patterns too. +- Abbreviations from non-imported module now invisible at printing time. +- Abbreviations now use implicit arguments and arguments scopes for printing. +- Abbreviations to pure names now strictly behave like the name they refer to + (make redirections of qualified names easier). +- Abbreviations for applied constant now propagate the implicit arguments + and arguments scope of the underlying reference (possible source of + incompatibilities generally solvable by changing such abbreviations from + e.g. ``Notation foo' := (foo x)`` to ``Notation foo' y := (foo x (y:=y))``). +- The "where" clause now supports multiple notations per defined object. +- Recursive notations automatically expand one step on the left for better + factorization; recursion notations inner separators now ensured being tokens. +- Added "Reserved Infix" as a specific shortcut of the corresponding + "Reserved Notation". +- Open/Close Scope command supports Global option in sections. + +Specification language + +- New support for local binders in the syntax of Record/Structure fields. +- Fixpoint/CoFixpoint now support building part or all of bodies using tactics. +- Binders given before ":" in lemmas and in definitions built by tactics are + now automatically introduced (possible source of incompatibility that can + be resolved by invoking "Unset Automatic Introduction"). +- New support for multiple implicit arguments signatures per reference. + +Module system + +- Include Type is now deprecated since Include now accept both modules and + module types. +- Declare ML Module supports Local option. +- The sharing between non-logical object and the management of the + name-space has been improved by the new "Delta-equivalence" on + qualified name. +- The include operator has been extended to high-order structures +- Sequences of Include can be abbreviated via new syntax "<+". +- A module (or module type) can be given several "<:" signatures. +- Interactive proofs are now permitted in module type. Functors can hence + be declared as Module Type and be used later to type themselves. +- A functor application can be prefixed by a "!" to make it ignore any + "Inline" annotation in the type of its argument(s) (for examples of + use of the new features, see libraries Structures and Numbers). +- Coercions are now active only when modules are imported (use "Set Automatic + Coercions Import" to get the behavior of the previous versions of Coq). + +Extraction + +- When using (Recursive) Extraction Library, the filenames are directly the + Coq ones with new appropriate extensions : we do not force anymore + uncapital first letters for Ocaml and capital ones for Haskell. +- The extraction now tries harder to avoid code transformations that can be + dangerous for the complexity. In particular many eta-expansions at the top + of functions body are now avoided, clever partial applications will likely + be preserved, let-ins are almost always kept, etc. +- In the same spirit, auto-inlining is now disabled by default, except for + induction principles, since this feature was producing more frequently + weird code than clear gain. The previous behavior can be restored via + "Set Extraction AutoInline". +- Unicode characters in identifiers are now transformed into ascii strings + that are legal in Ocaml and other languages. +- Harsh support of module extraction to Haskell and Scheme: module hierarchy + is flattened, module abbreviations and functor applications are expanded, + module types and unapplied functors are discarded. +- Less unsupported situations when extracting modules to Ocaml. In particular + module parameters might be alpha-renamed if a name clash is detected. +- Extract Inductive is now possible toward non-inductive types (e.g. nat => int) +- Extraction Implicit: this new experimental command allows to mark + some arguments of a function or constructor for removed during + extraction, even if these arguments don't fit the usual elimination + principles of extraction, for instance the length n of a vector. +- Files ExtrOcaml*.v in plugins/extraction try to provide a library of common + extraction commands: mapping of basics types toward Ocaml's counterparts, + conversions from/to int and big_int, or even complete mapping of nat,Z,N + to int or big_int, or mapping of ascii to char and string to char list + (in this case recognition of ascii constants is hard-wired in the extraction). + +Program + +- Streamlined definitions using well-founded recursion and measures so + that they can work on any subset of the arguments directly (uses currying). +- Try to automatically clear structural fixpoint prototypes in + obligations to avoid issues with opacity. +- Use return type clause inference in pattern-matching as in the standard + typing algorithm. +- Support [Local Obligation Tactic] and [Next Obligation with tactic]. +- Use [Show Obligation Tactic] to print the current default tactic. +- [fst] and [snd] have maximal implicit arguments in Program now (possible + source of incompatibility). + +Type classes + +- Declaring axiomatic type class instances in Module Type should be now + done via new command "Declare Instance", while the syntax "Instance" + now always provides a concrete instance, both in and out of Module Type. +- Use [Existing Class foo] to declare foo as a class a posteriori. + [foo] can be an inductive type or a constant definition. No + projections or instances are defined. +- Various bug fixes and improvements: support for defined fields, + anonymous instances, declarations giving terms, better handling of + sections and [Context]. + +Vernacular commands + +- New command "Timeout <n> <command>." interprets a command and a timeout + interrupts the interpretation after <n> seconds. +- New command "Compute <expr>." is a shortcut for "Eval vm_compute in <expr>". +- New command "Fail <command>." interprets a command and is successful iff + the command fails on an error (but not an anomaly). Handy for tests and + illustration of wrong commands. +- Most commands referring to constant (e.g. Print or About) now support + referring to the constant by a notation string. +- New option "Boolean Equality Schemes" to make generation of boolean + equality automatic for datatypes (together with option "Decidable + Equality Schemes", this replaces deprecated option "Equality Scheme"). +- Made support for automatic generation of case analysis schemes available + to user (governed by option "Set Case Analysis Schemes"). +- New command :n:`{? Global } Generalizable [All|No] [Variable|Variables] {* @ident}` to + declare which identifiers are generalizable in `` `{} `` and `` `() `` binders. +- New command "Print Opaque Dependencies" to display opaque constants in + addition to all variables, parameters or axioms a theorem or + definition relies on. +- New command "Declare Reduction <id> := <conv_expr>", allowing to write + later "Eval <id> in ...". This command accepts a Local variant. +- Syntax of Implicit Type now supports more than one block of variables of + a given type. +- Command "Canonical Structure" now warns when it has no effects. +- Commands of the form "Set X" or "Unset X" now support "Local" and "Global" + prefixes. + +Library + +- Use "standard" Coq names for the properties of eq and identity + (e.g. refl_equal is now eq_refl). Support for compatibility is provided. + +- The function Compare_dec.nat_compare is now defined directly, + instead of relying on lt_eq_lt_dec. The earlier version is still + available under the name nat_compare_alt. + +- Lemmas in library Relations and Reals have been homogenized a bit. + +- The implicit argument of Logic.eq is now maximally inserted, allowing + to simply write "eq" instead of "@eq _" in morphism signatures. + +- Wrongly named lemmas (Zlt_gt_succ and Zlt_succ_gt) fixed (potential source + of incompatibilities) + +- List library: + + + Definitions of list, length and app are now in Init/Datatypes. + Support for compatibility is provided. + + Definition of Permutation is now in Sorting/Permtation.v + + Some other light revisions and extensions (possible source + of incompatibilities solvable by qualifying names accordingly). + +- In ListSet, set_map has been fixed (source of incompatibilities if used). + +- Sorting library: + + + new mergesort of worst-case complexity O(n*ln(n)) made available in + Mergesort.v; + + former notion of permutation up to setoid from Permutation.v is + deprecated and moved to PermutSetoid.v; + + heapsort from Heap.v of worst-case complexity O(n*n) is deprecated; + + new file Sorted.v for some definitions of being sorted. + +- Structure library. This new library is meant to contain generic + structures such as types with equalities or orders, either + in Module version (for now) or Type Classes (still to do): + + + DecidableType.v and OrderedType.v: initial notions for FSets/FMaps, + left for compatibility but considered as deprecated. + + Equalities.v and Orders.v: evolutions of the previous files, + with fine-grain Module architecture, many variants, use of + Equivalence and other relevant Type Classes notions. + + OrdersTac.v: a generic tactic for solving chains of (in)equalities + over variables. See {Nat,N,Z,P}OrderedType.v for concrete instances. + + GenericMinMax.v: any ordered type can be equipped with min and max. + We derived here all the generic properties of these functions. + +- MSets library: an important evolution of the FSets library. + "MSets" stands for Modular (Finite) Sets, by contrast with a forthcoming + library of Class (Finite) Sets contributed by S. Lescuyer which will be + integrated with the next release of Coq. The main features of MSets are: + + + The use of Equivalence, Proper and other Type Classes features + easing the handling of setoid equalities. + + The interfaces are now stated in iff-style. Old specifications + are now derived properties. + + The compare functions are now pure, and return a "comparison" value. + Thanks to the CompSpec inductive type, reasoning on them remains easy. + + Sets structures requiring invariants (i.e. sorted lists) are + built first as "Raw" sets (pure objects and separate proofs) and + attached with their proofs thanks to a generic functor. "Raw" sets + have now a proper interface and can be manipulated directly. + + Note: No Maps yet in MSets. The FSets library is still provided + for compatibility, but will probably be considered as deprecated in the + next release of Coq. + +- Numbers library: + + + The abstract layer (NatInt, Natural/Abstract, Integer/Abstract) has + been simplified and enhance thanks to new features of the module + system such as Include (see above). It has been extended to Euclidean + division (three flavors for integers: Trunc, Floor and Math). + + The arbitrary-large efficient numbers (BigN, BigZ, BigQ) has also + been reworked. They benefit from the abstract layer improvements + (especially for div and mod). Note that some specifications have + slightly changed (compare, div, mod, shift{r,l}). Ring/Field should + work better (true recognition of constants). + +Tools + +- Option -R now supports binding Coq root read-only. +- New coqtop/coqc option -beautify to reformat .v files (usable + e.g. to globally update notations). +- New tool beautify-archive to beautify a full archive of developments. +- New coqtop/coqc option -compat X.Y to simulate the general behavior + of previous versions of Coq (provides e.g. support for 8.2 compatibility). + +Coqdoc + +- List have been revamped. List depth and scope is now determined by + an "offside" whitespace rule. +- Text may be italicized by placing it in _underscores_. +- The "--index <string>" flag changes the filename of the index. +- The "--toc-depth <int>" flag limits the depth of headers which are + included in the table of contents. +- The "--lib-name <string>" flag prints "<string> Foo" instead of + "Library Foo" where library titles are called for. The + "--no-lib-name" flag eliminates the extra title. +- New option "--parse-comments" to allow parsing of regular ``(* *)`` + comments. +- New option "--plain-comments" to disable interpretation inside comments. +- New option "--interpolate" to try and typeset identifiers in Coq escapings + using the available globalization information. +- New option "--external url root" to refer to external libraries. +- Links to section variables and notations now supported. + +Internal infrastructure + +- To avoid confusion with the repository of user's contributions, + the subdirectory "contrib" has been renamed into "plugins". + On platforms supporting ocaml native dynlink, code located there + is built as loadable plugins for coqtop. +- An experimental build mechanism via ocamlbuild is provided. + From the top of the archive, run ./configure as usual, and + then ./build. Feedback about this build mechanism is most welcome. + Compiling Coq on platforms such as Windows might be simpler + this way, but this remains to be tested. +- The Makefile system has been simplified and factorized with + the ocamlbuild system. In particular "make" takes advantage + of .mllib files for building .cma/.cmxa. The .vo files to + compile are now listed in several vo.itarget files. + +Version 8.2 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.2 adds new features, new libraries and improves on many +various aspects. + +Regarding the language of |Coq|, the main novelty is the introduction by +Matthieu Sozeau of a package of commands providing Haskell-style typeclasses. +Typeclasses, which come with a few convenient features such as +type-based resolution of implicit arguments, play a new landmark role +in the architecture of |Coq| with respect to automation. For +instance, thanks to typeclass support, Matthieu Sozeau could +implement a new resolution-based version of the tactics dedicated to +rewriting on arbitrary transitive relations. + +Another major improvement of |Coq| 8.2 is the evolution of the arithmetic +libraries and of the tools associated to them. Benjamin Grégoire and +Laurent Théry contributed a modular library for building arbitrarily +large integers from bounded integers while Evgeny Makarov contributed a +modular library of abstract natural and integer arithmetic together +with a few convenient tactics. On his side, Pierre Letouzey made +numerous extensions to the arithmetic libraries on :math:`\mathbb{Z}` +and :math:`\mathbb{Q}`, including extra support for automation in +presence of various number-theory concepts. + +Frédéric Besson contributed a reflective tactic based on Krivine-Stengle +Positivstellensatz (the easy way) for validating provability of systems +of inequalities. The platform is flexible enough to support the +validation of any algorithm able to produce a “certificate†for the +Positivstellensatz and this covers the case of Fourier-Motzkin (for +linear systems in :math:`\mathbb{Q}` and :math:`\mathbb{R}`), +Fourier-Motzkin with cutting planes (for linear systems in +:math:`\mathbb{Z}`) and sum-of-squares (for non-linear systems). Evgeny +Makarov made the platform generic over arbitrary ordered rings. + +Arnaud Spiwack developed a library of 31-bits machine integers and, +relying on Benjamin Grégoire and Laurent Théry’s library, delivered a +library of unbounded integers in base :math:`2^{31}`. As importantly, he +developed a notion of “retro-knowledge†so as to safely extend the +kernel-located bytecode-based efficient evaluation algorithm of |Coq| +version 8.1 to use 31-bits machine arithmetic for efficiently computing +with the library of integers he developed. + +Beside the libraries, various improvements were contributed to provide a more +comfortable end-user language and more expressive tactic language. Hugo +Herbelin and Matthieu Sozeau improved the pattern matching compilation +algorithm (detection of impossible clauses in pattern matching, +automatic inference of the return type). Hugo Herbelin, Pierre Letouzey +and Matthieu Sozeau contributed various new convenient syntactic +constructs and new tactics or tactic features: more inference of +redundant information, better unification, better support for proof or +definition by fixpoint, more expressive rewriting tactics, better +support for meta-variables, more convenient notations... + +Élie Soubiran improved the module system, adding new features (such as +an “include†command) and making it more flexible and more general. He +and Pierre Letouzey improved the support for modules in the extraction +mechanism. + +Matthieu Sozeau extended the Russell language, ending in an convenient +way to write programs of given specifications, Pierre Corbineau extended +the Mathematical Proof Language and the automation tools that +accompany it, Pierre Letouzey supervised and extended various parts of the +standard library, Stéphane Glondu contributed a few tactics and +improvements, Jean-Marc Notin provided help in debugging, general +maintenance and coqdoc support, Vincent Siles contributed extensions of +the Scheme command and of injection. + +Bruno Barras implemented the ``coqchk`` tool: this is a stand-alone +type checker that can be used to certify .vo files. Especially, as this +verifier runs in a separate process, it is granted not to be “hijacked†+by virtually malicious extensions added to |Coq|. + +Yves Bertot, Jean-Christophe Filliâtre, Pierre Courtieu and Julien +Forest acted as maintainers of features they implemented in previous +versions of |Coq|. + +Julien Narboux contributed to |CoqIDE|. Nicolas Tabareau made the +adaptation of the interface of the old “setoid rewrite†tactic to the +new version. Lionel Mamane worked on the interaction between |Coq| and its +external interfaces. With Samuel Mimram, he also helped making |Coq| +compatible with recent software tools. Russell O’Connor, Cezary +Kaliszyk, Milad Niqui contributed to improve the libraries of integers, +rational, and real numbers. We also thank many users and partners for +suggestions and feedback, in particular Pierre Castéran and Arthur +Charguéraud, the INRIA Marelle team, Georges Gonthier and the +INRIA-Microsoft Mathematical Components team, the Foundations group at +Radboud university in Nijmegen, reporters of bugs and participants to +the Coq-Club mailing list. + +| Palaiseau, June 2008 +| Hugo Herbelin +| + +Details of changes +~~~~~~~~~~~~~~~~~~ + +Language + +- If a fixpoint is not written with an explicit { struct ... }, then + all arguments are tried successively (from left to right) until one is + found that satisfies the structural decreasing condition. +- New experimental typeclass system giving ad-hoc polymorphism and + overloading based on dependent records and implicit arguments. +- New syntax "let 'pat := b in c" for let-binding using irrefutable patterns. +- New syntax "forall {A}, T" for specifying maximally inserted implicit + arguments in terms. +- Sort of Record/Structure, Inductive and CoInductive defaults to Type + if omitted. +- (Co)Inductive types can be defined as records + (e.g. "CoInductive stream := { hd : nat; tl : stream }.") +- New syntax "Theorem id1:t1 ... with idn:tn" for proving mutually dependent + statements. +- Support for sort-polymorphism on constants denoting inductive types. +- Several evolutions of the module system (handling of module aliases, + functorial module types, an Include feature, etc). +- Prop now a subtype of Set (predicative and impredicative forms). +- Recursive inductive types in Prop with a single constructor of which + all arguments are in Prop is now considered to be a singleton + type. It consequently supports all eliminations to Prop, Set and Type. + As a consequence, Acc_rect has now a more direct proof [possible source + of easily fixed incompatibility in case of manual definition of a recursor + in a recursive singleton inductive type]. + +Vernacular commands + +- Added option Global to "Arguments Scope" for section surviving. +- Added option "Unset Elimination Schemes" to deactivate the automatic + generation of elimination schemes. +- Modification of the Scheme command so you can ask for the name to be + automatically computed (e.g. Scheme Induction for nat Sort Set). +- New command "Combined Scheme" to build combined mutual induction + principles from existing mutual induction principles. +- New command "Scheme Equality" to build a decidable (boolean) equality + for simple inductive datatypes and a decision property over this equality + (e.g. Scheme Equality for nat). +- Added option "Set Equality Scheme" to make automatic the declaration + of the boolean equality when possible. +- Source of universe inconsistencies now printed when option + "Set Printing Universes" is activated. +- New option "Set Printing Existential Instances" for making the display of + existential variable instances explicit. +- Support for option "[id1 ... idn]", and "-[id1 ... idn]", for the + "compute"/"cbv" reduction strategy, respectively meaning reduce only, or + everything but, the constants id1 ... idn. "lazy" alone or followed by + "[id1 ... idn]", and "-[id1 ... idn]" also supported, meaning apply + all of beta-iota-zeta-delta, possibly restricting delta. +- New command "Strategy" to control the expansion of constants during + conversion tests. It generalizes commands Opaque and Transparent by + introducing a range of levels. Lower levels are assigned to constants + that should be expanded first. +- New options Global and Local to Opaque and Transparent. +- New command "Print Assumptions" to display all variables, parameters + or axioms a theorem or definition relies on. +- "Add Rec LoadPath" now provides references to libraries using partially + qualified names (this holds also for coqtop/coqc option -R). +- SearchAbout supports negated search criteria, reference to logical objects + by their notation, and more generally search of subterms. +- "Declare ML Module" now allows to import .cmxs files when Coq is + compiled in native code with a version of OCaml that supports native + Dynlink (>= 3.11). +- Specific sort constraints on Record now taken into account. +- "Print LoadPath" supports a path argument to filter the display. + +Libraries + +- Several parts of the libraries are now in Type, in particular FSets, + SetoidList, ListSet, Sorting, Zmisc. This may induce a few + incompatibilities. In case of trouble while fixing existing development, + it may help to simply declare Set as an alias for Type (see file + SetIsType). + +- New arithmetical library in theories/Numbers. It contains: + + * an abstract modular development of natural and integer arithmetics + in Numbers/Natural/Abstract and Numbers/Integer/Abstract + * an implementation of efficient computational bounded and unbounded + integers that can be mapped to processor native arithmetics. + See Numbers/Cyclic/Int31 for 31-bit integers and Numbers/Natural/BigN + for unbounded natural numbers and Numbers/Integer/BigZ for unbounded + integers. + * some proofs that both older libraries Arith, ZArith and NArith and + newer BigN and BigZ implement the abstract modular development. + This allows in particular BigN and BigZ to already come with a + large database of basic lemmas and some generic tactics (ring), + + This library has still an experimental status, as well as the + processor-acceleration mechanism, but both its abstract and its + concrete parts are already quite usable and could challenge the use + of nat, N and Z in actual developments. Moreover, an extension of + this framework to rational numbers is ongoing, and an efficient + Q structure is already provided (see Numbers/Rational/BigQ), but + this part is currently incomplete (no abstract layer and generic + lemmas). + +- Many changes in FSets/FMaps. In practice, compatibility with earlier + version should be fairly good, but some adaptations may be required. + + * Interfaces of unordered ("weak") and ordered sets have been factorized + thanks to new features of Coq modules (in particular Include), see + FSetInterface. Same for maps. Hints in these interfaces have been + reworked (they are now placed in a "set" database). + * To allow full subtyping between weak and ordered sets, a field + "eq_dec" has been added to OrderedType. The old version of OrderedType + is now called MiniOrderedType and functor MOT_to_OT allow to + convert to the new version. The interfaces and implementations + of sets now contain also such a "eq_dec" field. + * FSetDecide, contributed by Aaron Bohannon, contains a decision + procedure allowing to solve basic set-related goals (for instance, + is a point in a particular set ?). See FSetProperties for examples. + * Functors of properties have been improved, especially the ones about + maps, that now propose some induction principles. Some properties + of fold need less hypothesis. + * More uniformity in implementations of sets and maps: they all use + implicit arguments, and no longer export unnecessary scopes (see + bug #1347) + * Internal parts of the implementations based on AVL have evolved a + lot. The main files FSetAVL and FMapAVL are now much more + lightweight now. In particular, minor changes in some functions + has allowed to fully separate the proofs of operational + correctness from the proofs of well-balancing: well-balancing is + critical for efficiency, but not anymore for proving that these + trees implement our interfaces, hence we have moved these proofs + into appendix files FSetFullAVL and FMapFullAVL. Moreover, a few + functions like union and compare have been modified in order to be + structural yet efficient. The appendix files also contains + alternative versions of these few functions, much closer to the + initial Ocaml code and written via the Function framework. + +- Library IntMap, subsumed by FSets/FMaps, has been removed from + Coq Standard Library and moved into a user contribution Cachan/IntMap + +- Better computational behavior of some constants (eq_nat_dec and + le_lt_dec more efficient, Z_lt_le_dec and Positive_as_OT.compare + transparent, ...) (exceptional source of incompatibilities). + +- Boolean operators moved from module Bool to module Datatypes (may need + to rename qualified references in script and force notations || and && + to be at levels 50 and 40 respectively). + +- The constructors xI and xO of type positive now have postfix notations + "~1" and "~0", allowing to write numbers in binary form easily, for instance + 6 is 1~1~0 and 4*p is p~0~0 (see BinPos.v). + +- Improvements to NArith (Nminus, Nmin, Nmax), and to QArith (in particular + a better power function). + +- Changes in ZArith: several additional lemmas (used in theories/Numbers), + especially in Zdiv, Znumtheory, Zpower. Moreover, many results in + Zdiv have been generalized: the divisor may simply be non-null + instead of strictly positive (see lemmas with name ending by + "_full"). An alternative file ZOdiv proposes a different behavior + (the one of Ocaml) when dividing by negative numbers. + +- Changes in Arith: EqNat and Wf_nat now exported from Arith, some + constructions on nat that were outside Arith are now in (e.g. iter_nat). + +- In SetoidList, eqlistA now expresses that two lists have similar elements + at the same position, while the predicate previously called eqlistA + is now equivlistA (this one only states that the lists contain the same + elements, nothing more). + +- Changes in Reals: + + * Most statement in "sigT" (including the + completeness axiom) are now in "sig" (in case of incompatibility, + use proj1_sig instead of projT1, sig instead of sigT, etc). + * More uniform naming scheme (identifiers in French moved to English, + consistent use of 0 -- zero -- instead of O -- letter O --, etc). + * Lemma on prod_f_SO is now on prod_f_R0. + * Useless hypothesis of ln_exists1 dropped. + * New Rlogic.v states a few logical properties about R axioms. + * RIneq.v extended and made cleaner. + +- Slight restructuration of the Logic library regarding choice and classical + logic. Addition of files providing intuitionistic axiomatizations of + descriptions: Epsilon.v, Description.v and IndefiniteDescription.v. + +- Definition of pred and minus made compatible with the structural + decreasing criterion for use in fixpoints. + +- Files Relations/Rstar.v and Relations/Newman.v moved out to the user + contribution repository (contribution CoC_History). New lemmas about + transitive closure added and some bound variables renamed (exceptional + risk of incompatibilities). + +- Syntax for binders in terms (e.g. for "exists") supports anonymous names. + +Notations, coercions, implicit arguments and type inference + +- More automation in the inference of the return clause of dependent + pattern-matching problems. +- Experimental allowance for omission of the clauses easily detectable as + impossible in pattern-matching problems. +- Improved inference of implicit arguments. +- New options "Set Maximal Implicit Insertion", "Set Reversible Pattern + Implicit", "Set Strongly Strict Implicit" and "Set Printing Implicit + Defensive" for controlling inference and use of implicit arguments. +- New modifier in "Implicit Arguments" to force an implicit argument to + be maximally inserted. +- New modifier of "Implicit Arguments" to enrich the set of implicit arguments. +- New options Global and Local to "Implicit Arguments" for section + surviving or non export outside module. +- Level "constr" moved from 9 to 8. +- Structure/Record now printed as Record (unless option Printing All is set). +- Support for parametric notations defining constants. +- Insertion of coercions below product types refrains to unfold + constants (possible source of incompatibility). +- New support for fix/cofix in notations. + +Tactic Language + +- Second-order pattern-matching now working in Ltac "match" clauses + (syntax for second-order unification variable is "@?X"). +- Support for matching on let bindings in match context using syntax + "H := body" or "H := body : type". +- Ltac accepts integer arguments (syntax is "ltac:nnn" for nnn an integer). +- The general sequence tactical "expr_0 ; [ expr_1 | ... | expr_n ]" + is extended so that at most one expr_i may have the form "expr .." + or just "..". Also, n can be different from the number of subgoals + generated by expr_0. In this case, the value of expr (or idtac in + case of just "..") is applied to the intermediate subgoals to make + the number of tactics equal to the number of subgoals. +- A name used as the name of the parameter of a lemma (like f in + "apply f_equal with (f:=t)") is now interpreted as a ltac variable + if such a variable exists (this is a possible source of + incompatibility and it can be fixed by renaming the variables of a + ltac function into names that do not clash with the lemmas + parameter names used in the tactic). +- New syntax "Ltac tac ::= ..." to rebind a tactic to a new expression. +- "let rec ... in ... " now supported for expressions without explicit + parameters; interpretation is lazy to the contrary of "let ... in ..."; + hence, the "rec" keyword can be used to turn the argument of a + "let ... in ..." into a lazy one. +- Patterns for hypotheses types in "match goal" are now interpreted in + type_scope. +- A bound variable whose name is not used elsewhere now serves as + metavariable in "match" and it gets instantiated by an identifier + (allow e.g. to extract the name of a statement like "exists x, P x"). +- New printing of Ltac call trace for better debugging. + +Tactics + +- New tactics "apply -> term", "apply <- term", "apply -> term in + ident", "apply <- term in ident" for applying equivalences (iff). + +- Slight improvement of the hnf and simpl tactics when applied on + expressions with explicit occurrences of match or fix. + +- New tactics "eapply in", "erewrite", "erewrite in". + +- New tactics "ediscriminate", "einjection", "esimplify_eq". + +- Tactics "discriminate", "injection", "simplify_eq" now support any + term as argument. Clause "with" is also supported. + +- Unfoldable references can be given by notation's string rather than by name + in unfold. + +- The "with" arguments are now typed using informations from the current goal: + allows support for coercions and more inference of implicit arguments. + +- Application of "f_equal"-style lemmas works better. + +- Tactics elim, case, destruct and induction now support variants eelim, + ecase, edestruct and einduction. + +- Tactics destruct and induction now support the "with" option and the + "in" clause option. If the option "in" is used, an equality is added + to remember the term to which the induction or case analysis applied + (possible source of parsing incompatibilities when destruct or induction is + part of a let-in expression in Ltac; extra parentheses are then required). + +- New support for "as" clause in tactics "apply in" and "eapply in". + +- Some new intro patterns: + + * intro pattern "?A" genererates a fresh name based on A. + Caveat about a slight loss of compatibility: + Some intro patterns don't need space between them. In particular + intros ?a?b used to be legal and equivalent to intros ? a ? b. Now it + is still legal but equivalent to intros ?a ?b. + * intro pattern "(A & ... & Y & Z)" synonym to "(A,....,(Y,Z)))))" + for right-associative constructs like /\ or exists. + +- Several syntax extensions concerning "rewrite": + + * "rewrite A,B,C" can be used to rewrite A, then B, then C. These rewrites + occur only on the first subgoal: in particular, side-conditions of the + "rewrite A" are not concerned by the "rewrite B,C". + * "rewrite A by tac" allows to apply tac on all side-conditions generated by + the "rewrite A". + * "rewrite A at n" allows to select occurrences to rewrite: rewrite only + happen at the n-th exact occurrence of the first successful matching of + A in the goal. + * "rewrite 3 A" or "rewrite 3!A" is equivalent to "rewrite A,A,A". + * "rewrite !A" means rewriting A as long as possible (and at least once). + * "rewrite 3?A" means rewriting A at most three times. + * "rewrite ?A" means rewriting A as long as possible (possibly never). + * many of the above extensions can be combined with each other. + +- Introduction patterns better respect the structure of context in presence of + missing or extra names in nested disjunction-conjunction patterns [possible + source of rare incompatibilities]. + +- New syntax "rename a into b, c into d" for "rename a into b; rename c into d" + +- New tactics "dependent induction/destruction H [ generalizing id_1 .. id_n ]" + to do induction-inversion on instantiated inductive families à la BasicElim. + +- Tactics "apply" and "apply in" now able to reason modulo unfolding of + constants (possible source of incompatibility in situations where apply + may fail, e.g. as argument of a try or a repeat and in a ltac function); + versions that do not unfold are renamed into "simple apply" and + "simple apply in" (usable for compatibility or for automation). + +- Tactics "apply" and "apply in" now able to traverse conjunctions and to + select the first matching lemma among the components of the conjunction; + tactic "apply" also able to apply lemmas of conclusion an empty type. + +- Tactic "apply" now supports application of several lemmas in a row. + +- Tactics "set" and "pose" can set functions using notation "(f x1..xn := c)". + +- New tactic "instantiate" (without argument). + +- Tactic firstorder "with" and "using" options have their meaning swapped for + consistency with auto/eauto (source of incompatibility). + +- Tactic "generalize" now supports "at" options to specify occurrences + and "as" options to name the quantified hypotheses. + +- New tactic "specialize H with a" or "specialize (H a)" allows to transform + in-place a universally-quantified hypothesis (H : forall x, T x) into its + instantiated form (H : T a). Nota: "specialize" was in fact there in earlier + versions of Coq, but was undocumented, and had a slightly different behavior. + +- New tactic "contradict H" can be used to solve any kind of goal as long as + the user can provide afterwards a proof of the negation of the hypothesis H. + If H is already a negation, say ~T, then a proof of T is asked. + If the current goal is a negation, say ~U, then U is saved in H afterwards, + hence this new tactic "contradict" extends earlier tactic "swap", which is + now obsolete. + +- Tactics f_equal is now done in ML instead of Ltac: it now works on any + equality of functions, regardless of the arity of the function. + +- New options "before id", "at top", "at bottom" for tactics "move"/"intro". + +- Some more debug of reflexive omega (``romega``), and internal clarifications. + Moreover, romega now has a variant ``romega with *`` that can be also used + on non-Z goals (nat, N, positive) via a call to a translation tactic named + zify (its purpose is to Z-ify your goal...). This zify may also be used + independently of romega. + +- Tactic "remember" now supports an "in" clause to remember only selected + occurrences of a term. + +- Tactic "pose proof" supports name overwriting in case of specialization of an + hypothesis. + +- Semi-decision tactic "jp" for first-order intuitionistic logic moved to user + contributions (subsumed by "firstorder"). + +Program + +- Moved useful tactics in theories/Program and documented them. +- Add Program.Basics which contains standard definitions for functional + programming (id, apply, flip...) +- More robust obligation handling, dependent pattern-matching and + well-founded definitions. +- New syntax " dest term as pat in term " for destructing objects using + an irrefutable pattern while keeping equalities (use this instead of + "let" in Programs). +- Program CoFixpoint is accepted, Program Fixpoint uses the new way to infer + which argument decreases structurally. +- Program Lemma, Axiom etc... now permit to have obligations in the statement + iff they can be automatically solved by the default tactic. +- Renamed "Obligations Tactic" command to "Obligation Tactic". +- New command "Preterm [ of id ]" to see the actual term fed to Coq for + debugging purposes. +- New option "Transparent Obligations" to control the declaration of + obligations as transparent or opaque. All obligations are now transparent + by default, otherwise the system declares them opaque if possible. +- Changed the notations "left" and "right" to "in_left" and "in_right" to hide + the proofs in standard disjunctions, to avoid breaking existing scripts when + importing Program. Also, put them in program_scope. + +Type Classes + +- New "Class", "Instance" and "Program Instance" commands to define + classes and instances documented in the reference manual. +- New binding construct " [ Class_1 param_1 .. param_n, Class_2 ... ] " + for binding type classes, usable everywhere. +- New command " Print Classes " and " Print Instances some_class " to + print tables for typeclasses. +- New default eauto hint database "typeclass_instances" used by the default + typeclass instance search tactic. +- New theories directory "theories/Classes" for standard typeclasses + declarations. Module Classes.RelationClasses is a typeclass port of + Relation_Definitions plus a generic development of algebra on + n-ary heterogeneous predicates. + +Setoid rewriting + +- Complete (and still experimental) rewrite of the tactic + based on typeclasses. The old interface and semantics are + almost entirely respected, except: + + + Import Setoid is now mandatory to be able to call setoid_replace + and declare morphisms. + + + "-->", "++>" and "==>" are now right associative notations + declared at level 55 in scope signature_scope. + Their introduction may break existing scripts that defined + them as notations with different levels. + + + One needs to use [Typeclasses unfold [cst]] if [cst] is used + as an abbreviation hiding products in types of morphisms, + e.g. if ones redefines [relation] and declares morphisms + whose type mentions [relation]. + + + The [setoid_rewrite]'s semantics change when rewriting with + a lemma: it can rewrite two different instantiations of the lemma + at once. Use [setoid_rewrite H at 1] for (almost) the usual semantics. + [setoid_rewrite] will also try to rewrite under binders now, and can + succeed on different terms than before. In particular, it will unify under + let-bound variables. When called through [rewrite], the semantics are + unchanged though. + + + [Add Morphism term : id] has different semantics when used with + parametric morphism: it will try to find a relation on the parameters + too. The behavior has also changed with respect to default relations: + the most recently declared Setoid/Relation will be used, the documentation + explains how to customize this behavior. + + + Parametric Relation and Morphism are declared differently, using the + new [Add Parametric] commands, documented in the manual. + + + Setoid_Theory is now an alias to Equivalence, scripts building objects + of type Setoid_Theory need to unfold (or "red") the definitions + of Reflexive, Symmetric and Transitive in order to get the same goals + as before. Scripts which introduced variables explicitely will not break. + + + The order of subgoals when doing [setoid_rewrite] with side-conditions + is always the same: first the new goal, then the conditions. + +- New standard library modules ``Classes.Morphisms`` declares + standard morphisms on ``refl`` / ``sym`` / ``trans`` relations. + ``Classes.Morphisms_Prop`` declares morphisms on propositional + connectives and ``Classes.Morphisms_Relations`` on generalized predicate + connectives. ``Classes.Equivalence`` declares notations and tactics + related to equivalences and ``Classes.SetoidTactics`` defines the + setoid_replace tactics and some support for the ``Add *`` interface, + notably the tactic applied automatically before each ``Add Morphism`` + proof. + +- User-defined subrelations are supported, as well as higher-order morphisms + and rewriting under binders. The tactic is also extensible entirely in Ltac. + The documentation has been updated to cover these features. + +- [setoid_rewrite] and [rewrite] now support the [at] modifier to select + occurrences to rewrite, and both use the [setoid_rewrite] code, even when + rewriting with leibniz equality if occurrences are specified. + +Extraction + +- Improved behavior of the Caml extraction of modules: name clashes should + not happen anymore. + +- The command Extract Inductive has now a syntax for infix notations. This + allows in particular to map Coq lists and pairs onto Caml ones: + + + Extract Inductive list => list [ "[]" "(::)" ]. + + Extract Inductive prod => "(*)" [ "(,)" ]. + +- In pattern matchings, a default pattern "| _ -> ..." is now used whenever + possible if several branches are identical. For instance, functions + corresponding to decidability of equalities are now linear instead of + quadratic. + +- A new instruction Extraction Blacklist id1 .. idn allows to prevent filename + conflits with existing code, for instance when extracting module List + to Ocaml. + +CoqIDE + +- CoqIDE font defaults to monospace so as indentation to be meaningful. +- CoqIDE supports nested goals and any other kind of declaration in the middle + of a proof. +- Undoing non-tactic commands in CoqIDE works faster. +- New CoqIDE menu for activating display of various implicit informations. +- Added the possibility to choose the location of tabs in coqide: + (in Edit->Preferences->Misc) +- New Open and Save As dialogs in CoqIDE which filter ``*.v`` files. + +Tools + +- New stand-alone .vo files verifier "coqchk". +- Extended -I coqtop/coqc option to specify a logical dir: "-I dir -as coqdir". +- New coqtop/coqc option -exclude-dir to exclude subdirs for option -R. +- The binary "parser" has been renamed to "coq-parser". +- Improved coqdoc and dump of globalization information to give more + meta-information on identifiers. All categories of Coq definitions are + supported, which makes typesetting trivial in the generated documentation. + Support for hyperlinking and indexing developments in the tex output + has been implemented as well. + +Miscellaneous + +- Coq installation provides enough files so that Ocaml's extensions need not + the Coq sources to be compiled (this assumes O'Caml 3.10 and Camlp5). +- New commands "Set Whelp Server" and "Set Whelp Getter" to customize the + Whelp search tool. +- Syntax of "Test Printing Let ref" and "Test Printing If ref" changed into + "Test Printing Let for ref" and "Test Printing If for ref". +- An overhauled build system (new Makefiles); see dev/doc/build-system.txt. +- Add -browser option to configure script. +- Build a shared library for the C part of Coq, and use it by default on + non-(Windows or MacOS) systems. Bytecode executables are now pure. The + behaviour is configurable with -coqrunbyteflags, -coqtoolsbyteflags and + -custom configure options. +- Complexity tests can be skipped by setting the environment variable + COQTEST_SKIPCOMPLEXITY. + +Version 8.1 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8.1 adds various new functionalities. + +Benjamin Grégoire implemented an alternative algorithm to check the +convertibility of terms in the |Coq| type checker. This alternative +algorithm works by compilation to an efficient bytecode that is +interpreted in an abstract machine similar to Xavier Leroy’s ZINC +machine. Convertibility is performed by comparing the normal forms. This +alternative algorithm is specifically interesting for proofs by +reflection. More generally, it is convenient in case of intensive +computations. + +Christine Paulin implemented an extension of inductive types allowing +recursively non uniform parameters. Hugo Herbelin implemented +sort-polymorphism for inductive types (now called template polymorphism). + +Claudio Sacerdoti Coen improved the tactics for rewriting on arbitrary +compatible equivalence relations. He also generalized rewriting to +arbitrary transition systems. + +Claudio Sacerdoti Coen added new features to the module system. + +Benjamin Grégoire, Assia Mahboubi and Bruno Barras developed a new, more +efficient and more general simplification algorithm for rings and +semirings. + +Laurent Théry and Bruno Barras developed a new, significantly more +efficient simplification algorithm for fields. + +Hugo Herbelin, Pierre Letouzey, Julien Forest, Julien Narboux and +Claudio Sacerdoti Coen added new tactic features. + +Hugo Herbelin implemented matching on disjunctive patterns. + +New mechanisms made easier the communication between |Coq| and external +provers. Nicolas Ayache and Jean-Christophe Filliâtre implemented +connections with the provers cvcl, Simplify and zenon. Hugo Herbelin +implemented an experimental protocol for calling external tools from the +tactic language. + +Matthieu Sozeau developed Russell, an experimental language to specify +the behavior of programs with subtypes. + +A mechanism to automatically use some specific tactic to solve +unresolved implicit has been implemented by Hugo Herbelin. + +Laurent Théry’s contribution on strings and Pierre Letouzey and +Jean-Christophe Filliâtre’s contribution on finite maps have been +integrated to the |Coq| standard library. Pierre Letouzey developed a +library about finite sets “à la Objective Camlâ€. With Jean-Marc Notin, +he extended the library on lists. Pierre Letouzey’s contribution on +rational numbers has been integrated and extended. + +Pierre Corbineau extended his tactic for solving first-order statements. +He wrote a reflection-based intuitionistic tautology solver. + +Pierre Courtieu, Julien Forest and Yves Bertot added extra support to +reason on the inductive structure of recursively defined functions. + +Jean-Marc Notin significantly contributed to the general maintenance of +the system. He also took care of ``coqdoc``. + +Pierre Castéran contributed to the documentation of (co-)inductive types +and suggested improvements to the libraries. + +Pierre Corbineau implemented a declarative mathematical proof language, +usable in combination with the tactic-based style of proof. + +Finally, many users suggested improvements of the system through the +Coq-Club mailing list and bug-tracker systems, especially user groups +from INRIA Rocquencourt, Radboud University, University of Pennsylvania +and Yale University. + +| Palaiseau, July 2006 +| Hugo Herbelin +| + +Details of changes in 8.1beta +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Logic + +- Added sort-polymorphism on inductive families +- Allowance for recursively non uniform parameters in inductive types + +Syntax + +- No more support for version 7 syntax and for translation to version 8 syntax. +- In fixpoints, the { struct ... } annotation is not mandatory any more when + only one of the arguments has an inductive type +- Added disjunctive patterns in match-with patterns +- Support for primitive interpretation of string literals +- Extended support for Unicode ranges + +Vernacular commands + +- Added "Print Ltac qualid" to print a user defined tactic. +- Added "Print Rewrite HintDb" to print the content of a DB used by + autorewrite. +- Added "Print Canonical Projections". +- Added "Example" as synonym of "Definition". +- Added "Proposition" and "Corollary" as extra synonyms of "Lemma". +- New command "Whelp" to send requests to the Helm database of proofs + formalized in the Calculus of Inductive Constructions. +- Command "functional induction" has been re-implemented from the new + "Function" command. + +Ltac and tactic syntactic extensions + +- New primitive "external" for communication with tool external to Coq +- New semantics for "match t with": if a clause returns a + tactic, it is now applied to the current goal. If it fails, the next + clause or next matching subterm is tried (i.e. it behaves as "match + goal with" does). The keyword "lazymatch" can be used to delay the + evaluation of tactics occurring in matching clauses. +- Hint base names can be parametric in auto and trivial. +- Occurrence values can be parametric in unfold, pattern, etc. +- Added entry constr_may_eval for tactic extensions. +- Low-priority term printer made available in ML-written tactic extensions. +- "Tactic Notation" extended to allow notations of tacticals. + +Tactics + +- New implementation and generalization of ``setoid_*`` (``setoid_rewrite``, + ``setoid_symmetry``, ``setoid_transitivity``, ``setoid_reflexivity`` and ``autorewite``). + New syntax for declaring relations and morphisms (old syntax still working + with minor modifications, but deprecated). + +- New implementation (still experimental) of the ring tactic with a built-in + notion of coefficients and a better usage of setoids. + +- New conversion tactic "vm_compute": evaluates the goal (or an hypothesis) + with a call-by-value strategy, using the compiled version of terms. + +- When rewriting H where H is not directly a Coq equality, search first H for + a registered setoid equality before starting to reduce in H. This is unlikely + to break any script. Should this happen nonetheless, one can insert manually + some "unfold ... in H" before rewriting. + +- Fixed various bugs about (setoid) rewrite ... in ... (in particular bug #5941) + +- "rewrite ... in" now accepts a clause as place where to rewrite instead of + just a simple hypothesis name. For instance: + ``rewrite H in H1,H2 |- *`` means ``rewrite H in H1; rewrite H in H2; rewrite H`` + ``rewrite H in * |-`` will do try ``rewrite H in Hi`` for all hypothesis Hi <> H. + +- Added "dependent rewrite term" and "dependent rewrite term in hyp". + +- Added "autorewrite with ... in hyp [using ...]". + +- Tactic "replace" now accepts a "by" tactic clause. + +- Added "clear - id" to clear all hypotheses except the ones depending in id. + +- The argument of Declare Left Step and Declare Right Step is now a term + (it used to be a reference). + +- Omega now handles arbitrary precision integers. + +- Several bug fixes in Reflexive Omega (romega). + +- Idtac can now be left implicit in a [...|...] construct: for instance, + [ foo | | bar ] stands for [ foo | idtac | bar ]. + +- Fixed a "fold" bug (non critical but possible source of incompatibilities). + +- Added classical_left and classical_right which transforms ``|- A \/ B`` into + ``~B |- A`` and ``~A |- B`` respectively. + +- Added command "Declare Implicit Tactic" to set up a default tactic to be + used to solve unresolved subterms of term arguments of tactics. + +- Better support for coercions to Sortclass in tactics expecting type + arguments. + +- Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses. + +- New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns. + +- New introduction pattern "?" for letting Coq choose a name. + +- Introduction patterns now support side hypotheses (e.g. intros [|] on + "(nat -> nat) -> nat" works). + +- New introduction patterns "->" and "<-" for immediate rewriting of + introduced hypotheses. + +- Introduction patterns coming after non trivial introduction patterns now + force full introduction of the first pattern (e.g. ``intros [[|] p]`` on + ``nat->nat->nat`` now behaves like ``intros [[|?] p]``) + +- Added "eassumption". + +- Added option 'using lemmas' to auto, trivial and eauto. + +- Tactic "congruence" is now complete for its intended scope (ground + equalities and inequalities with constructors). Furthermore, it + tries to equates goal and hypotheses. + +- New tactic "rtauto" solves pure propositional logic and gives a + reflective version of the available proof. + +- Numbering of "pattern", "unfold", "simpl", ... occurrences in "match + with" made consistent with the printing of the return clause after + the term to match in the "match-with" construct (use "Set Printing All" + to see hidden occurrences). + +- Generalization of induction "induction x1...xn using scheme" where + scheme is an induction principle with complex predicates (like the + ones generated by function induction). + +- Some small Ltac tactics has been added to the standard library + (file Tactics.v): + + * f_equal : instead of using the different f_equalX lemmas + * case_eq : a "case" without loss of information. An equality + stating the current situation is generated in every sub-cases. + * swap : for a negated goal ~B and a negated hypothesis H:~A, + swap H asks you to prove A from hypothesis B + * revert : revert H is generalize H; clear H. + +Extraction + +- All type parts should now disappear instead of sometimes producing _ + (for instance in Map.empty). +- Haskell extraction: types of functions are now printed, better + unsafeCoerce mechanism, both for hugs and ghc. +- Scheme extraction improved, see http://www.pps.jussieu.fr/~letouzey/scheme. +- Many bug fixes. + +Modules + +- Added "Locate Module qualid" to get the full path of a module. +- Module/Declare Module syntax made more uniform. +- Added syntactic sugar "Declare Module Export/Import" and + "Module Export/Import". +- Added syntactic sugar "Module M(Export/Import X Y: T)" and + "Module Type M(Export/Import X Y: T)" + (only for interactive definitions) +- Construct "with" generalized to module paths: + T with (Definition|Module) M1.M2....Mn.l := l'. + +Notations + +- Option "format" aware of recursive notations. +- Added insertion of spaces by default in recursive notations w/o separators. +- No more automatic printing box in case of user-provided printing "format". +- New notation "exists! x:A, P" for unique existence. +- Notations for specific numerals now compatible with generic notations of + numerals (e.g. "1" can be used to denote the unit of a group without + hiding 1%nat) + +Libraries + +- New library on String and Ascii characters (contributed by L. Thery). +- New library FSets+FMaps of finite sets and maps. +- New library QArith on rational numbers. +- Small extension of Zmin.V, new Zmax.v, new Zminmax.v. +- Reworking and extension of the files on classical logic and + description principles (possible incompatibilities) +- Few other improvements in ZArith potentially exceptionally breaking the + compatibility (useless hypothesys of Zgt_square_simpl and + Zlt_square_simpl removed; fixed names mentioning letter O instead of + digit 0; weaken premises in Z_lt_induction). +- Restructuration of Eqdep_dec.v and Eqdep.v: more lemmas in Type. +- Znumtheory now contains a gcd function that can compute within Coq. +- More lemmas stated on Type in Wf.v, removal of redundant Acc_iter and + Acc_iter2. +- Change of the internal names of lemmas in OmegaLemmas. +- Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on + the allowance for recursively non uniform parameters (possible + source of incompatibilities: explicit pattern-matching on these + types may require to remove the occurrence associated to their + recursively non uniform parameter). +- Coq.List.In_dec has been set transparent (this may exceptionally break + proof scripts, set it locally opaque for compatibility). +- More on permutations of lists in List.v and Permutation.v. +- List.v has been much expanded. +- New file SetoidList.v now contains results about lists seen with + respect to a setoid equality. +- Library NArith has been expanded, mostly with results coming from + Intmap (for instance a bitwise xor), plus also a bridge between N and + Bitvector. +- Intmap has been reorganized. In particular its address type "addr" is + now N. User contributions known to use Intmap have been adapted + accordingly. If you're using this library please contact us. + A wrapper FMapIntMap now presents Intmap as a particular implementation + of FMaps. New developments are strongly encouraged to use either this + wrapper or any other implementations of FMap instead of using directly + this obsolete Intmap. + +Tools + +- New semantics for coqtop options ("-batch" expects option "-top dir" + for loading vernac file that contains definitions). +- Tool coq_makefile now removes custom targets that are file names in + "make clean" +- New environment variable COQREMOTEBROWSER to set the command invoked + to start the remote browser both in Coq and coqide. Standard syntax: + "%s" is the placeholder for the URL. + +Details of changes in 8.1gamma +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Syntax + +- changed parsing precedence of let/in and fun constructions of Ltac: + let x := t in e1; e2 is now parsed as let x := t in (e1;e2). + +Language and commands + +- Added sort-polymorphism for definitions in Type (but finally abandonned). +- Support for implicit arguments in the types of parameters in + (co-)fixpoints and (co-)inductive declarations. +- Improved type inference: use as much of possible general information. + before applying irreversible unification heuristics (allow e.g. to + infer the predicate in "(exist _ 0 (refl_equal 0) : {n:nat | n=0 })"). +- Support for Miller-Pfenning's patterns unification in type synthesis + (e.g. can infer P such that P x y = phi(x,y)). +- Support for "where" clause in cofixpoint definitions. +- New option "Set Printing Universes" for making Type levels explicit. + +Tactics + +- Improved implementation of the ring and field tactics. For compatibility + reasons, the previous tactics are renamed as legacy ring and legacy field, + but should be considered as deprecated. +- New declarative mathematical proof language. +- Support for argument lists of arbitrary length in Tactic Notation. +- ``rewrite ... in H`` now fails if ``H`` is used either in an hypothesis + or in the goal. +- The semantics of ``rewrite ... in *`` has been slightly modified (see doc). +- Support for ``as`` clause in tactic injection. +- New forward-reasoning tactic "apply in". +- Ltac fresh operator now builds names from a concatenation of its arguments. +- New ltac tactic "remember" to abstract over a subterm and keep an equality +- Support for Miller-Pfenning's patterns unification in apply/rewrite/... + (may lead to few incompatibilities - generally now useless tactic calls). + +Bug fixes + +- Fix for notations involving basic "match" expressions. +- Numerous other bugs solved (a few fixes may lead to incompatibilities). + +Details of changes in 8.1 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Bug fixes + +- Many bugs have been fixed (cf coq-bugs web page) + +Tactics + +- New tactics ring, ring_simplify and new tactic field now able to manage + power to a positive integer constant. Tactic ring on Z and R, and + field on R manage power (may lead to incompatibilities with V8.1gamma). +- Tactic field_simplify now applicable in hypotheses. +- New field_simplify_eq for simplifying field equations into ring equations. +- Tactics ring, ring_simplify, field, field_simplify and field_simplify_eq + all able to apply user-given equations to rewrite monoms on the fly + (see documentation). + +Libraries + +- New file ConstructiveEpsilon.v defining an epsilon operator and + proving the axiom of choice constructively for a countable domain + and a decidable predicate. + +Version 8.0 +----------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +Coq version 8 is a major revision of the |Coq| proof assistant. First, the +underlying logic is slightly different. The so-called *impredicativity* +of the sort Set has been dropped. The main reason is that it is +inconsistent with the principle of description which is quite a useful +principle for formalizing mathematics within classical logic. Moreover, +even in an constructive setting, the impredicativity of Set does not add +so much in practice and is even subject of criticism from a large part +of the intuitionistic mathematician community. Nevertheless, the +impredicativity of Set remains optional for users interested in +investigating mathematical developments which rely on it. + +Secondly, the concrete syntax of terms has been completely revised. The +main motivations were + +- a more uniform, purified style: all constructions are now lowercase, + with a functional programming perfume (e.g. abstraction is now + written fun), and more directly accessible to the novice (e.g. + dependent product is now written forall and allows omission of + types). Also, parentheses are no longer mandatory for function + application. + +- extensibility: some standard notations (e.g. “<†and “>â€) were + incompatible with the previous syntax. Now all standard arithmetic + notations (=, +, \*, /, <, <=, ... and more) are directly part of the + syntax. + +Together with the revision of the concrete syntax, a new mechanism of +*interpretation scopes* permits to reuse the same symbols (typically +, +-, \*, /, <, <=) in various mathematical theories without any +ambiguities for |Coq|, leading to a largely improved readability of |Coq| +scripts. New commands to easily add new symbols are also provided. + +Coming with the new syntax of terms, a slight reform of the tactic +language and of the language of commands has been carried out. The +purpose here is a better uniformity making the tactics and commands +easier to use and to remember. + +Thirdly, a restructuring and uniformization of the standard library of +Coq has been performed. There is now just one Leibniz equality usable +for all the different kinds of |Coq| objects. Also, the set of real +numbers now lies at the same level as the sets of natural and integer +numbers. Finally, the names of the standard properties of numbers now +follow a standard pattern and the symbolic notations for the standard +definitions as well. + +The fourth point is the release of |CoqIDE|, a new graphical gtk2-based +interface fully integrated with |Coq|. Close in style to the Proof General +Emacs interface, it is faster and its integration with |Coq| makes +interactive developments more friendly. All mathematical Unicode symbols +are usable within |CoqIDE|. + +Finally, the module system of |Coq| completes the picture of |Coq| version +8.0. Though released with an experimental status in the previous version +7.4, it should be considered as a salient feature of the new version. + +Besides, |Coq| comes with its load of novelties and improvements: new or +improved tactics (including a new tactic for solving first-order +statements), new management commands, extended libraries. + +Bruno Barras and Hugo Herbelin have been the main contributors of the +reflection and the implementation of the new syntax. The smart automatic +translator from old to new syntax released with |Coq| is also their work +with contributions by Olivier Desmettre. + +Hugo Herbelin is the main designer and implementer of the notion of +interpretation scopes and of the commands for easily adding new +notations. + +Hugo Herbelin is the main implementer of the restructured standard library. + +Pierre Corbineau is the main designer and implementer of the new tactic +for solving first-order statements in presence of inductive types. He is +also the maintainer of the non-domain specific automation tactics. + +Benjamin Monate is the developer of the |CoqIDE| graphical interface with +contributions by Jean-Christophe Filliâtre, Pierre Letouzey, Claude +Marché and Bruno Barras. + +Claude Marché coordinated the edition of the Reference Manual for |Coq| +V8.0. + +Pierre Letouzey and Jacek ChrzÄ…szcz respectively maintained the +extraction tool and module system of |Coq|. + +Jean-Christophe Filliâtre, Pierre Letouzey, Hugo Herbelin and other +contributors from Sophia-Antipolis and Nijmegen participated in +extending the library. + +Julien Narboux built a NSIS-based automatic |Coq| installation tool for +the Windows platform. + +Hugo Herbelin and Christine Paulin coordinated the development which was +under the responsibility of Christine Paulin. + +| Palaiseau & Orsay, Apr. 2004 +| Hugo Herbelin & Christine Paulin +| (updated Apr. 2006) +| + +Details of changes in 8.0beta old syntax +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Logic + +- Set now predicative by default +- New option -impredicative-set to set Set impredicative +- The standard library doesn't need impredicativity of Set and is + compatible with the classical axioms which contradict Set impredicativity + +Syntax for arithmetic + +- Notation "=" and "<>" in Z and R are no longer implicitly in Z or R + (with possible introduction of a coercion), use <Z>...=... or + <Z>...<>... instead +- Locate applied to a simple string (e.g. "+") searches for all + notations containing this string + +Vernacular commands + +- "Declare ML Module" now allows to import .cma files. This avoids to use a + bunch of "Declare ML Module" statements when using several ML files. +- "Set Printing Width n" added, allows to change the size of width printing. +- "Implicit Variables Type x,y:t" (new syntax: "Implicit Types x y:t") + assigns default types for binding variables. +- Declarations of Hints and Notation now accept a "Local" flag not to + be exported outside the current file even if not in section +- "Print Scopes" prints all notations +- New command "About name" for light printing of type, implicit arguments, etc. +- New command "Admitted" to declare incompletely proven statement as axioms +- New keyword "Conjecture" to declare an axiom intended to be provable +- SearchAbout can now search for lemmas referring to more than one constant + and on substrings of the name of the lemma +- "Print Implicit" displays the implicit arguments of a constant +- Locate now searches for all names having a given suffix +- New command "Functional Scheme" for building an induction principle + from a function defined by case analysis and fix. + +Commands + +- new coqtop/coqc option -dont-load-proofs not to load opaque proofs in memory + +Implicit arguments + +- Inductive in sections declared with implicits now "discharged" with + implicits (like constants and variables) +- Implicit Arguments flags are now synchronous with reset +- New switch "Unset/Set Printing Implicits" (new syntax: "Unset/Set Printing + Implicit") to globally control printing of implicits + +Grammar extensions + +- Many newly supported UTF-8 encoded unicode blocks + - Greek letters (0380-03FF), Hebrew letters (U05D0-05EF), letter-like + symbols (2100-214F, that includes double N,Z,Q,R), prime + signs (from 2080-2089) and characters from many written languages + are valid in identifiers + - mathematical operators (2200-22FF), supplemental mathematical + operators (2A00-2AFF), miscellaneous technical (2300-23FF that + includes sqrt symbol), miscellaneous symbols (2600-26FF), arrows + (2190-21FF and 2900-297F), invisible mathematical operators (from + 2080-2089), ... are valid symbols + +Library + +- New file about the factorial function in Arith + +- An additional elimination Acc_iter for Acc, simplier than Acc_rect. + This new elimination principle is used for definition well_founded_induction. + +- New library NArith on binary natural numbers + +- R is now of type Set + +- Restructuration in ZArith library + + + "true_sub" used in Zplus now a definition, not a local one (source + of incompatibilities in proof referring to true_sub, may need extra Unfold) + + Some lemmas about minus moved from fast_integer to Arith/Minus.v + (le_minus, lt_mult_left) (theoretical source of incompatibilities) + + Several lemmas moved from auxiliary.v and zarith_aux.v to + fast_integer.v (theoretical source of incompatibilities) + + Variables names of iff_trans changed (source of incompatibilities) + + ZArith lemmas named ``OMEGA`` something or ``fast_`` something, and lemma ``new_var`` + are now out of ZArith (except ``OMEGA2``) + + Redundant ZArith lemmas have been renamed: for the following pairs, + use the second name (Zle_Zmult_right2, Zle_mult_simpl), (OMEGA2, + Zle_0_plus), (Zplus_assoc_l, Zplus_assoc), (Zmult_one, Zmult_1_n), + (Zmult_assoc_l, Zmult_assoc), (Zmult_minus_distr, Zmult_Zminus_distr_l) + (add_un_double_moins_un_xO, is_double_moins_un), + (Rlt_monotony_rev,Rlt_monotony_contra) (source of incompatibilities) + +- Few minor changes (no more implicit arguments in + Zmult_Zminus_distr_l and Zmult_Zminus_distr_r, lemmas moved from + Zcomplements to other files) (rare source of incompatibilities) + +- New lemmas provided by users added + +Tactic language + +- Fail tactic now accepts a failure message +- Idtac tactic now accepts a message +- New primitive tactic "FreshId" (new syntax: "fresh") to generate new names +- Debugger prints levels of calls + +Tactics + +- Replace can now replace proofs also +- Fail levels are now decremented at "Match Context" blocks only and + if the right-hand-side of "Match term With" are tactics, these + tactics are never evaluated immediately and do not induce + backtracking (in contrast with "Match Context") +- Quantified names now avoid global names of the current module (like + Intro names did) [source of rare incompatibilities: 2 changes in the set of + user contribs] +- NewDestruct/NewInduction accepts intro patterns as introduction names +- NewDestruct/NewInduction now work for non-inductive type using option "using" +- A NewInduction naming bug for inductive types with functional + arguments (e.g. the accessibility predicate) has been fixed (source + of incompatibilities) +- Symmetry now applies to hypotheses too +- Inversion now accept option "as [ ... ]" to name the hypotheses +- Contradiction now looks also for contradictory hypotheses stating ~A and A + (source of incompatibility) +- "Contradiction c" try to find an hypothesis in context which + contradicts the type of c +- Ring applies to new library NArith (require file NArithRing) +- Field now works on types in Set +- Auto with reals now try to replace le by ge (Rge_le is no longer an + immediate hint), resulting in shorter proofs +- Instantiate now works in hyps (syntax : Instantiate in ...) +- Some new tactics : EConstructor, ELeft, Eright, ESplit, EExists +- New tactic "functional induction" to perform case analysis and + induction following the definition of a function. +- Clear now fails when trying to remove a local definition used by + a constant appearing in the current goal + +Extraction (See details in plugins/extraction/CHANGES) + +- The old commands: (Recursive) Extraction Module M. + are now: (Recursive) Extraction Library M. + To use these commands, M should come from a library M.v +- The other syntax Extraction & Recursive Extraction now accept + module names as arguments. + +Bugs + +- see coq-bugs server for the complete list of fixed bugs + +Miscellaneous + +- Implicit parameters of inductive types definition now taken into + account for infering other implicit arguments + +Incompatibilities + +- Persistence of true_sub (4 incompatibilities in Coq user contributions) +- Variable names of some constants changed for a better uniformity (2 changes + in Coq user contributions) +- Naming of quantified names in goal now avoid global names (2 occurrences) +- NewInduction naming for inductive types with functional arguments + (no incompatibility in Coq user contributions) +- Contradiction now solve more goals (source of 2 incompatibilities) +- Merge of eq and eqT may exceptionally result in subgoals now + solved automatically +- Redundant pairs of ZArith lemmas may have different names: it may + cause "Apply/Rewrite with" to fail if using the first name of a pair + of redundant lemmas (this is solved by renaming the variables bound by + "with"; 3 incompatibilities in Coq user contribs) +- ML programs referring to constants from fast_integer.v must use + "Coqlib.gen_constant_modules Coqlib.zarith_base_modules" instead + +Details of changes in 8.0beta new syntax +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +New concrete syntax + +- A completely new syntax for terms +- A more uniform syntax for tactics and the tactic language +- A few syntactic changes for vernacular commands +- A smart automatic translator translating V8.0 files in old syntax to + files valid for V8.0 + +Syntax extensions + +- "Grammar" for terms disappears +- "Grammar" for tactics becomes "Tactic Notation" +- "Syntax" disappears +- Introduction of a notion of interpretation scope allowing to use the + same notations in various contexts without using specific delimiters + (e.g the same expression "4<=3+x" is interpreted either in "nat", + "positive", "N" (previously "entier"), "Z", "R", depending on which + interpretation scope is currently open) [see documentation for details] +- Notation now mandatorily requires a precedence and associativity + (default was to set precedence to 1 and associativity to none) + +Revision of the standard library + +- Many lemmas and definitions names have been made more uniform mostly + in Arith, NArith, ZArith and Reals (e.g : "times" -> "Pmult", + "times_sym" -> "Pmult_comm", "Zle_Zmult_pos_right" -> + "Zmult_le_compat_r", "SUPERIEUR" -> "Gt", "ZERO" -> "Z0") +- Order and names of arguments of basic lemmas on nat, Z, positive and R + have been made uniform. +- Notions of Coq initial state are declared with (strict) implicit arguments +- eq merged with eqT: old eq disappear, new eq (written =) is old eqT + and new eqT is syntactic sugar for new eq (notation == is an alias + for = and is written as it, exceptional source of incompatibilities) +- Similarly, ex, ex2, all, identity are merged with exT, exT2, allT, identityT +- Arithmetical notations for nat, positive, N, Z, R, without needing + any backquote or double-backquotes delimiters. +- In Lists: new concrete notations; argument of nil is now implicit +- All changes in the library are taken in charge by the translator + +Semantical changes during translation + +- Recursive keyword set by default (and no longer needed) in Tactic Definition +- Set Implicit Arguments is strict by default in new syntax +- reductions in hypotheses of the form "... in H" now apply to the type + also if H is a local definition +- etc + +Gallina + +- New syntax of the form "Inductive bool : Set := true, false : bool." for + enumerated types +- Experimental syntax of the form p.(fst) for record projections + (activable with option "Set Printing Projections" which is + recognized by the translator) + +Known problems of the automatic translation + +- iso-latin-1 characters are no longer supported: move your files to + 7-bits ASCII or unicode before translation (swith to unicode is + automatically done if a file is loaded and saved again by coqide) +- Renaming in ZArith: incompatibilities in Coq user contribs due to + merging names INZ, from Reals, and inject_nat. +- Renaming and new lemmas in ZArith: may clash with names used by users +- Restructuration of ZArith: replace requirement of specific modules + in ZArith by "Require Import ZArith_base" or "Require Import ZArith" +- Some implicit arguments must be made explicit before translation: typically + for "length nil", the implicit argument of length must be made explicit +- Grammar rules, Infix notations and V7.4 Notations must be updated wrt the + new scheme for syntactic extensions (see translator documentation) +- Unsafe for annotation Cases when constructors coercions are used or when + annotations are eta-reduced predicates + +Details of changes in 8.0 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Vernacular commands + +- New option "Set Printing All" to deactivate all high-level forms of + printing (implicit arguments, coercions, destructing let, + if-then-else, notations, projections) +- "Functional Scheme" and "Functional Induction" extended to polymorphic + types and dependent types +- Notation now allows recursive patterns, hence recovering parts of the + fonctionalities of pre-V8 Grammar/Syntax commands +- Command "Print." discontinued. +- Redundant syntax "Implicit Arguments On/Off" discontinued + +New syntax + +- Semantics change of the if-then-else construction in new syntax: + "if c then t1 else t2" now stands for + "match c with c1 _ ... _ => t1 | c2 _ ... _ => t2 end" + with no dependency of t1 and t2 in the arguments of the constructors; + this may cause incompatibilities for files translated using coq 8.0beta + +Interpretation scopes + +- Delimiting key %bool for bool_scope added +- Import no more needed to activate argument scopes from a module + +Tactics and the tactic Language + +- Semantics of "assert" is now consistent with the reference manual +- New tactics stepl and stepr for chaining transitivity steps +- Tactic "replace ... with ... in" added +- Intro patterns now supported in Ltac (parsed with prefix "ipattern:") + +Executables and tools + +- Added option -top to change the name of the toplevel module "Top" +- Coqdoc updated to new syntax and now part of Coq sources +- XML exportation tool now exports the structure of vernacular files + (cf chapter 13 in the reference manual) + +User contributions + +- User contributions have been updated to the new syntax + +Bug fixes + +- Many bugs have been fixed (cf coq-bugs web page) diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits.rst deleted file mode 100644 index 5873096523..0000000000 --- a/doc/sphinx/credits.rst +++ /dev/null @@ -1,1884 +0,0 @@ -------- -Credits -------- - -Historical roots ----------------- - -Coq is a proof assistant for higher-order logic, allowing the -development of computer programs consistent with their formal -specification. It is the result of about ten years [#years]_ of research -of the Coq project. We shall briefly survey here three main aspects: the -*logical language* in which we write our axiomatizations and -specifications, the *proof assistant* which allows the development of -verified mathematical proofs, and the *program extractor* which -synthesizes computer programs obeying their formal specifications, -written as logical assertions in the language. - -The logical language used by |Coq| is a variety of type theory, called the -*Calculus of Inductive Constructions*. Without going back to Leibniz and -Boole, we can date the creation of what is now called mathematical logic -to the work of Frege and Peano at the turn of the century. The discovery -of antinomies in the free use of predicates or comprehension principles -prompted Russell to restrict predicate calculus with a stratification of -*types*. This effort culminated with *Principia Mathematica*, the first -systematic attempt at a formal foundation of mathematics. A -simplification of this system along the lines of simply typed -λ-calculus occurred with Church’s *Simple Theory of -Types*. The λ-calculus notation, originally used for -expressing functionality, could also be used as an encoding of natural -deduction proofs. This Curry-Howard isomorphism was used by N. de Bruijn -in the *Automath* project, the first full-scale attempt to develop and -mechanically verify mathematical proofs. This effort culminated with -Jutting’s verification of Landau’s *Grundlagen* in the 1970’s. -Exploiting this Curry-Howard isomorphism, notable achievements in proof -theory saw the emergence of two type-theoretic frameworks; the first -one, Martin-Löf’s *Intuitionistic Theory of Types*, attempts a new -foundation of mathematics on constructive principles. The second one, -Girard’s polymorphic λ-calculus :math:`F_\omega`, is a -very strong functional system in which we may represent higher-order -logic proof structures. Combining both systems in a higher-order -extension of the Automath language, T. Coquand presented in 1985 the -first version of the *Calculus of Constructions*, CoC. This strong -logical system allowed powerful axiomatizations, but direct inductive -definitions were not possible, and inductive notions had to be defined -indirectly through functional encodings, which introduced inefficiencies -and awkwardness. The formalism was extended in 1989 by T. Coquand and C. -Paulin with primitive inductive definitions, leading to the current -*Calculus of Inductive Constructions*. This extended formalism is not -rigorously defined here. Rather, numerous concrete examples are -discussed. We refer the interested reader to relevant research papers -for more information about the formalism, its meta-theoretic properties, -and semantics. However, it should not be necessary to understand this -theoretical material in order to write specifications. It is possible to -understand the Calculus of Inductive Constructions at a higher level, as -a mixture of predicate calculus, inductive predicate definitions -presented as typed PROLOG, and recursive function definitions close to -the language ML. - -Automated theorem-proving was pioneered in the 1960’s by Davis and -Putnam in propositional calculus. A complete mechanization (in the sense -of a semidecision procedure) of classical first-order logic was -proposed in 1965 by J.A. Robinson, with a single uniform inference rule -called *resolution*. Resolution relies on solving equations in free -algebras (i.e. term structures), using the *unification algorithm*. Many -refinements of resolution were studied in the 1970’s, but few convincing -implementations were realized, except of course that PROLOG is in some -sense issued from this effort. A less ambitious approach to proof -development is computer-aided proof-checking. The most notable -proof-checkers developed in the 1970’s were LCF, designed by R. Milner -and his colleagues at U. Edinburgh, specialized in proving properties -about denotational semantics recursion equations, and the Boyer and -Moore theorem-prover, an automation of primitive recursion over -inductive data types. While the Boyer-Moore theorem-prover attempted to -synthesize proofs by a combination of automated methods, LCF constructed -its proofs through the programming of *tactics*, written in a high-level -functional meta-language, ML. - -The salient feature which clearly distinguishes our proof assistant from -say LCF or Boyer and Moore’s, is its possibility to extract programs -from the constructive contents of proofs. This computational -interpretation of proof objects, in the tradition of Bishop’s -constructive mathematics, is based on a realizability interpretation, in -the sense of Kleene, due to C. Paulin. The user must just mark his -intention by separating in the logical statements the assertions stating -the existence of a computational object from the logical assertions -which specify its properties, but which may be considered as just -comments in the corresponding program. Given this information, the -system automatically extracts a functional term from a consistency proof -of its specifications. This functional term may be in turn compiled into -an actual computer program. This methodology of extracting programs from -proofs is a revolutionary paradigm for software engineering. Program -synthesis has long been a theme of research in artificial intelligence, -pioneered by R. Waldinger. The Tablog system of Z. Manna and R. -Waldinger allows the deductive synthesis of functional programs from -proofs in tableau form of their specifications, written in a variety of -first-order logic. Development of a systematic *programming logic*, -based on extensions of Martin-Löf’s type theory, was undertaken at -Cornell U. by the Nuprl team, headed by R. Constable. The first actual -program extractor, PX, was designed and implemented around 1985 by S. -Hayashi from Kyoto University. It allows the extraction of a LISP -program from a proof in a logical system inspired by the logical -formalisms of S. Feferman. Interest in this methodology is growing in -the theoretical computer science community. We can foresee the day when -actual computer systems used in applications will contain certified -modules, automatically generated from a consistency proof of their -formal specifications. We are however still far from being able to use -this methodology in a smooth interaction with the standard tools from -software engineering, i.e. compilers, linkers, run-time systems taking -advantage of special hardware, debuggers, and the like. We hope that |Coq| -can be of use to researchers interested in experimenting with this new -methodology. - -.. [#years] At the time of writting, i.e. 1995. - -Brief summary of the versions up to 5.10 ----------------------------------------- - -.. note:: - This summary was written in 1995 together with the previous - section and formed the initial version of the Credits chapter - (that has since then been appended to, at each new release). - A more comprehensive description of these early versions is - available in the next few sections, which were written in 2015. - -A first implementation of CoC was started in 1984 by G. Huet and T. -Coquand. Its implementation language was CAML, a functional programming -language from the ML family designed at INRIA in Rocquencourt. The core -of this system was a proof-checker for CoC seen as a typed -λ-calculus, called the *Constructive Engine*. This engine -was operated through a high-level notation permitting the declaration of -axioms and parameters, the definition of mathematical types and objects, -and the explicit construction of proof objects encoded as -λ-terms. A section mechanism, designed and implemented by -G. Dowek, allowed hierarchical developments of mathematical theories. -This high-level language was called the *Mathematical Vernacular*. -Furthermore, an interactive *Theorem Prover* permitted the incremental -construction of proof trees in a top-down manner, subgoaling recursively -and backtracking from dead-ends. The theorem prover executed tactics -written in CAML, in the LCF fashion. A basic set of tactics was -predefined, which the user could extend by his own specific tactics. -This system (Version 4.10) was released in 1989. Then, the system was -extended to deal with the new calculus with inductive types by C. -Paulin, with corresponding new tactics for proofs by induction. A new -standard set of tactics was streamlined, and the vernacular extended for -tactics execution. A package to compile programs extracted from proofs -to actual computer programs in CAML or some other functional language -was designed and implemented by B. Werner. A new user-interface, relying -on a CAML-X interface by D. de Rauglaudre, was designed and implemented -by A. Felty. It allowed operation of the theorem-prover through the -manipulation of windows, menus, mouse-sensitive buttons, and other -widgets. This system (Version 5.6) was released in 1991. - -Coq was ported to the new implementation Caml-light of X. Leroy and D. -Doligez by D. de Rauglaudre (Version 5.7) in 1992. A new version of |Coq| -was then coordinated by C. Murthy, with new tools designed by C. Parent -to prove properties of ML programs (this methodology is dual to program -extraction) and a new user-interaction loop. This system (Version 5.8) -was released in May 1993. A Centaur interface CTCoq was then developed -by Y. Bertot from the Croap project from INRIA-Sophia-Antipolis. - -In parallel, G. Dowek and H. Herbelin developed a new proof engine, -allowing the general manipulation of existential variables consistently -with dependent types in an experimental version of |Coq| (V5.9). - -The version V5.10 of |Coq| is based on a generic system for manipulating -terms with binding operators due to Chet Murthy. A new proof engine -allows the parallel development of partial proofs for independent -subgoals. The structure of these proof trees is a mixed representation -of derivation trees for the Calculus of Inductive Constructions with -abstract syntax trees for the tactics scripts, allowing the navigation -in a proof at various levels of details. The proof engine allows generic -environment items managed in an object-oriented way. This new -architecture, due to C. Murthy, supports several new facilities which -make the system easier to extend and to scale up: - -- User-programmable tactics are allowed - -- It is possible to separately verify development modules, and to load - their compiled images without verifying them again - a quick - relocation process allows their fast loading - -- A generic parsing scheme allows user-definable notations, with a - symmetric table-driven pretty-printer - -- Syntactic definitions allow convenient abbreviations - -- A limited facility of meta-variables allows the automatic synthesis - of certain type expressions, allowing generic notations for e.g. - equality, pairing, and existential quantification. - -In the Fall of 1994, C. Paulin-Mohring replaced the structure of -inductively defined types and families by a new structure, allowing the -mutually recursive definitions. P. Manoury implemented a translation of -recursive definitions into the primitive recursive style imposed by the -internal recursion operators, in the style of the ProPre system. C. -Muñoz implemented a decision procedure for intuitionistic propositional -logic, based on results of R. Dyckhoff. J.C. Filliâtre implemented a -decision procedure for first-order logic without contraction, based on -results of J. Ketonen and R. Weyhrauch. Finally C. Murthy implemented a -library of inversion tactics, relieving the user from tedious -definitions of “inversion predicatesâ€. - -| Rocquencourt, Feb. 1st 1995 -| Gérard Huet -| - -Version 1 ---------- - -.. note:: - - These additional notes come from a document written - in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin - to accompany their public release of the archive of versions 1.10 to 6.2 - of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and - implemented in the Formel team, joint between the INRIA Rocquencourt - laboratory and the Ecole Normale Supérieure of Paris, from 1984 - onwards. - -This software is a prototype type-checker for a higher-order logical -formalism known as the Theory of Constructions, presented in his PhD -thesis by Thierry Coquand, with influences from Girard's system F and -de Bruijn's Automath. The metamathematical analysis of the system is -the PhD work of Thierry Coquand. The software is mostly the work of -Gérard Huet. Most of the mathematical examples verified with the -software are due to Thierry Coquand. - -The programming language of the CONSTR software (as it was called at -the time) was a version of ML adapted from the Edinburgh LCF system -and running on a LISP backend. The main improvements from the original -LCF ML were that ML was compiled rather than interpreted (Gérard Huet -building on the original translator by Lockwood Morris), and that it -was enriched by recursively defined types (work of Guy -Cousineau). This ancestor of CAML was used and improved by Larry -Paulson for his implementation of Cambridge LCF. - -Software developments of this prototype occurred from late 1983 to -early 1985. - -Version 1.10 was frozen on December 22nd 1984. It is the version used -for the examples in Thierry Coquand's thesis, defended on January 31st -1985. There was a unique binding operator, used both for universal -quantification (dependent product) at the level of types and -functional abstraction (λ) at the level of terms/proofs, in the manner -of Automath. Substitution (λ-reduction) was implemented using de -Bruijn's indexes. - -Version 1.11 was frozen on February 19th, 1985. It is the version used -for the examples in the paper: T. Coquand, G. Huet. *Constructions: A -Higher Order Proof System for Mechanizing Mathematics* :cite:`CH85`. - -Christine Paulin joined the team at this point, for her DEA research -internship. In her DEA memoir (August 1985) she presents developments -for the *lambo* function – :math:`\text{lambo}(f)(n)` computes the minimal -:math:`m` such that :math:`f(m)` is greater than :math:`n`, for :math:`f` -an increasing integer function, a challenge for constructive mathematics. -She also encoded the majority voting algorithm of Boyer and Moore. - -Version 2 ---------- - -The formal system, now renamed as the *Calculus of Constructions*, was -presented with a proof of consistency and comparisons with proof -systems of Per Martin Löf, Girard, and the Automath family of N. de -Bruijn, in the paper: T. Coquand and G. Huet. *The Calculus of -Constructions* :cite:`CH88`. - -An abstraction of the software design, in the form of an abstract -machine for proof checking, and a fuller sequence of mathematical -developments was presented in: T. Coquand, G. Huet. *Concepts -Mathématiques et Informatiques Formalisés dans le Calcul des -Constructions* :cite:`CH87`. - -Version 2.8 was frozen on December 16th, 1985, and served for -developing the examples in the above papers. - -This calculus was then enriched in version 2.9 with a cumulative -hierarchy of universes. Universe levels were initially explicit -natural numbers. Another improvement was the possibility of automatic -synthesis of implicit type arguments, relieving the user of tedious -redundant declarations. - -Christine Paulin wrote an article *Algorithm development in the -Calculus of Constructions* :cite:`P86`. Besides *lambo* and *majority*, -she presents *quicksort* and a text formatting algorithm. - -Version 2.13 of the Calculus of Constructions with universes was -frozen on June 25th, 1986. - -A synthetic presentation of type theory along constructive lines with -ML algorithms was given by Gérard Huet in his May 1986 CMU course -notes *Formal Structures for Computation and Deduction*. Its chapter -*Induction and Recursion in the Theory of Constructions* was presented -as an invited paper at the Joint Conference on Theory and Practice of -Software Development TAPSOFT’87 at Pise in March 1987, and published -as *Induction Principles Formalized in the Calculus of -Constructions* :cite:`H88`. - -Version 3 ---------- - -This version saw the beginning of proof automation, with a search -algorithm inspired from PROLOG and the applicative logic programming -programs of the course notes *Formal structures for computation and -deduction*. The search algorithm was implemented in ML by Thierry -Coquand. The proof system could thus be used in two modes: proof -verification and proof synthesis, with tactics such as ``AUTO``. - -The implementation language was now called CAML, for Categorical -Abstract Machine Language. It used as backend the LLM3 virtual machine -of Le Lisp by Jérôme Chailloux. The main developers of CAML were -Michel Mauny, Ascander Suarez and Pierre Weis. - -V3.1 was started in the summer of 1986, V3.2 was frozen at the end of -November 1986. V3.4 was developed in the first half of 1987. - -Thierry Coquand held a post-doctoral position in Cambrige University -in 1986-87, where he developed a variant implementation in SML, with -which he wrote some developments on fixpoints in Scott's domains. - -Version 4 ---------- - -This version saw the beginning of program extraction from proofs, with -two varieties of the type ``Prop`` of propositions, indicating -constructive intent. The proof extraction algorithms were implemented -by Christine Paulin-Mohring. - -V4.1 was frozen on July 24th, 1987. It had a first identified library -of mathematical developments (directory ``exemples``), with libraries -``Logic`` (containing impredicative encodings of intuitionistic logic and -algebraic primitives for booleans, natural numbers and list), ``Peano`` -developing second-order Peano arithmetic, ``Arith`` defining addition, -multiplication, euclidean division and factorial. Typical developments -were the Knaster-Tarski theorem and Newman's lemma from rewriting -theory. - -V4.2 was a joint development of a team consisting of Thierry Coquand, -Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the -log of changes. It was frozen on September 1987 as the last version -implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable -development system. - -V4.3 saw the first top-level of the system. Instead of evaluating -explicit quotations, the user could develop his mathematics in a -high-level language called the mathematical vernacular (following -Automath terminology). The user could develop files in the vernacular -notation (with ``.v`` extension) which were now separate from the ``ml`` -sources of the implementation. Gilles Dowek joined the team to -develop the vernacular language as his DEA internship research. - -A notion of sticky constant was introduced, in order to keep names of -lemmas when local hypotheses of proofs were discharged. This gave a -notion of global mathematical environment with local sections. - -Another significant practical change was that the system, originally -developped on the VAX central computer of our lab, was transferred on -SUN personal workstations, allowing a level of distributed -development. The extraction algorithm was modified, with three -annotations ``Pos``, ``Null`` and ``Typ`` decorating the sorts ``Prop`` -and ``Type``. - -Version 4.3 was frozen at the end of November 1987, and was -distributed to an early community of users (among those were Hugo -Herbelin and Loic Colson). - -V4.4 saw the first version of (encoded) inductive types. Now natural -numbers could be defined as:: - - [source, coq] - Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. - -These inductive types were encoded impredicatively in the calculus, -using a subsystem *rec* due to Christine Paulin. V4.4 was frozen on -March 6th 1988. - -Version 4.5 was the first one to support inductive types and program -extraction. Its banner was *Calcul des Constructions avec -Réalisations et Synthèse*. The vernacular language was enriched to -accommodate extraction commands. - -The verification engine design was presented as: G. Huet. *The -Constructive Engine*. Version 4.5. Invited Conference, 2nd European -Symposium on Programming, Nancy, March 88. The final paper, -describing the V4.9 implementation, appeared in: A perspective in -Theoretical Computer Science, Commemorative Volume in memory of Gift -Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. - -Version 4.5 was demonstrated in June 1988 at the YoP Institute on -Logical Foundations of Functional Programming organized by Gérard Huet -at Austin, Texas. - -Version 4.6 was started during the summer of 1988. Its main -improvement was the complete rehaul of the proof synthesis engine by -Thierry Coquand, with a tree structure of goals. - -Its source code was communicated to Randy Pollack on September 2nd -1988. It evolved progressively into LEGO, proof system for Luo's -formalism of Extended Calculus of Constructions. - -The discharge tactic was modified by Gérard Huet to allow for -inter-dependencies in discharged lemmas. Christine Paulin improved the -inductive definition scheme in order to accommodate predicates of any -arity. - -Version 4.7 was started on September 6th, 1988. - -This version starts exploiting the CAML notion of module in order to -improve the modularity of the implementation. Now the term verifier is -identified as a proper module Machine, which the structure of its -internal data structures being hidden and thus accessible only through -the legitimate operations. This machine (the constructive engine) was -the trusted core of the implementation. The proof synthesis mechanism -was a separate proof term generator. Once a complete proof term was -synthesized with the help of tactics, it was entirely re-checked by -the engine. Thus there was no need to certify the tactics, and the -system took advantage of this fact by having tactics ignore the -universe levels, universe consistency check being relegated to the -final type-checking pass. This induced a certain puzzlement in early -users who saw, after a successful proof search, their ``QED`` followed -by silence, followed by a failure message due to a universe -inconsistency… - -The set of examples comprise set theory experiments by Hugo Herbelin, -and notably the Schroeder-Bernstein theorem. - -Version 4.8, started on October 8th, 1988, saw a major -re-implementation of the abstract syntax type ``constr``, separating -variables of the formalism and metavariables denoting incomplete terms -managed by the search mechanism. A notion of level (with three values -``TYPE``, ``OBJECT`` and ``PROOF``) is made explicit and a type judgement -clarifies the constructions, whose implementation is now fully -explicit. Structural equality is speeded up by using pointer equality, -yielding spectacular improvements. Thierry Coquand adapts the proof -synthesis to the new representation, and simplifies pattern matching -to first-order predicate calculus matching, with important performance -gain. - -A new representation of the universe hierarchy is then defined by -Gérard Huet. Universe levels are now implemented implicitly, through -a hidden graph of abstract levels constrained with an order relation. -Checking acyclicity of the graph insures well-foundedness of the -ordering, and thus consistency. This was documented in a memo *Adding -Type:Type to the Calculus of Constructions* which was never published. - -The development version is released as a stable 4.8 at the end of -1988. - -Version 4.9 is released on March 1st 1989, with the new "elastic" -universe hierarchy. - -The spring of 1989 saw the first attempt at documenting the system -usage, with a number of papers describing the formalism: - -- *Metamathematical Investigations of a Calculus of Constructions*, by - Thierry Coquand :cite:`C90`, - -- *Inductive definitions in the Calculus of Constructions*, by - Christine Paulin-Mohrin, - -- *Extracting Fω's programs from proofs in the Calculus of - Constructions*, by Christine Paulin-Mohring* :cite:`P89`, - -- *The Constructive Engine*, by Gérard Huet :cite:`H89`, - -as well as a number of user guides: - -- *A short user's guide for the Constructions*, Version 4.10, by Gérard Huet -- *A Vernacular Syllabus*, by Gilles Dowek. -- *The Tactics Theorem Prover, User's guide*, Version 4.10, by Thierry - Coquand. - -Stable V4.10, released on May 1st, 1989, was then a mature system, -distributed with CAML V2.6. - -In the mean time, Thierry Coquand and Christine Paulin-Mohring had -been investigating how to add native inductive types to the Calculus -of Constructions, in the manner of Per Martin-Löf's Intuitionistic -Type Theory. The impredicative encoding had already been presented in: -F. Pfenning and C. Paulin-Mohring. *Inductively defined types in the -Calculus of Constructions* :cite:`PP90`. An extension of the calculus -with primitive inductive types appeared in: T. Coquand and -C. Paulin-Mohring. *Inductively defined types* :cite:`CP90`. - -This led to the Calculus of Inductive Constructions, logical formalism -implemented in Versions 5 upward of the system, and documented in: -C. Paulin-Mohring. *Inductive Definitions in the System Coq - Rules -and Properties* :cite:`P93`. - -The last version of CONSTR is Version 4.11, which was last distributed -in the spring of 1990. It was demonstrated at the first workshop of -the European Basic Research Action Logical Frameworks In Sophia -Antipolis in May 1990. - -Version 5 ---------- - -At the end of 1989, Version 5.1 was started, and renamed as the system -Coq for the Calculus of Inductive Constructions. It was then ported to -the new stand-alone implementation of ML called Caml-light. - -In 1990 many changes occurred. Thierry Coquand left for Chalmers -University in Göteborg. Christine Paulin-Mohring took a CNRS -researcher position at the LIP laboratory of École Normale Supérieure -de Lyon. Project Formel was terminated, and gave rise to two teams: -Cristal at INRIA-Roquencourt, that continued developments in -functional programming with Caml-light then OCaml, and Coq, continuing -the type theory research, with a joint team headed by Gérard Huet at -INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory -of CNRS-ENS Lyon. - -Chetan Murthy joined the team in 1991 and became the main software -architect of Version 5. He completely rehauled the implementation for -efficiency. Versions 5.6 and 5.8 were major distributed versions, -with complete documentation and a library of users' developements. The -use of the RCS revision control system, and systematic ChangeLog -files, allow a more precise tracking of the software developments. - -| September 2015 + -| Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. -| - -Version 6.1 ------------ - -The present version 6.1 of |Coq| is based on the V5.10 architecture. It -was ported to the new language Objective Caml by Bruno Barras. The -underlying framework has slightly changed and allows more conversions -between sorts. - -The new version provides powerful tools for easier developments. - -Cristina Cornes designed an extension of the |Coq| syntax to allow -definition of terms using a powerful pattern matching analysis in the -style of ML programs. - -Amokrane Saïbi wrote a mechanism to simulate inheritance between types -families extending a proposal by Peter Aczel. He also developed a -mechanism to automatically compute which arguments of a constant may be -inferred by the system and consequently do not need to be explicitly -written. - -Yann Coscoy designed a command which explains a proof term using natural -language. Pierre Crégut built a new tactic which solves problems in -quantifier-free Presburger Arithmetic. Both functionalities have been -integrated to the |Coq| system by Hugo Herbelin. - -Samuel Boutin designed a tactic for simplification of commutative rings -using a canonical set of rewriting rules and equality modulo -associativity and commutativity. - -Finally the organisation of the |Coq| distribution has been supervised by -Jean-Christophe Filliâtre with the help of Judicaël Courant and Bruno -Barras. - -| Lyon, Nov. 18th 1996 -| Christine Paulin -| - -Version 6.2 ------------ - -In version 6.2 of |Coq|, the parsing is done using camlp4, a preprocessor -and pretty-printer for CAML designed by Daniel de Rauglaudre at INRIA. -Daniel de Rauglaudre made the first adaptation of |Coq| for camlp4, this -work was continued by Bruno Barras who also changed the structure of |Coq| -abstract syntax trees and the primitives to manipulate them. The result -of these changes is a faster parsing procedure with greatly improved -syntax-error messages. The user-interface to introduce grammar or -pretty-printing rules has also changed. - -Eduardo Giménez redesigned the internal tactic libraries, giving uniform -names to Caml functions corresponding to |Coq| tactic names. - -Bruno Barras wrote new, more efficient reduction functions. - -Hugo Herbelin introduced more uniform notations in the |Coq| specification -language: the definitions by fixpoints and pattern matching have a more -readable syntax. Patrick Loiseleur introduced user-friendly notations -for arithmetic expressions. - -New tactics were introduced: Eduardo Giménez improved the mechanism to -introduce macros for tactics, and designed special tactics for -(co)inductive definitions; Patrick Loiseleur designed a tactic to -simplify polynomial expressions in an arbitrary commutative ring which -generalizes the previous tactic implemented by Samuel Boutin. -Jean-Christophe Filliâtre introduced a tactic for refining a goal, using -a proof term with holes as a proof scheme. - -David Delahaye designed the tool to search an object in the library -given its type (up to isomorphism). - -Henri Laulhère produced the |Coq| distribution for the Windows -environment. - -Finally, Hugo Herbelin was the main coordinator of the |Coq| documentation -with principal contributions by Bruno Barras, David Delahaye, -Jean-Christophe Filliâtre, Eduardo Giménez, Hugo Herbelin and Patrick -Loiseleur. - -| Orsay, May 4th 1998 -| Christine Paulin -| - -Version 6.3 ------------ - -The main changes in version V6.3 were the introduction of a few new -tactics and the extension of the guard condition for fixpoint -definitions. - -B. Barras extended the unification algorithm to complete partial terms -and fixed various tricky bugs related to universes. - -D. Delahaye developed the ``AutoRewrite`` tactic. He also designed the -new behavior of ``Intro`` and provided the tacticals ``First`` and -``Solve``. - -J.-C. Filliâtre developed the ``Correctness`` tactic. - -\E. Giménez extended the guard condition in fixpoints. - -H. Herbelin designed the new syntax for definitions and extended the -``Induction`` tactic. - -P. Loiseleur developed the ``Quote`` tactic and the new design of the -``Auto`` tactic, he also introduced the index of errors in the -documentation. - -C. Paulin wrote the ``Focus`` command and introduced the reduction -functions in definitions, this last feature was proposed by J.-F. -Monin from CNET Lannion. - -| Orsay, Dec. 1999 -| Christine Paulin -| - -Versions 7 ----------- - -The version V7 is a new implementation started in September 1999 by -Jean-Christophe Filliâtre. This is a major revision with respect to the -internal architecture of the system. The |Coq| version 7.0 was distributed -in March 2001, version 7.1 in September 2001, version 7.2 in January -2002, version 7.3 in May 2002 and version 7.4 in February 2003. - -Jean-Christophe Filliâtre designed the architecture of the new system. -He introduced a new representation for environments and wrote a new -kernel for type checking terms. His approach was to use functional -data-structures in order to get more sharing, to prepare the addition of -modules and also to get closer to a certified kernel. - -Hugo Herbelin introduced a new structure of terms with local -definitions. He introduced “qualified†names, wrote a new -pattern matching compilation algorithm and designed a more compact -algorithm for checking the logical consistency of universes. He -contributed to the simplification of |Coq| internal structures and the -optimisation of the system. He added basic tactics for forward reasoning -and coercions in patterns. - -David Delahaye introduced a new language for tactics. General tactics -using pattern matching on goals and context can directly be written from -the |Coq| toplevel. He also provided primitives for the design of -user-defined tactics in Caml. - -Micaela Mayero contributed the library on real numbers. Olivier -Desmettre extended this library with axiomatic trigonometric functions, -square, square roots, finite sums, Chasles property and basic plane -geometry. - -Jean-Christophe Filliâtre and Pierre Letouzey redesigned a new -extraction procedure from |Coq| terms to Caml or Haskell programs. This -new extraction procedure, unlike the one implemented in previous version -of |Coq| is able to handle all terms in the Calculus of Inductive -Constructions, even involving universes and strong elimination. P. -Letouzey adapted user contributions to extract ML programs when it was -sensible. Jean-Christophe Filliâtre wrote ``coqdoc``, a documentation -tool for |Coq| libraries usable from version 7.2. - -Bruno Barras improved the efficiency of the reduction algorithm and the -confidence level in the correctness of |Coq| critical type checking -algorithm. - -Yves Bertot designed the ``SearchPattern`` and ``SearchRewrite`` tools -and the support for the pcoq interface -(http://www-sop.inria.fr/lemme/pcoq/). - -Micaela Mayero and David Delahaye introduced Field, a decision tactic -for commutative fields. - -Christine Paulin changed the elimination rules for empty and singleton -propositional inductive types. - -Loïc Pottier developed Fourier, a tactic solving linear inequalities on -real numbers. - -Pierre Crégut developed a new, reflection-based version of the Omega -decision procedure. - -Claudio Sacerdoti Coen designed an XML output for the |Coq| modules to be -used in the Hypertextual Electronic Library of Mathematics (HELM cf -http://www.cs.unibo.it/helm). - -A library for efficient representation of finite maps using binary trees -contributed by Jean Goubault was integrated in the basic theories. - -Pierre Courtieu developed a command and a tactic to reason on the -inductive structure of recursively defined functions. - -Jacek ChrzÄ…szcz designed and implemented the module system of |Coq| whose -foundations are in Judicaël Courant’s PhD thesis. - -The development was coordinated by C. Paulin. - -Many discussions within the Démons team and the LogiCal project -influenced significantly the design of |Coq| especially with J. Courant, -J. Duprat, J. Goubault, A. Miquel, C. Marché, B. Monate and B. Werner. - -Intensive users suggested improvements of the system : Y. Bertot, L. -Pottier, L. Théry, P. Zimmerman from INRIA, C. Alvarado, P. Crégut, -J.-F. Monin from France Telecom R & D. - -| Orsay, May. 2002 -| Hugo Herbelin & Christine Paulin -| - -Version 8.0 ------------ - -Coq version 8 is a major revision of the |Coq| proof assistant. First, the -underlying logic is slightly different. The so-called *impredicativity* -of the sort Set has been dropped. The main reason is that it is -inconsistent with the principle of description which is quite a useful -principle for formalizing mathematics within classical logic. Moreover, -even in an constructive setting, the impredicativity of Set does not add -so much in practice and is even subject of criticism from a large part -of the intuitionistic mathematician community. Nevertheless, the -impredicativity of Set remains optional for users interested in -investigating mathematical developments which rely on it. - -Secondly, the concrete syntax of terms has been completely revised. The -main motivations were - -- a more uniform, purified style: all constructions are now lowercase, - with a functional programming perfume (e.g. abstraction is now - written fun), and more directly accessible to the novice (e.g. - dependent product is now written forall and allows omission of - types). Also, parentheses are no longer mandatory for function - application. - -- extensibility: some standard notations (e.g. “<†and “>â€) were - incompatible with the previous syntax. Now all standard arithmetic - notations (=, +, \*, /, <, <=, ... and more) are directly part of the - syntax. - -Together with the revision of the concrete syntax, a new mechanism of -*interpretation scopes* permits to reuse the same symbols (typically +, --, \*, /, <, <=) in various mathematical theories without any -ambiguities for |Coq|, leading to a largely improved readability of |Coq| -scripts. New commands to easily add new symbols are also provided. - -Coming with the new syntax of terms, a slight reform of the tactic -language and of the language of commands has been carried out. The -purpose here is a better uniformity making the tactics and commands -easier to use and to remember. - -Thirdly, a restructuring and uniformization of the standard library of -Coq has been performed. There is now just one Leibniz equality usable -for all the different kinds of |Coq| objects. Also, the set of real -numbers now lies at the same level as the sets of natural and integer -numbers. Finally, the names of the standard properties of numbers now -follow a standard pattern and the symbolic notations for the standard -definitions as well. - -The fourth point is the release of |CoqIDE|, a new graphical gtk2-based -interface fully integrated with |Coq|. Close in style to the Proof General -Emacs interface, it is faster and its integration with |Coq| makes -interactive developments more friendly. All mathematical Unicode symbols -are usable within |CoqIDE|. - -Finally, the module system of |Coq| completes the picture of |Coq| version -8.0. Though released with an experimental status in the previous version -7.4, it should be considered as a salient feature of the new version. - -Besides, |Coq| comes with its load of novelties and improvements: new or -improved tactics (including a new tactic for solving first-order -statements), new management commands, extended libraries. - -Bruno Barras and Hugo Herbelin have been the main contributors of the -reflection and the implementation of the new syntax. The smart automatic -translator from old to new syntax released with |Coq| is also their work -with contributions by Olivier Desmettre. - -Hugo Herbelin is the main designer and implementer of the notion of -interpretation scopes and of the commands for easily adding new -notations. - -Hugo Herbelin is the main implementer of the restructured standard library. - -Pierre Corbineau is the main designer and implementer of the new tactic -for solving first-order statements in presence of inductive types. He is -also the maintainer of the non-domain specific automation tactics. - -Benjamin Monate is the developer of the |CoqIDE| graphical interface with -contributions by Jean-Christophe Filliâtre, Pierre Letouzey, Claude -Marché and Bruno Barras. - -Claude Marché coordinated the edition of the Reference Manual for |Coq| -V8.0. - -Pierre Letouzey and Jacek ChrzÄ…szcz respectively maintained the -extraction tool and module system of |Coq|. - -Jean-Christophe Filliâtre, Pierre Letouzey, Hugo Herbelin and other -contributors from Sophia-Antipolis and Nijmegen participated in -extending the library. - -Julien Narboux built a NSIS-based automatic |Coq| installation tool for -the Windows platform. - -Hugo Herbelin and Christine Paulin coordinated the development which was -under the responsibility of Christine Paulin. - -| Palaiseau & Orsay, Apr. 2004 -| Hugo Herbelin & Christine Paulin -| (updated Apr. 2006) -| - -Version 8.1 ------------ - -Coq version 8.1 adds various new functionalities. - -Benjamin Grégoire implemented an alternative algorithm to check the -convertibility of terms in the |Coq| type checker. This alternative -algorithm works by compilation to an efficient bytecode that is -interpreted in an abstract machine similar to Xavier Leroy’s ZINC -machine. Convertibility is performed by comparing the normal forms. This -alternative algorithm is specifically interesting for proofs by -reflection. More generally, it is convenient in case of intensive -computations. - -Christine Paulin implemented an extension of inductive types allowing -recursively non uniform parameters. Hugo Herbelin implemented -sort-polymorphism for inductive types (now called template polymorphism). - -Claudio Sacerdoti Coen improved the tactics for rewriting on arbitrary -compatible equivalence relations. He also generalized rewriting to -arbitrary transition systems. - -Claudio Sacerdoti Coen added new features to the module system. - -Benjamin Grégoire, Assia Mahboubi and Bruno Barras developed a new, more -efficient and more general simplification algorithm for rings and -semirings. - -Laurent Théry and Bruno Barras developed a new, significantly more -efficient simplification algorithm for fields. - -Hugo Herbelin, Pierre Letouzey, Julien Forest, Julien Narboux and -Claudio Sacerdoti Coen added new tactic features. - -Hugo Herbelin implemented matching on disjunctive patterns. - -New mechanisms made easier the communication between |Coq| and external -provers. Nicolas Ayache and Jean-Christophe Filliâtre implemented -connections with the provers cvcl, Simplify and zenon. Hugo Herbelin -implemented an experimental protocol for calling external tools from the -tactic language. - -Matthieu Sozeau developed Russell, an experimental language to specify -the behavior of programs with subtypes. - -A mechanism to automatically use some specific tactic to solve -unresolved implicit has been implemented by Hugo Herbelin. - -Laurent Théry’s contribution on strings and Pierre Letouzey and -Jean-Christophe Filliâtre’s contribution on finite maps have been -integrated to the |Coq| standard library. Pierre Letouzey developed a -library about finite sets “à la Objective Camlâ€. With Jean-Marc Notin, -he extended the library on lists. Pierre Letouzey’s contribution on -rational numbers has been integrated and extended. - -Pierre Corbineau extended his tactic for solving first-order statements. -He wrote a reflection-based intuitionistic tautology solver. - -Pierre Courtieu, Julien Forest and Yves Bertot added extra support to -reason on the inductive structure of recursively defined functions. - -Jean-Marc Notin significantly contributed to the general maintenance of -the system. He also took care of ``coqdoc``. - -Pierre Castéran contributed to the documentation of (co-)inductive types -and suggested improvements to the libraries. - -Pierre Corbineau implemented a declarative mathematical proof language, -usable in combination with the tactic-based style of proof. - -Finally, many users suggested improvements of the system through the -Coq-Club mailing list and bug-tracker systems, especially user groups -from INRIA Rocquencourt, Radboud University, University of Pennsylvania -and Yale University. - -| Palaiseau, July 2006 -| Hugo Herbelin -| - -Version 8.2 ------------ - -Coq version 8.2 adds new features, new libraries and improves on many -various aspects. - -Regarding the language of |Coq|, the main novelty is the introduction by -Matthieu Sozeau of a package of commands providing Haskell-style typeclasses. -Typeclasses, which come with a few convenient features such as -type-based resolution of implicit arguments, play a new landmark role -in the architecture of |Coq| with respect to automation. For -instance, thanks to typeclass support, Matthieu Sozeau could -implement a new resolution-based version of the tactics dedicated to -rewriting on arbitrary transitive relations. - -Another major improvement of |Coq| 8.2 is the evolution of the arithmetic -libraries and of the tools associated to them. Benjamin Grégoire and -Laurent Théry contributed a modular library for building arbitrarily -large integers from bounded integers while Evgeny Makarov contributed a -modular library of abstract natural and integer arithmetic together -with a few convenient tactics. On his side, Pierre Letouzey made -numerous extensions to the arithmetic libraries on :math:`\mathbb{Z}` -and :math:`\mathbb{Q}`, including extra support for automation in -presence of various number-theory concepts. - -Frédéric Besson contributed a reflective tactic based on Krivine-Stengle -Positivstellensatz (the easy way) for validating provability of systems -of inequalities. The platform is flexible enough to support the -validation of any algorithm able to produce a “certificate†for the -Positivstellensatz and this covers the case of Fourier-Motzkin (for -linear systems in :math:`\mathbb{Q}` and :math:`\mathbb{R}`), -Fourier-Motzkin with cutting planes (for linear systems in -:math:`\mathbb{Z}`) and sum-of-squares (for non-linear systems). Evgeny -Makarov made the platform generic over arbitrary ordered rings. - -Arnaud Spiwack developed a library of 31-bits machine integers and, -relying on Benjamin Grégoire and Laurent Théry’s library, delivered a -library of unbounded integers in base :math:`2^{31}`. As importantly, he -developed a notion of “retro-knowledge†so as to safely extend the -kernel-located bytecode-based efficient evaluation algorithm of |Coq| -version 8.1 to use 31-bits machine arithmetic for efficiently computing -with the library of integers he developed. - -Beside the libraries, various improvements were contributed to provide a more -comfortable end-user language and more expressive tactic language. Hugo -Herbelin and Matthieu Sozeau improved the pattern matching compilation -algorithm (detection of impossible clauses in pattern matching, -automatic inference of the return type). Hugo Herbelin, Pierre Letouzey -and Matthieu Sozeau contributed various new convenient syntactic -constructs and new tactics or tactic features: more inference of -redundant information, better unification, better support for proof or -definition by fixpoint, more expressive rewriting tactics, better -support for meta-variables, more convenient notations... - -Élie Soubiran improved the module system, adding new features (such as -an “include†command) and making it more flexible and more general. He -and Pierre Letouzey improved the support for modules in the extraction -mechanism. - -Matthieu Sozeau extended the Russell language, ending in an convenient -way to write programs of given specifications, Pierre Corbineau extended -the Mathematical Proof Language and the automation tools that -accompany it, Pierre Letouzey supervised and extended various parts of the -standard library, Stéphane Glondu contributed a few tactics and -improvements, Jean-Marc Notin provided help in debugging, general -maintenance and coqdoc support, Vincent Siles contributed extensions of -the Scheme command and of injection. - -Bruno Barras implemented the ``coqchk`` tool: this is a stand-alone -type checker that can be used to certify .vo files. Especially, as this -verifier runs in a separate process, it is granted not to be “hijacked†-by virtually malicious extensions added to |Coq|. - -Yves Bertot, Jean-Christophe Filliâtre, Pierre Courtieu and Julien -Forest acted as maintainers of features they implemented in previous -versions of |Coq|. - -Julien Narboux contributed to |CoqIDE|. Nicolas Tabareau made the -adaptation of the interface of the old “setoid rewrite†tactic to the -new version. Lionel Mamane worked on the interaction between |Coq| and its -external interfaces. With Samuel Mimram, he also helped making |Coq| -compatible with recent software tools. Russell O’Connor, Cezary -Kaliszyk, Milad Niqui contributed to improve the libraries of integers, -rational, and real numbers. We also thank many users and partners for -suggestions and feedback, in particular Pierre Castéran and Arthur -Charguéraud, the INRIA Marelle team, Georges Gonthier and the -INRIA-Microsoft Mathematical Components team, the Foundations group at -Radboud university in Nijmegen, reporters of bugs and participants to -the Coq-Club mailing list. - -| Palaiseau, June 2008 -| Hugo Herbelin -| - -Version 8.3 ------------ - -Coq version 8.3 is before all a transition version with refinements or -extensions of the existing features and libraries and a new tactic nsatz -based on Hilbert’s Nullstellensatz for deciding systems of equations -over rings. - -With respect to libraries, the main evolutions are due to Pierre -Letouzey with a rewriting of the library of finite sets FSets and a new -round of evolutions in the modular development of arithmetic (library -Numbers). The reason for making FSets evolve is that the computational -and logical contents were quite intertwined in the original -implementation, leading in some cases to longer computations than -expected and this problem is solved in the new MSets implementation. As -for the modular arithmetic library, it was only dealing with the basic -arithmetic operators in the former version and its current extension -adds the standard theory of the division, min and max functions, all -made available for free to any implementation of :math:`\mathbb{N}`, -:math:`\mathbb{Z}` or :math:`\mathbb{Z}/n\mathbb{Z}`. - -The main other evolutions of the library are due to Hugo Herbelin who -made a revision of the sorting library (including a certified -merge-sort) and to Guillaume Melquiond who slightly revised and cleaned -up the library of reals. - -The module system evolved significantly. Besides the resolution of some -efficiency issues and a more flexible construction of module types, Élie -Soubiran brought a new model of name equivalence, the -:math:`\Delta`-equivalence, which respects as much as possible the names -given by the users. He also designed with Pierre Letouzey a new, -convenient operator ``<+`` for nesting functor application that -provides a light notation for inheriting the properties of cascading -modules. - -The new tactic nsatz is due to Loïc Pottier. It works by computing -Gröbner bases. Regarding the existing tactics, various improvements have -been done by Matthieu Sozeau, Hugo Herbelin and Pierre Letouzey. - -Matthieu Sozeau extended and refined the typeclasses and Program -features (the Russell language). Pierre Letouzey maintained and improved -the extraction mechanism. Bruno Barras and Élie Soubiran maintained the -Coq checker, Julien Forest maintained the Function mechanism for -reasoning over recursively defined functions. Matthieu Sozeau, Hugo -Herbelin and Jean-Marc Notin maintained coqdoc. Frédéric Besson -maintained the Micromega platform for deciding systems of inequalities. -Pierre Courtieu maintained the support for the Proof General Emacs -interface. Claude Marché maintained the plugin for calling external -provers (dp). Yves Bertot made some improvements to the libraries of -lists and integers. Matthias Puech improved the search functions. -Guillaume Melquiond usefully contributed here and there. Yann -Régis-Gianas grounded the support for Unicode on a more standard and -more robust basis. - -Though invisible from outside, Arnaud Spiwack improved the general -process of management of existential variables. Pierre Letouzey and -Stéphane Glondu improved the compilation scheme of the |Coq| archive. -Vincent Gross provided support to |CoqIDE|. Jean-Marc Notin provided -support for benchmarking and archiving. - -Many users helped by reporting problems, providing patches, suggesting -improvements or making useful comments, either on the bug tracker or on -the Coq-Club mailing list. This includes but not exhaustively Cédric -Auger, Arthur Charguéraud, François Garillot, Georges Gonthier, Robin -Green, Stéphane Lescuyer, Eelis van der Weegen, ... - -Though not directly related to the implementation, special thanks are -going to Yves Bertot, Pierre Castéran, Adam Chlipala, and Benjamin -Pierce for the excellent teaching materials they provided. - -| Paris, April 2010 -| Hugo Herbelin -| - -Version 8.4 ------------ - -Coq version 8.4 contains the result of three long-term projects: a new -modular library of arithmetic by Pierre Letouzey, a new proof engine by -Arnaud Spiwack and a new communication protocol for |CoqIDE| by Vincent -Gross. - -The new modular library of arithmetic extends, generalizes and unifies -the existing libraries on Peano arithmetic (types nat, N and BigN), -positive arithmetic (type positive), integer arithmetic (Z and BigZ) and -machine word arithmetic (type Int31). It provides with unified notations -(e.g. systematic use of add and mul for denoting the addition and -multiplication operators), systematic and generic development of -operators and properties of these operators for all the types mentioned -above, including gcd, pcm, power, square root, base 2 logarithm, -division, modulo, bitwise operations, logical shifts, comparisons, -iterators, ... - -The most visible feature of the new proof engine is the support for -structured scripts (bullets and proof brackets) but, even if yet not -user-available, the new engine also provides the basis for refining -existential variables using tactics, for applying tactics to several -goals simultaneously, for reordering goals, all features which are -planned for the next release. The new proof engine forced Pierre Letouzey -to reimplement info and Show Script differently. - -Before version 8.4, |CoqIDE| was linked to |Coq| with the graphical -interface living in a separate thread. From version 8.4, |CoqIDE| is a -separate process communicating with |Coq| through a textual channel. This -allows for a more robust interfacing, the ability to interrupt |Coq| -without interrupting the interface, and the ability to manage several -sessions in parallel. Relying on the infrastructure work made by Vincent -Gross, Pierre Letouzey, Pierre Boutillier and Pierre-Marie Pédrot -contributed many various refinements of |CoqIDE|. - -Coq 8.4 also comes with a bunch of various smaller-scale changes -and improvements regarding the different components of the system. - -The underlying logic has been extended with :math:`\eta`-conversion -thanks to Hugo Herbelin, Stéphane Glondu and Benjamin Grégoire. The -addition of :math:`\eta`-conversion is justified by the confidence that -the formulation of the Calculus of Inductive Constructions based on -typed equality (such as the one considered in Lee and Werner to build a -set-theoretic model of CIC :cite:`LeeWerner11`) is -applicable to the concrete implementation of |Coq|. - -The underlying logic benefited also from a refinement of the guard -condition for fixpoints by Pierre Boutillier, the point being that it is -safe to propagate the information about structurally smaller arguments -through :math:`\beta`-redexes that are blocked by the “match†-construction (blocked commutative cuts). - -Relying on the added permissiveness of the guard condition, Hugo -Herbelin could extend the pattern matching compilation algorithm so that -matching over a sequence of terms involving dependencies of a term or of -the indices of the type of a term in the type of other terms is -systematically supported. - -Regarding the high-level specification language, Pierre Boutillier -introduced the ability to give implicit arguments to anonymous -functions, Hugo Herbelin introduced the ability to define notations with -several binders (e.g. ``exists x y z, P``), Matthieu Sozeau made the -typeclass inference mechanism more robust and predictable, Enrico -Tassi introduced a command Arguments that generalizes Implicit Arguments -and Arguments Scope for assigning various properties to arguments of -constants. Various improvements in the type inference algorithm were -provided by Matthieu Sozeau and Hugo Herbelin with contributions from -Enrico Tassi. - -Regarding tactics, Hugo Herbelin introduced support for referring to -expressions occurring in the goal by pattern in tactics such as set or -destruct. Hugo Herbelin also relied on ideas from Chung-Kil Hur’s Heq -plugin to introduce automatic computation of occurrences to generalize -when using destruct and induction on types with indices. Stéphane Glondu -introduced new tactics :tacn:`constr_eq`, :tacn:`is_evar`, and :tacn:`has_evar`, to be used -when writing complex tactics. Enrico Tassi added support to fine-tuning -the behavior of :tacn:`simpl`. Enrico Tassi added the ability to specify over -which variables of a section a lemma has to be exactly generalized. -Pierre Letouzey added a tactic timeout and the interruptibility of -:tacn:`vm_compute`. Bug fixes and miscellaneous improvements of the tactic -language came from Hugo Herbelin, Pierre Letouzey and Matthieu Sozeau. - -Regarding decision tactics, Loïc Pottier maintained nsatz, moving in -particular to a typeclass based reification of goals while Frédéric -Besson maintained Micromega, adding in particular support for division. - -Regarding vernacular commands, Stéphane Glondu provided new commands to -analyze the structure of type universes. - -Regarding libraries, a new library about lists of a given length (called -vectors) has been provided by Pierre Boutillier. A new instance of -finite sets based on Red-Black trees and provided by Andrew Appel has -been adapted for the standard library by Pierre Letouzey. In the library -of real analysis, Yves Bertot changed the definition of :math:`\pi` and -provided a proof of the long-standing fact yet remaining unproved in -this library, namely that :math:`sin \frac{\pi}{2} = -1`. - -Pierre Corbineau maintained the Mathematical Proof Language (C-zar). - -Bruno Barras and Benjamin Grégoire maintained the call-by-value -reduction machines. - -The extraction mechanism benefited from several improvements provided by -Pierre Letouzey. - -Pierre Letouzey maintained the module system, with contributions from -Élie Soubiran. - -Julien Forest maintained the Function command. - -Matthieu Sozeau maintained the setoid rewriting mechanism. - -Coq related tools have been upgraded too. In particular, coq\_makefile -has been largely revised by Pierre Boutillier. Also, patches from Adam -Chlipala for coqdoc have been integrated by Pierre Boutillier. - -Bruno Barras and Pierre Letouzey maintained the `coqchk` checker. - -Pierre Courtieu and Arnaud Spiwack contributed new features for using -Coq through Proof General. - -The Dp plugin has been removed. Use the plugin provided with Why 3 -instead (http://why3.lri.fr/). - -Under the hood, the |Coq| architecture benefited from improvements in -terms of efficiency and robustness, especially regarding universes -management and existential variables management, thanks to Pierre -Letouzey and Yann Régis-Gianas with contributions from Stéphane Glondu -and Matthias Puech. The build system is maintained by Pierre Letouzey -with contributions from Stéphane Glondu and Pierre Boutillier. - -A new backtracking mechanism simplifying the task of external interfaces -has been designed by Pierre Letouzey. - -The general maintenance was done by Pierre Letouzey, Hugo Herbelin, -Pierre Boutillier, Matthieu Sozeau and Stéphane Glondu with also -specific contributions from Guillaume Melquiond, Julien Narboux and -Pierre-Marie Pédrot. - -Packaging tools were provided by Pierre Letouzey (Windows), Pierre -Boutillier (MacOS), Stéphane Glondu (Debian). Releasing, testing and -benchmarking support was provided by Jean-Marc Notin. - -Many suggestions for improvements were motivated by feedback from users, -on either the bug tracker or the Coq-Club mailing list. Special thanks -are going to the users who contributed patches, starting with Tom -Prince. Other patch contributors include Cédric Auger, David Baelde, Dan -Grayson, Paolo Herms, Robbert Krebbers, Marc Lasson, Hendrik Tews and -Eelis van der Weegen. - -| Paris, December 2011 -| Hugo Herbelin -| - -Version 8.5 ------------ - -Coq version 8.5 contains the result of five specific long-term projects: - -- A new asynchronous evaluation and compilation mode by Enrico Tassi - with help from Bruno Barras and Carst Tankink. - -- Full integration of the new proof engine by Arnaud Spiwack helped by - Pierre-Marie Pédrot, - -- Addition of conversion and reduction based on native compilation by - Maxime Dénès and Benjamin Grégoire. - -- Full universe polymorphism for definitions and inductive types by - Matthieu Sozeau. - -- An implementation of primitive projections with - :math:`\eta`\-conversion bringing significant performance improvements - when using records by Matthieu Sozeau. - -The full integration of the proof engine, by Arnaud Spiwack and -Pierre-Marie Pédrot, brings to primitive tactics and the user level Ltac -language dependent subgoals, deep backtracking and multiple goal -handling, along with miscellaneous features and an improved potential -for future modifications. Dependent subgoals allow statements in a goal -to mention the proof of another. Proofs of unsolved subgoals appear as -existential variables. Primitive backtracking makes it possible to write -a tactic with several possible outcomes which are tried successively -when subsequent tactics fail. Primitives are also available to control -the backtracking behavior of tactics. Multiple goal handling paves the -way for smarter automation tactics. It is currently used for simple goal -manipulation such as goal reordering. - -The way |Coq| processes a document in batch and interactive mode has been -redesigned by Enrico Tassi with help from Bruno Barras. Opaque proofs, -the text between Proof and Qed, can be processed asynchronously, -decoupling the checking of definitions and statements from the checking -of proofs. It improves the responsiveness of interactive development, -since proofs can be processed in the background. Similarly, compilation -of a file can be split into two phases: the first one checking only -definitions and statements and the second one checking proofs. A file -resulting from the first phase – with the .vio extension – can be -already Required. All .vio files can be turned into complete .vo files -in parallel. The same infrastructure also allows terminating tactics to -be run in parallel on a set of goals via the ``par:`` goal selector. - -|CoqIDE| was modified to cope with asynchronous checking of the document. -Its source code was also made separate from that of |Coq|, so that |CoqIDE| -no longer has a special status among user interfaces, paving the way for -decoupling its release cycle from that of |Coq| in the future. - -Carst Tankink developed a |Coq| back-end for user interfaces built on -Makarius Wenzel’s Prover IDE framework (PIDE), like PIDE/jEdit (with -help from Makarius Wenzel) or PIDE/Coqoon (with help from Alexander -Faithfull and Jesper Bengtson). The development of such features was -funded by the Paral-ITP French ANR project. - -The full universe polymorphism extension was designed by Matthieu -Sozeau. It conservatively extends the universes system and core calculus -with definitions and inductive declarations parameterized by universes -and constraints. It is based on a modification of the kernel -architecture to handle constraint checking only, leaving the generation -of constraints to the refinement/type inference engine. Accordingly, -tactics are now fully universe aware, resulting in more localized error -messages in case of inconsistencies and allowing higher-level algorithms -like unification to be entirely type safe. The internal representation -of universes has been modified but this is invisible to the user. - -The underlying logic has been extended with :math:`\eta`\-conversion for -records defined with primitive projections by Matthieu Sozeau. This -additional form of :math:`\eta`\-conversion is justified using the same -principle than the previously added :math:`\eta`\-conversion for function -types, based on formulations of the Calculus of Inductive Constructions -with typed equality. Primitive projections, which do not carry the -parameters of the record and are rigid names (not defined as a -pattern matching construct), make working with nested records more -manageable in terms of time and space consumption. This extension and -universe polymorphism were carried out partly while Matthieu Sozeau was -working at the IAS in Princeton. - -The guard condition has been made compliant with extensional equality -principles such as propositional extensionality and univalence, thanks -to Maxime Dénès and Bruno Barras. To ensure compatibility with the -univalence axiom, a new flag ``-indices-matter`` has been implemented, -taking into account the universe levels of indices when computing the -levels of inductive types. This supports using |Coq| as a tool to explore -the relations between homotopy theory and type theory. - -Maxime Dénès and Benjamin Grégoire developed an implementation of -conversion test and normal form computation using the OCaml native -compiler. It complements the virtual machine conversion offering much -faster computation for expensive functions. - -Coq 8.5 also comes with a bunch of many various smaller-scale changes -and improvements regarding the different components of the system. We -shall only list a few of them. - -Pierre Boutillier developed an improved tactic for simplification of -expressions called :tacn:`cbn`. - -Maxime Dénès maintained the bytecode-based reduction machine. Pierre -Letouzey maintained the extraction mechanism. - -Pierre-Marie Pédrot has extended the syntax of terms to, experimentally, -allow holes in terms to be solved by a locally specified tactic. - -Existential variables are referred to by identifiers rather than mere -numbers, thanks to Hugo Herbelin who also improved the tactic language -here and there. - -Error messages for universe inconsistencies have been improved by -Matthieu Sozeau. Error messages for unification and type inference -failures have been improved by Hugo Herbelin, Pierre-Marie Pédrot and -Arnaud Spiwack. - -Pierre Courtieu contributed new features for using |Coq| through Proof -General and for better interactive experience (bullets, Search, etc). - -The efficiency of the whole system has been significantly improved -thanks to contributions from Pierre-Marie Pédrot. - -A distribution channel for |Coq| packages using the OPAM tool has been -initiated by Thomas Braibant and developed by Guillaume Claret, with -contributions by Enrico Tassi and feedback from Hugo Herbelin. - -Packaging tools were provided by Pierre Letouzey and Enrico Tassi -(Windows), Pierre Boutillier, Matthieu Sozeau and Maxime Dénès (MacOS -X). Maxime Dénès improved significantly the testing and benchmarking -support. - -Many power users helped to improve the design of the new features via -the bug tracker, the coq development mailing list or the Coq-Club -mailing list. Special thanks are going to the users who contributed -patches and intensive brain-storming, starting with Jason Gross, -Jonathan Leivent, Greg Malecha, Clément Pit-Claudel, Marc Lasson, Lionel -Rieg. It would however be impossible to mention with precision all names -of people who to some extent influenced the development. - -Version 8.5 is one of the most important releases of |Coq|. Its development -spanned over about 3 years and a half with about one year of -beta-testing. General maintenance during part or whole of this period -has been done by Pierre Boutillier, Pierre Courtieu, Maxime Dénès, Hugo -Herbelin, Pierre Letouzey, Guillaume Melquiond, Pierre-Marie Pédrot, -Matthieu Sozeau, Arnaud Spiwack, Enrico Tassi as well as Bruno Barras, -Yves Bertot, Frédéric Besson, Xavier Clerc, Pierre Corbineau, -Jean-Christophe Filliâtre, Julien Forest, Sébastien Hinderer, Assia -Mahboubi, Jean-Marc Notin, Yann Régis-Gianas, François Ripault, Carst -Tankink. Maxime Dénès coordinated the release process. - -| Paris, January 2015, revised December 2015, -| Hugo Herbelin, Matthieu Sozeau and the |Coq| development team -| - -Version 8.6 ------------ - -Coq version 8.6 contains the result of refinements, stabilization of -8.5’s features and cleanups of the internals of the system. Over the -year of (now time-based) development, about 450 bugs were resolved and -over 100 contributions integrated. The main user visible changes are: - -- A new, faster state-of-the-art universe constraint checker, by - Jacques-Henri Jourdan. - -- In |CoqIDE| and other asynchronous interfaces, more fine-grained - asynchronous processing and error reporting by Enrico Tassi, making - |Coq| capable of recovering from errors and continue processing the - document. - -- More access to the proof engine features from Ltac: goal management - primitives, range selectors and a :tacn:`typeclasses eauto` engine handling - multiple goals and multiple successes, by Cyprien Mangin, Matthieu - Sozeau and Arnaud Spiwack. - -- Tactic behavior uniformization and specification, generalization of - intro-patterns by Hugo Herbelin and others. - -- A brand new warning system allowing to control warnings, turn them - into errors or ignore them selectively by Maxime Dénès, Guillaume - Melquiond, Pierre-Marie Pédrot and others. - -- Irrefutable patterns in abstractions, by Daniel de Rauglaudre. - -- The ssreflect subterm selection algorithm by Georges Gonthier and - Enrico Tassi is now accessible to tactic writers through the - ssrmatching plugin. - -- Integration of LtacProf, a profiler for Ltac by Jason Gross, Paul - Steckler, Enrico Tassi and Tobias Tebbi. - -Coq 8.6 also comes with a bunch of smaller-scale changes and -improvements regarding the different components of the system. We shall -only list a few of them. - -The iota reduction flag is now a shorthand for match, fix and cofix -flags controlling the corresponding reduction rules (by Hugo Herbelin -and Maxime Dénès). - -Maxime Dénès maintained the native compilation machinery. - -Pierre-Marie Pédrot separated the Ltac code from general purpose -tactics, and generalized and rationalized the handling of generic -arguments, allowing to create new versions of Ltac more easily in the -future. - -In patterns and terms, @, abbreviations and notations are now -interpreted the same way, by Hugo Herbelin. - -Name handling for universes has been improved by Pierre-Marie Pédrot and -Matthieu Sozeau. The minimization algorithm has been improved by -Matthieu Sozeau. - -The unifier has been improved by Hugo Herbelin and Matthieu Sozeau, -fixing some incompatibilities introduced in |Coq| 8.5. Unification -constraints can now be left floating around and be seen by the user -thanks to a new option. The Keyed Unification mode has been improved by -Matthieu Sozeau. - -The typeclass resolution engine and associated proof-search tactic have -been reimplemented on top of the proof-engine monad, providing better -integration in tactics, and new options have been introduced to control -it, by Matthieu Sozeau with help from Théo Zimmermann. - -The efficiency of the whole system has been significantly improved -thanks to contributions from Pierre-Marie Pédrot, Maxime Dénès and -Matthieu Sozeau and performance issue tracking by Jason Gross and Paul -Steckler. - -Standard library improvements by Jason Gross, Sébastien Hinderer, Pierre -Letouzey and others. - -Emilio Jesús Gallego Arias contributed many cleanups and refactorings of -the pretty-printing and user interface communication components. - -Frédéric Besson maintained the micromega tactic. - -The OPAM repository for |Coq| packages has been maintained by Guillaume -Claret, Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi and others. A -list of packages is now available at https://coq.inria.fr/opam/www/. - -Packaging tools and software development kits were prepared by Michael -Soegtrop with the help of Maxime Dénès and Enrico Tassi for Windows, and -Maxime Dénès and Matthieu Sozeau for MacOS X. Packages are now regularly -built on the continuous integration server. |Coq| now comes with a META -file usable with ocamlfind, contributed by Emilio Jesús Gallego Arias, -Gregory Malecha, and Matthieu Sozeau. - -Matej KoÅ¡Ãk maintained and greatly improved the continuous integration -setup and the testing of |Coq| contributions. He also contributed many API -improvements and code cleanups throughout the system. - -The contributors for this version are Bruno Barras, C.J. Bell, Yves -Bertot, Frédéric Besson, Pierre Boutillier, Tej Chajed, Guillaume -Claret, Xavier Clerc, Pierre Corbineau, Pierre Courtieu, Maxime Dénès, -Ricky Elrod, Emilio Jesús Gallego Arias, Jason Gross, Hugo Herbelin, -Sébastien Hinderer, Jacques-Henri Jourdan, Matej KoÅ¡Ãk, Xavier Leroy, -Pierre Letouzey, Gregory Malecha, Cyprien Mangin, Erik Martin-Dorel, -Guillaume Melquiond, Clément Pit–Claudel, Pierre-Marie Pédrot, Daniel de -Rauglaudre, Lionel Rieg, Gabriel Scherer, Thomas Sibut-Pinote, Matthieu -Sozeau, Arnaud Spiwack, Paul Steckler, Enrico Tassi, Laurent Théry, -Nickolai Zeldovich and Théo Zimmermann. The development process was -coordinated by Hugo Herbelin and Matthieu Sozeau with the help of Maxime -Dénès, who was also in charge of the release process. - -Many power users helped to improve the design of the new features via -the bug tracker, the pull request system, the |Coq| development mailing -list or the Coq-Club mailing list. Special thanks to the users who -contributed patches and intensive brain-storming and code reviews, -starting with Cyril Cohen, Jason Gross, Robbert Krebbers, Jonathan -Leivent, Xavier Leroy, Gregory Malecha, Clément Pit–Claudel, Gabriel -Scherer and Beta Ziliani. It would however be impossible to mention -exhaustively the names of everybody who to some extent influenced the -development. - -Version 8.6 is the first release of |Coq| developed on a time-based -development cycle. Its development spanned 10 months from the release of -Coq 8.5 and was based on a public roadmap. To date, it contains more -external contributions than any previous |Coq| system. Code reviews were -systematically done before integration of new features, with an -important focus given to compatibility and performance issues, resulting -in a hopefully more robust release than |Coq| 8.5. - -Coq Enhancement Proposals (CEPs for short) were introduced by Enrico -Tassi to provide more visibility and a discussion period on new -features, they are publicly available https://github.com/coq/ceps. - -Started during this period, an effort is led by Yves Bertot and Maxime -Dénès to put together a |Coq| consortium. - -| Paris, November 2016, -| Matthieu Sozeau and the |Coq| development team -| - -Version 8.7 ------------ - -|Coq| version 8.7 contains the result of refinements, stabilization of features -and cleanups of the internals of the system along with a few new features. The -main user visible changes are: - -- New tactics: variants of tactics supporting existential variables :tacn:`eassert`, - :tacn:`eenough`, etc... by Hugo Herbelin. Tactics ``extensionality in H`` and - :tacn:`inversion_sigma` by Jason Gross, ``specialize with ...`` accepting partial bindings - by Pierre Courtieu. - -- ``Cumulative Polymorphic Inductive`` types, allowing cumulativity of universes to - go through applied inductive types, by Amin Timany and Matthieu Sozeau. - -- Integration of the SSReflect plugin and its documentation in the reference - manual, by Enrico Tassi, Assia Mahboubi and Maxime Dénès. - -- The ``coq_makefile`` tool was completely redesigned to improve its maintainability - and the extensibility of generated Makefiles, and to make ``_CoqProject`` files - more palatable to IDEs by Enrico Tassi. - -|Coq| 8.7 involved a large amount of work on cleaning and speeding up the code -base, notably the work of Pierre-Marie Pédrot on making the tactic-level system -insensitive to existential variable expansion, providing a safer API to plugin -writers and making the code more robust. The ``dev/doc/changes.txt`` file -documents the numerous changes to the implementation and improvements of -interfaces. An effort to provide an official, streamlined API to plugin writers -is in progress, thanks to the work of Matej KoÅ¡Ãk. - -Version 8.7 also comes with a bunch of smaller-scale changes and improvements -regarding the different components of the system. We shall only list a few of -them. - -The efficiency of the whole system has been significantly improved thanks to -contributions from Pierre-Marie Pédrot, Maxime Dénès and Matthieu Sozeau and -performance issue tracking by Jason Gross and Paul Steckler. - -Thomas Sibut-Pinote and Hugo Herbelin added support for side effect hooks in -cbv, cbn and simpl. The side effects are provided via a plugin available at -https://github.com/herbelin/reduction-effects/. - -The BigN, BigZ, BigQ libraries are no longer part of the |Coq| standard library, -they are now provided by a separate repository https://github.com/coq/bignums, -maintained by Pierre Letouzey. - -In the Reals library, ``IZR`` has been changed to produce a compact representation -of integers and real constants are now represented using ``IZR`` (work by -Guillaume Melquiond). - -Standard library additions and improvements by Jason Gross, Pierre Letouzey and -others, documented in the ``CHANGES.md`` file. - -The mathematical proof language/declarative mode plugin was removed from the -archive. - -The OPAM repository for |Coq| packages has been maintained by Guillaume Melquiond, -Matthieu Sozeau, Enrico Tassi with contributions from many users. A list of -packages is available at https://coq.inria.fr/opam/www/. - -Packaging tools and software development kits were prepared by Michael Soegtrop -with the help of Maxime Dénès and Enrico Tassi for Windows, and Maxime Dénès for -MacOS X. Packages are regularly built on the Travis continuous integration -server. - -The contributors for this version are Abhishek Anand, C.J. Bell, Yves Bertot, -Frédéric Besson, Tej Chajed, Pierre Courtieu, Maxime Dénès, Julien Forest, -Gaëtan Gilbert, Jason Gross, Hugo Herbelin, Emilio Jesús Gallego Arias, Ralf -Jung, Matej KoÅ¡Ãk, Xavier Leroy, Pierre Letouzey, Assia Mahboubi, Cyprien -Mangin, Erik Martin-Dorel, Olivier Marty, Guillaume Melquiond, Sam Pablo Kuper, -Benjamin Pierce, Pierre-Marie Pédrot, Lars Rasmusson, Lionel Rieg, Valentin -Robert, Yann Régis-Gianas, Thomas Sibut-Pinote, Michael Soegtrop, Matthieu -Sozeau, Arnaud Spiwack, Paul Steckler, George Stelle, Pierre-Yves Strub, Enrico -Tassi, Hendrik Tews, Amin Timany, Laurent Théry, Vadim Zaliva and Théo -Zimmermann. - -The development process was coordinated by Matthieu Sozeau with the help of -Maxime Dénès, who was also in charge of the release process. Théo Zimmermann is -the maintainer of this release. - -Many power users helped to improve the design of the new features via the bug -tracker, the pull request system, the |Coq| development mailing list or the -Coq-Club mailing list. Special thanks to the users who contributed patches and -intensive brain-storming and code reviews, starting with Jason Gross, Ralf Jung, -Robbert Krebbers, Xavier Leroy, Clément Pit–Claudel and Gabriel Scherer. It -would however be impossible to mention exhaustively the names of everybody who -to some extent influenced the development. - -Version 8.7 is the second release of |Coq| developed on a time-based development -cycle. Its development spanned 9 months from the release of |Coq| 8.6 and was -based on a public road-map. It attracted many external contributions. Code -reviews and continuous integration testing were systematically used before -integration of new features, with an important focus given to compatibility and -performance issues, resulting in a hopefully more robust release than |Coq| 8.6 -while maintaining compatibility. - -|Coq| Enhancement Proposals (CEPs for short) and open pull request discussions -were used to discuss publicly the new features. - -The |Coq| consortium, an organization directed towards users and supporters of the -system, is now upcoming and will rely on Inria’s newly created Foundation. - -| Paris, August 2017, -| Matthieu Sozeau and the |Coq| development team -| - -Version 8.8 ------------ - -|Coq| version 8.8 contains the result of refinements and stabilization of -features and deprecations, cleanups of the internals of the system along -with a few new features. The main user visible changes are: - -- Kernel: fix a subject reduction failure due to allowing fixpoints - on non-recursive values, by Matthieu Sozeau. - Handling of evars in the VM (the kernel still does not accept evars) - by Pierre-Marie Pédrot. - -- Notations: many improvements on recursive notations and support for - destructuring patterns in the syntax of notations by Hugo Herbelin. - -- Proof language: tacticals for profiling, timing and checking success - or failure of tactics by Jason Gross. The focusing bracket ``{`` - supports single-numbered goal selectors, e.g. ``2:{``, by Théo - Zimmermann. - -- Vernacular: deprecation of commands and more uniform handling of the - ``Local`` flag, by Vincent Laporte and Maxime Dénès, part of a larger - attribute system overhaul. Experimental ``Show Extraction`` command by - Pierre Letouzey. Coercion now accepts ``Prop`` or ``Type`` as a source - by Arthur Charguéraud. ``Export`` modifier for options allowing to - export the option to modules that ``Import`` and not only ``Require`` - a module, by Pierre-Marie Pédrot. - -- Universes: many user-level and API level enhancements: qualified - naming and printing, variance annotations for cumulative inductive - types, more general constraints and enhancements of the minimization - heuristics, interaction with modules by Gaëtan Gilbert, Pierre-Marie - Pédrot and Matthieu Sozeau. - -- Library: Decimal Numbers library by Pierre Letouzey and various small - improvements. - -- Documentation: a large community effort resulted in the migration - of the reference manual to the Sphinx documentation tool. The result - is this manual. The new documentation infrastructure (based on Sphinx) - is by Clément Pit-Claudel. The migration was coordinated by Maxime Dénès - and Paul Steckler, with some help of Théo Zimmermann during the - final integration phase. The 14 people who ported the manual are - Calvin Beck, Heiko Becker, Yves Bertot, Maxime Dénès, Richard Ford, - Pierre Letouzey, Assia Mahboubi, Clément Pit-Claudel, - Laurence Rideau, Matthieu Sozeau, Paul Steckler, Enrico Tassi, - Laurent Théry, Nikita Zyuzin. - -- Tools: experimental ``-mangle-names`` option to ``coqtop``/``coqc`` for - linting proof scripts, by Jasper Hugunin. - -On the implementation side, the ``dev/doc/changes.md`` file -documents the numerous changes to the implementation and improvements of -interfaces. The file provides guidelines on porting a plugin to the new -version. - -Version 8.8 also comes with a bunch of smaller-scale changes and -improvements regarding the different components of the system. -Most important ones are documented in the ``CHANGES.md`` file. - -The efficiency of the whole system has seen improvements thanks to -contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and -Matthieu Sozeau and performance issue tracking by Jason Gross and Paul -Steckler. - -The official wiki and the bugtracker of |Coq| migrated to the GitHub -platform, thanks to the work of Pierre Letouzey and Théo -Zimmermann. Gaëtan Gilbert, Emilio Jesús Gallego Arias worked on -maintaining and improving the continuous integration system. - -The OPAM repository for |Coq| packages has been maintained by Guillaume -Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many -users. A list of packages is available at https://coq.inria.fr/opam/www/. - -The 44 contributors for this version are Yves Bertot, Joachim Breitner, Tej -Chajed, Arthur Charguéraud, Jacques-Pascal Deplaix, Maxime Dénès, Jim Fehrle, -Julien Forest, Yannick Forster, Gaëtan Gilbert, Jason Gross, Samuel Gruetter, -Thomas Hebb, Hugo Herbelin, Jasper Hugunin, Emilio Jesus Gallego Arias, Ralf -Jung, Johannes Kloos, Matej KoÅ¡Ãk, Robbert Krebbers, Tony Beta Lambda, Vincent -Laporte, Peter LeFanu Lumsdaine, Pierre Letouzey, Farzon Lotfi, Cyprien Mangin, -Guillaume Melquiond, Raphaël Monat, Carl Patenaude Poulin, Pierre-Marie Pédrot, -Clément Pit-Claudel, Matthew Ryan, Matt Quinn, Sigurd Schneider, Bernhard -Schommer, Michael Soegtrop, Matthieu Sozeau, Arnaud Spiwack, Paul Steckler, -Enrico Tassi, Anton Trunov, Martin Vassor, Vadim Zaliva and Théo Zimmermann. - -Version 8.8 is the third release of |Coq| developed on a time-based -development cycle. Its development spanned 6 months from the release of -|Coq| 8.7 and was based on a public roadmap. The development process -was coordinated by Matthieu Sozeau. Maxime Dénès was in charge of the -release process. Théo Zimmermann is the maintainer of this release. - -Many power users helped to improve the design of the new features via -the bug tracker, the pull request system, the |Coq| development mailing -list or the coq-club@inria.fr mailing list. Special thanks to the users who -contributed patches and intensive brain-storming and code reviews, -starting with Jason Gross, Ralf Jung, Robbert Krebbers and Amin Timany. -It would however be impossible to mention exhaustively the names -of everybody who to some extent influenced the development. - -The |Coq| consortium, an organization directed towards users and -supporters of the system, is now running and employs Maxime Dénès. -The contacts of the Coq Consortium are Yves Bertot and Maxime Dénès. - -| Santiago de Chile, March 2018, -| Matthieu Sozeau for the |Coq| development team -| - -Version 8.9 ------------ - -|Coq| version 8.9 contains the result of refinements and stabilization -of features and deprecations or removals of deprecated features, -cleanups of the internals of the system and API along with a few new -features. This release includes many user-visible changes, including -deprecations that are documented in ``CHANGES.md`` and new features that -are documented in the reference manual. Here are the most important -changes: - -- Kernel: mutually recursive records are now supported, by Pierre-Marie - Pédrot. - -- Notations: - - - Support for autonomous grammars of terms called “custom entriesâ€, by - Hugo Herbelin (see Section :ref:`custom-entries` of the reference - manual). - - - Deprecated notations of the standard library will be removed in the - next version of |Coq|, see the ``CHANGES.md`` file for a script to - ease porting, by Jason Gross and Jean-Christophe Léchenet. - - - Added the :cmd:`Numeral Notation` command for registering decimal - numeral notations for custom types, by Daniel de Rauglaudre, Pierre - Letouzey and Jason Gross. - -- Tactics: Introduction tactics :tacn:`intro`/:tacn:`intros` on a goal that is an - existential variable now force a refinement of the goal into a - dependent product rather than failing, by Hugo Herbelin. - -- Decision procedures: deprecation of tactic ``romega`` in favor of - :tacn:`lia` and removal of ``fourier``, replaced by :tacn:`lra` which - subsumes it, by Frédéric Besson, Maxime Dénès, Vincent Laporte and - Laurent Théry. - -- Proof language: focusing bracket ``{`` now supports named - :ref:`goals <curly-braces>`, e.g. ``[x]:{`` will focus - on a goal (existential variable) named ``x``, by Théo Zimmermann. - -- SSReflect: the implementation of delayed clear was simplified by - Enrico Tassi: the variables are always renamed using inaccessible - names when the clear switch is processed and finally cleared at the - end of the intro pattern. In addition to that, the use-and-discard flag - ``{}`` typical of rewrite rules can now be also applied to views, - e.g. ``=> {}/v`` applies ``v`` and then clears ``v``. See Section - :ref:`introduction_ssr`. - -- Vernacular: - - - Experimental support for :ref:`attributes <gallina-attributes>` on - commands, by Vincent Laporte, as in ``#[local] Lemma foo : bar.`` - Tactics and tactic notations now support the ``deprecated`` - attribute. - - - Removed deprecated commands ``Arguments Scope`` and ``Implicit - Arguments`` in favor of :cmd:`Arguments`, with the help of Jasper - Hugunin. - - - New flag :flag:`Uniform Inductive Parameters` by Jasper Hugunin to - avoid repeating uniform parameters in constructor declarations. - - - New commands :cmd:`Hint Variables` and :cmd:`Hint Constants`, by - Matthieu Sozeau, for controlling the opacity status of variables and - constants in hint databases. It is recommended to always use these - commands after creating a hint databse with :cmd:`Create HintDb`. - - - Multiple sections with the same name are now allowed, by Jasper - Hugunin. - -- Library: additions and changes in the ``VectorDef``, ``Ascii``, and - ``String`` libraries. Syntax notations are now available only when using - ``Import`` of libraries and not merely ``Require``, by various - contributors (source of incompatibility, see ``CHANGES.md`` for details). - -- Toplevels: ``coqtop`` and ``coqide`` can now display diffs between proof - steps in color, using the :opt:`Diffs` option, by Jim Fehrle. - -- Documentation: we integrated a large number of fixes to the new Sphinx - documentation by various contributors, coordinated by Clément - Pit-Claudel and Théo Zimmermann. - -- Tools: removed the ``gallina`` utility and the homebrewed ``Emacs`` mode. - -- Packaging: as in |Coq| 8.8.2, the Windows installer now includes many - more external packages that can be individually selected for - installation, by Michael Soegtrop. - -Version 8.9 also comes with a bunch of smaller-scale changes and -improvements regarding the different components of the system. Most -important ones are documented in the ``CHANGES.md`` file. - -On the implementation side, the ``dev/doc/changes.md`` file documents -the numerous changes to the implementation and improvements of -interfaces. The file provides guidelines on porting a plugin to the new -version and a plugin development tutorial kept in sync with Coq was -introduced by Yves Bertot http://github.com/ybertot/plugin_tutorials. -The new ``dev/doc/critical-bugs`` file documents the known critical bugs -of |Coq| and affected releases. - -The efficiency of the whole system has seen improvements thanks to -contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. - -Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael -Soegtrop, Théo Zimmermann worked on maintaining and improving the -continuous integration system. - -The OPAM repository for |Coq| packages has been maintained by Guillaume -Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many -users. A list of packages is available at https://coq.inria.fr/opam/www/. - -The 54 contributors for this version are Léo Andrès, Rin Arakaki, -Benjamin Barenblat, Langston Barrett, Siddharth Bhat, Martin Bodin, -Simon Boulier, Timothy Bourke, Joachim Breitner, Tej Chajed, Arthur -Charguéraud, Pierre Courtieu, Maxime Dénès, Andres Erbsen, Jim Fehrle, -Julien Forest, Emilio Jesus Gallego Arias, Gaëtan Gilbert, MatÄ›j -Grabovský, Jason Gross, Samuel Gruetter, Armaël Guéneau, Hugo Herbelin, -Jasper Hugunin, Ralf Jung, Sam Pablo Kuper, Ambroise Lafont, Leonidas -Lampropoulos, Vincent Laporte, Peter LeFanu Lumsdaine, Pierre Letouzey, -Jean-Christophe Léchenet, Nick Lewycky, Yishuai Li, Sven M. Hallberg, -Assia Mahboubi, Cyprien Mangin, Guillaume Melquiond, Perry E. Metzger, -Clément Pit-Claudel, Pierre-Marie Pédrot, Daniel R. Grayson, Kazuhiko -Sakaguchi, Michael Soegtrop, Matthieu Sozeau, Paul Steckler, Enrico -Tassi, Laurent Théry, Anton Trunov, whitequark, Théo Winterhalter, -Zeimer, Beta Ziliani, Théo Zimmermann. - -Many power users helped to improve the design of the new features via -the issue and pull request system, the |Coq| development mailing list or -the coq-club@inria.fr mailing list. It would be impossible to mention -exhaustively the names of everybody who to some extent influenced the -development. - -Version 8.9 is the fourth release of |Coq| developed on a time-based -development cycle. Its development spanned 7 months from the release of -|Coq| 8.8. The development moved to a decentralized merging process -during this cycle. Guillaume Melquiond was in charge of the release -process and is the maintainer of this release. This release is the -result of ~2,000 commits and ~500 PRs merged, closing 75+ issues. - -The |Coq| development team welcomed Vincent Laporte, a new |Coq| -engineer working with Maxime Dénès in the |Coq| consortium. - -| Paris, November 2018, -| Matthieu Sozeau for the |Coq| development team -| diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst new file mode 100644 index 0000000000..0f5b991ba4 --- /dev/null +++ b/doc/sphinx/history.rst @@ -0,0 +1,1449 @@ +-------------------- +Early history of Coq +-------------------- + +Historical roots +---------------- + +Coq is a proof assistant for higher-order logic, allowing the +development of computer programs consistent with their formal +specification. It is the result of about ten years [#years]_ of research +of the Coq project. We shall briefly survey here three main aspects: the +*logical language* in which we write our axiomatizations and +specifications, the *proof assistant* which allows the development of +verified mathematical proofs, and the *program extractor* which +synthesizes computer programs obeying their formal specifications, +written as logical assertions in the language. + +The logical language used by |Coq| is a variety of type theory, called the +*Calculus of Inductive Constructions*. Without going back to Leibniz and +Boole, we can date the creation of what is now called mathematical logic +to the work of Frege and Peano at the turn of the century. The discovery +of antinomies in the free use of predicates or comprehension principles +prompted Russell to restrict predicate calculus with a stratification of +*types*. This effort culminated with *Principia Mathematica*, the first +systematic attempt at a formal foundation of mathematics. A +simplification of this system along the lines of simply typed +λ-calculus occurred with Church’s *Simple Theory of +Types*. The λ-calculus notation, originally used for +expressing functionality, could also be used as an encoding of natural +deduction proofs. This Curry-Howard isomorphism was used by N. de Bruijn +in the *Automath* project, the first full-scale attempt to develop and +mechanically verify mathematical proofs. This effort culminated with +Jutting’s verification of Landau’s *Grundlagen* in the 1970’s. +Exploiting this Curry-Howard isomorphism, notable achievements in proof +theory saw the emergence of two type-theoretic frameworks; the first +one, Martin-Löf’s *Intuitionistic Theory of Types*, attempts a new +foundation of mathematics on constructive principles. The second one, +Girard’s polymorphic λ-calculus :math:`F_\omega`, is a +very strong functional system in which we may represent higher-order +logic proof structures. Combining both systems in a higher-order +extension of the Automath language, T. Coquand presented in 1985 the +first version of the *Calculus of Constructions*, CoC. This strong +logical system allowed powerful axiomatizations, but direct inductive +definitions were not possible, and inductive notions had to be defined +indirectly through functional encodings, which introduced inefficiencies +and awkwardness. The formalism was extended in 1989 by T. Coquand and C. +Paulin with primitive inductive definitions, leading to the current +*Calculus of Inductive Constructions*. This extended formalism is not +rigorously defined here. Rather, numerous concrete examples are +discussed. We refer the interested reader to relevant research papers +for more information about the formalism, its meta-theoretic properties, +and semantics. However, it should not be necessary to understand this +theoretical material in order to write specifications. It is possible to +understand the Calculus of Inductive Constructions at a higher level, as +a mixture of predicate calculus, inductive predicate definitions +presented as typed PROLOG, and recursive function definitions close to +the language ML. + +Automated theorem-proving was pioneered in the 1960’s by Davis and +Putnam in propositional calculus. A complete mechanization (in the sense +of a semidecision procedure) of classical first-order logic was +proposed in 1965 by J.A. Robinson, with a single uniform inference rule +called *resolution*. Resolution relies on solving equations in free +algebras (i.e. term structures), using the *unification algorithm*. Many +refinements of resolution were studied in the 1970’s, but few convincing +implementations were realized, except of course that PROLOG is in some +sense issued from this effort. A less ambitious approach to proof +development is computer-aided proof-checking. The most notable +proof-checkers developed in the 1970’s were LCF, designed by R. Milner +and his colleagues at U. Edinburgh, specialized in proving properties +about denotational semantics recursion equations, and the Boyer and +Moore theorem-prover, an automation of primitive recursion over +inductive data types. While the Boyer-Moore theorem-prover attempted to +synthesize proofs by a combination of automated methods, LCF constructed +its proofs through the programming of *tactics*, written in a high-level +functional meta-language, ML. + +The salient feature which clearly distinguishes our proof assistant from +say LCF or Boyer and Moore’s, is its possibility to extract programs +from the constructive contents of proofs. This computational +interpretation of proof objects, in the tradition of Bishop’s +constructive mathematics, is based on a realizability interpretation, in +the sense of Kleene, due to C. Paulin. The user must just mark his +intention by separating in the logical statements the assertions stating +the existence of a computational object from the logical assertions +which specify its properties, but which may be considered as just +comments in the corresponding program. Given this information, the +system automatically extracts a functional term from a consistency proof +of its specifications. This functional term may be in turn compiled into +an actual computer program. This methodology of extracting programs from +proofs is a revolutionary paradigm for software engineering. Program +synthesis has long been a theme of research in artificial intelligence, +pioneered by R. Waldinger. The Tablog system of Z. Manna and R. +Waldinger allows the deductive synthesis of functional programs from +proofs in tableau form of their specifications, written in a variety of +first-order logic. Development of a systematic *programming logic*, +based on extensions of Martin-Löf’s type theory, was undertaken at +Cornell U. by the Nuprl team, headed by R. Constable. The first actual +program extractor, PX, was designed and implemented around 1985 by S. +Hayashi from Kyoto University. It allows the extraction of a LISP +program from a proof in a logical system inspired by the logical +formalisms of S. Feferman. Interest in this methodology is growing in +the theoretical computer science community. We can foresee the day when +actual computer systems used in applications will contain certified +modules, automatically generated from a consistency proof of their +formal specifications. We are however still far from being able to use +this methodology in a smooth interaction with the standard tools from +software engineering, i.e. compilers, linkers, run-time systems taking +advantage of special hardware, debuggers, and the like. We hope that |Coq| +can be of use to researchers interested in experimenting with this new +methodology. + +.. [#years] At the time of writting, i.e. 1995. + +Versions 1 to 5 +--------------- + +.. note:: + This summary was written in 1995 together with the previous + section and formed the initial version of the Credits chapter. + + A more comprehensive description of these early versions is available + in the following subsections, which come from a document written in + September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin. + +A first implementation of CoC was started in 1984 by G. Huet and T. +Coquand. Its implementation language was CAML, a functional programming +language from the ML family designed at INRIA in Rocquencourt. The core +of this system was a proof-checker for CoC seen as a typed +λ-calculus, called the *Constructive Engine*. This engine +was operated through a high-level notation permitting the declaration of +axioms and parameters, the definition of mathematical types and objects, +and the explicit construction of proof objects encoded as +λ-terms. A section mechanism, designed and implemented by +G. Dowek, allowed hierarchical developments of mathematical theories. +This high-level language was called the *Mathematical Vernacular*. +Furthermore, an interactive *Theorem Prover* permitted the incremental +construction of proof trees in a top-down manner, subgoaling recursively +and backtracking from dead-ends. The theorem prover executed tactics +written in CAML, in the LCF fashion. A basic set of tactics was +predefined, which the user could extend by his own specific tactics. +This system (Version 4.10) was released in 1989. Then, the system was +extended to deal with the new calculus with inductive types by C. +Paulin, with corresponding new tactics for proofs by induction. A new +standard set of tactics was streamlined, and the vernacular extended for +tactics execution. A package to compile programs extracted from proofs +to actual computer programs in CAML or some other functional language +was designed and implemented by B. Werner. A new user-interface, relying +on a CAML-X interface by D. de Rauglaudre, was designed and implemented +by A. Felty. It allowed operation of the theorem-prover through the +manipulation of windows, menus, mouse-sensitive buttons, and other +widgets. This system (Version 5.6) was released in 1991. + +Coq was ported to the new implementation Caml-light of X. Leroy and D. +Doligez by D. de Rauglaudre (Version 5.7) in 1992. A new version of |Coq| +was then coordinated by C. Murthy, with new tools designed by C. Parent +to prove properties of ML programs (this methodology is dual to program +extraction) and a new user-interaction loop. This system (Version 5.8) +was released in May 1993. A Centaur interface CTCoq was then developed +by Y. Bertot from the Croap project from INRIA-Sophia-Antipolis. + +In parallel, G. Dowek and H. Herbelin developed a new proof engine, +allowing the general manipulation of existential variables consistently +with dependent types in an experimental version of |Coq| (V5.9). + +The version V5.10 of |Coq| is based on a generic system for manipulating +terms with binding operators due to Chet Murthy. A new proof engine +allows the parallel development of partial proofs for independent +subgoals. The structure of these proof trees is a mixed representation +of derivation trees for the Calculus of Inductive Constructions with +abstract syntax trees for the tactics scripts, allowing the navigation +in a proof at various levels of details. The proof engine allows generic +environment items managed in an object-oriented way. This new +architecture, due to C. Murthy, supports several new facilities which +make the system easier to extend and to scale up: + +- User-programmable tactics are allowed + +- It is possible to separately verify development modules, and to load + their compiled images without verifying them again - a quick + relocation process allows their fast loading + +- A generic parsing scheme allows user-definable notations, with a + symmetric table-driven pretty-printer + +- Syntactic definitions allow convenient abbreviations + +- A limited facility of meta-variables allows the automatic synthesis + of certain type expressions, allowing generic notations for e.g. + equality, pairing, and existential quantification. + +In the Fall of 1994, C. Paulin-Mohring replaced the structure of +inductively defined types and families by a new structure, allowing the +mutually recursive definitions. P. Manoury implemented a translation of +recursive definitions into the primitive recursive style imposed by the +internal recursion operators, in the style of the ProPre system. C. +Muñoz implemented a decision procedure for intuitionistic propositional +logic, based on results of R. Dyckhoff. J.C. Filliâtre implemented a +decision procedure for first-order logic without contraction, based on +results of J. Ketonen and R. Weyhrauch. Finally C. Murthy implemented a +library of inversion tactics, relieving the user from tedious +definitions of “inversion predicatesâ€. + +| Rocquencourt, Feb. 1st 1995 +| Gérard Huet +| + +Version 1 +~~~~~~~~~ + +This software is a prototype type-checker for a higher-order logical +formalism known as the Theory of Constructions, presented in his PhD +thesis by Thierry Coquand, with influences from Girard's system F and +de Bruijn's Automath. The metamathematical analysis of the system is +the PhD work of Thierry Coquand. The software is mostly the work of +Gérard Huet. Most of the mathematical examples verified with the +software are due to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at +the time) was a version of ML adapted from the Edinburgh LCF system +and running on a LISP backend. The main improvements from the original +LCF ML were that ML was compiled rather than interpreted (Gérard Huet +building on the original translator by Lockwood Morris), and that it +was enriched by recursively defined types (work of Guy +Cousineau). This ancestor of CAML was used and improved by Larry +Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to +early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used +for the examples in Thierry Coquand's thesis, defended on January 31st +1985. There was a unique binding operator, used both for universal +quantification (dependent product) at the level of types and +functional abstraction (λ) at the level of terms/proofs, in the manner +of Automath. Substitution (λ-reduction) was implemented using de +Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used +for the examples in the paper: T. Coquand, G. Huet. *Constructions: A +Higher Order Proof System for Mechanizing Mathematics* :cite:`CH85`. + +Christine Paulin joined the team at this point, for her DEA research +internship. In her DEA memoir (August 1985) she presents developments +for the *lambo* function – :math:`\text{lambo}(f)(n)` computes the minimal +:math:`m` such that :math:`f(m)` is greater than :math:`n`, for :math:`f` +an increasing integer function, a challenge for constructive mathematics. +She also encoded the majority voting algorithm of Boyer and Moore. + +Version 2 +~~~~~~~~~ + +The formal system, now renamed as the *Calculus of Constructions*, was +presented with a proof of consistency and comparisons with proof +systems of Per Martin Löf, Girard, and the Automath family of N. de +Bruijn, in the paper: T. Coquand and G. Huet. *The Calculus of +Constructions* :cite:`CH88`. + +An abstraction of the software design, in the form of an abstract +machine for proof checking, and a fuller sequence of mathematical +developments was presented in: T. Coquand, G. Huet. *Concepts +Mathématiques et Informatiques Formalisés dans le Calcul des +Constructions* :cite:`CH87`. + +Version 2.8 was frozen on December 16th, 1985, and served for +developing the examples in the above papers. + +This calculus was then enriched in version 2.9 with a cumulative +hierarchy of universes. Universe levels were initially explicit +natural numbers. Another improvement was the possibility of automatic +synthesis of implicit type arguments, relieving the user of tedious +redundant declarations. + +Christine Paulin wrote an article *Algorithm development in the +Calculus of Constructions* :cite:`P86`. Besides *lambo* and *majority*, +she presents *quicksort* and a text formatting algorithm. + +Version 2.13 of the Calculus of Constructions with universes was +frozen on June 25th, 1986. + +A synthetic presentation of type theory along constructive lines with +ML algorithms was given by Gérard Huet in his May 1986 CMU course +notes *Formal Structures for Computation and Deduction*. Its chapter +*Induction and Recursion in the Theory of Constructions* was presented +as an invited paper at the Joint Conference on Theory and Practice of +Software Development TAPSOFT’87 at Pise in March 1987, and published +as *Induction Principles Formalized in the Calculus of +Constructions* :cite:`H88`. + +Version 3 +~~~~~~~~~ + +This version saw the beginning of proof automation, with a search +algorithm inspired from PROLOG and the applicative logic programming +programs of the course notes *Formal structures for computation and +deduction*. The search algorithm was implemented in ML by Thierry +Coquand. The proof system could thus be used in two modes: proof +verification and proof synthesis, with tactics such as ``AUTO``. + +The implementation language was now called CAML, for Categorical +Abstract Machine Language. It used as backend the LLM3 virtual machine +of Le Lisp by Jérôme Chailloux. The main developers of CAML were +Michel Mauny, Ascander Suarez and Pierre Weis. + +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of +November 1986. V3.4 was developed in the first half of 1987. + +Thierry Coquand held a post-doctoral position in Cambrige University +in 1986-87, where he developed a variant implementation in SML, with +which he wrote some developments on fixpoints in Scott's domains. + +Version 4 +~~~~~~~~~ + +This version saw the beginning of program extraction from proofs, with +two varieties of the type ``Prop`` of propositions, indicating +constructive intent. The proof extraction algorithms were implemented +by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library +of mathematical developments (directory ``exemples``), with libraries +``Logic`` (containing impredicative encodings of intuitionistic logic and +algebraic primitives for booleans, natural numbers and list), ``Peano`` +developing second-order Peano arithmetic, ``Arith`` defining addition, +multiplication, euclidean division and factorial. Typical developments +were the Knaster-Tarski theorem and Newman's lemma from rewriting +theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, +Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the +log of changes. It was frozen on September 1987 as the last version +implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable +development system. + +V4.3 saw the first top-level of the system. Instead of evaluating +explicit quotations, the user could develop his mathematics in a +high-level language called the mathematical vernacular (following +Automath terminology). The user could develop files in the vernacular +notation (with ``.v`` extension) which were now separate from the ``ml`` +sources of the implementation. Gilles Dowek joined the team to +develop the vernacular language as his DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of +lemmas when local hypotheses of proofs were discharged. This gave a +notion of global mathematical environment with local sections. + +Another significant practical change was that the system, originally +developped on the VAX central computer of our lab, was transferred on +SUN personal workstations, allowing a level of distributed +development. The extraction algorithm was modified, with three +annotations ``Pos``, ``Null`` and ``Typ`` decorating the sorts ``Prop`` +and ``Type``. + +Version 4.3 was frozen at the end of November 1987, and was +distributed to an early community of users (among those were Hugo +Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. Now natural +numbers could be defined as:: + + [source, coq] + Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. + +These inductive types were encoded impredicatively in the calculus, +using a subsystem *rec* due to Christine Paulin. V4.4 was frozen on +March 6th 1988. + +Version 4.5 was the first one to support inductive types and program +extraction. Its banner was *Calcul des Constructions avec +Réalisations et Synthèse*. The vernacular language was enriched to +accommodate extraction commands. + +The verification engine design was presented as: G. Huet. *The +Constructive Engine*. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. The final paper, +describing the V4.9 implementation, appeared in: A perspective in +Theoretical Computer Science, Commemorative Volume in memory of Gift +Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on +Logical Foundations of Functional Programming organized by Gérard Huet +at Austin, Texas. + +Version 4.6 was started during the summer of 1988. Its main +improvement was the complete rehaul of the proof synthesis engine by +Thierry Coquand, with a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd +1988. It evolved progressively into LEGO, proof system for Luo's +formalism of Extended Calculus of Constructions. + +The discharge tactic was modified by Gérard Huet to allow for +inter-dependencies in discharged lemmas. Christine Paulin improved the +inductive definition scheme in order to accommodate predicates of any +arity. + +Version 4.7 was started on September 6th, 1988. + +This version starts exploiting the CAML notion of module in order to +improve the modularity of the implementation. Now the term verifier is +identified as a proper module Machine, which the structure of its +internal data structures being hidden and thus accessible only through +the legitimate operations. This machine (the constructive engine) was +the trusted core of the implementation. The proof synthesis mechanism +was a separate proof term generator. Once a complete proof term was +synthesized with the help of tactics, it was entirely re-checked by +the engine. Thus there was no need to certify the tactics, and the +system took advantage of this fact by having tactics ignore the +universe levels, universe consistency check being relegated to the +final type-checking pass. This induced a certain puzzlement in early +users who saw, after a successful proof search, their ``QED`` followed +by silence, followed by a failure message due to a universe +inconsistency… + +The set of examples comprise set theory experiments by Hugo Herbelin, +and notably the Schroeder-Bernstein theorem. + +Version 4.8, started on October 8th, 1988, saw a major +re-implementation of the abstract syntax type ``constr``, separating +variables of the formalism and metavariables denoting incomplete terms +managed by the search mechanism. A notion of level (with three values +``TYPE``, ``OBJECT`` and ``PROOF``) is made explicit and a type judgement +clarifies the constructions, whose implementation is now fully +explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof +synthesis to the new representation, and simplifies pattern matching +to first-order predicate calculus matching, with important performance +gain. + +A new representation of the universe hierarchy is then defined by +Gérard Huet. Universe levels are now implemented implicitly, through +a hidden graph of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the +ordering, and thus consistency. This was documented in a memo *Adding +Type:Type to the Calculus of Constructions* which was never published. + +The development version is released as a stable 4.8 at the end of +1988. + +Version 4.9 is released on March 1st 1989, with the new "elastic" +universe hierarchy. + +The spring of 1989 saw the first attempt at documenting the system +usage, with a number of papers describing the formalism: + +- *Metamathematical Investigations of a Calculus of Constructions*, by + Thierry Coquand :cite:`C90`, + +- *Inductive definitions in the Calculus of Constructions*, by + Christine Paulin-Mohrin, + +- *Extracting Fω's programs from proofs in the Calculus of + Constructions*, by Christine Paulin-Mohring* :cite:`P89`, + +- *The Constructive Engine*, by Gérard Huet :cite:`H89`, + +as well as a number of user guides: + +- *A short user's guide for the Constructions*, Version 4.10, by Gérard Huet +- *A Vernacular Syllabus*, by Gilles Dowek. +- *The Tactics Theorem Prover, User's guide*, Version 4.10, by Thierry + Coquand. + +Stable V4.10, released on May 1st, 1989, was then a mature system, +distributed with CAML V2.6. + +In the mean time, Thierry Coquand and Christine Paulin-Mohring had +been investigating how to add native inductive types to the Calculus +of Constructions, in the manner of Per Martin-Löf's Intuitionistic +Type Theory. The impredicative encoding had already been presented in: +F. Pfenning and C. Paulin-Mohring. *Inductively defined types in the +Calculus of Constructions* :cite:`PP90`. An extension of the calculus +with primitive inductive types appeared in: T. Coquand and +C. Paulin-Mohring. *Inductively defined types* :cite:`CP90`. + +This led to the Calculus of Inductive Constructions, logical formalism +implemented in Versions 5 upward of the system, and documented in: +C. Paulin-Mohring. *Inductive Definitions in the System Coq - Rules +and Properties* :cite:`P93`. + +The last version of CONSTR is Version 4.11, which was last distributed +in the spring of 1990. It was demonstrated at the first workshop of +the European Basic Research Action Logical Frameworks In Sophia +Antipolis in May 1990. + +Version 5 +~~~~~~~~~ + +At the end of 1989, Version 5.1 was started, and renamed as the system +Coq for the Calculus of Inductive Constructions. It was then ported to +the new stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers +University in Göteborg. Christine Paulin-Mohring took a CNRS +researcher position at the LIP laboratory of École Normale Supérieure +de Lyon. Project Formel was terminated, and gave rise to two teams: +Cristal at INRIA-Roquencourt, that continued developments in +functional programming with Caml-light then OCaml, and Coq, continuing +the type theory research, with a joint team headed by Gérard Huet at +INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory +of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software +architect of Version 5. He completely rehauled the implementation for +efficiency. Versions 5.6 and 5.8 were major distributed versions, +with complete documentation and a library of users' developements. The +use of the RCS revision control system, and systematic ChangeLog +files, allow a more precise tracking of the software developments. + +| September 2015 + +| Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. +| + +Versions 6 +---------- + +Version 6.1 +~~~~~~~~~~~ + +The present version 6.1 of |Coq| is based on the V5.10 architecture. It +was ported to the new language Objective Caml by Bruno Barras. The +underlying framework has slightly changed and allows more conversions +between sorts. + +The new version provides powerful tools for easier developments. + +Cristina Cornes designed an extension of the |Coq| syntax to allow +definition of terms using a powerful pattern matching analysis in the +style of ML programs. + +Amokrane Saïbi wrote a mechanism to simulate inheritance between types +families extending a proposal by Peter Aczel. He also developed a +mechanism to automatically compute which arguments of a constant may be +inferred by the system and consequently do not need to be explicitly +written. + +Yann Coscoy designed a command which explains a proof term using natural +language. Pierre Crégut built a new tactic which solves problems in +quantifier-free Presburger Arithmetic. Both functionalities have been +integrated to the |Coq| system by Hugo Herbelin. + +Samuel Boutin designed a tactic for simplification of commutative rings +using a canonical set of rewriting rules and equality modulo +associativity and commutativity. + +Finally the organisation of the |Coq| distribution has been supervised by +Jean-Christophe Filliâtre with the help of Judicaël Courant and Bruno +Barras. + +| Lyon, Nov. 18th 1996 +| Christine Paulin +| + +Version 6.2 +~~~~~~~~~~~ + +In version 6.2 of |Coq|, the parsing is done using camlp4, a preprocessor +and pretty-printer for CAML designed by Daniel de Rauglaudre at INRIA. +Daniel de Rauglaudre made the first adaptation of |Coq| for camlp4, this +work was continued by Bruno Barras who also changed the structure of |Coq| +abstract syntax trees and the primitives to manipulate them. The result +of these changes is a faster parsing procedure with greatly improved +syntax-error messages. The user-interface to introduce grammar or +pretty-printing rules has also changed. + +Eduardo Giménez redesigned the internal tactic libraries, giving uniform +names to Caml functions corresponding to |Coq| tactic names. + +Bruno Barras wrote new, more efficient reduction functions. + +Hugo Herbelin introduced more uniform notations in the |Coq| specification +language: the definitions by fixpoints and pattern matching have a more +readable syntax. Patrick Loiseleur introduced user-friendly notations +for arithmetic expressions. + +New tactics were introduced: Eduardo Giménez improved the mechanism to +introduce macros for tactics, and designed special tactics for +(co)inductive definitions; Patrick Loiseleur designed a tactic to +simplify polynomial expressions in an arbitrary commutative ring which +generalizes the previous tactic implemented by Samuel Boutin. +Jean-Christophe Filliâtre introduced a tactic for refining a goal, using +a proof term with holes as a proof scheme. + +David Delahaye designed the tool to search an object in the library +given its type (up to isomorphism). + +Henri Laulhère produced the |Coq| distribution for the Windows +environment. + +Finally, Hugo Herbelin was the main coordinator of the |Coq| documentation +with principal contributions by Bruno Barras, David Delahaye, +Jean-Christophe Filliâtre, Eduardo Giménez, Hugo Herbelin and Patrick +Loiseleur. + +| Orsay, May 4th 1998 +| Christine Paulin +| + +Version 6.3 +~~~~~~~~~~~ + +The main changes in version V6.3 were the introduction of a few new +tactics and the extension of the guard condition for fixpoint +definitions. + +B. Barras extended the unification algorithm to complete partial terms +and fixed various tricky bugs related to universes. + +D. Delahaye developed the ``AutoRewrite`` tactic. He also designed the +new behavior of ``Intro`` and provided the tacticals ``First`` and +``Solve``. + +J.-C. Filliâtre developed the ``Correctness`` tactic. + +\E. Giménez extended the guard condition in fixpoints. + +H. Herbelin designed the new syntax for definitions and extended the +``Induction`` tactic. + +P. Loiseleur developed the ``Quote`` tactic and the new design of the +``Auto`` tactic, he also introduced the index of errors in the +documentation. + +C. Paulin wrote the ``Focus`` command and introduced the reduction +functions in definitions, this last feature was proposed by J.-F. +Monin from CNET Lannion. + +| Orsay, Dec. 1999 +| Christine Paulin +| + +Versions 7 +---------- + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +The version V7 is a new implementation started in September 1999 by +Jean-Christophe Filliâtre. This is a major revision with respect to the +internal architecture of the system. The |Coq| version 7.0 was distributed +in March 2001, version 7.1 in September 2001, version 7.2 in January +2002, version 7.3 in May 2002 and version 7.4 in February 2003. + +Jean-Christophe Filliâtre designed the architecture of the new system. +He introduced a new representation for environments and wrote a new +kernel for type checking terms. His approach was to use functional +data-structures in order to get more sharing, to prepare the addition of +modules and also to get closer to a certified kernel. + +Hugo Herbelin introduced a new structure of terms with local +definitions. He introduced “qualified†names, wrote a new +pattern matching compilation algorithm and designed a more compact +algorithm for checking the logical consistency of universes. He +contributed to the simplification of |Coq| internal structures and the +optimisation of the system. He added basic tactics for forward reasoning +and coercions in patterns. + +David Delahaye introduced a new language for tactics. General tactics +using pattern matching on goals and context can directly be written from +the |Coq| toplevel. He also provided primitives for the design of +user-defined tactics in Caml. + +Micaela Mayero contributed the library on real numbers. Olivier +Desmettre extended this library with axiomatic trigonometric functions, +square, square roots, finite sums, Chasles property and basic plane +geometry. + +Jean-Christophe Filliâtre and Pierre Letouzey redesigned a new +extraction procedure from |Coq| terms to Caml or Haskell programs. This +new extraction procedure, unlike the one implemented in previous version +of |Coq| is able to handle all terms in the Calculus of Inductive +Constructions, even involving universes and strong elimination. P. +Letouzey adapted user contributions to extract ML programs when it was +sensible. Jean-Christophe Filliâtre wrote ``coqdoc``, a documentation +tool for |Coq| libraries usable from version 7.2. + +Bruno Barras improved the efficiency of the reduction algorithm and the +confidence level in the correctness of |Coq| critical type checking +algorithm. + +Yves Bertot designed the ``SearchPattern`` and ``SearchRewrite`` tools +and the support for the pcoq interface +(http://www-sop.inria.fr/lemme/pcoq/). + +Micaela Mayero and David Delahaye introduced Field, a decision tactic +for commutative fields. + +Christine Paulin changed the elimination rules for empty and singleton +propositional inductive types. + +Loïc Pottier developed Fourier, a tactic solving linear inequalities on +real numbers. + +Pierre Crégut developed a new, reflection-based version of the Omega +decision procedure. + +Claudio Sacerdoti Coen designed an XML output for the |Coq| modules to be +used in the Hypertextual Electronic Library of Mathematics (HELM cf +http://www.cs.unibo.it/helm). + +A library for efficient representation of finite maps using binary trees +contributed by Jean Goubault was integrated in the basic theories. + +Pierre Courtieu developed a command and a tactic to reason on the +inductive structure of recursively defined functions. + +Jacek ChrzÄ…szcz designed and implemented the module system of |Coq| whose +foundations are in Judicaël Courant’s PhD thesis. + +The development was coordinated by C. Paulin. + +Many discussions within the Démons team and the LogiCal project +influenced significantly the design of |Coq| especially with J. Courant, +J. Duprat, J. Goubault, A. Miquel, C. Marché, B. Monate and B. Werner. + +Intensive users suggested improvements of the system : Y. Bertot, L. +Pottier, L. Théry, P. Zimmerman from INRIA, C. Alvarado, P. Crégut, +J.-F. Monin from France Telecom R & D. + +| Orsay, May. 2002 +| Hugo Herbelin & Christine Paulin +| + +Details of changes in 7.0 and 7.1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Notes: + +- items followed by (**) are important sources of incompatibilities +- items followed by (*) may exceptionally be sources of incompatibilities +- items followed by (+) have been introduced in version 7.0 + + +Main novelties +^^^^^^^^^^^^^^ + +References are to Coq 7.1 reference manual + +- New primitive let-in construct (see sections 1.2.8 and ) +- Long names (see sections 2.6 and 2.7) +- New high-level tactic language (see chapter 10) +- Improved search facilities (see section 5.2) +- New extraction algorithm managing the Type level (see chapter 17) +- New rewriting tactic for arbitrary equalities (see chapter 19) +- New tactic Field to decide equalities on commutative fields (see 7.11) +- New tactic Fourier to solve linear inequalities on reals numbers (see 7.11) +- New tactics for induction/case analysis in "natural" style (see 7.7) +- Deep restructuration of the code (safer, simpler and more efficient) +- Export of theories to XML for publishing and rendering purposes + (see http://www.cs.unibo.it/helm) + + +Details of changes +^^^^^^^^^^^^^^^^^^ + +Language: new "let-in" construction +*********************************** + +- New construction for local definitions (let-in) with syntax [x:=u]t (*)(+) + +- Local definitions allowed in Record (a.k.a. record à la Randy Pollack) + + +Language: long names +******************** + +- Each construction has a unique absolute names built from a base + name, the name of the module in which they are defined (Top if in + coqtop), and possibly an arbitrary long sequence of directory (e.g. + "Coq.Lists.PolyList.flat_map" where "Coq" means that "flat_map" is part + of Coq standard library, "Lists" means it is defined in the Lists + library and "PolyList" means it is in the file Polylist) (+) + +- Constructions can be referred by their base name, or, in case of + conflict, by a "qualified" name, where the base name is prefixed + by the module name (and possibly by a directory name, and so + on). A fully qualified name is an absolute name which always refer + to the construction it denotes (to preserve the visibility of + all constructions, no conflict is allowed for an absolute name) (+) + +- Long names are available for modules with the possibility of using + the directory name as a component of the module full name (with + option -R to coqtop and coqc, or command Add LoadPath) (+) + +- Improved conflict resolution strategy (the Unix PATH model), + allowing more constructions to be referred just by their base name + + +Language: miscellaneous +*********************** + +- The names of variables for Record projections _and_ for induction principles + (e.g. sum_ind) is now based on the first letter of their type (main + source of incompatibility) (**)(+) + +- Most typing errors have now a precise location in the source (+) + +- Slightly different mechanism to solve "?" (*)(+) + +- More arguments may be considered implicit at section closing (*)(+) + +- Bug with identifiers ended by a number greater than 2^30 fixed (+) + +- New visibility discipline for Remark, Fact and Local: Remark's and + Fact's now survive at the end of section, but are only accessible using a + qualified names as soon as their strength expires; Local's disappear and + are moved into local definitions for each construction persistent at + section closing + + +Language: Cases +*************** + +- Cases no longer considers aliases inferable from dependencies in types (*)(+) + +- A redundant clause in Cases is now an error (*) + + +Reduction +********* + +- New reduction flags "Zeta" and "Evar" in Eval Compute, for inlining of + local definitions and instantiation of existential variables + +- Delta reduction flag does not perform Zeta and Evar reduction any more (*) + +- Constants declared as opaque (using Qed) can no longer become + transparent (a constant intended to be alternatively opaque and + transparent must be declared as transparent (using Defined)); a risk + exists (until next Coq version) that Simpl and Hnf reduces opaque + constants (*) + + +New tactics +*********** + +- New set of tactics to deal with types equipped with specific + equalities (a.k.a. Setoids, e.g. nat equipped with eq_nat) [by C. Renard] + +- New tactic Assert, similar to Cut but expected to be more user-friendly + +- New tactic NewDestruct and NewInduction intended to replace Elim + and Induction, Case and Destruct in a more user-friendly way (see + restrictions in the reference manual) + +- New tactic ROmega: an experimental alternative (based on reflexion) to Omega + [by P. Crégut] + +- New tactic language Ltac (see reference manual) (+) + +- New versions of Tauto and Intuition, fully rewritten in the new Ltac + language; they run faster and produce more compact proofs; Tauto is + fully compatible but, in exchange of a better uniformity, Intuition + is slightly weaker (then use Tauto instead) (**)(+) + +- New tactic Field to decide equalities on commutative fields (as a + special case, it works on real numbers) (+) + +- New tactic Fourier to solve linear inequalities on reals numbers + [by L. Pottier] (+) + +- New tactics dedicated to real numbers: DiscrR, SplitRmult, SplitAbsolu (+) + + +Changes in existing tactics +*************************** + +- Reduction tactics in local definitions apply only to the body + +- New syntax of the form "Compute in Type of H." to require a reduction on + the types of local definitions + +- Inversion, Injection, Discriminate, ... apply also on the + quantified premises of a goal (using the "Intros until" syntax) + +- Decompose has been fixed but hypotheses may get different names (*)(+) + +- Tauto now manages uniformly hypotheses and conclusions of the form + ``t=t`` which all are considered equivalent to ``True``. Especially, + Tauto now solves goals of the form ``H : ~ t = t |- A``. + +- The "Let" tactic has been renamed "LetTac" and is now based on the + primitive "let-in" (+) + +- Elim can no longer be used with an elimination schema different from + the one defined at definition time of the inductive type. To overload + an elimination schema, use "Elim <hyp> using <name of the new schema>" + (*)(+) + +- Simpl no longer unfolds the recursive calls of a mutually defined + fixpoint (*)(+) + +- Intro now fails if the hypothesis name already exists (*)(+) + +- "Require Prolog" is no longer needed (i.e. it is available by default) (*)(+) + +- Unfold now fails on a non unfoldable identifier (*)(+) + +- Unfold also applies on definitions of the local context + +- AutoRewrite now deals only with the main goal and it is the purpose of + Hint Rewrite to deal with generated subgoals (+) + +- Redundant or incompatible instantiations in Apply ... with ... are now + correctly managed (+) + + +Efficiency +********** + +- Excessive memory uses specific to V7.0 fixed + +- Sizes of .vo files vary a lot compared to V6.3 (from -30% to +300% + depending on the developments) + +- An improved reduction strategy for lazy evaluation + +- A more economical mechanism to ensure logical consistency at the Type level; + warning: this is experimental and may produce "universes" anomalies + (please report) + + +Concrete syntax of constructions +******************************** + +- Only identifiers starting with "_" or a letter, and followed by letters, + digits, "_" or "'" are allowed (e.g. "$" and "@" are no longer allowed) (*) + +- A multiple binder like (a:A)(a,b:(P a))(Q a) is no longer parsed as + (a:A)(a0:(P a))(b:(P a))(Q a0) but as (a:A)(a0:(P a))(b:(P a0))(Q a0) (*)(+) + +- A dedicated syntax has been introduced for Reals (e.g ``3+1/x``) (+) + +- Pretty-printing of Infix notations fixed. (+) + + +Parsing and grammar extension +***************************** + +- More constraints when writing ast + + - "{...}" and the macros $LIST, $VAR, etc. now expect a metavariable + (an identifier starting with $) (*) + - identifiers should starts with a letter or "_" and be followed + by letters, digits, "_" or "'" (other characters are still + supported but it is not advised to use them) (*)(+) + +- Entry "command" in "Grammar" and quotations (<<...>> stuff) is + renamed "constr" as in "Syntax" (+) + +- New syntax "[" sentence_1 ... sentence_n"]." to group sentences (useful + for Time and to write grammar rules abbreviating several commands) (+) + +- The default parser for actions in the grammar rules (and for + patterns in the pretty-printing rules) is now the one associated to + the grammar (i.e. vernac, tactic or constr); no need then for + quotations as in <:vernac:<...>>; to return an "ast", the grammar + must be explicitly typed with tag ": ast" or ": ast list", or if a + syntax rule, by using <<...>> in the patterns (expression inside + these angle brackets are parsed as "ast"); for grammars other than + vernac, tactic or constr, you may explicitly type the action with + tags ": constr", ": tactic", or ":vernac" (**)(+) + +- Interpretation of names in Grammar rule is now based on long names, + which allows to avoid problems (or sometimes tricks;) related to + overloaded names (+) + + +New commands +************ + +- New commands "Print XML All", "Show XML Proof", ... to show or + export theories to XML to be used with Helm's publishing and rendering + tools (see http://www.cs.unibo.it/helm) (by Claudio Sacerdoti Coen) (+) + +- New commands to manually set implicit arguments (+) + + - "Implicits ident." to activate the implicit arguments mode just for ident + - "Implicits ident [num1 num2 ...]." to explicitly give which + arguments have to be considered as implicit + +- New SearchPattern/SearchRewrite (by Yves Bertot) (+) + +- New commands "Debug on"/"Debug off" to activate/deactivate the tactic + language debugger (+) + +- New commands to map physical paths to logical paths (+) + - Add LoadPath physical_dir as logical_dir + - Add Rec LoadPath physical_dir as logical_dir + + +Changes in existing commands +**************************** + +- Generalization of the usage of qualified identifiers in tactics + and commands about globals, e.g. Decompose, Eval Delta; + Hints Unfold, Transparent, Require + +- Require synchronous with Reset; Require's scope stops at Section ending (*) + +- For a module indirectly loaded by a "Require" but not exported, + the command "Import module" turns the constructions defined in the + module accessible by their short name, and activates the Grammar, + Syntax, Hint, ... declared in the module (+) + +- The scope of the "Search" command can be restricted to some modules (+) + +- Final dot in command (full stop/period) must be followed by a blank + (newline, tabulation or whitespace) (+) + +- Slight restriction of the syntax for Cbv Delta: if present, option [-myconst] + must immediately follow the Delta keyword (*)(+) + +- SearchIsos currently not supported + +- Add ML Path is now implied by Add LoadPath (+) + +- New names for the following commands (+) + + AddPath -> Add LoadPath + Print LoadPath -> Print LoadPath + DelPath -> Remove LoadPath + AddRecPath -> Add Rec LoadPath + Print Path -> Print Coercion Paths + + Implicit Arguments On -> Set Implicit Arguments + Implicit Arguments Off -> Unset Implicit Arguments + + Begin Silent -> Set Silent + End Silent -> Unset Silent. + + +Tools +***** + +- coqtop (+) + + - Two executables: coqtop.byte and coqtop.opt (if supported by the platform) + - coqtop is a link to the more efficient executable (coqtop.opt if present) + - option -full is obsolete (+) + +- do_Makefile renamed into coq_makefile (+) + +- New option -R to coqtop and coqc to map a physical directory to a logical + one (+) + +- coqc no longer needs to create a temporary file + +- No more warning if no initialization file .coqrc exists + + +Extraction +********** + +- New algorithm for extraction able to deal with "Type" (+) + (by J.-C. Filliâtre and P. Letouzey) + + +Standard library +**************** + +- New library on maps on integers (IntMap, contributed by Jean Goubault) + +- New lemmas about integer numbers [ZArith] + +- New lemmas and a "natural" syntax for reals [Reals] (+) + +- Exc/Error/Value renamed into Option/Some/None (*) + + +New user contributions +********************** + +- Constructive complex analysis and the Fundamental Theorem of Algebra [FTA] + (Herman Geuvers, Freek Wiedijk, Jan Zwanenburg, Randy Pollack, + Henk Barendregt, Nijmegen) + +- A new axiomatization of ZFC set theory [Functions_in_ZFC] + (C. Simpson, Sophia-Antipolis) + +- Basic notions of graph theory [GRAPHS-BASICS] (Jean Duprat, Lyon) + +- A library for floating-point numbers [Float] (Laurent Théry, Sylvie Boldo, + Sophia-Antipolis) + +- Formalisation of CTL and TCTL temporal logic [CtlTctl] (Carlos + Daniel Luna,Montevideo) + +- Specification and verification of the Railroad Crossing Problem + in CTL and TCTL [RailroadCrossing] (Carlos Daniel Luna,Montevideo) + +- P-automaton and the ABR algorithm [PAutomata] + (Christine Paulin, Emmanuel Freund, Orsay) + +- Semantics of a subset of the C language [MiniC] + (Eduardo Giménez, Emmanuel Ledinot, Suresnes) + +- Correctness proofs of the following imperative algorithms: + Bresenham line drawing algorithm [Bresenham], Marché's minimal edition + distance algorithm [Diff] (Jean-Christophe Filliâtre, Orsay) + +- Correctness proofs of Buchberger's algorithm [Buchberger] and RSA + cryptographic algorithm [Rsa] (Laurent Théry, Sophia-Antipolis) + +- Correctness proof of Stalmarck tautology checker algorithm + [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis) + + +Details of changes in 7.2 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Language + +- Automatic insertion of patterns for local definitions in the type of + the constructors of an inductive types (for compatibility with V6.3 + let-in style) +- Coercions allowed in Cases patterns +- New declaration "Canonical Structure id = t : I" to help resolution of + equations of the form (proj ?)=a; if proj(e)=a then a is canonically + equipped with the remaining fields in e, i.e. ? is instantiated by e + +Tactics + +- New tactic "ClearBody H" to clear the body of definitions in local context +- New tactic "Assert H := c" for forward reasoning +- Slight improvement in naming strategy for NewInduction/NewDestruct +- Intuition/Tauto do not perform useless unfolding and work up to conversion + +Extraction (details in plugins/extraction/CHANGES or documentation) + +- Syntax changes: there are no more options inside the extraction commands. + New commands for customization and options have been introduced instead. +- More optimizations on extracted code. +- Extraction tests are now embedded in 14 user contributions. + +Standard library + +- In [Relations], Rstar.v and Newman.v now axiom-free. +- In [Sets], Integers.v now based on nat +- In [Arith], more lemmas in Min.v, new file Max.v, tail-recursive + plus and mult added to Plus.v and Mult.v respectively +- New directory [Sorting] with a proof of heapsort (dragged from 6.3.1 lib) +- In [Reals], more lemmas in Rbase.v, new lemmas on square, square root and + trigonometric functions (R_sqr.v - Rtrigo.v); a complementary approach + and new theorems about continuity and derivability in Ranalysis.v; some + properties in plane geometry such as translation, rotation or similarity + in Rgeom.v; finite sums and Chasles property in Rsigma.v + +Bugs + +- Confusion between implicit args of locals and globals of same base name fixed +- Various incompatibilities wrt inference of "?" in V6.3.1 fixed +- Implicits in infix section variables bug fixed +- Known coercions bugs fixed + +- Apply "universe anomaly" bug fixed +- NatRing now working +- "Discriminate 1", "Injection 1", "Simplify_eq 1" now working +- NewInduction bugs with let-in and recursively dependent hypotheses fixed +- Syntax [x:=t:T]u now allowed as mentioned in documentation + +- Bug with recursive inductive types involving let-in fixed +- Known pattern-matching bugs fixed +- Known Cases elimination predicate bugs fixed +- Improved errors messages for pattern-matching and projections +- Better error messages for ill-typed Cases expressions + +Incompatibilities + +- New naming strategy for NewInduction/NewDestruct may affect 7.1 compatibility +- Extra parentheses may exceptionally be needed in tactic definitions. +- Coq extensions written in Ocaml need to be updated (see dev/changements.txt + for a description of the main changes in the interface files of V7.2) +- New behaviour of Intuition/Tauto may exceptionally lead to incompatibilities + + +Details of changes in 7.3 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Language + +- Slightly improved compilation of pattern-matching (slight source of + incompatibilities) +- Record's now accept anonymous fields "_" which does not build projections +- Changes in the allowed elimination sorts for certain class of inductive + definitions : an inductive definition without constructors + of Sort Prop can be eliminated on sorts Set and Type A "singleton" + inductive definition (one constructor with arguments in the sort Prop + like conjunction of two propositions or equality) can be eliminated + directly on sort Type (In V7.2, only the sorts Prop and Set were allowed) + +Tactics + +- New tactic "Rename x into y" for renaming hypotheses +- New tactics "Pose x:=u" and "Pose u" to add definitions to local context +- Pattern now working on partially applied subterms +- Ring no longer applies irreversible congruence laws of mult but + better applies congruence laws of plus (slight source of incompatibilities). +- Field now accepts terms to be simplified as arguments (as for Ring). This + extension has been also implemented using the toplevel tactic language. +- Intuition does no longer unfold constants except "<->" and "~". It + can be parameterized by a tactic. It also can introduce dependent + product if needed (source of incompatibilities) +- "Match Context" now matching more recent hypotheses first and failing only + on user errors and Fail tactic (possible source of incompatibilities) +- Tactic Definition's without arguments now allowed in Coq states +- Better simplification and discrimination made by Inversion (source + of incompatibilities) + +Bugs + +- "Intros H" now working like "Intro H" trying first to reduce if not a product +- Forward dependencies in Cases now taken into account +- Known bugs related to Inversion and let-in's fixed +- Bug unexpected Delta with let-in now fixed + +Extraction (details in plugins/extraction/CHANGES or documentation) + +- Signatures of extracted terms are now mostly expunged from dummy arguments. +- Haskell extraction is now operational (tested & debugged). + +Standard library + +- Some additions in [ZArith]: three files (Zcomplements.v, Zpower.v + and Zlogarithms.v) moved from plugins/omega in order to be more + visible, one Zsgn function, more induction principles (Wf_Z.v and + tail of Zcomplements.v), one more general Euclid theorem +- Peano_dec.v and Compare_dec.v now part of Arith.v + +Tools + +- new option -dump-glob to coqtop to dump globalizations (to be used by the + new documentation tool coqdoc; see http://www.lri.fr/~filliatr/coqdoc) + +User Contributions + +- CongruenceClosure (congruence closure decision procedure) + [Pierre Corbineau, ENS Cachan] +- MapleMode (an interface to embed Maple simplification procedures over + rational fractions in Coq) + [David Delahaye, Micaela Mayero, Chalmers University] +- Presburger: A formalization of Presburger's algorithm + [Laurent Thery, INRIA Sophia Antipolis] +- Chinese has been rewritten using Z from ZArith as datatype + ZChinese is the new version, Chinese the obsolete one + [Pierre Letouzey, LRI Orsay] + +Incompatibilities + +- Ring: exceptional incompatibilities (1 above 650 in submitted user + contribs, leading to a simplification) +- Intuition: does not unfold any definition except "<->" and "~" +- Cases: removal of some extra Cases in configurations of the form + "Cases ... of C _ => ... | _ D => ..." (effects on 2 definitions of + submitted user contributions necessitating the removal of now superfluous + proof steps in 3 different proofs) +- Match Context, in case of incompatibilities because of a now non + trapped error (e.g. Not_found or Failure), use instead tactic Fail + to force Match Context trying the next clause +- Inversion: better simplification and discrimination may occasionally + lead to less subgoals and/or hypotheses and different naming of hypotheses +- Unification done by Apply/Elim has been changed and may exceptionally lead + to incompatible instantiations +- Peano_dec.v and Compare_dec.v parts of Arith.v make Auto more + powerful if these files were not already required (1 occurrence of + this in submitted user contribs) + + +Changes in 7.3.1 +^^^^^^^^^^^^^^^^ + +Bug fixes + + - Corrupted Field tactic and Match Context tactic construction fixed + - Checking of names already existing in Assert added (#1386) + - Invalid argument bug in Exact tactic solved (#1387) + - Colliding bound names bug fixed (#1412) + - Wrong non-recursivity test for Record fixed (#1394) + - Out of memory/seg fault bug related to parametric inductive fixed (#1404) + - Setoid_replace/Setoid_rewrite bug wrt "==" fixed + +Misc + + - Ocaml version >= 3.06 is needed to compile Coq from sources + - Simplification of fresh names creation strategy for Assert, Pose and + LetTac (#1402) + + +Details of changes in 7.4 +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Symbolic notations + +- Introduction of a notion of scope gathering notations in a consistent set; + a notation sets has been developed for nat, Z and R (undocumented) +- New command "Notation" for declaring notations simultaneously for + parsing and printing (see chap 10 of the reference manual) +- Declarations with only implicit arguments now handled (e.g. the + argument of nil can be set implicit; use !nil to refer to nil + without arguments) +- "Print Scope sc" and "Locate ntn" allows to know to what expression a + notation is bound +- New defensive strategy for printing or not implicit arguments to ensure + re-type-checkability of the printed term +- In Grammar command, the only predefined non-terminal entries are ident, + global, constr and pattern (e.g. nvar, numarg disappears); the only + allowed grammar types are constr and pattern; ast and ast list are no + longer supported; some incompatibilities in Grammar: when a syntax is a + initial segment of an other one, Grammar does not work, use Notation + +Library + +- Lemmas in Set from Compare_dec.v (le_lt_dec, ...) and Wf_nat.v + (lt_wf_rec, ...) are now transparent. This may be source of + incompatibilities. +- Syntactic Definitions Fst, Snd, Ex, All, Ex2, AllT, ExT, ExT2, + ProjS1, ProjS2, Error, Value and Except are turned to + notations. They now must be applied (incompatibilities only in + unrealistic cases). +- More efficient versions of Zmult and times (30% faster) +- Reals: the library is now divided in 6 parts (Rbase, Rfunctions, + SeqSeries, Rtrigo, Ranalysis, Integration). New tactics: Sup and + RCompute. See Reals.v for details. + +Modules + +- Beta version, see doc chap 2.5 for commands and chap 5 for theory + +Language + +- Inductive definitions now accept ">" in constructor types to declare + the corresponding constructor as a coercion. +- Idem for assumptions declarations and constants when the type is mentionned. +- The "Coercion" and "Canonical Structure" keywords now accept the + same syntax as "Definition", i.e. "hyps :=c (:t)?" or "hyps :t". +- Theorem-like declaration now accepts the syntax "Theorem thm [x:t;...] : u". +- Remark's and Fact's now definitively behave as Theorem and Lemma: when + sections are closed, the full name of a Remark or a Fact has no longer a + section part (source of incompatibilities) +- Opaque Local's (i.e. built by tactics and ended by Qed), do not + survive section closing any longer; as a side-effect, Opaque Local's + now appear in the local context of proofs; their body is hidden + though (source of incompatibilities); use one of Remark/Fact/Lemma/Theorem + instead to simulate the old behaviour of Local (the section part of + the name is not kept though) + +ML tactic and vernacular commands + +- "Grammar tactic" and "Grammar vernac" of type "ast" are no longer + supported (only "Grammar tactic simple_tactic" of type "tactic" + remains available). +- Concrete syntax for ML written vernacular commands and tactics is + now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC + COMMAND EXTEND. +- "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..." +- ``Proof with T`` (no documentation) +- SearchAbout id - prints all theorems which contain id in their type + +Tactic definitions + +- Static globalisation of identifiers and global references (source of + incompatibilities, especially, Recursive keyword is required for + mutually recursive definitions). +- New evaluation semantics: no more partial evaluation at definition time; + evaluation of all Tactic/Meta Definition, even producing terms, expect + a proof context to be evaluated (especially "()" is no longer needed). +- Debugger now shows the nesting level and the reasons of failure + +Tactics + +- Equality tactics (Rewrite, Reflexivity, Symmetry, Transitivity) now + understand JM equality +- Simpl and Change now apply to subterms also +- "Simpl f" reduces subterms whose head constant is f +- Double Induction now referring to hypotheses like "Intros until" +- "Inversion" now applies also on quantified hypotheses (naming as + for Intros until) +- NewDestruct now accepts terms with missing hypotheses +- NewDestruct and NewInduction now accept user-provided elimination scheme +- NewDestruct and NewInduction now accept user-provided introduction names +- Omega could solve goals such as ``~x<y |- x>=y`` but failed when the + hypothesis was unfolded to ``x < y -> False``. This is fixed. In addition, + it can also recognize 'False' in the hypothesis and use it to solve the + goal. +- Coercions now handled in "with" bindings +- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses + when an hypothesis x=t or x:=t or t=x exists +- Fresh names for Assert and Pose now based on collision-avoiding + Intro naming strategy (exceptional source of incompatibilities) +- LinearIntuition (no documentation) +- Unfold expects a correct evaluable argument +- Clear expects existing hypotheses + +Extraction (See details in plugins/extraction/CHANGES and README): + +- An experimental Scheme extraction is provided. +- Concerning Ocaml, extracted code is now ensured to always type-check, + thanks to automatic inserting of Obj.magic. +- Experimental extraction of Coq new modules to Ocaml modules. + +Proof rendering in natural language + +- Export of theories to XML for publishing and rendering purposes now + includes proof-trees (see http://www.cs.unibo.it/helm) + +Miscellaneous + +- Printing Coercion now used through the standard keywords Set/Add, Test, Print +- "Print Term id" is an alias for "Print id" +- New switch "Unset/Set Printing Symbols" to control printing of + symbolic notations +- Two new variants of implicit arguments are available + + + ``Unset``/``Set Contextual Implicits`` tells to consider implicit also the + arguments inferable from the context (e.g. for nil or refl_eq) + + ``Unset``/``Set Strict Implicits`` tells to consider implicit only the + arguments that are inferable in any case (i.e. arguments that occurs + as argument of rigid constants in the type of the remaining arguments; + e.g. the witness of an existential is not strict since it can vanish when + applied to a predicate which does not use its argument) + +Incompatibilities + +- "Grammar tactic ... : ast" and "Grammar vernac ... : ast" are no + longer supported, use TACTIC EXTEND and VERNAC COMMAND EXTEND on the + ML-side instead +- Transparency of le_lt_dec and co (leads to some simplification in + proofs; in some cases, incompatibilites is solved by declaring locally + opaque the relevant constant) +- Opaque Local do not now survive section closing (rename them into + Remark/Lemma/... to get them still surviving the sections; this + renaming allows also to solve incompatibilites related to now + forbidden calls to the tactic Clear) +- Remark and Fact have no longer (very) long names (use Local instead in case + of name conflict) + +Bugs + +- Improved localisation of errors in Syntactic Definitions +- Induction principle creation failure in presence of let-in fixed (#1459) +- Inversion bugs fixed (#1427 and #1437) +- Omega bug related to Set fixed (#1384) +- Type-checking inefficiency of nested destructuring let-in fixed (#1435) +- Improved handling of let-in during holes resolution phase (#1460) + +Efficiency + +- Implementation of a memory sharing strategy reducing memory + requirements by an average ratio of 3. diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index 5a349fcf75..a91c6a9c5f 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -23,7 +23,8 @@ Contents :caption: Preamble self - credits + history + changes .. toctree:: :caption: The language diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index ff3971aee4..708820fff7 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -15,7 +15,9 @@ Introduction Company-Coq :cite:`Pit16` (see https://github.com/cpitclaudel/company-coq). -.. include:: credits.rst +.. include:: history.rst + +.. include:: changes.rst ------------ The language diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 8a5e9d87f8..5a1af9f9fa 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -74,14 +74,20 @@ Identifiers and access identifiers `.` (dot) without blank. They are used in the syntax of qualified identifiers. -Natural numbers and integers - Numerals are sequences of digits. Integers are numerals optionally - preceded by a minus sign. +Numerals + Numerals are sequences of digits with a potential fractional part + and exponent. Integers are numerals without fractional nor exponent + part and optionally preceded by a minus sign. Underscores ``_`` can + be used as comments in numerals. .. productionlist:: coq digit : 0..9 num : `digit`…`digit` integer : [-]`num` + dot : . + exp : e | E + sign : + | - + numeral : `num`[`dot` `num`][`exp`[`sign`]`num`] Strings Strings are delimited by ``"`` (double quote), and enclose a sequence of diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index eebf1f11e1..bdda35fcc0 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -210,6 +210,13 @@ and ``coqtop``, unless stated otherwise: is intended to be used as a linter for developments that want to be robust to changes in the auto-generated name scheme. The options are provided to facilitate tracking down problems. +:-set *string*: Enable flags and set options. *string* should be + ``Option Name=value``, the value is interpreted according to the + type of the option. For flags ``Option Name`` is equivalent to + ``Option Name=true``. For instance ``-set "Universe Polymorphism"`` + will enable :flag:`Universe Polymorphism`. Note that the quotes are + shell syntax, Coq does not see them. +:-unset *string*: As ``-set`` but used to disable options and flags. :-compat *version*: Attempt to maintain some backward-compatibility with a previous version. :-dump-glob *file*: Dump references for global names in file *file* diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 7c78e1a50f..8346b72cb9 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -34,9 +34,16 @@ For example, to statically link |Ltac|, you can just do: and similarly for other plugins. +Building a |Coq| project +------------------------ + +As of today it is possible to build Coq projects using two tools: + +- coq_makefile, which is distributed by Coq and is based on generating a makefile, +- Dune, the standard OCaml build tool, which, since version 1.9, supports building Coq libraries. Building a |Coq| project with coq_makefile ------------------------------------------- +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The majority of |Coq| projects are very similar: a collection of ``.v`` files and eventually some ``.ml`` ones (a |Coq| plugin). The main piece of @@ -119,7 +126,7 @@ distinct plugins because of a clash in their auxiliary module names. .. _coqmakefilelocal: CoqMakefile.local -~~~~~~~~~~~~~~~~~ ++++++++++++++++++ The optional file ``CoqMakefile.local`` is included by the generated file ``CoqMakefile``. It can contain two kinds of directives. @@ -205,7 +212,7 @@ The following makefile rules can be extended. target. Timing targets and performance testing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +++++++++++++++++++++++++++++++++++++++ The generated ``Makefile`` supports the generation of two kinds of timing data: per-file build-times, and per-line times for an individual file. @@ -385,7 +392,7 @@ line timing data: Reusing/extending the generated Makefile -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +++++++++++++++++++++++++++++++++++++++++ Including the generated makefile with an include directive is discouraged. The contents of this file, including variable names and @@ -429,7 +436,7 @@ have a generic target for invoking unknown targets. Building a subset of the targets with ``-j`` -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +++++++++++++++++++++++++++++++++++++++++++++ To build, say, two targets foo.vo and bar.vo in parallel one can use ``make only TGTS="foo.vo bar.vo" -j``. @@ -452,11 +459,90 @@ To build, say, two targets foo.vo and bar.vo in parallel one can use -Module dependencies --------------------- +Building a |Coq| project with Dune +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. note:: + + The canonical documentation for the Coq Dune extension is + maintained upstream; please refer to the `Dune manual + <https://dune.readthedocs.io/>`_ for up-to-date information. + +Building a Coq project with Dune requires setting up a Dune project +for your files. This involves adding a ``dune-project`` and +``pkg.opam`` file to the root (``pkg.opam`` can be empty), and then +providing ``dune`` files in the directories your ``.v`` files are +placed. For the experimental version "0.1" of the Coq Dune language, +|Coq| library stanzas look like: + +.. code:: scheme -In order to compute module dependencies (so to use ``make``), |Coq| comes -with an appropriate tool, ``coqdep``. + (coqlib + (name <module_prefix>) + (public_name <package.lib_name>) + (synopsis <text>) + (modules <ordered_set_lang>) + (libraries <ocaml_libraries>) + (flags <coq_flags>)) + +This stanza will build all `.v` files in the given directory, wrapping +the library under ``<module_prefix>``. If you declare a +``<package.lib_name>`` a ``.install`` file for the library will be +generated; the optional ``<modules>`` field allows you to filter +the list of modules, and ``<libraries>`` allows to depend on ML +plugins. For the moment, Dune relies on Coq's standard mechanisms +(such as ``COQPATH``) to locate installed Coq libraries. + +By default Dune will skip ``.v`` files present in subdirectories. In +order to enable the usual recursive organization of Coq projects add + +.. code:: scheme + + (include_subdirs qualified) + +to you ``dune`` file. + +Once your project is set up, `dune build` will generate the +`pkg.install` files and all the files necessary for the installation +of your project. + +.. example:: + + A typical stanza for a Coq plugin is split into two parts. An OCaml build directive, which is standard Dune: + + .. code:: scheme + + (library + (name equations_plugin) + (public_name equations.plugin) + (flags :standard -warn-error -3-9-27-32-33-50) + (libraries coq.plugins.cc coq.plugins.extraction)) + + (rule + (targets g_equations.ml) + (deps (:pp-file g_equations.mlg)) + (action (run coqpp %{pp-file}))) + + And a Coq-specific part that depends on it via the ``libraries`` field: + + .. code:: scheme + + (coqlib + (name Equations) ; -R flag + (public_name equations.Equations) + (synopsis "Equations Plugin") + (libraries coq.plugins.extraction equations.plugin) + (modules :standard \ IdDec NoCycle)) ; exclude some modules that don't build + + (include_subdirs qualified) + +.. _coqdep: + +Computing Module dependencies +----------------------------- + +In order to compute module dependencies (to be used by ``make`` or +``dune``), |Coq| provides the ``coqdep`` tool. ``coqdep`` computes inter-module dependencies for |Coq| and |OCaml| programs, and prints the dependencies on the standard output in a @@ -474,10 +560,8 @@ done approximately and you are advised to use ``ocamldep`` instead for the See the man page of ``coqdep`` for more details and options. -The build infrastructure generated by ``coq_makefile`` uses ``coqdep`` to -automatically compute the dependencies among the files part of the -project. - +Both Dune and ``coq_makefile`` use ``coqdep`` to compute the +dependencies among the files part of a Coq project. .. _coqdoc: diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 52e3029b8f..0322b43694 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1071,6 +1071,16 @@ Proving a subgoal as a separate lemma It may be useful to generate lemmas minimal w.r.t. the assumptions they depend on. This can be obtained thanks to the option below. + .. warning:: + + The abstract tactic, while very useful, still has some known + limitations, see https://github.com/coq/coq/issues/9146 for more + details. Thus we recommend using it caution in some + "non-standard" contexts. In particular, ``abstract`` won't + properly work when used inside quotations ``ltac:(...)``, or + if used as part of typeclass resolution, it may produce wrong + terms when in universe polymorphic mode. + .. tacv:: abstract @expr using @ident Give explicitly the name of the auxiliary lemma. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 7b395900e9..afb0239be4 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3912,6 +3912,8 @@ At Coq startup, only the core database is nonempty and can be used. environment, including those used for ``setoid_rewrite``, from the Classes directory. +:fset: internal database for the implementation of the ``FSets`` library. + You are advised not to put your own hints in the core database, but use one or several databases specific to your development. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 3e8dd25ee0..e207a072cc 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -510,6 +510,20 @@ Requests to the environment .. seealso:: Section :ref:`locating-notations` +.. _printing-flags: + +Printing flags +------------------------------- + +.. flag:: Fast Name Printing + + When turned on, |Coq| uses an asymptotically faster algorithm for the + generation of unambiguous names of bound variables while printing terms. + While faster, it is also less clever and results in a typically less elegant + display, e.g. it will generate more names rather than reusing certain names + across subterms. This flag is not enabled by default, because as Ltac + observes bound names, turning it on can break existing proof scripts. + .. _loading-files: diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index e5eb7eb4f5..63df3d37bf 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -943,8 +943,8 @@ instance the infix symbol ``+``, can be used to denote distinct definitions of the additive operator. Depending on which interpretation scopes are currently open, the interpretation is different. Interpretation scopes can include an interpretation for numerals and -strings. However, this is only made possible at the Objective Caml -level. +strings, either at the OCaml level or using :cmd:`Numeral Notation` +or :cmd:`String Notation`. .. cmd:: Declare Scope @scope @@ -1214,7 +1214,7 @@ Scopes` or :cmd:`Print Scope`. ``nat_scope`` This scope includes the standard arithmetical operators and relations on type - nat. Positive numerals in this scope are mapped to their canonical + nat. Positive integer numerals in this scope are mapped to their canonical representent built from :g:`O` and :g:`S`. The scope is delimited by the key ``nat``, and bound to the type :g:`nat` (see above). @@ -1238,20 +1238,19 @@ Scopes` or :cmd:`Print Scope`. This scope includes the standard arithmetical operators and relations on type :g:`Q` (rational numbers defined as fractions of an integer and a strictly positive integer modulo the equality of the numerator- - denominator cross-product). As for numerals, only 0 and 1 have an - interpretation in scope ``Q_scope`` (their interpretations are 0/1 and 1/1 - respectively). + denominator cross-product) and comes with an interpretation for numerals + as closed terms of type :g:`Q`. ``Qc_scope`` This scope includes the standard arithmetical operators and relations on the type :g:`Qc` of rational numbers defined as the type of irreducible fractions of an integer and a strictly positive integer. -``real_scope`` +``R_scope`` This scope includes the standard arithmetical operators and relations on type :g:`R` (axiomatic real numbers). It is delimited by the key ``R`` and comes with an interpretation for numerals using the :g:`IZR` morphism from binary - integer numbers to :g:`R`. + integer numbers to :g:`R` and :g:`Z.pow_pos` for potential exponent parts. ``bool_scope`` This scope includes notations for the boolean operators. It is delimited by the @@ -1458,6 +1457,8 @@ Numeral notations * :n:`Decimal.uint -> option @ident__1` * :n:`Z -> @ident__1` * :n:`Z -> option @ident__1` + * :n:`Decimal.decimal -> @ident__1` + * :n:`Decimal.decimal -> option @ident__1` And the printing function :n:`@ident__3` should have one of the following types: @@ -1468,11 +1469,17 @@ Numeral notations * :n:`@ident__1 -> option Decimal.uint` * :n:`@ident__1 -> Z` * :n:`@ident__1 -> option Z` + * :n:`@ident__1 -> Decimal.decimal` + * :n:`@ident__1 -> option Decimal.decimal` When parsing, the application of the parsing function :n:`@ident__2` to the number will be fully reduced, and universes of the resulting term will be refreshed. + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, and + primitive integers) will be considered for printing. + .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (warning after @num). When a literal larger than :token:`num` is parsed, a warning @@ -1497,15 +1504,16 @@ Numeral notations The numeral notation registered for :token:`type` does not support the given numeral. This error is given when the interpretation function returns :g:`None`, or if the interpretation is registered - for only non-negative integers, and the given numeral is negative. + only for integers or non-negative integers, and the given numeral + has a fractional or exponent part or is negative. - .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first). + .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first). The parsing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. - .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first). + .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first). The printing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. @@ -1518,9 +1526,9 @@ Numeral notations .. exn:: Unexpected term @term while parsing a numeral notation. Parsing functions must always return ground terms, made up of - applications of constructors and inductive types. Parsing - functions may not return terms containing axioms, bare - (co)fixpoints, lambdas, etc. + applications of constructors, inductive types, and primitive + integers. Parsing functions may not return terms containing + axioms, bare (co)fixpoints, lambdas, etc. .. exn:: Unexpected non-option term @term while parsing a numeral notation. @@ -1618,6 +1626,10 @@ String notations :n:`@ident__2` to the string will be fully reduced, and universes of the resulting term will be refreshed. + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, and + primitive integers) will be considered for printing. + .. exn:: Cannot interpret this string as a value of type @type The string notation registered for :token:`type` does not support @@ -1642,9 +1654,9 @@ String notations .. exn:: Unexpected term @term while parsing a string notation. Parsing functions must always return ground terms, made up of - applications of constructors and inductive types. Parsing - functions may not return terms containing axioms, bare - (co)fixpoints, lambdas, etc. + applications of constructors, inductive types, and primitive + integers. Parsing functions may not return terms containing + axioms, bare (co)fixpoints, lambdas, etc. .. exn:: Unexpected non-option term @term while parsing a string notation. diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index b58148ffff..b25104ddb9 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -22,6 +22,7 @@ plugins/extraction/Extraction.v plugins/funind/FunInd.v plugins/funind/Recdef.v plugins/ltac/Ltac.v +plugins/micromega/DeclConstant.v plugins/micromega/Env.v plugins/micromega/EnvRing.v plugins/micromega/Fourier.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index fd79996bb7..a561de1d0c 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -619,7 +619,6 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Compat/AdmitAxiom.v - theories/Compat/Coq87.v theories/Compat/Coq88.v theories/Compat/Coq89.v theories/Compat/Coq810.v @@ -42,3 +42,5 @@ (name runtest) (package coqide-server) (deps test-suite/summary.log)) + +; (dirs (:standard _build_ci)) diff --git a/engine/nameops.ml b/engine/nameops.ml index 2047772cfe..31914f9cfa 100644 --- a/engine/nameops.ml +++ b/engine/nameops.ml @@ -13,6 +13,51 @@ open Names (* Utilities *) +module Subscript = +struct + +type t = { + ss_zero : int; + (** Number of leading zeros of the subscript *) + ss_subs : int; + (** Digital value of the subscript, zero meaning empty *) +} + +let rec overflow n = + Int.equal (n mod 10) 9 && (Int.equal (n / 10) 0 || overflow (n / 10)) + +let zero = { ss_subs = 0; ss_zero = 0 } + +let succ s = + if Int.equal s.ss_subs 0 then + if Int.equal s.ss_zero 0 then + (* [] -> [0] *) + { ss_zero = 1; ss_subs = 0 } + else + (* [0...00] -> [0..01] *) + { ss_zero = s.ss_zero - 1; ss_subs = 1 } + else if overflow s.ss_subs then + if Int.equal s.ss_zero 0 then + (* [9...9] -> [10...0] *) + { ss_zero = 0; ss_subs = 1 + s.ss_subs } + else + (* [0...009...9] -> [0...010...0] *) + { ss_zero = s.ss_zero - 1; ss_subs = 1 + s.ss_subs } + else + (* [0...0n] -> [0...0{n+1}] *) + { ss_zero = s.ss_zero; ss_subs = s.ss_subs + 1 } + +let equal s1 s2 = + Int.equal s1.ss_zero s2.ss_zero && Int.equal s1.ss_subs s2.ss_subs + +let compare s1 s2 = + (* Lexicographic order is reversed in order to ensure that [succ] is strictly + increasing. *) + let c = Int.compare s1.ss_subs s2.ss_subs in + if Int.equal c 0 then Int.compare s1.ss_zero s2.ss_zero else c + +end + let code_of_0 = Char.code '0' let code_of_9 = Char.code '9' @@ -104,6 +149,46 @@ let has_subscript id = let id = Id.to_string id in is_digit (id.[String.length id - 1]) +let get_subscript id = + let id0 = id in + let id = Id.to_string id in + let len = String.length id in + let rec get_suf accu pos = + if pos < 0 then (pos, accu) + else + let c = id.[pos] in + if is_digit c then get_suf (Char.code c - Char.code '0' :: accu) (pos - 1) + else (pos, accu) + in + let (pos, suf) = get_suf [] (len - 1) in + if Int.equal pos (len - 1) then (id0, Subscript.zero) + else + let id = String.sub id 0 (pos + 1) in + let rec compute_zeros accu = function + | [] -> (accu, []) + | 0 :: l -> compute_zeros (succ accu) l + | _ :: _ as l -> (accu, l) + in + let (ss_zero, suf) = compute_zeros 0 suf in + let rec compute_suf accu = function + | [] -> accu + | n :: l -> compute_suf (10 * accu + n) l + in + let ss_subs = compute_suf 0 suf in + (Id.of_string id, { Subscript.ss_subs; ss_zero; }) + +let add_subscript id ss = + if Subscript.equal Subscript.zero ss then id + else if Int.equal ss.Subscript.ss_subs 0 then + let id = Id.to_string id in + let pad = String.make ss.Subscript.ss_zero '0' in + Id.of_string (Printf.sprintf "%s%s" id pad) + else + let id = Id.to_string id in + let pad = String.make ss.Subscript.ss_zero '0' in + let suf = ss.Subscript.ss_subs in + Id.of_string (Printf.sprintf "%s%s%i" id pad suf) + let forget_subscript id = let numstart = cut_ident false id in let newid = Bytes.make (numstart+1) '0' in diff --git a/engine/nameops.mli b/engine/nameops.mli index 0e75fed045..222573450b 100644 --- a/engine/nameops.mli +++ b/engine/nameops.mli @@ -24,8 +24,42 @@ val add_prefix : string -> Id.t -> Id.t (** Below, by {i subscript} we mean a suffix composed solely from (decimal) digits. *) +module Subscript : +sig + type t + (** Abstract datatype of subscripts. Isomorphic to a string of digits. *) + + val zero : t + (** Empty subscript *) + + val succ : t -> t + (** Guarantees that [x < succ x], but [succ x] might not be the smallest + element strictly above [x], generally it does not exist. Example mappings: + "" ↦ "0" + "0" ↦ "1" + "00" ↦ "01" + "1" ↦ "2" + "01" ↦ "02" + "9" ↦ "10" + "09" ↦ "10" + "99" ↦ "100" + *) + + val compare : t -> t -> int + (** Well-founded order. *) + + val equal : t -> t -> bool + +end + val has_subscript : Id.t -> bool +val get_subscript : Id.t -> Id.t * Subscript.t +(** Split an identifier into a base name and a subscript. *) + +val add_subscript : Id.t -> Subscript.t -> Id.t +(** Append the subscript to the identifier. *) + val increment_subscript : Id.t -> Id.t (** Return the same identifier as the original one but whose {i subscript} is incremented. If the original identifier does not have a suffix, [0] is appended to it. diff --git a/engine/proofview.ml b/engine/proofview.ml index 2d693e0259..316f02bc37 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -899,8 +899,8 @@ module Progress = struct (** Equality function on goals *) let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 (drop_state gl1) in - let evi2 = Evd.find evars2 (drop_state gl2) in + let evi1 = Evd.find evars1 gl1 in + let evi2 = Evd.find evars2 gl2 in eq_evar_info evars1 evars2 evi1 evi2 end @@ -918,7 +918,7 @@ let tclPROGRESS t = let test = quick_test || Util.List.for_all2eq begin fun i f -> - Progress.goal_equal initial.solution i final.solution f + Progress.goal_equal initial.solution (drop_state i) final.solution (drop_state f) end initial.comb final.comb in if not test then diff --git a/engine/proofview.mli b/engine/proofview.mli index 680a93f0cc..c772525c86 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -395,10 +395,14 @@ val give_up : unit tactic (** {7 Control primitives} *) (** [tclPROGRESS t] checks the state of the proof after [t]. It it is - identical to the state before, then [tclePROGRESS t] fails, otherwise + identical to the state before, then [tclPROGRESS t] fails, otherwise it succeeds like [t]. *) val tclPROGRESS : 'a tactic -> 'a tactic +module Progress : sig + val goal_equal : Evd.evar_map -> Evar.t -> Evd.evar_map -> Evar.t -> bool +end + (** Checks for interrupts *) val tclCHECKINTERRUPT : unit tactic diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f46ddffd6e..c452c7b307 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -4,19 +4,19 @@ open Gramext open Format - -type ('a, 'b) eq = Refl : ('a, 'a) eq +open Util (* Functorial interface *) -module type GLexerType = sig type te val lexer : te Plexing.lexer end +module type GLexerType = Plexing.Lexer module type S = sig type te + type 'c pattern type parsable - val parsable : char Stream.t -> parsable - val tokens : string -> (string * int) list + val parsable : ?loc:Loc.t -> char Stream.t -> parsable + val tokens : string -> (string option * int) list module Entry : sig type 'a e @@ -27,29 +27,36 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ('self, 'a) ty_symbol - type ('self, 'f, 'r) ty_rule + type ty_norec = TyNoRec + type ty_mayrec = TyMayRec + type ('self, 'trec, 'a) ty_symbol + type ('self, 'trec, 'f, 'r) ty_rule + type 'a ty_rules type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol - val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + val s_nterm : 'a Entry.e -> ('self, ty_norec, 'a) ty_symbol + val s_nterml : 'a Entry.e -> string -> ('self, ty_norec, 'a) ty_symbol + val s_list0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list0sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_list1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list1sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_self : ('self, 'self) ty_symbol - val s_next : ('self, 'self) ty_symbol - val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol - val r_stop : ('self, 'r, 'r) ty_rule + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_opt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol + val s_self : ('self, ty_mayrec, 'self) ty_symbol + val s_next : ('self, ty_mayrec, 'self) ty_symbol + val s_token : 'c pattern -> ('self, ty_norec, 'c) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_rules list -> ('self, ty_norec, 'a) ty_symbol + val r_stop : ('self, ty_norec, 'r, 'r) ty_rule val r_next : - ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> - ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production + ('self, _, 'a, 'r) ty_rule -> ('self, _, 'b) ty_symbol -> + ('self, ty_mayrec, 'b -> 'a, 'r) ty_rule + val r_next_norec : + ('self, ty_norec, 'a, 'r) ty_rule -> ('self, ty_norec, 'b) ty_symbol -> + ('self, ty_norec, 'b -> 'a, 'r) ty_rule + val rules : (_, ty_norec, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_rules + val production : ('a, _, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig val clear_entry : 'a Entry.e -> unit @@ -59,7 +66,7 @@ module type S = (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit + val safe_delete_rule : 'a Entry.e -> ('a, _, 'r, 'f) ty_rule -> unit end (* Implementation *) @@ -68,15 +75,15 @@ module GMake (L : GLexerType) = struct type te = L.te +type 'c pattern = 'c L.pattern type 'a parser_t = L.te Stream.t -> 'a type grammar = - { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - glexer : L.te Plexing.lexer } + { gtokens : (string * string option, int ref) Hashtbl.t } let egram = - {gtokens = Hashtbl.create 301; glexer = L.lexer } + {gtokens = Hashtbl.create 301 } let tokens con = let list = ref [] in @@ -85,6 +92,17 @@ let tokens con = egram.gtokens; !list +type ty_norec = TyNoRec +type ty_mayrec = TyMayRec + +type ('a, 'b, 'c) ty_and_rec = +| NoRec2 : (ty_norec, ty_norec, ty_norec) ty_and_rec +| MayRec2 : ('a, 'b, ty_mayrec) ty_and_rec + +type ('a, 'b, 'c, 'd) ty_and_rec3 = +| NoRec3 : (ty_norec, ty_norec, ty_norec, ty_norec) ty_and_rec3 +| MayRec3 : ('a, 'b, 'c, ty_mayrec) ty_and_rec3 + type 'a ty_entry = { ename : string; mutable estart : int -> 'a parser_t; @@ -96,45 +114,50 @@ and 'a ty_desc = | Dlevels of 'a ty_level list | Dparser of 'a parser_t -and 'a ty_level = { +and 'a ty_level = Level : (_, _, 'a) ty_rec_level -> 'a ty_level + +and ('trecs, 'trecp, 'a) ty_rec_level = { assoc : g_assoc; lname : string option; - lsuffix : ('a, 'a -> Loc.t -> 'a) ty_tree; - lprefix : ('a, Loc.t -> 'a) ty_tree; + lsuffix : ('a, 'trecs, 'a -> Loc.t -> 'a) ty_tree; + lprefix : ('a, 'trecp, Loc.t -> 'a) ty_tree; } -and ('self, 'a) ty_symbol = -| Stoken : Plexing.pattern -> ('self, string) ty_symbol -| Slist1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol -| Slist1sep : ('self, 'a) ty_symbol * ('self, _) ty_symbol * bool -> ('self, 'a list) ty_symbol -| Slist0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol -| Slist0sep : ('self, 'a) ty_symbol * ('self, _) ty_symbol * bool -> ('self, 'a list) ty_symbol -| Sopt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol -| Sself : ('self, 'self) ty_symbol -| Snext : ('self, 'self) ty_symbol -| Snterm : 'a ty_entry -> ('self, 'a) ty_symbol -| Snterml : 'a ty_entry * string -> ('self, 'a) ty_symbol -| Stree : ('self, Loc.t -> 'a) ty_tree -> ('self, 'a) ty_symbol - -and ('self, _, 'r) ty_rule = -| TStop : ('self, 'r, 'r) ty_rule -| TNext : ('self, 'a, 'r) ty_rule * ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule - -and ('self, 'a) ty_tree = -| Node : ('self, 'b, 'a) ty_node -> ('self, 'a) ty_tree -| LocAct : 'k * 'k list -> ('self, 'k) ty_tree -| DeadEnd : ('self, 'k) ty_tree - -and ('self, 'a, 'r) ty_node = { - node : ('self, 'a) ty_symbol; - son : ('self, 'a -> 'r) ty_tree; - brother : ('self, 'r) ty_tree; +and ('self, 'trec, 'a) ty_symbol = +| Stoken : 'c pattern -> ('self, ty_norec, 'c) ty_symbol +| Slist1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol +| Slist1sep : ('self, 'trec, 'a) ty_symbol * ('self, ty_norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol +| Slist0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol +| Slist0sep : ('self, 'trec, 'a) ty_symbol * ('self, ty_norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol +| Sopt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol +| Sself : ('self, ty_mayrec, 'self) ty_symbol +| Snext : ('self, ty_mayrec, 'self) ty_symbol +| Snterm : 'a ty_entry -> ('self, ty_norec, 'a) ty_symbol +| Snterml : 'a ty_entry * string -> ('self, ty_norec, 'a) ty_symbol +| Stree : ('self, 'trec, Loc.t -> 'a) ty_tree -> ('self, 'trec, 'a) ty_symbol + +and ('self, _, _, 'r) ty_rule = +| TStop : ('self, ty_norec, 'r, 'r) ty_rule +| TNext : ('trr, 'trs, 'tr) ty_and_rec * ('self, 'trr, 'a, 'r) ty_rule * ('self, 'trs, 'b) ty_symbol -> ('self, 'tr, 'b -> 'a, 'r) ty_rule + +and ('self, 'trec, 'a) ty_tree = +| Node : ('trn, 'trs, 'trb, 'tr) ty_and_rec3 * ('self, 'trn, 'trs, 'trb, 'b, 'a) ty_node -> ('self, 'tr, 'a) ty_tree +| LocAct : 'k * 'k list -> ('self, ty_norec, 'k) ty_tree +| DeadEnd : ('self, ty_norec, 'k) ty_tree + +and ('self, 'trec, 'trecs, 'trecb, 'a, 'r) ty_node = { + node : ('self, 'trec, 'a) ty_symbol; + son : ('self, 'trecs, 'a -> 'r) ty_tree; + brother : ('self, 'trecb, 'r) ty_tree; } +type 'a ty_rules = +| TRules : (_, ty_norec, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_rules + type 'a ty_production = -| TProd : ('a, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_production +| TProd : ('a, _, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_production -let rec derive_eps : type s a. (s, a) ty_symbol -> bool = +let rec derive_eps : type s r a. (s, r, a) ty_symbol -> bool = function Slist0 _ -> true | Slist0sep (_, _, _) -> true @@ -142,14 +165,14 @@ let rec derive_eps : type s a. (s, a) ty_symbol -> bool = | Stree t -> tree_derive_eps t | Slist1 _ -> false | Slist1sep (_, _, _) -> false - | Snterm _ | Snterml (_, _) -> false + | Snterm _ -> false | Snterml (_, _) -> false | Snext -> false | Sself -> false | Stoken _ -> false -and tree_derive_eps : type s a. (s, a) ty_tree -> bool = +and tree_derive_eps : type s tr a. (s, tr, a) ty_tree -> bool = function LocAct (_, _) -> true - | Node {node = s; brother = bro; son = son} -> + | Node (_, {node = s; brother = bro; son = son}) -> derive_eps s && tree_derive_eps son || tree_derive_eps bro | DeadEnd -> false @@ -158,7 +181,7 @@ let eq_entry : type a1 a2. a1 ty_entry -> a2 ty_entry -> (a1, a2) eq option = fu if (Obj.magic e1) == (Obj.magic e2) then Some (Obj.magic Refl) else None -let rec eq_symbol : type s a1 a2. (s, a1) ty_symbol -> (s, a2) ty_symbol -> (a1, a2) eq option = fun s1 s2 -> +let rec eq_symbol : type s r1 r2 a1 a2. (s, r1, a1) ty_symbol -> (s, r2, a2) ty_symbol -> (a1, a2) eq option = fun s1 s2 -> match s1, s2 with Snterm e1, Snterm e2 -> eq_entry e1 e2 | Snterml (e1, l1), Snterml (e2, l2) -> @@ -188,23 +211,42 @@ let rec eq_symbol : type s a1 a2. (s, a1) ty_symbol -> (s, a2) ty_symbol -> (a1, | Stree _, Stree _ -> None | Sself, Sself -> Some Refl | Snext, Snext -> Some Refl - | Stoken p1, Stoken p2 -> if p1 = p2 then Some Refl else None + | Stoken p1, Stoken p2 -> L.tok_pattern_eq p1 p2 | _ -> None -let is_before : type s1 s2 a1 a2. (s1, a1) ty_symbol -> (s2, a2) ty_symbol -> bool = fun s1 s2 -> +let is_before : type s1 s2 r1 r2 a1 a2. (s1, r1, a1) ty_symbol -> (s2, r2, a2) ty_symbol -> bool = fun s1 s2 -> match s1, s2 with - Stoken ("ANY", _), _ -> false - | _, Stoken ("ANY", _) -> true - | Stoken (_, s), Stoken (_, "") when s <> "" -> true - | Stoken _, Stoken _ -> false + | Stoken p1, Stoken p2 -> + snd (L.tok_pattern_strings p1) <> None + && snd (L.tok_pattern_strings p2) = None | Stoken _, _ -> true | _ -> false (** Ancilliary datatypes *) -type ('self, _) ty_symbols = -| TNil : ('self, unit) ty_symbols -| TCns : ('self, 'a) ty_symbol * ('self, 'b) ty_symbols -> ('self, 'a * 'b) ty_symbols +type 'a ty_rec = MayRec : ty_mayrec ty_rec | NoRec : ty_norec ty_rec + +type ('a, 'b, 'c) ty_and_ex = +| NR00 : (ty_mayrec, ty_mayrec, ty_mayrec) ty_and_ex +| NR01 : (ty_mayrec, ty_norec, ty_mayrec) ty_and_ex +| NR10 : (ty_norec, ty_mayrec, ty_mayrec) ty_and_ex +| NR11 : (ty_norec, ty_norec, ty_norec) ty_and_ex + +type ('a, 'b) ty_mayrec_and_ex = +| MayRecNR : ('a, 'b, _) ty_and_ex -> ('a, 'b) ty_mayrec_and_ex + +type ('s, 'a) ty_mayrec_symbol = +| MayRecSymbol : ('s, _, 'a) ty_symbol -> ('s, 'a) ty_mayrec_symbol + +type ('s, 'a) ty_mayrec_tree = +| MayRecTree : ('s, 'tr, 'a) ty_tree -> ('s, 'a) ty_mayrec_tree + +type ('s, 'a, 'r) ty_mayrec_rule = +| MayRecRule : ('s, _, 'a, 'r) ty_rule -> ('s, 'a, 'r) ty_mayrec_rule + +type ('self, 'trec, _) ty_symbols = +| TNil : ('self, ty_norec, unit) ty_symbols +| TCns : ('trh, 'trt, 'tr) ty_and_rec * ('self, 'trh, 'a) ty_symbol * ('self, 'trt, 'b) ty_symbols -> ('self, 'tr, 'a * 'b) ty_symbols (** ('i, 'p, 'f, 'r) rel_prod0 ~ ∃ α₠... αₙ. @@ -217,99 +259,196 @@ type ('i, _, 'f, _) rel_prod0 = type ('p, 'k, 'r) rel_prod = (unit, 'p, 'k, 'r) rel_prod0 -type ('s, 'i, 'k, 'r) any_symbols = -| AnyS : ('s, 'p) ty_symbols * ('i, 'p, 'k, 'r) rel_prod0 -> ('s, 'i, 'k, 'r) any_symbols - -(** FIXME *) -let rec symbols : type s p k r. (s, p) ty_symbols -> (s, k, r) ty_rule -> (s, unit, k, r) any_symbols = - fun accu r -> match r with - | TStop -> AnyS (Obj.magic accu, Rel0) - | TNext (r, s) -> - let AnyS (r, pf) = symbols (TCns (s, accu)) r in - AnyS (Obj.magic r, RelS (Obj.magic pf)) - -let get_symbols : type s k r. (s, k, r) ty_rule -> (s, unit, k, r) any_symbols = - fun r -> symbols TNil r - -let insert_tree (type s p k a) ~warning entry_name (gsymbols : (s, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, a) ty_tree) = - let rec insert : type p f k. (s, p) ty_symbols -> (p, k, f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree = - fun symbols pf tree action -> +type ('s, 'tr, 'i, 'k, 'r) any_symbols = +| AnyS : ('s, 'tr, 'p) ty_symbols * ('i, 'p, 'k, 'r) rel_prod0 -> ('s, 'tr, 'i, 'k, 'r) any_symbols + +type ('s, 'tr, 'k, 'r) ty_belast_rule = +| Belast : ('trr, 'trs, 'tr) ty_and_rec * ('s, 'trr, 'k, 'a -> 'r) ty_rule * ('s, 'trs, 'a) ty_symbol -> ('s, 'tr, 'k, 'r) ty_belast_rule + +(* unfortunately, this is quadratic, but ty_rules aren't too long + * (99% of the time of length less or equal 10 and maximum is 22 + * when compiling Coq and its standard library) *) +let rec get_symbols : type s trec k r. (s, trec, k, r) ty_rule -> (s, trec, unit, k, r) any_symbols = + let rec belast_rule : type s trr trs tr a k r. (trr, trs, tr) ty_and_rec -> (s, trr, k, r) ty_rule -> (s, trs, a) ty_symbol -> (s, tr, a -> k, r) ty_belast_rule = + fun ar r s -> match ar, r with + | NoRec2, TStop -> Belast (NoRec2, TStop, s) + | MayRec2, TStop -> Belast (MayRec2, TStop, s) + | NoRec2, TNext (NoRec2, r, s') -> + let Belast (NoRec2, r, s') = belast_rule NoRec2 r s' in + Belast (NoRec2, TNext (NoRec2, r, s), s') + | MayRec2, TNext (_, r, s') -> + let Belast (_, r, s') = belast_rule MayRec2 r s' in + Belast (MayRec2, TNext (MayRec2, r, s), s') in + function + | TStop -> AnyS (TNil, Rel0) + | TNext (MayRec2, r, s) -> + let Belast (MayRec2, r, s) = belast_rule MayRec2 r s in + let AnyS (r, pf) = get_symbols r in + AnyS (TCns (MayRec2, s, r), RelS pf) + | TNext (NoRec2, r, s) -> + let Belast (NoRec2, r, s) = belast_rule NoRec2 r s in + let AnyS (r, pf) = get_symbols r in + AnyS (TCns (NoRec2, s, r), RelS pf) + +let get_rec_symbols (type s tr p) (s : (s, tr, p) ty_symbols) : tr ty_rec = + match s with TCns (MayRec2, _, _) -> MayRec + | TCns (NoRec2, _, _) -> NoRec | TNil -> NoRec + +let get_rec_tree (type s tr f) (s : (s, tr, f) ty_tree) : tr ty_rec = + match s with Node (MayRec3, _) -> MayRec + | Node (NoRec3, _) -> NoRec | LocAct _ -> NoRec | DeadEnd -> NoRec + +let and_symbols_tree (type s trs trt p f) (s : (s, trs, p) ty_symbols) (t : (s, trt, f) ty_tree) : (trs, trt) ty_mayrec_and_ex = + match get_rec_symbols s, get_rec_tree t with + | MayRec, MayRec -> MayRecNR NR00 | MayRec, NoRec -> MayRecNR NR01 + | NoRec, MayRec -> MayRecNR NR10 | NoRec, NoRec -> MayRecNR NR11 + +let and_and_tree (type s tr' trt tr trn trs trb f) (ar : (tr', trt, tr) ty_and_rec) (arn : (trn, trs, trb, trt) ty_and_rec3) (t : (s, trb, f) ty_tree) : (tr', trb, tr) ty_and_rec = + match ar, arn, get_rec_tree t with + | MayRec2, _, MayRec -> MayRec2 | MayRec2, _, NoRec -> MayRec2 + | NoRec2, NoRec3, NoRec -> NoRec2 + +let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, tr) ty_and_ex) (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, tr, a) ty_tree = + let rec insert : type trs trt tr p f k. (trs, trt, tr) ty_and_ex -> (s, trs, p) ty_symbols -> (p, k, f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = + fun ar symbols pf tree action -> match symbols, pf with - TCns (s, sl), RelS pf -> insert_in_tree s sl pf tree action + TCns (ars, s, sl), RelS pf -> insert_in_tree ar ars s sl pf tree action | TNil, Rel0 -> - match tree with - Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert TNil Rel0 bro action} - | LocAct (old_action, action_list) -> + let node (type tb) ({node = s; son = son; brother = bro} : (_, _, _, tb, _, _) ty_node) = + let ar : (ty_norec, tb, tb) ty_and_ex = + match get_rec_tree bro with MayRec -> NR10 | NoRec -> NR11 in + {node = s; son = son; brother = insert ar TNil Rel0 bro action} in + match ar, tree with + | NR10, Node (_, n) -> Node (MayRec3, node n) + | NR11, Node (NoRec3, n) -> Node (NoRec3, node n) + | NR11, LocAct (old_action, action_list) -> begin match warning with | None -> () | Some warn_fn -> let msg = "<W> Grammar extension: " ^ - (if entry_name <> "" then "" else "in ["^entry_name^"%s], ") ^ + (if entry_name = "" then "" else "in ["^entry_name^"%s], ") ^ "some rule has been masked" in warn_fn msg end; LocAct (action, old_action :: action_list) - | DeadEnd -> LocAct (action, []) - and insert_in_tree : type a p f k. (s, a) ty_symbol -> (s, p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree = - fun s sl pf tree action -> - match try_insert s sl pf tree action with + | NR11, DeadEnd -> LocAct (action, []) + and insert_in_tree : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_ex -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = + fun ar ars s sl pf tree action -> + let ar : (trs'', trt, tr) ty_and_rec = match ar with NR11 -> NoRec2 + | NR00 -> MayRec2 | NR01 -> MayRec2 | NR10 -> MayRec2 in + match try_insert ar ars s sl pf tree action with Some t -> t - | None -> Node {node = s; son = insert sl pf DeadEnd action; brother = tree} - and try_insert : type a p f k. (s, a) ty_symbol -> (s, p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree option = - fun s sl pf tree action -> + | None -> + let node ar = + {node = s; son = insert ar sl pf DeadEnd action; brother = tree} in + match ar, ars, get_rec_symbols sl with + | MayRec2, MayRec2, MayRec -> Node (MayRec3, node NR01) + | MayRec2, _, NoRec -> Node (MayRec3, node NR11) + | NoRec2, NoRec2, NoRec -> Node (NoRec3, node NR11) + and try_insert : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_rec -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree option = + fun ar ars s sl pf tree action -> match tree with - Node {node = s1; son = son; brother = bro} -> + Node (arn, {node = s1; son = son; brother = bro}) -> begin match eq_symbol s s1 with | Some Refl -> - let t = Node {node = s1; son = insert sl pf son action; brother = bro} in - Some t + let MayRecNR arss = and_symbols_tree sl son in + let son = insert arss sl pf son action in + let node = {node = s1; son = son; brother = bro} in + begin match ar, ars, arn, arss with + | MayRec2, _, _, _ -> Some (Node (MayRec3, node)) + | NoRec2, NoRec2, NoRec3, NR11 -> Some (Node (NoRec3, node)) end | None -> + let ar' = and_and_tree ar arn bro in if is_before s1 s || derive_eps s && not (derive_eps s1) then let bro = - match try_insert s sl pf bro action with + match try_insert ar' ars s sl pf bro action with Some bro -> bro - | None -> Node {node = s; son = insert sl pf DeadEnd action; brother = bro} + | None -> + let MayRecNR arss = and_symbols_tree sl DeadEnd in + let son = insert arss sl pf DeadEnd action in + let node = {node = s; son = son; brother = bro} in + match ar, ars, arn, arss with + | MayRec2, _, _, _ -> Node (MayRec3, node) + | NoRec2, NoRec2, NoRec3, NR11 -> Node (NoRec3, node) in - let t = Node {node = s1; son = son; brother = bro} in Some t + let node = {node = s1; son = son; brother = bro} in + match ar, arn with + | MayRec2, _ -> Some (Node (MayRec3, node)) + | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) else - begin match try_insert s sl pf bro action with + match try_insert ar' ars s sl pf bro action with Some bro -> - let t = Node {node = s1; son = son; brother = bro} in Some t + let node = {node = s1; son = son; brother = bro} in + begin match ar, arn with + | MayRec2, _ -> Some (Node (MayRec3, node)) + | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) end | None -> None - end end - | LocAct (_, _) | DeadEnd -> None + | LocAct (_, _) -> None | DeadEnd -> None in - insert gsymbols pf tree action + insert ar gsymbols pf tree action -let srules (type self a) ~warning (rl : a ty_production list) = +let insert_tree_norec (type s p k a) ~warning entry_name (gsymbols : (s, ty_norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, ty_norec, a) ty_tree) : (s, ty_norec, a) ty_tree = + insert_tree ~warning entry_name NR11 gsymbols pf action tree + +let insert_tree (type s trs trt p k a) ~warning entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = + let MayRecNR ar = and_symbols_tree gsymbols tree in + MayRecTree (insert_tree ~warning entry_name ar gsymbols pf action tree) + +let srules (type self a) ~warning (rl : a ty_rules list) : (self, ty_norec, a) ty_symbol = + let rec retype_tree : type s a. (s, ty_norec, a) ty_tree -> (self, ty_norec, a) ty_tree = + function + | Node (NoRec3, {node = s; son = son; brother = bro}) -> + Node (NoRec3, {node = retype_symbol s; son = retype_tree son; brother = retype_tree bro}) + | LocAct (k, kl) -> LocAct (k, kl) + | DeadEnd -> DeadEnd + and retype_symbol : type s a. (s, ty_norec, a) ty_symbol -> (self, ty_norec, a) ty_symbol = + function + | Stoken p -> Stoken p + | Slist1 s -> Slist1 (retype_symbol s) + | Slist1sep (s, sep, b) -> Slist1sep (retype_symbol s, retype_symbol sep, b) + | Slist0 s -> Slist0 (retype_symbol s) + | Slist0sep (s, sep, b) -> Slist0sep (retype_symbol s, retype_symbol sep, b) + | Sopt s -> Sopt (retype_symbol s) + | Snterm e -> Snterm e + | Snterml (e, l) -> Snterml (e, l) + | Stree t -> Stree (retype_tree t) in + let rec retype_rule : type s k r. (s, ty_norec, k, r) ty_rule -> (self, ty_norec, k, r) ty_rule = + function + | TStop -> TStop + | TNext (NoRec2, r, s) -> TNext (NoRec2, retype_rule r, retype_symbol s) in let t = List.fold_left - (fun tree (TProd (symbols, action)) -> + (fun tree (TRules (symbols, action)) -> + let symbols = retype_rule symbols in let AnyS (symbols, pf) = get_symbols symbols in - insert_tree ~warning "" symbols pf action tree) + insert_tree_norec ~warning "" symbols pf action tree) DeadEnd rl in - (* FIXME: use an universal self type to ensure well-typedness *) - (Obj.magic (Stree t) : (self, a) ty_symbol) + Stree t -let is_level_labelled n lev = +let is_level_labelled n (Level lev) = match lev.lname with Some n1 -> n = n1 | None -> false -let insert_level (type s p k) ~warning entry_name (symbols : (s, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = +let insert_level (type s tr p k) ~warning entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = match symbols with - | TCns (Sself, symbols) -> + | TCns (_, Sself, symbols) -> + let Level slev = slev in let RelS pf = pf in + let MayRecTree lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix in + Level {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix; + lsuffix = lsuffix; lprefix = slev.lprefix} | _ -> + let Level slev = slev in + let MayRecTree lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix in + Level {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix} + lprefix = lprefix} let empty_lev lname assoc = let assoc = @@ -317,9 +456,10 @@ let empty_lev lname assoc = Some a -> a | None -> LeftA in + Level {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -let change_lev ~warning lev n lname assoc = +let change_lev ~warning (Level lev) n lname assoc = let a = match assoc with None -> lev.assoc @@ -343,6 +483,7 @@ let change_lev ~warning lev n lname assoc = end; | None -> () end; + Level {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} let get_level ~warning entry position levs = @@ -396,21 +537,24 @@ let get_level ~warning entry position levs = lev :: levs -> [], change_lev ~warning lev "<top>", levs | [] -> [], empty_lev, [] -let change_to_self0 (type s) (type a) (entry : s ty_entry) : (s, a) ty_symbol -> (s, a) ty_symbol = +let change_to_self0 (type s) (type trec) (type a) (entry : s ty_entry) : (s, trec, a) ty_symbol -> (s, a) ty_mayrec_symbol = function | Snterm e -> begin match eq_entry e entry with - | None -> Snterm e - | Some Refl -> Sself + | None -> MayRecSymbol (Snterm e) + | Some Refl -> MayRecSymbol (Sself) end - | x -> x + | x -> MayRecSymbol x -let rec change_to_self : type s a r. s ty_entry -> (s, a, r) ty_rule -> (s, a, r) ty_rule = fun e r -> match r with -| TStop -> TStop -| TNext (r, t) -> TNext (change_to_self e r, change_to_self0 e t) +let rec change_to_self : type s trec a r. s ty_entry -> (s, trec, a, r) ty_rule -> (s, a, r) ty_mayrec_rule = fun e r -> match r with +| TStop -> MayRecRule TStop +| TNext (_, r, t) -> + let MayRecRule r = change_to_self e r in + let MayRecSymbol t = change_to_self0 e t in + MayRecRule (TNext (MayRec2, r, t)) let insert_tokens gram symbols = - let rec insert : type s a. (s, a) ty_symbol -> unit = + let rec insert : type s trec a. (s, trec, a) ty_symbol -> unit = function | Slist0 s -> insert s | Slist1 s -> insert s @@ -418,25 +562,25 @@ let insert_tokens gram symbols = | Slist1sep (s, t, _) -> insert s; insert t | Sopt s -> insert s | Stree t -> tinsert t - | Stoken ("ANY", _) -> () | Stoken tok -> - gram.glexer.Plexing.tok_using tok; + L.tok_using tok; let r = + let tok = L.tok_pattern_strings tok in try Hashtbl.find gram.gtokens tok with Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r in incr r - | Snterm _ | Snterml (_, _) -> () + | Snterm _ -> () | Snterml (_, _) -> () | Snext -> () | Sself -> () - and tinsert : type s a. (s, a) ty_tree -> unit = + and tinsert : type s tr a. (s, tr, a) ty_tree -> unit = function - Node {node = s; brother = bro; son = son} -> + Node (_, {node = s; brother = bro; son = son}) -> insert s; tinsert bro; tinsert son - | LocAct (_, _) | DeadEnd -> () - and linsert : type s p. (s, p) ty_symbols -> unit = function + | LocAct (_, _) -> () | DeadEnd -> () + and linsert : type s tr p. (s, tr, p) ty_symbols -> unit = function | TNil -> () - | TCns (s, r) -> insert s; linsert r + | TCns (_, s, r) -> insert s; linsert r in linsert symbols @@ -460,7 +604,7 @@ let levels_of_rules ~warning entry position rules = let lev = List.fold_left (fun lev (TProd (symbols, action)) -> - let symbols = change_to_self entry symbols in + let MayRecRule symbols = change_to_self entry symbols in let AnyS (symbols, pf) = get_symbols symbols in insert_tokens egram symbols; insert_level ~warning entry.ename symbols pf action lev) @@ -472,7 +616,7 @@ let levels_of_rules ~warning entry position rules = levs1 @ List.rev levs @ levs2 let logically_eq_symbols entry = - let rec eq_symbols : type s1 s2 a1 a2. (s1, a1) ty_symbol -> (s2, a2) ty_symbol -> bool = fun s1 s2 -> + let rec eq_symbols : type s1 s2 trec1 trec2 a1 a2. (s1, trec1, a1) ty_symbol -> (s2, trec2, a2) ty_symbol -> bool = fun s1 s2 -> match s1, s2 with Snterm e1, Snterm e2 -> e1.ename = e2.ename | Snterm e1, Sself -> e1.ename = entry.ename @@ -486,16 +630,19 @@ let logically_eq_symbols entry = eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2 | Sopt s1, Sopt s2 -> eq_symbols s1 s2 | Stree t1, Stree t2 -> eq_trees t1 t2 - | Stoken p1, Stoken p2 -> p1 = p2 + | Stoken p1, Stoken p2 -> L.tok_pattern_eq p1 p2 <> None | Sself, Sself -> true | Snext, Snext -> true | _ -> false - and eq_trees : type s1 s2 a1 a2. (s1, a1) ty_tree -> (s2, a2) ty_tree -> bool = fun t1 t2 -> + and eq_trees : type s1 s2 tr1 tr2 a1 a2. (s1, tr1, a1) ty_tree -> (s2, tr2, a2) ty_tree -> bool = fun t1 t2 -> match t1, t2 with - Node n1, Node n2 -> + Node (_, n1), Node (_, n2) -> eq_symbols n1.node n2.node && eq_trees n1.son n2.son && eq_trees n1.brother n2.brother - | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true + | LocAct _, LocAct _ -> true + | LocAct _, DeadEnd -> true + | DeadEnd, LocAct _ -> true + | DeadEnd, DeadEnd -> true | _ -> false in eq_symbols @@ -509,55 +656,56 @@ let logically_eq_symbols entry = [None] if failure *) type 's ex_symbols = -| ExS : ('s, 'p) ty_symbols -> 's ex_symbols +| ExS : ('s, 'tr, 'p) ty_symbols -> 's ex_symbols let delete_rule_in_tree entry = let rec delete_in_tree : - type s p r. (s, p) ty_symbols -> (s, r) ty_tree -> (s ex_symbols option * (s, r) ty_tree) option = + type s tr tr' p r. (s, tr, p) ty_symbols -> (s, tr', r) ty_tree -> (s ex_symbols option * (s, r) ty_mayrec_tree) option = fun symbols tree -> match symbols, tree with - | TCns (s, sl), Node n -> + | TCns (_, s, sl), Node (_, n) -> if logically_eq_symbols entry s n.node then delete_son sl n else begin match delete_in_tree symbols n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) + Some (dsl, MayRecTree t) -> + Some (dsl, MayRecTree (Node (MayRec3, {node = n.node; son = n.son; brother = t}))) | None -> None end - | TCns (s, sl), _ -> None - | TNil, Node n -> + | TCns (_, s, sl), _ -> None + | TNil, Node (_, n) -> begin match delete_in_tree TNil n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) + Some (dsl, MayRecTree t) -> + Some (dsl, MayRecTree (Node (MayRec3, {node = n.node; son = n.son; brother = t}))) | None -> None end | TNil, DeadEnd -> None - | TNil, LocAct (_, []) -> Some (Some (ExS TNil), DeadEnd) - | TNil, LocAct (_, action :: list) -> Some (None, LocAct (action, list)) + | TNil, LocAct (_, []) -> Some (Some (ExS TNil), MayRecTree DeadEnd) + | TNil, LocAct (_, action :: list) -> Some (None, MayRecTree (LocAct (action, list))) and delete_son : - type s p a r. (s, p) ty_symbols -> (s, a, r) ty_node -> (s ex_symbols option * (s, r) ty_tree) option = + type s p tr trn trs trb a r. (s, tr, p) ty_symbols -> (s, trn, trs, trb, a, r) ty_node -> (s ex_symbols option * (s, r) ty_mayrec_tree) option = fun sl n -> match delete_in_tree sl n.son with - Some (Some (ExS dsl), DeadEnd) -> Some (Some (ExS (TCns (n.node, dsl))), n.brother) - | Some (Some (ExS dsl), t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some (ExS (TCns (n.node, dsl))), t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) + Some (Some (ExS dsl), MayRecTree DeadEnd) -> Some (Some (ExS (TCns (MayRec2, n.node, dsl))), MayRecTree n.brother) + | Some (Some (ExS dsl), MayRecTree t) -> + let t = Node (MayRec3, {node = n.node; son = t; brother = n.brother}) in + Some (Some (ExS (TCns (MayRec2, n.node, dsl))), MayRecTree t) + | Some (None, MayRecTree t) -> + let t = Node (MayRec3, {node = n.node; son = t; brother = n.brother}) in + Some (None, MayRecTree t) | None -> None in delete_in_tree -let rec decr_keyw_use : type s a. _ -> (s, a) ty_symbol -> unit = fun gram -> +let rec decr_keyw_use : type s tr a. _ -> (s, tr, a) ty_symbol -> unit = fun gram -> function Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in + let tok' = L.tok_pattern_strings tok in + let r = Hashtbl.find gram.gtokens tok' in decr r; if !r == 0 then begin - Hashtbl.remove gram.gtokens tok; - gram.glexer.Plexing.tok_removing tok + Hashtbl.remove gram.gtokens tok'; + L.tok_removing tok end | Slist0 s -> decr_keyw_use gram s | Slist1 s -> decr_keyw_use gram s @@ -567,69 +715,71 @@ let rec decr_keyw_use : type s a. _ -> (s, a) ty_symbol -> unit = fun gram -> | Stree t -> decr_keyw_use_in_tree gram t | Sself -> () | Snext -> () - | Snterm _ | Snterml (_, _) -> () -and decr_keyw_use_in_tree : type s a. _ -> (s, a) ty_tree -> unit = fun gram -> + | Snterm _ -> () | Snterml (_, _) -> () +and decr_keyw_use_in_tree : type s tr a. _ -> (s, tr, a) ty_tree -> unit = fun gram -> function - DeadEnd | LocAct (_, _) -> () - | Node n -> + DeadEnd -> () | LocAct (_, _) -> () + | Node (_, n) -> decr_keyw_use gram n.node; decr_keyw_use_in_tree gram n.son; decr_keyw_use_in_tree gram n.brother -and decr_keyw_use_in_list : type s p. _ -> (s, p) ty_symbols -> unit = fun gram -> +and decr_keyw_use_in_list : type s tr p. _ -> (s, tr, p) ty_symbols -> unit = fun gram -> function | TNil -> () - | TCns (s, l) -> decr_keyw_use gram s; decr_keyw_use_in_list gram l + | TCns (_, s, l) -> decr_keyw_use gram s; decr_keyw_use_in_list gram l let rec delete_rule_in_suffix entry symbols = function - lev :: levs -> + Level lev :: levs -> begin match delete_rule_in_tree entry symbols lev.lsuffix with - Some (dsl, t) -> + Some (dsl, MayRecTree t) -> begin match dsl with Some (ExS dsl) -> decr_keyw_use_in_list egram dsl | None -> () end; - begin match t with - DeadEnd when lev.lprefix == DeadEnd -> levs + begin match t, lev.lprefix with + DeadEnd, DeadEnd -> levs | _ -> let lev = {assoc = lev.assoc; lname = lev.lname; lsuffix = t; lprefix = lev.lprefix} in - lev :: levs + Level lev :: levs end | None -> - let levs = delete_rule_in_suffix entry symbols levs in lev :: levs + let levs = delete_rule_in_suffix entry symbols levs in + Level lev :: levs end | [] -> raise Not_found let rec delete_rule_in_prefix entry symbols = function - lev :: levs -> + Level lev :: levs -> begin match delete_rule_in_tree entry symbols lev.lprefix with - Some (dsl, t) -> + Some (dsl, MayRecTree t) -> begin match dsl with Some (ExS dsl) -> decr_keyw_use_in_list egram dsl | None -> () end; - begin match t with - DeadEnd when lev.lsuffix == DeadEnd -> levs + begin match t, lev.lsuffix with + DeadEnd, DeadEnd -> levs | _ -> let lev = {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = t} in - lev :: levs + Level lev :: levs end | None -> - let levs = delete_rule_in_prefix entry symbols levs in lev :: levs + let levs = delete_rule_in_prefix entry symbols levs in + Level lev :: levs end | [] -> raise Not_found -let delete_rule_in_level_list (type s p) (entry : s ty_entry) (symbols : (s, p) ty_symbols) levs = +let delete_rule_in_level_list (type s tr p) (entry : s ty_entry) (symbols : (s, tr, p) ty_symbols) levs = match symbols with - TCns (Sself, symbols) -> delete_rule_in_suffix entry symbols levs - | TCns (Snterm e, symbols') -> + TCns (_, Sself, symbols) -> delete_rule_in_suffix entry symbols levs + | TCns (_, Snterm e, symbols') -> begin match eq_entry e entry with | None -> delete_rule_in_prefix entry symbols levs | Some Refl -> @@ -637,12 +787,12 @@ let delete_rule_in_level_list (type s p) (entry : s ty_entry) (symbols : (s, p) end | _ -> delete_rule_in_prefix entry symbols levs -let rec flatten_tree : type s a. (s, a) ty_tree -> s ex_symbols list = +let rec flatten_tree : type s tr a. (s, tr, a) ty_tree -> s ex_symbols list = function DeadEnd -> [] | LocAct (_, _) -> [ExS TNil] - | Node {node = n; brother = b; son = s} -> - List.map (fun (ExS l) -> ExS (TCns (n, l))) (flatten_tree s) @ flatten_tree b + | Node (_, {node = n; brother = b; son = s}) -> + List.map (fun (ExS l) -> ExS (TCns (MayRec2, n, l))) (flatten_tree s) @ flatten_tree b let utf8_print = ref true @@ -671,7 +821,7 @@ let string_escaped s = let print_str ppf s = fprintf ppf "\"%s\"" (string_escaped s) -let rec print_symbol : type s r. formatter -> (s, r) ty_symbol -> unit = +let rec print_symbol : type s tr r. formatter -> (s, tr, r) ty_symbol -> unit = fun ppf -> function | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s @@ -683,30 +833,36 @@ let rec print_symbol : type s r. formatter -> (s, r) ty_symbol -> unit = fprintf ppf "LIST1 %a SEP %a%s" print_symbol1 s print_symbol1 t (if osep then " OPT_SEP" else "") | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm + | Stoken p when L.tok_pattern_strings p <> ("", None) -> + begin match L.tok_pattern_strings p with + | con, Some prm -> fprintf ppf "%s@ %a" con print_str prm + | con, None -> fprintf ppf "%s" con end | Snterml (e, l) -> fprintf ppf "%s%s@ LEVEL@ %a" e.ename "" print_str l | s -> print_symbol1 ppf s -and print_symbol1 : type s r. formatter -> (s, r) ty_symbol -> unit = +and print_symbol1 : type s tr r. formatter -> (s, tr, r) ty_symbol -> unit = fun ppf -> function | Snterm e -> fprintf ppf "%s%s" e.ename "" | Sself -> pp_print_string ppf "SELF" | Snext -> pp_print_string ppf "NEXT" - | Stoken ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con + | Stoken p -> + begin match L.tok_pattern_strings p with + | "", Some s -> print_str ppf s + | con, None -> pp_print_string ppf con + | con, Some prm -> fprintf ppf "(%s@ %a)" con print_str prm end | Stree t -> print_level ppf pp_print_space (flatten_tree t) | s -> fprintf ppf "(%a)" print_symbol s -and print_rule : type s p. formatter -> (s, p) ty_symbols -> unit = +and print_rule : type s tr p. formatter -> (s, tr, p) ty_symbols -> unit = fun ppf symbols -> fprintf ppf "@[<hov 0>"; - let rec fold : type s p. _ -> (s, p) ty_symbols -> unit = - fun sep symbols -> match symbols with + let rec fold : type s tr p. _ -> (s, tr, p) ty_symbols -> unit = + fun sep symbols -> + match symbols with | TNil -> () - | TCns (symbol, symbols) -> + | TCns (_, symbol, symbols) -> fprintf ppf "%t%a" sep print_symbol symbol; fold (fun ppf -> fprintf ppf ";@ ") symbols in @@ -727,9 +883,9 @@ and print_level : type s. _ -> _ -> s ex_symbols list -> _ = let print_levels ppf elev = let _ = List.fold_left - (fun sep lev -> + (fun sep (Level lev) -> let rules = - List.map (fun (ExS t) -> ExS (TCns (Sself, t))) (flatten_tree lev.lsuffix) @ + List.map (fun (ExS t) -> ExS (TCns (MayRec2, Sself, t))) (flatten_tree lev.lsuffix) @ flatten_tree lev.lprefix in fprintf ppf "%t@[<hov 2>" sep; @@ -765,31 +921,39 @@ let loc_of_token_interval bp ep = else let loc1 = !floc bp in let loc2 = !floc (pred ep) in Loc.merge loc1 loc2 -let name_of_symbol : type s a. s ty_entry -> (s, a) ty_symbol -> string = +let name_of_symbol : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> string = fun entry -> function Snterm e -> "[" ^ e.ename ^ "]" | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]" | Sself -> "[" ^ entry.ename ^ "]" | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> egram.glexer.Plexing.tok_text tok + | Stoken tok -> L.tok_text tok | _ -> "???" type ('r, 'f) tok_list = | TokNil : ('f, 'f) tok_list -| TokCns : ('r, 'f) tok_list -> (string -> 'r, 'f) tok_list +| TokCns : 'a pattern * ('r, 'f) tok_list -> ('a -> 'r, 'f) tok_list + +type ('s, 'f) tok_tree = TokTree : 'a pattern * ('s, _, 'a -> 'r) ty_tree * ('r, 'f) tok_list -> ('s, 'f) tok_tree -type ('s, 'f) tok_tree = TokTree : ('s, string -> 'r) ty_tree * ('r, 'f) tok_list -> ('s, 'f) tok_tree +let rec tok_list_length : type a b. (a, b) tok_list -> int = + function + | TokNil -> 0 + | TokCns (_, t) -> 1 + tok_list_length t -let rec get_token_list : type s r f. - s ty_entry -> _ -> _ -> _ -> (r, f) tok_list -> (s, string -> r) ty_tree -> (_ * _ * _ * (s, f) tok_tree) option = - fun entry first_tok rev_tokl last_tok pf tree -> +let rec get_token_list : type s tr a r f. + s ty_entry -> a pattern -> (r, f) tok_list -> (s, tr, a -> r) ty_tree -> (s, f) tok_tree option = + fun entry last_tok rev_tokl tree -> match tree with - Node {node = Stoken tok; son = son; brother = DeadEnd} -> - get_token_list entry first_tok (last_tok :: rev_tokl) tok (TokCns pf) son - | _ -> if rev_tokl = [] then None else Some (first_tok, rev_tokl, last_tok, TokTree (tree, pf)) + Node (_, {node = Stoken tok; son = son; brother = DeadEnd}) -> + get_token_list entry tok (TokCns (last_tok, rev_tokl)) son + | _ -> + match rev_tokl with + | TokNil -> None + | _ -> Some (TokTree (last_tok, tree, rev_tokl)) -let rec name_of_symbol_failed : type s a. s ty_entry -> (s, a) ty_symbol -> _ = +let rec name_of_symbol_failed : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> _ = fun entry -> function | Slist0 s -> name_of_symbol_failed entry s @@ -799,13 +963,13 @@ let rec name_of_symbol_failed : type s a. s ty_entry -> (s, a) ty_symbol -> _ = | Sopt s -> name_of_symbol_failed entry s | Stree t -> name_of_tree_failed entry t | s -> name_of_symbol entry s -and name_of_tree_failed : type s a. s ty_entry -> (s, a) ty_tree -> _ = +and name_of_tree_failed : type s tr a. s ty_entry -> (s, tr, a) ty_tree -> _ = fun entry -> function - Node {node = s; brother = bro; son = son} -> + Node (_, {node = s; brother = bro; son = son}) -> let tokl = match s with - Stoken tok -> get_token_list entry tok [] tok TokNil son + Stoken tok -> get_token_list entry tok TokNil son | _ -> None in begin match tokl with @@ -818,20 +982,20 @@ and name_of_tree_failed : type s a. s ty_entry -> (s, a) ty_tree -> _ = in let txt = match bro with - DeadEnd | LocAct (_, _) -> txt + DeadEnd -> txt | LocAct (_, _) -> txt | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro in txt - | Some (_, rev_tokl, last_tok, _) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - egram.glexer.Plexing.tok_text tok) - "" (List.rev (last_tok :: rev_tokl)) + | Some (TokTree (last_tok, _, rev_tokl)) -> + let rec build_str : type a b. string -> (a, b) tok_list -> string = + fun s -> function + | TokNil -> s + | TokCns (tok, t) -> build_str (L.tok_text tok ^ " " ^ s) t in + build_str (L.tok_text last_tok) rev_tokl end - | DeadEnd | LocAct (_, _) -> "???" + | DeadEnd -> "???" | LocAct (_, _) -> "???" -let tree_failed (type s a) (entry : s ty_entry) (prev_symb_result : a) (prev_symb : (s, a) ty_symbol) tree = +let tree_failed (type s tr a) (entry : s ty_entry) (prev_symb_result : a) (prev_symb : (s, tr, a) ty_symbol) tree = let txt = name_of_tree_failed entry tree in let txt = match prev_symb with @@ -866,14 +1030,9 @@ let tree_failed (type s a) (entry : s ty_entry) (prev_symb_result : a) (prev_sym txt ^ " (in [" ^ entry.ename ^ "])" let symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in + let tree = Node (MayRec3, {node = symb; brother = DeadEnd; son = DeadEnd}) in tree_failed entry prev_symb_result prev_symb tree -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false - let level_number entry lab = let rec lookup levn = function @@ -885,7 +1044,7 @@ let level_number entry lab = Dlevels elev -> lookup 0 elev | Dparser _ -> raise Not_found -let rec top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> (s, a) ty_symbol = +let rec top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> (s, ty_norec, a) ty_symbol = fun entry -> function Sself -> Snterm entry @@ -894,7 +1053,7 @@ let rec top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> (s, a) ty_symbol | Slist1sep (s, sep, b) -> Slist1sep (top_symb entry s, sep, b) | _ -> raise Stream.Failure -let entry_of_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a ty_entry = +let entry_of_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> a ty_entry = fun entry -> function Sself -> entry @@ -903,12 +1062,14 @@ let entry_of_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a ty_entry = | Snterml (e, _) -> e | _ -> raise Stream.Failure -let top_tree : type s a. s ty_entry -> (s, a) ty_tree -> (s, a) ty_tree = +let top_tree : type s tr a. s ty_entry -> (s, tr, a) ty_tree -> (s, tr, a) ty_tree = fun entry -> function - Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct (_, _) | DeadEnd -> raise Stream.Failure + Node (MayRec3, {node = s; brother = bro; son = son}) -> + Node (MayRec3, {node = top_symb entry s; brother = bro; son = son}) + | Node (NoRec3, {node = s; brother = bro; son = son}) -> + Node (NoRec3, {node = top_symb entry s; brother = bro; son = son}) + | LocAct (_, _) -> raise Stream.Failure | DeadEnd -> raise Stream.Failure let skip_if_empty bp p strm = if Stream.count strm == bp then fun a -> p strm @@ -957,18 +1118,18 @@ let call_and_push ps al strm = let al = if !item_skipped then al else a :: al in item_skipped := false; al let token_ematch gram tok = - let tematch = gram.glexer.Plexing.tok_match tok in + let tematch = L.tok_match tok in fun tok -> tematch tok -let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> r parser_t = +let rec parser_of_tree : type s tr r. s ty_entry -> int -> int -> (s, tr, r) ty_tree -> r parser_t = fun entry nlevn alevn -> function DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) - | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> + | Node (_, {node = Sself; son = LocAct (act, _); brother = DeadEnd}) -> (fun (strm__ : _ Stream.t) -> let a = entry.estart alevn strm__ in act a) - | Node {node = Sself; son = LocAct (act, _); brother = bro} -> + | Node (_, {node = Sself; son = LocAct (act, _); brother = bro}) -> let p2 = parser_of_tree entry nlevn alevn bro in (fun (strm__ : _ Stream.t) -> match @@ -976,10 +1137,10 @@ let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> with Some a -> act a | _ -> p2 strm__) - | Node {node = s; son = son; brother = DeadEnd} -> + | Node (_, {node = s; son = son; brother = DeadEnd}) -> let tokl = match s with - Stoken tok -> get_token_list entry tok [] tok TokNil son + Stoken tok -> get_token_list entry tok TokNil son | _ -> None in begin match tokl with @@ -996,19 +1157,16 @@ let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> raise (Stream.Error (tree_failed entry a s son)) in act a) - | Some (first_tok, rev_tokl, last_tok, TokTree (son, pf)) -> - let s = Stoken first_tok in + | Some (TokTree (last_tok, son, rev_tokl)) -> let lt = Stoken last_tok in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in - parser_of_token_list entry s son pf p1 - (fun (strm__ : _ Stream.t) -> raise Stream.Failure) rev_tokl - last_tok + parser_of_token_list entry son p1 rev_tokl last_tok end - | Node {node = s; son = son; brother = bro} -> + | Node (_, {node = s; son = son; brother = bro}) -> let tokl = match s with - Stoken tok -> get_token_list entry tok [] tok TokNil son + Stoken tok -> get_token_list entry tok TokNil son | _ -> None in match tokl with @@ -1028,28 +1186,28 @@ let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> | None -> raise (Stream.Error (tree_failed entry a s son)) end | None -> p2 strm) - | Some (first_tok, rev_tokl, last_tok, TokTree (son, pf)) -> + | Some (TokTree (last_tok, son, rev_tokl)) -> let lt = Stoken last_tok in let p2 = parser_of_tree entry nlevn alevn bro in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in let p1 = - parser_of_token_list entry lt son pf p1 p2 rev_tokl last_tok + parser_of_token_list entry son p1 rev_tokl last_tok in fun (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> p2 strm__ -and parser_cont : type s a r. - (a -> r) parser_t -> s ty_entry -> int -> int -> (s, a) ty_symbol -> (s, a -> r) ty_tree -> int -> a -> (a -> r) parser_t = +and parser_cont : type s tr tr' a r. + (a -> r) parser_t -> s ty_entry -> int -> int -> (s, tr, a) ty_symbol -> (s, tr', a -> r) ty_tree -> int -> a -> (a -> r) parser_t = fun p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> recover parser_of_tree entry nlevn alevn bp a s son strm__ -and parser_of_token_list : type s r f. - s ty_entry -> (s, string) ty_symbol -> (s, string -> r) ty_tree -> - (r, f) tok_list -> (int -> string -> (string -> r) parser_t) -> f parser_t -> _ -> _ -> f parser_t = - fun entry s son pf p1 p2 rev_tokl last_tok -> +and parser_of_token_list : type s tr lt r f. + s ty_entry -> (s, tr, lt -> r) ty_tree -> + (int -> lt -> (lt -> r) parser_t) -> (r, f) tok_list -> lt pattern -> f parser_t = + fun entry son p1 rev_tokl last_tok -> + let n = tok_list_length rev_tokl + 1 in let plast : r parser_t = - let n = List.length rev_tokl + 1 in let tematch = token_ematch egram last_tok in let ps strm = match peek_nth n strm with @@ -1063,41 +1221,24 @@ and parser_of_token_list : type s r f. let a = ps strm in match try Some (p1 bp a strm) with Stream.Failure -> None with Some act -> act a - | None -> raise (Stream.Error (tree_failed entry a s son)) + | None -> raise (Stream.Error (tree_failed entry a (Stoken last_tok) son)) in - match List.rev rev_tokl, pf with - [], TokNil -> (fun (strm__ : _ Stream.t) -> plast strm__) - | tok :: tokl, TokCns pf -> - let tematch = token_ematch egram tok in - let ps strm = - match peek_nth 1 strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = - let rec loop : type s f. _ -> _ -> (s, f) tok_list -> (string -> s) parser_t -> (string -> f) parser_t = - fun n tokl pf plast -> - match tokl, pf with - [], TokNil -> plast - | tok :: tokl, TokCns pf -> - let tematch = token_ematch egram tok in - let ps strm = - match peek_nth n strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = loop (n + 1) tokl pf (Obj.magic plast) in (* FIXME *) - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in (Obj.magic act a) (* FIXME *) - | _ -> assert false - in - loop 2 tokl pf plast - in - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in act a - | _ -> assert false -and parser_of_symbol : type s a. - s ty_entry -> int -> (s, a) ty_symbol -> a parser_t = + let rec loop : type s f. _ -> (s, f) tok_list -> s parser_t -> f parser_t = + fun n tokl plast -> match tokl with + | TokNil -> plast + | TokCns (tok, tokl) -> + let tematch = token_ematch egram tok in + let ps strm = + match peek_nth n strm with + Some tok -> tematch tok + | None -> raise Stream.Failure + in + let plast = fun (strm : _ Stream.t) -> + let a = ps strm in let act = plast strm in act a in + loop (n - 1) tokl plast in + loop (n - 1) rev_tokl plast +and parser_of_symbol : type s tr a. + s ty_entry -> int -> (s, tr, a) ty_symbol -> a parser_t = fun entry nlevn -> function | Slist0 s -> @@ -1219,22 +1360,22 @@ and parser_of_symbol : type s a. | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) | Stoken tok -> parser_of_token entry tok -and parser_of_token : type s. - s ty_entry -> Plexing.pattern -> string parser_t = +and parser_of_token : type s a. + s ty_entry -> a pattern -> a parser_t = fun entry tok -> - let f = egram.glexer.Plexing.tok_match tok in + let f = L.tok_match tok in fun strm -> match Stream.peek strm with Some tok -> let r = f tok in Stream.junk strm; r | None -> raise Stream.Failure -and parse_top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a parser_t = +and parse_top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> a parser_t = fun entry symb -> parser_of_symbol entry 0 (top_symb entry symb) let rec start_parser_of_levels entry clevn = function [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> + | Level lev :: levs -> let p1 = start_parser_of_levels entry (succ clevn) levs in match lev.lprefix with DeadEnd -> p1 @@ -1277,7 +1418,7 @@ let rec start_parser_of_levels entry clevn = let rec continue_parser_of_levels entry clevn = function [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> + | Level lev :: levs -> let p1 = continue_parser_of_levels entry (succ clevn) levs in match lev.lsuffix with DeadEnd -> p1 @@ -1398,8 +1539,8 @@ let clear_entry e = Dlevels _ -> e.edesc <- Dlevels [] | Dparser _ -> () - let parsable cs = - let (ts, lf) = L.lexer.Plexing.tok_func cs in + let parsable ?loc cs = + let (ts, lf) = L.tok_func ?loc cs in {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} module Entry = struct @@ -1432,9 +1573,11 @@ let clear_entry e = let s_self = Sself let s_next = Snext let s_token tok = Stoken tok - let s_rules ~warning (t : 'a ty_production list) = srules ~warning t + let s_rules ~warning (t : 'a ty_rules list) = srules ~warning t let r_stop = TStop - let r_next r s = TNext (r, s) + let r_next r s = TNext (MayRec2, r, s) + let r_next_norec r s = TNext (NoRec2, r, s) + let rules (p, act) = TRules (p, act) let production (p, act) = TProd (p, act) module Unsafe = struct diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index bde07ddc48..ec4ec62409 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -15,16 +15,17 @@ rule "an entry cannot call an entry of another grammar" by normal OCaml typing. *) -module type GLexerType = sig type te val lexer : te Plexing.lexer end +module type GLexerType = Plexing.Lexer (** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) module type S = sig type te + type 'c pattern type parsable - val parsable : char Stream.t -> parsable - val tokens : string -> (string * int) list + val parsable : ?loc:Loc.t -> char Stream.t -> parsable + val tokens : string -> (string option * int) list module Entry : sig type 'a e @@ -35,29 +36,37 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ('self, 'a) ty_symbol - type ('self, 'f, 'r) ty_rule + type ty_norec = TyNoRec + type ty_mayrec = TyMayRec + type ('self, 'trec, 'a) ty_symbol + type ('self, 'trec, 'f, 'r) ty_rule + type 'a ty_rules type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol - val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + val s_nterm : 'a Entry.e -> ('self, ty_norec, 'a) ty_symbol + val s_nterml : 'a Entry.e -> string -> ('self, ty_norec, 'a) ty_symbol + val s_list0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list0sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_list1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list1sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_self : ('self, 'self) ty_symbol - val s_next : ('self, 'self) ty_symbol - val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol - val r_stop : ('self, 'r, 'r) ty_rule + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_opt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol + val s_self : ('self, ty_mayrec, 'self) ty_symbol + val s_next : ('self, ty_mayrec, 'self) ty_symbol + val s_token : 'c pattern -> ('self, ty_norec, 'c) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_rules list -> ('self, ty_norec, 'a) ty_symbol + + val r_stop : ('self, ty_norec, 'r, 'r) ty_rule val r_next : - ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> - ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production + ('self, _, 'a, 'r) ty_rule -> ('self, _, 'b) ty_symbol -> + ('self, ty_mayrec, 'b -> 'a, 'r) ty_rule + val r_next_norec : + ('self, ty_norec, 'a, 'r) ty_rule -> ('self, ty_norec, 'b) ty_symbol -> + ('self, ty_norec, 'b -> 'a, 'r) ty_rule + val rules : (_, ty_norec, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_rules + val production : ('a, _, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig @@ -68,7 +77,7 @@ module type S = (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val safe_delete_rule : 'a Entry.e -> ('a, 'f, 'r) ty_rule -> unit + val safe_delete_rule : 'a Entry.e -> ('a, _, 'f, 'r) ty_rule -> unit end (** Signature type of the functor [Grammar.GMake]. The types and functions are almost the same than in generic interface, but: @@ -80,4 +89,5 @@ module type S = type (instead of (string * string)); the module parameter must specify a way to show them as (string * string) *) -module GMake (L : GLexerType) : S with type te = L.te +module GMake (L : GLexerType) : + S with type te = L.te and type 'c pattern = 'c L.pattern diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index fce5445ad8..e881ab3350 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -2,15 +2,17 @@ (* plexing.ml,v *) (* Copyright (c) INRIA 2007-2017 *) -type pattern = string * string - type location_function = int -> Loc.t -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function +type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function -type 'te lexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - } +module type Lexer = sig + type te + type 'c pattern + val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option + val tok_pattern_strings : 'c pattern -> string * string option + val tok_func : te lexer_func + val tok_using : 'c pattern -> unit + val tok_removing : 'c pattern -> unit + val tok_match : 'c pattern -> te -> 'c + val tok_text : 'c pattern -> string +end diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 6139dc4020..521eba7446 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -8,27 +8,21 @@ grammars (see module [Grammar]). It also provides some useful functions to create lexers. *) -type pattern = string * string - (* Type for values used by the generated code of the EXTEND - statement to represent terminals in entry rules. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter (corresponding to the 'wildcard' pattern). -- The way tokens patterns are interpreted to parse tokens is done - by the lexer, function [tok_match] below. *) - (** Lexer type *) -type 'te lexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - } -and 'te lexer_func = char Stream.t -> 'te Stream.t * location_function +type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function and location_function = int -> Loc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) + +module type Lexer = sig + type te + type 'c pattern + val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option + val tok_pattern_strings : 'c pattern -> string * string option + val tok_func : te lexer_func + val tok_using : 'c pattern -> unit + val tok_removing : 'c pattern -> unit + val tok_match : 'c pattern -> te -> 'c + val tok_text : 'c pattern -> string +end diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 4aa801c2b2..8da9900724 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -250,7 +250,6 @@ object(self) feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; let md = segment_model document in segment#set_model md; -(* let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -267,7 +266,6 @@ object(self) ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in let _ = segment#connect#clicked ~callback:on_click in -*) () method private tooltip_callback ~x ~y ~kbd tooltip = diff --git a/ide/idetop.ml b/ide/idetop.ml index 608577b297..543ff924bd 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -57,9 +57,9 @@ let coqide_known_option table = List.mem table [ ["Diffs"]] let is_known_option cmd = match Vernacprop.under_control cmd with - | VernacSetOption (_, o, BoolValue true) - | VernacSetOption (_, o, StringValue _) - | VernacUnsetOption (_, o) -> coqide_known_option o + | VernacSetOption (_, o, OptionSetTrue) + | VernacSetOption (_, o, OptionSetString _) + | VernacSetOption (_, o, OptionUnset) -> coqide_known_option o | _ -> false (** Check whether a command is forbidden in the IDE *) @@ -231,30 +231,30 @@ let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let newp = Proof_global.give_me_the_proof () in + let newp = Vernacstate.Proof_global.give_me_the_proof () in if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Proof_global.NoCurrentProof -> None;; + with Vernacstate.Proof_global.NoCurrentProof -> None;; let evars () = try let doc = get_doc () in set_doc @@ Stm.finish ~doc; - let pfts = Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Proof_global.give_me_the_proof () in let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in Some el - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None let hints () = try - let pfts = Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Proof_global.give_me_the_proof () in let Proof.{ goals; sigma } = Proof.data pfts in match goals with | [] -> None @@ -263,7 +263,7 @@ let hints () = let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None (** Other API calls *) @@ -284,11 +284,11 @@ let status force = List.rev_map Names.Id.to_string l in let proof = - try Some (Names.Id.to_string (Proof_global.get_current_proof_name ())) - with Proof_global.NoCurrentProof -> None + try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) + with Vernacstate.Proof_global.NoCurrentProof -> None in let allproofs = - let l = Proof_global.get_all_proof_names () in + let l = Vernacstate.Proof_global.get_all_proof_names () in List.map Names.Id.to_string l in { @@ -336,7 +336,8 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - List.map export_coq_object (Search.interface_search ( + let pstate = Vernacstate.Proof_global.get () in + List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) @@ -365,12 +366,13 @@ let get_options () = Goptions.OptionMap.fold fold table [] let set_options options = + let open Goptions in let iter (name, value) = match import_option_value value with - | BoolValue b -> Goptions.set_bool_option_value name b - | IntValue i -> Goptions.set_int_option_value name i - | StringValue s -> Goptions.set_string_option_value name s - | StringOptValue (Some s) -> Goptions.set_string_option_value name s - | StringOptValue None -> Goptions.unset_option_value_gen name + | BoolValue b -> set_bool_option_value name b + | IntValue i -> set_int_option_value name i + | StringValue s -> set_string_option_value name s + | StringOptValue (Some s) -> set_string_option_value name s + | StringOptValue None -> unset_option_value_gen name in List.iter iter options @@ -465,7 +467,7 @@ let print_xml = let m = Mutex.create () in fun oc xml -> Mutex.lock m; - try Xml_printer.print oc xml; Mutex.unlock m + try Control.protect_sigalrm (Xml_printer.print oc) xml; Mutex.unlock m with e -> let e = CErrors.push e in Mutex.unlock m; iraise e let slave_feeder fmt xml_oc msg = diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml index d668788954..dc8fd0e85d 100644 --- a/ide/macos_prehook.ml +++ b/ide/macos_prehook.ml @@ -24,13 +24,13 @@ let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir let () = Unix.putenv "GTK_PATH" resources_dir let () = - Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc") + Unix.putenv "GTK3_RC_FILES" (Filename.concat etc_dir "gtk-3.0/gtkrc") let () = Unix.putenv "GTK_IM_MODULE_FILE" - (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders") + (Filename.concat etc_dir "gtk-3.0/gtk-immodules.loaders") let () = Unix.putenv "GDK_PIXBUF_MODULE_FILE" - (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders") + (Filename.concat etc_dir "gtk-3.0/gdk-pixbuf.loaders") let () = Unix.putenv "PANGO_LIBDIR" lib_dir let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir let () = Unix.putenv "CHARSETALIASDIR" lib_dir diff --git a/ide/preferences.ml b/ide/preferences.ml index e04001974e..47cd4c58b6 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -410,8 +410,8 @@ let vertical_tabs = let opposite_tabs = new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool) -let background_color = - new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string) +(* let background_color = *) +(* new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string) *) let attach_tag (pref : string preference) (tag : GText.tag) f = tag#set_property (f pref#get); @@ -737,7 +737,7 @@ let configure ?(apply=(fun () -> ())) parent = () in let () = Util.List.iteri iter [ - ("Background color", background_color); +(* ("Background color", background_color); *) ("Background color of processed text", processed_color); ("Background color of text being processed", processing_color); ("Background color of incompletely processed Qed", incompletely_processed_color); diff --git a/ide/preferences.mli b/ide/preferences.mli index d2f1b5ba29..785c191b46 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -88,7 +88,7 @@ val reset_on_tab_switch : bool preference val line_ending : line_ending preference val vertical_tabs : bool preference val opposite_tabs : bool preference -val background_color : string preference +(* val background_color : string preference *) val processing_color : string preference val processed_color : string preference val error_color : string preference diff --git a/ide/session.ml b/ide/session.ml index fd21515ca5..90412f53f0 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -257,9 +257,10 @@ let make_table_widget ?sort cd cb = ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in let () = data#set_headers_clickable true in - let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:refresh in - let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in +(* FIXME: handle this using CSS *) +(* let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:refresh in *) +(* let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in *) let mk_rend c = GTree.cell_renderer_text [], ["text",c] in let cols = List.map2 (fun (_,c) (_,n,v) -> diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index be400a5f2d..2cadd7ffbf 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,9 +100,10 @@ object(self) router#register_route route_id result; r_bin#add_with_viewport (result :> GObj.widget); views <- (frame#coerce, result, combo#entry) :: views; - let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) @@ -171,8 +172,9 @@ object(self) self#new_page_maker; self#new_query_aux ~grab_now:false (); frame#misc#hide (); - let _ = background_color#connect#changed ~callback:self#refresh_color in - self#refresh_color background_color#get; +(* FIXME: handle this using CSS *) +(* let _ = background_color#connect#changed ~callback:self#refresh_color in *) +(* self#refresh_color background_color#get; *) ignore(notebook#event#connect#key_press ~callback:(fun ev -> if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true) else false diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 7943b099fc..53e004c4e3 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -59,9 +59,10 @@ let message_view () : message_view = let _ = buffer#add_selection_clipboard default_clipboard in let () = view#set_left_margin 2 in view#misc#show (); - let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 596df227b7..7bf73b5ebe 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -204,9 +204,10 @@ let proof_view () = let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in - let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 8802eb0f1c..c1ed9b7506 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -506,9 +506,10 @@ object (self) in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in (* Plug on preferences *) - let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb b = self#set_wrap_mode (if b then `WORD else `NONE) in stick dynamic_word_wrap self cb; diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 2e5de64254..b62c0a2190 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -8,10 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(* open Util open Preferences -*) type color = GDraw.color @@ -24,7 +22,6 @@ object method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end -(* let i2f = float_of_int let f2i = int_of_float @@ -35,14 +32,20 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2 | `WHITE, `WHITE -> true | _ -> false -*) + +let set_cairo_color ctx c = + let open Gdk.Color in + let c = GDraw.color c in + let cast i = i2f i /. 65536. in + Cairo.set_source_rgb ctx (cast @@ red c) (cast @@ green c) (cast @@ blue c) + class type segment_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals method clicked : callback:(int -> unit) -> GtkSignal.id end -(* + class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = object val after = false @@ -50,14 +53,11 @@ object inherit GUtil.add_ml_signals obj [clicked#disconnect] method clicked = clicked#connect ~after end -*) class segment () = let box = GBin.frame () in -(* -let eventbox = GBin.event_box ~packing:box#add () in -let draw = GMisc.image ~packing:eventbox#add () in -*) +let draw = GMisc.drawing_area ~packing:box#add () in + object (self) inherit GObj.widget box#as_widget @@ -66,56 +66,40 @@ object (self) val mutable height = 20 val mutable model : model option = None val mutable default : color = `WHITE -(* - val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () -*) val clicked = new GUtil.signal () - val mutable need_refresh = false - val refresh_timer = Ideutils.mktimer () -(* + initializer box#misc#set_size_request ~height (); let cb rect = let w = rect.Gtk.width in let h = rect.Gtk.height in - (* Only refresh when size actually changed, otherwise loops *) - if self#misc#visible && (width <> w || height <> h) then begin - width <- w; - height <- h; - self#redraw (); - end + width <- w; + height <- h in let _ = box#misc#connect#size_allocate ~callback:cb in + let () = draw#event#add [`BUTTON_PRESS] in let clicked_cb ev = match model with | None -> true | Some md -> let x = GdkEvent.Button.x ev in - let (width, _) = pixmap#size in let len = md#length in let idx = f2i ((x *. i2f len) /. i2f width) in let () = clicked#call idx in true in - let _ = eventbox#event#connect#button_press ~callback:clicked_cb in + let _ = draw#event#connect#button_press ~callback:clicked_cb in let cb show = if show then self#misc#show () else self#misc#hide () in stick show_progress_bar self cb; - (* Initial pixmap *) - draw#set_pixmap pixmap; - refresh_timer.Ideutils.run ~ms:300 - ~callback:(fun () -> if need_refresh then self#refresh (); true) -*) + let cb ctx = self#refresh ctx; false in + let _ = draw#misc#connect#draw ~callback:cb in + () + method set_model md = model <- Some md; - let changed_cb = function - | `INSERT | `REMOVE -> - if self#misc#visible then need_refresh <- true - | `SET (i, color) -> - () -(* if self#misc#visible then self#fill_range color i (i + 1)*) - in + let changed_cb _ = self#misc#queue_draw () in md#changed ~callback:changed_cb -(* - method private fill_range color i j = match model with + + method private fill_range ctx color i j = match model with | None -> () | Some md -> let i = i2f i in @@ -125,24 +109,19 @@ object (self) let x = f2i ((i *. width) /. len) in let x' = f2i ((j *. width) /. len) in let w = x' - x in - pixmap#set_foreground color; - pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true (); - draw#set_mask None; + set_cairo_color ctx color; + Cairo.rectangle ctx (i2f x) 0. ~w:(i2f w) ~h:(i2f height); + Cairo.fill ctx method set_default_color color = default <- color method default_color = default - method private redraw () = - pixmap <- GDraw.pixmap ~width ~height (); - draw#set_pixmap pixmap; - self#refresh (); - - method private refresh () = match model with + method private refresh ctx = match model with | None -> () | Some md -> - need_refresh <- false; - pixmap#set_foreground default; - pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); + set_cairo_color ctx default; + Cairo.rectangle ctx 0. 0. ~w:(i2f width) ~h:(i2f height); + Cairo.fill ctx; let make (k, cur, accu) v = match cur with | None -> pred k, Some (k, k, v), accu | Some (i, j, w) -> @@ -154,11 +133,9 @@ object (self) | None -> segments | Some p -> p :: segments in - List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments; - draw#set_mask None; + List.iter (fun (i, j, v) -> self#fill_range ctx v i (j + 1)) segments method connect = new segment_signals_impl box#as_widget clicked -*) end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 84d487f35f..07f545fee7 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -31,9 +31,7 @@ class segment : unit -> inherit GObj.widget val obj : Gtk.widget Gtk.obj method set_model : model -> unit -(* method connect : segment_signals method default_color : color method set_default_color : color -> unit -*) end diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 757d186c8b..9f778d99e9 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -48,16 +48,26 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) -(** Representation of integer literals that appear in Coq scripts. - We now use raw strings of digits in base 10 (big-endian), and a separate - sign flag. Note that this representation is not unique, due to possible - multiple leading zeros, and -0 = +0 *) - -type sign = bool -type raw_natural_number = string +(** Representation of decimal literals that appear in Coq scripts. + We now use raw strings following the format defined by + [NumTok.t] and a separate sign flag. + + Note that this representation is not unique, due to possible + multiple leading or trailing zeros, and -0 = +0, for instances. + The reason to keep the numeral exactly as it was parsed is that + specific notations can be declared for specific numerals + (e.g. [Notation "0" := False], or [Notation "00" := (nil,nil)], or + [Notation "2e1" := ...]). Those notations, which override the + generic interpretation as numeral, use the same representation of + numeral using the Numeral constructor. So the latter should be able + to record the form of the numeral which exactly matches the + notation. *) + +type sign = SPlus | SMinus +type raw_numeral = NumTok.t type prim_token = - | Numeral of raw_natural_number * sign + | Numeral of sign * raw_numeral | String of string type instance_expr = Glob_term.glob_level list @@ -124,16 +134,17 @@ and branch_expr = (cases_pattern_expr list list * constr_expr) CAst.t and fix_expr = - lident * (lident option * recursion_order_expr) * + lident * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr and cofix_expr = lident * local_binder_expr list * constr_expr * constr_expr -and recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option (** measure, relation *) +and recursion_order_expr_r = + | CStructRec of lident + | CWfRec of lident * constr_expr + | CMeasureRec of lident option * constr_expr * constr_expr option (** argument, measure, relation *) +and recursion_order_expr = recursion_order_expr_r CAst.t (* Anonymous defs allowed ?? *) and local_binder_expr = diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 95a0039b0a..443473d5b6 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -50,13 +50,14 @@ let names_of_local_binders bl = (**********************************************************************) (* Functions on constr_expr *) -(* Note: redundant Numeral representations such as -0 and +0 (or different - numbers of leading zeros) are considered different here. *) +(* Note: redundant Numeral representations, such as -0 and +0 (and others), + are considered different here. *) let prim_token_eq t1 t2 = match t1, t2 with -| Numeral (n1,s1), Numeral (n2,s2) -> String.equal n1 n2 && s1 == s2 +| Numeral (SPlus,n1), Numeral (SPlus,n2) +| Numeral (SMinus,n1), Numeral (SMinus,n2) -> NumTok.equal n1 n2 | String s1, String s2 -> String.equal s1 s2 -| _ -> false +| (Numeral ((SPlus|SMinus),_) | String _), _ -> false let explicitation_eq ex1 ex2 = match ex1, ex2 with | ExplByPos (i1, id1), ExplByPos (i2, id2) -> @@ -195,10 +196,9 @@ and branch_expr_eq {CAst.v=(p1, e1)} {CAst.v=(p2, e2)} = List.equal (List.equal cases_pattern_expr_eq) p1 p2 && constr_expr_eq e1 e2 -and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) = +and fix_expr_eq (id1,r1,bl1,a1,b1) (id2,r2,bl2,a2,b2) = (eq_ast Id.equal id1 id2) && - Option.equal (eq_ast Id.equal) j1 j2 && - recursion_order_expr_eq r1 r2 && + Option.equal recursion_order_expr_eq r1 r2 && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 @@ -209,13 +209,17 @@ and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = constr_expr_eq a1 a2 && constr_expr_eq b1 b2 -and recursion_order_expr_eq r1 r2 = match r1, r2 with - | CStructRec, CStructRec -> true - | CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 - | CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> +and recursion_order_expr_eq_r r1 r2 = match r1, r2 with + | CStructRec i1, CStructRec i2 -> eq_ast Id.equal i1 i2 + | CWfRec (i1,e1), CWfRec (i2,e2) -> + constr_expr_eq e1 e2 + | CMeasureRec (i1, e1, o1), CMeasureRec (i2, e2, o2) -> + Option.equal (eq_ast Id.equal) i1 i2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 | _ -> false +and recursion_order_expr_eq r1 r2 = eq_ast recursion_order_expr_eq_r r1 r2 + and local_binder_eq l1 l2 = match l1, l2 with | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 @@ -348,7 +352,7 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function (f (Option.fold_right (CAst.with_val (Name.fold_right g)) ona n)) acc po | CFix (_,l) -> let n' = List.fold_right (fun ( { CAst.v = id },_,_,_,_) -> g id) l n in - List.fold_right (fun (_,(_,o),lb,t,c) acc -> + List.fold_right (fun (_,ro,lb,t,c) acc -> fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (_,_) -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index c2afa097bb..3b169edaab 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -212,7 +212,7 @@ let encode_record r = module PrintingRecordRecord = PrintingInductiveMake (struct - let encode = encode_record + let encode _env = encode_record let field = "Record" let title = "Types leading to pretty-printing using record notation: " let member_message s b = @@ -224,7 +224,7 @@ module PrintingRecordRecord = module PrintingRecordConstructor = PrintingInductiveMake (struct - let encode = encode_record + let encode _env = encode_record let field = "Constructor" let title = "Types leading to pretty-printing using constructor form: " let member_message s b = @@ -289,11 +289,11 @@ let extern_reference ?loc vars l = !my_extern_reference vars l let add_patt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CAst.make @@ CPatAtom None) l + Util.List.addn (Inductiveops.inductive_nparamdecls (Global.env()) ind) (CAst.make @@ CPatAtom None) l let add_cpatt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (DAst.make @@ PatVar Anonymous) l + Util.List.addn (Inductiveops.inductive_nparamdecls (Global.env()) ind) (DAst.make @@ PatVar Anonymous) l let drop_implicits_in_patt cst nb_expl args = let impl_st = (implicits_of_global cst) in @@ -318,29 +318,28 @@ let drop_implicits_in_patt cst nb_expl args = let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None -let is_number s = - let rec aux i = - Int.equal (String.length s) i || - match s.[i] with '0'..'9' -> aux (i+1) | _ -> false - in aux 0 - let is_zero s = let rec aux i = Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) in aux 0 +let is_zero n = is_zero n.NumTok.int && is_zero n.NumTok.frac let make_notation_gen loc ntn mknot mkprim destprim l bl = match snd ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) - | "- _", [Some (Numeral (p,true))] when not (is_zero p) -> + | "- _", [Some (Numeral (SPlus,p))] when not (is_zero p) -> assert (bl=[]); mknot (loc,ntn,([mknot (loc,(InConstrEntrySomeLevel,"( _ )"),l,[])]),[]) | _ -> match decompose_notation_key ntn, l with - | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] when is_number x -> - mkprim (loc, Numeral (x,false)) - | (InConstrEntrySomeLevel,[Terminal x]), [] when is_number x -> - mkprim (loc, Numeral (x,true)) + | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] -> + begin match NumTok.of_string x with + | Some n -> mkprim (loc, Numeral (SMinus,n)) + | None -> mknot (loc,ntn,l,bl) end + | (InConstrEntrySomeLevel,[Terminal x]), [] -> + begin match NumTok.of_string x with + | Some n -> mkprim (loc, Numeral (SPlus,n)) + | None -> mknot (loc,ntn,l,bl) end | _ -> mknot (loc,ntn,l,bl) let make_notation loc ntn (terms,termlists,binders,binderlists as subst) = @@ -365,7 +364,7 @@ let mkPat ?loc qid l = CAst.make ?loc @@ let pattern_printable_in_both_syntax (ind,_ as c) = let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in - let nb_params = Inductiveops.inductive_nparams ind in + let nb_params = Inductiveops.inductive_nparams (Global.env()) ind in List.exists (fun (_,impls) -> (List.length impls >= nb_params) && let params,args = Util.List.chop nb_params impls in @@ -527,7 +526,7 @@ let rec extern_notation_ind_pattern allscopes lonely_seen vars ind args = functi let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and not explicit application. *) - if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then + if !Flags.in_debugger||Inductiveops.inductive_has_local_defs (Global.env()) ind then let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in CAst.make @@ CPatCstr (c, Some (add_patt_for_params ind args), []) @@ -939,13 +938,12 @@ let rec extern inctx (custom,scopes as allscopes) vars r = let (assums,ids,bl) = extern_local_binder scopes vars bl in let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in - let n = - match fst nv.(i) with - | None -> None - | Some x -> Some (CAst.make @@ Name.get_id (List.nth assums x)) - in - let ro = extern_recursion_order scopes vars (snd nv.(i)) in - ((CAst.make fi), (n, ro), bl, extern_typ scopes vars0 ty, + let n = + match nv.(i) with + | None -> None + | Some x -> Some (CAst.make @@ CStructRec (CAst.make @@ Name.get_id (List.nth assums x))) + in + ((CAst.make fi), n, bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv in CFix (CAst.(make ?loc idv.(n)), Array.to_list listdecl) @@ -969,7 +967,7 @@ let rec extern inctx (custom,scopes as allscopes) vars r = CCast (sub_extern true scopes vars c, map_cast_type (extern_typ scopes vars) c') | GInt i -> - CPrim(Numeral (Uint63.to_string i,true)) + CPrim(Numeral (SPlus, NumTok.int (Uint63.to_string i))) in insert_coercion coercion (CAst.make ?loc c) @@ -1160,13 +1158,6 @@ and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function let lonely_seen = add_lonely keyrule lonely_seen in extern_notation allscopes lonely_seen vars t rules -and extern_recursion_order scopes vars = function - GStructRec -> CStructRec - | GWfRec c -> CWfRec (extern true scopes vars c) - | GMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m, - Option.map (extern true scopes vars) r) - - let extern_glob_constr vars c = extern false (InConstrEntrySomeLevel,(None,[])) vars c @@ -1295,7 +1286,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with let v = Array.map3 (fun c t i -> Detyping.share_pattern_names glob_of_pat (i+1) [] def_avoid def_env sigma c (Patternops.lift_pattern n t)) bl tl ln in - GRec(GFix (Array.map (fun i -> Some i, GStructRec) ln,i),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i) ln,i),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 349402035c..c0801067ce 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -96,21 +96,6 @@ let is_global id = with Not_found -> false -let global_reference_of_reference qid = - locate_reference qid - -let global_reference id = - locate_reference (qualid_of_ident id) - -let construct_reference ctx id = - try - VarRef (let _ = Context.Named.lookup id ctx in id) - with Not_found -> - global_reference id - -let global_reference_in_absolute_module dir id = - Nametab.global_of_path (Libnames.make_path dir id) - (**********************************************************************) (* Internalization errors *) @@ -658,7 +643,7 @@ let terms_of_binders bl = | PatCstr (c,l,_) -> let qid = qualid_of_path ?loc (Nametab.path_of_global (ConstructRef c)) in let hole = CAst.make ?loc @@ CHole (None,IntroAnonymous,None) in - let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in + let params = List.make (Inductiveops.inductive_nparams (Global.env()) (fst c)) hole in CAppExpl ((None,qid,None),params @ List.map term_of_pat l)) pt in let rec extract_variables l = match l with | bnd :: l -> @@ -753,7 +738,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = else let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in match disjpat with - | [pat] -> (glob_constr_of_cases_pattern pat, None) + | [pat] -> (glob_constr_of_cases_pattern (Global.env()) pat, None) | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () in let terms = Id.Map.fold mk_env terms Id.Map.empty in @@ -815,7 +800,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = else let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in match disjpat with - | [pat] -> glob_constr_of_cases_pattern pat + | [pat] -> glob_constr_of_cases_pattern (Global.env()) pat | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") with Not_found -> try @@ -1033,7 +1018,7 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = | TrueGlobal (VarRef _) when no_secvar -> (* Rule out section vars since these should have been found by intern_var *) raise Not_found - | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args + | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), Some ref, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition ?loc sp in let nids = List.length ids in @@ -1043,7 +1028,6 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let terms = make_subst ids (List.map fst args1) in let subst = (terms, Id.Map.empty, Id.Map.empty, Id.Map.empty) in let infos = (Id.Map.empty, env) in - let projapp = match c with NRef _ -> true | _ -> false in let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in let loc = c.loc in let err () = @@ -1067,33 +1051,60 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) | Some _, _ -> err () in - c, projapp, args2 + c, None, args2 + +let warn_nonprimitive_projection = + CWarnings.create ~name:"nonprimitive-projection-syntax" ~category:"syntax" ~default:CWarnings.Disabled + Pp.(fun f -> pr_qualid f ++ str " used as a primitive projection but is not one.") + +let error_nonprojection_syntax ?loc qid = + CErrors.user_err ?loc ~hdr:"nonprojection-syntax" Pp.(pr_qualid qid ++ str" is not a projection.") + +let check_applied_projection isproj realref qid = + match isproj with + | None -> () + | Some projargs -> + let is_prim = match realref with + | None | Some (IndRef _ | ConstructRef _ | VarRef _) -> false + | Some (ConstRef c) -> + if Recordops.is_primitive_projection c then true + else if Recordops.is_projection c then false + else error_nonprojection_syntax ?loc:qid.loc qid + (* TODO check projargs, note we will need implicit argument info *) + in + if not is_prim then warn_nonprimitive_projection ?loc:qid.loc qid -let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args qid = +let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us args qid = let loc = qid.CAst.loc in if qualid_is_ident qid then - try intern_var env lvar namedctx loc (qualid_basename qid) us, args + try + let res = intern_var env lvar namedctx loc (qualid_basename qid) us in + check_applied_projection isproj None qid; + res, args with Not_found -> try - let r, projapp, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in + let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in + check_applied_projection isproj realref qid; let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then + (* check_applied_projection ?? *) (gvar (loc,qualid_basename qid) us, [], [], []), args else Nametab.error_global_not_found qid else - let r,projapp,args2 = + let r,realref,args2 = try intern_qualid qid intern env ntnvars us args with Not_found -> Nametab.error_global_not_found qid in + check_applied_projection isproj realref qid; let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 let interp_reference vars r = let (r,_,_,_),_ = - intern_applied_reference (fun _ -> error_not_enough_arguments ?loc:None) + intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env} Environ.empty_named_context_val @@ -1186,10 +1197,10 @@ let check_or_pat_variables loc ids idsl = @return if letin are included *) let check_constructor_length env loc cstr len_pl pl0 = let n = len_pl + List.length pl0 in - if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else - (Int.equal n (Inductiveops.constructor_nalldecls cstr) || + if Int.equal n (Inductiveops.constructor_nallargs env cstr) then false else + (Int.equal n (Inductiveops.constructor_nalldecls env cstr) || (error_wrong_numarg_constructor ?loc env cstr - (Inductiveops.constructor_nrealargs cstr))) + (Inductiveops.constructor_nrealargs env cstr))) open Declarations @@ -1215,9 +1226,9 @@ let add_local_defs_and_check_length loc env g pl args = match g with have been given in the "explicit" arguments, which come from a "@C args" notation or from a custom user notation *) let pl' = insert_local_defs_in_pattern cstr pl in - let maxargs = Inductiveops.constructor_nalldecls cstr in + let maxargs = Inductiveops.constructor_nalldecls env cstr in if List.length pl' + List.length args > maxargs then - error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs cstr); + error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs env cstr); (* Two possibilities: either the args are given with explict variables for local definitions, then we give the explicit args extended with local defs, so that there is nothing more to be @@ -1247,15 +1258,15 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 in aux 0 (impl_list,pl2) let add_implicits_check_constructor_length env loc c len_pl1 pl2 = - let nargs = Inductiveops.constructor_nallargs c in - let nargs' = Inductiveops.constructor_nalldecls c in + let nargs = Inductiveops.constructor_nallargs env c in + let nargs' = Inductiveops.constructor_nalldecls env c in let impls_st = implicits_of_global (ConstructRef c) in add_implicits_check_length (error_wrong_numarg_constructor ?loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = - let nallargs = inductive_nallargs_env env c in - let nalldecls = inductive_nalldecls_env env c in + let nallargs = inductive_nallargs env c in + let nalldecls = inductive_nalldecls env c in let impls_st = implicits_of_global (IndRef c) in add_implicits_check_length (error_wrong_numarg_inductive ?loc env c) nallargs nalldecls impls_st len_pl1 pl2 @@ -1263,8 +1274,8 @@ let add_implicits_check_ind_length env loc c len_pl1 pl2 = (** Do not raise NotEnoughArguments thanks to preconditions*) let chop_params_pattern loc ind args with_letin = let nparams = if with_letin - then Inductiveops.inductive_nparamdecls ind - else Inductiveops.inductive_nparams ind in + then Inductiveops.inductive_nparamdecls (Global.env()) ind + else Inductiveops.inductive_nparams (Global.env()) ind in assert (nparams <= List.length args); let params,args = List.chop nparams args in List.iter (fun c -> match DAst.get c with @@ -1284,10 +1295,11 @@ let find_constructor loc add_params ref = in cstr, match add_params with | Some nb_args -> + let env = Global.env () in let nb = - if Int.equal nb_args (Inductiveops.constructor_nrealdecls cstr) - then Inductiveops.inductive_nparamdecls ind - else Inductiveops.inductive_nparams ind + if Int.equal nb_args (Inductiveops.constructor_nrealdecls env cstr) + then Inductiveops.inductive_nparamdecls env ind + else Inductiveops.inductive_nparams env ind in List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) | None -> [] @@ -1328,7 +1340,7 @@ let sort_fields ~complete loc fields completer = | (first_field_ref, first_field_value):: other_fields -> let (first_field_glob_ref, record) = try - let gr = global_reference_of_reference first_field_ref in + let gr = locate_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> raise (InternalizationError(loc, NotAProjection first_field_ref)) @@ -1386,7 +1398,7 @@ let sort_fields ~complete loc fields completer = let rec index_fields fields remaining_projs acc = match fields with | (field_ref, field_value) :: fields -> - let field_glob_ref = try global_reference_of_reference field_ref + let field_glob_ref = try locate_reference field_ref with Not_found -> user_err ?loc ~hdr:"intern" (str "The field \"" ++ pr_qualid field_ref ++ str "\" does not exist.") in @@ -1461,8 +1473,9 @@ let alias_of als = match als.alias_ids with let is_zero s = let rec aux i = - Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) + Int.equal (String.length s) i || ((s.[i] == '0' || s.[i] == '_') && aux (i+1)) in aux 0 +let is_zero n = is_zero n.NumTok.int && is_zero n.NumTok.frac let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2 @@ -1487,11 +1500,11 @@ let rec subst_pat_iterator y t = DAst.(map (function | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let is_non_zero c = match c with -| { CAst.v = CPrim (Numeral (p, true)) } -> not (is_zero p) +| { CAst.v = CPrim (Numeral (SPlus, p)) } -> not (is_zero p) | _ -> false let is_non_zero_pat c = match c with -| { CAst.v = CPatPrim (Numeral (p, true)) } -> not (is_zero p) +| { CAst.v = CPatPrim (Numeral (SPlus, p)) } -> not (is_zero p) | _ -> false let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref @@ -1602,8 +1615,8 @@ let drop_notations_pattern looked_for genv = let (argscs1,_) = find_remaining_scopes expl_pl pl g in DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) | CPatNotation ((InConstrEntrySomeLevel,"- _"),([a],[]),[]) when is_non_zero_pat a -> - let p = match a.CAst.v with CPatPrim (Numeral (p, _)) -> p | _ -> assert false in - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (p,false)) scopes in + let p = match a.CAst.v with CPatPrim (Numeral (_, p)) -> p | _ -> assert false in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (SMinus,p)) scopes in rcp_of_glob scopes pat | CPatNotation ((InConstrEntrySomeLevel,"( _ )"),([a],[]),[]) -> in_pat top scopes a @@ -1827,56 +1840,49 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> let (c,imp,subscopes,l),_ = - intern_applied_reference intern env (Environ.named_context_val globalenv) - lvar us [] ref + intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) + lvar us [] ref in apply_impargs c env imp subscopes l loc - | CFix ({ CAst.loc = locid; v = iddef}, dl) -> + | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in let dl = Array.of_list dl in - let n = - try List.index0 Id.equal iddef lf + let n = + try List.index0 Id.equal iddef lf with Not_found -> - raise (InternalizationError (locid,UnboundFixName (false,iddef))) - in - let idl_temp = Array.map - (fun (id,(n,order),bl,ty,_) -> - let intern_ro_arg f = - let before, after = split_at_annot bl n in - let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in - let ro = f (intern env') in - let n' = Option.map (fun _ -> List.count (fun c -> match DAst.get c with - | GLocalAssum _ -> true - | _ -> false (* remove let-ins *)) - rbefore) n in - n', ro, List.fold_left intern_local_binder (env',rbefore) after - in - let n, ro, (env',rbl) = - match order with - | CStructRec -> - intern_ro_arg (fun _ -> GStructRec) - | CWfRec c -> - intern_ro_arg (fun f -> GWfRec (f c)) - | CMeasureRec (m,r) -> - intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r)) - in - let bl = List.rev (List.map glob_local_binder_of_extended rbl) in - ((n, ro), bl, intern_type env' ty, env')) dl in + raise (InternalizationError (locid,UnboundFixName (false,iddef))) + in + let idl_temp = Array.map + (fun (id,recarg,bl,ty,_) -> + let recarg = Option.map (function { CAst.v = v } -> match v with + | CStructRec i -> i + | _ -> anomaly Pp.(str "Non-structural recursive argument in non-program fixpoint")) recarg + in + let before, after = split_at_annot bl recarg in + let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in + let n = Option.map (fun _ -> List.count (fun c -> match DAst.get c with + | GLocalAssum _ -> true + | _ -> false (* remove let-ins *)) + rbefore) recarg in + let (env',rbl) = List.fold_left intern_local_binder (env',rbefore) after in + let bl = List.rev (List.map glob_local_binder_of_extended rbl) in + (n, bl, intern_type env' ty, env')) dl in let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> - let env'' = List.fold_left_i (fun i en name -> - let (_,bli,tyi,_) = idl_temp.(i) in - let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in - push_name_env ntnvars (impls_type_list ~args:fix_args tyi) - en (CAst.make @@ Name name)) 0 env' lf in - (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in - DAst.make ?loc @@ - GRec (GFix - (Array.map (fun (ro,_,_,_) -> ro) idl,n), + let env'' = List.fold_left_i (fun i en name -> + let (_,bli,tyi,_) = idl_temp.(i) in + let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in + push_name_env ntnvars (impls_type_list ~args:fix_args tyi) + en (CAst.make @@ Name name)) 0 env' lf in + (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in + DAst.make ?loc @@ + GRec (GFix + (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, Array.map (fun (_,bl,_,_) -> bl) idl, Array.map (fun (_,_,ty,_) -> ty) idl, Array.map (fun (_,_,_,bd) -> bd) idl) + | CCoFix ({ CAst.loc = locid; v = iddef }, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_) -> id) dl in let dl = Array.of_list dl in @@ -1918,8 +1924,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = GLetIn (na.CAst.v, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) | CNotation ((InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> - let p = match a.CAst.v with CPrim (Numeral (p, _)) -> p | _ -> assert false in - intern env (CAst.make ?loc @@ CPrim (Numeral (p,false))) + let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in + intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) | CNotation ((InConstrEntrySomeLevel,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (ntn,args) -> intern_notation intern env ntnvars loc ntn args @@ -1933,30 +1939,31 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CAppExpl ((isproj,ref,us), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in - intern_applied_reference intern env (Environ.named_context_val globalenv) - lvar us args ref + intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) + lvar us args ref in (* Rem: GApp(_,f,[]) stands for @f *) if args = [] then DAst.make ?loc @@ GApp (f,[]) else smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> - let f,args = match f.CAst.v with + let isproj,f,args = match f.CAst.v with (* Compact notations like "t.(f args') args" *) - | CApp ((Some _,f), args') when not (Option.has_some isproj) -> - f,args'@args + | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) - | _ -> f,args in + | _ -> isproj,f,args in let (c,impargs,args_scopes,l),args = match f.CAst.v with | CRef (ref,us) -> - intern_applied_reference intern env + intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref | CNotation (ntn,([],[],[],[])) -> + assert (Option.is_empty isproj); let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in let x, impl, scopes, l = find_appl_head_data c in (x,impl,scopes,l), args - | _ -> (intern env f,[],[],[]), args in + | _ -> assert (Option.is_empty isproj); (intern env f,[],[],[]), args in apply_impargs c env impargs args_scopes (merge_impargs l args) loc diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2d14a0d0a7..0d4bc91f57 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -162,24 +162,11 @@ val interp_context_evars : env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) -(* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) -(* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) -(* ?global_level:bool -> ?impl_env:internalization_env -> *) -(* env -> evar_map -> local_binder_expr list -> internalization_env * ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) - -(* val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> *) -(* env -> evar_map -> local_binder_expr list -> *) -(* internalization_env * *) -(* ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) - (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) val locate_reference : Libnames.qualid -> GlobRef.t val is_global : Id.t -> bool -val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> GlobRef.t -val global_reference : Id.t -> GlobRef.t -val global_reference_in_absolute_module : DirPath.t -> Id.t -> GlobRef.t (** Interprets a term as the left-hand side of a notation. The returned map is guaranteed to have the same domain as the input one. *) diff --git a/interp/declare.ml b/interp/declare.ml index 08a6ac5f7b..76b4bab2ce 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -119,7 +119,6 @@ let set_declare_scheme f = declare_scheme := f let update_tables c = declare_constant_implicits c; - Heads.declare_head (EvalConstRef c); Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) let register_side_effect (c, role) = @@ -257,7 +256,6 @@ let declare_variable id obj = let oname = add_leaf id (inVariable (Inr (id,obj))) in declare_var_implicits id; Notation.declare_ref_arguments_scope Evd.empty (VarRef id); - Heads.declare_head (EvalVarRef id); oname (** Declaration of inductive blocks *) @@ -348,6 +346,25 @@ let inInductive : mutual_inductive_entry -> obj = discharge_function = discharge_inductive; rebuild_function = rebuild_inductive } +let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c + +let load_prim _ p = cache_prim p + +let subst_prim (subst,(p,c)) = Mod_subst.subst_proj_repr subst p, Mod_subst.subst_constant subst c + +let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) + +let inPrim : (Projection.Repr.t * Constant.t) -> obj = + declare_object { + (default_object "PRIMPROJS") with + cache_function = cache_prim ; + load_function = load_prim; + subst_function = subst_prim; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_prim } + +let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) + let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = let id = Label.to_id label in let univs, u = match univs with @@ -362,7 +379,7 @@ let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (ter let entry = definition_entry ~types ~univs term in let cst = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in - Recordops.declare_primitive_projection p cst + declare_primitive_projection p cst let declare_projections univs mind = diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 854651e7b7..dffccf02fc 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -231,23 +231,25 @@ let implicit_application env ?(allow_partial=true) f ty = | Some ({CAst.loc;v=(id, par, inst)}, gr) -> let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = - let c = class_info gr in - let (ci, rd) = c.cl_context in - if not allow_partial then - begin - let opt_succ x n = match x with - | None -> succ n - | Some _ -> n - in - let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in - let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in - if not (Int.equal needlen applen) then - mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd - end; - let pars = List.rev (List.combine ci rd) in - let args, avoid = combine_params avoid f par pars in - CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid - in c, avoid + let env = Global.env () in + let sigma = Evd.from_env env in + let c = class_info env sigma gr in + let (ci, rd) = c.cl_context in + if not allow_partial then + begin + let opt_succ x n = match x with + | None -> succ n + | Some _ -> n + in + let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in + let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in + if not (Int.equal needlen applen) then + mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd + end; + let pars = List.rev (List.combine ci rd) in + let args, avoid = combine_params avoid f par pars in + CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid + in c, avoid let warn_ignoring_implicit_status = CWarnings.create ~name:"ignoring_implicit_status" ~category:"implicits" diff --git a/interp/interp.mllib b/interp/interp.mllib index 147eaf20dc..1262dbb181 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,3 +1,4 @@ +NumTok Constrexpr Tactypes Stdarg diff --git a/interp/notation.ml b/interp/notation.ml index bc68d97bb8..56504db04e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -476,7 +476,7 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) (* Interpreting numbers (not in summary because functional objects) *) type required_module = full_path * string list -type rawnum = Constrexpr.raw_natural_number * Constrexpr.sign +type rawnum = Constrexpr.sign * Constrexpr.raw_numeral type prim_token_uid = string @@ -499,15 +499,20 @@ module InnerPrimToken = struct | StringInterp f, StringInterp f' -> f == f' | _ -> false - let ofNumeral n s = - if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) + let ofNumeral s n = + let n = String.(concat "" (split_on_char '_' n)) in + match s with + | SPlus -> Bigint.of_string n + | SMinus -> Bigint.neg (Bigint.of_string n) let do_interp ?loc interp primtok = match primtok, interp with - | Numeral (n,s), RawNumInterp interp -> interp ?loc (n,s) - | Numeral (n,s), BigNumInterp interp -> interp ?loc (ofNumeral n s) + | Numeral (s,n), RawNumInterp interp -> interp ?loc (s,n) + | Numeral (s,{ NumTok.int = n; frac = ""; exp = "" }), + BigNumInterp interp -> interp ?loc (ofNumeral s n) | String s, StringInterp interp -> interp ?loc s - | _ -> raise Not_found + | (Numeral _ | String _), + (RawNumInterp _ | BigNumInterp _ | StringInterp _) -> raise Not_found type uninterpreter = | RawNumUninterp of (any_glob_constr -> rawnum option) @@ -521,15 +526,17 @@ module InnerPrimToken = struct | _ -> false let mkNumeral n = - if Bigint.is_pos_or_zero n then Numeral (Bigint.to_string n, true) - else Numeral (Bigint.to_string (Bigint.neg n), false) + if Bigint.is_pos_or_zero n then + Numeral (SPlus,NumTok.int (Bigint.to_string n)) + else + Numeral (SMinus,NumTok.int (Bigint.to_string (Bigint.neg n))) let mkString = function | None -> None | Some s -> if Unicode.is_utf8 s then Some (String s) else None let do_uninterp uninterp g = match uninterp with - | RawNumUninterp u -> Option.map (fun (n,s) -> Numeral (n,s)) (u g) + | RawNumUninterp u -> Option.map (fun (s,n) -> Numeral (s,n)) (u g) | BigNumUninterp u -> Option.map mkNumeral (u g) | StringUninterp u -> mkString (u g) @@ -559,8 +566,8 @@ exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_t type numnot_option = | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number + | Warning of string + | Abstract of string type int_ty = { uint : Names.inductive; @@ -570,11 +577,16 @@ type z_pos_ty = { z_ty : Names.inductive; pos_ty : Names.inductive } +type decimal_ty = + { int : int_ty; + decimal : Names.inductive } + type target_kind = | Int of int_ty (* Coq.Init.Decimal.int + uint *) | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Decimal of decimal_ty (* Coq.Init.Decimal.decimal + uint + int *) type string_target_kind = | ListByte @@ -606,20 +618,18 @@ module PrimTokenNotation = struct At least [c] is known to be evar-free, since it comes from our own ad-hoc [constr_of_glob] or from conversions such as [coqint_of_rawnum]. -*) -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let sigma,t = Typing.type_of env sigma c in - let c' = Vnorm.cbv_vm env sigma c t in - EConstr.Unsafe.to_constr c' + It is important to fully normalize the term, *including inductive + parameters of constructors*; see + https://github.com/coq/coq/issues/9840 for details on what goes + wrong if this does not happen, e.g., from using the vm rather than + cbv. +*) -(* For testing with "compute" instead of "vm_compute" : let eval_constr env sigma (c : Constr.t) = let c = EConstr.of_constr c in let c' = Tacred.compute env sigma c in EConstr.Unsafe.to_constr c' -*) let eval_constr_app env sigma c1 c2 = eval_constr env sigma (mkApp (c1,[| c2 |])) @@ -628,12 +638,21 @@ exception NotAValidPrimToken (** The uninterp function below work at the level of [glob_constr] which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) + to [constr] for the subset that concerns us. + + Note that if you update [constr_of_glob], you should update the + corresponding numeral notation *and* string notation doc in + doc/sphinx/user-extensions/syntax-extensions.rst that describes + what it means for a term to be ground / to be able to be + considered for parsing. *) let rec constr_of_glob env sigma g = match DAst.get g with | Glob_term.GRef (ConstructRef c, _) -> let sigma,c = Evd.fresh_constructor_instance env sigma c in sigma,mkConstructU c + | Glob_term.GRef (IndRef c, _) -> + let sigma,c = Evd.fresh_inductive_instance env sigma c in + sigma,mkIndU c | Glob_term.GApp (gc, gcl) -> let sigma,c = constr_of_glob env sigma gc in let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in @@ -753,15 +772,29 @@ let coquint_of_rawnum uint str = let nil = mkConstruct (uint,1) in let rec do_chars s i acc = if i < 0 then acc - else + else if s.[i] == '_' then do_chars s (i-1) acc else let dg = mkConstruct (uint, digit_of_char s.[i]) in do_chars s (i-1) (mkApp(dg,[|acc|])) in do_chars str (String.length str - 1) nil -let coqint_of_rawnum inds (str,sign) = +let coqint_of_rawnum inds sign str = let uint = coquint_of_rawnum inds.uint str in - mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) + let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in + mkApp (mkConstruct (inds.int, pos_neg), [|uint|]) + +let coqdecimal_of_rawnum inds sign n = + let i, f, e = NumTok.(n.int, n.frac, n.exp) in + let i = coqint_of_rawnum inds.int sign i in + let f = coquint_of_rawnum inds.int.uint f in + if e = "" then mkApp (mkConstruct (inds.decimal, 1), [|i; f|]) (* Decimal *) + else + let sign, e = match e.[1] with + | '-' -> SMinus, String.sub e 2 (String.length e - 2) + | '+' -> SPlus, String.sub e 2 (String.length e - 2) + | _ -> SPlus, String.sub e 1 (String.length e - 1) in + let e = coqint_of_rawnum inds.int sign e in + mkApp (mkConstruct (inds.decimal, 2), [|i; f; e|]) (* DecimalExp *) let rawnum_of_coquint c = let rec of_uint_loop c buf = @@ -781,17 +814,30 @@ let rawnum_of_coquint c = (* To avoid ambiguities between Nil and (D0 Nil), we choose to not display Nil alone as "0" *) raise NotAValidPrimToken - else Buffer.contents buf + else NumTok.int (Buffer.contents buf) let rawnum_of_coqint c = match Constr.kind c with | App (c,[|c'|]) -> (match Constr.kind c with - | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) - | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) + | Construct ((_,1), _) (* Pos *) -> (SPlus, rawnum_of_coquint c') + | Construct ((_,2), _) (* Neg *) -> (SMinus, rawnum_of_coquint c') | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken +let rawnum_of_decimal c = + let of_ife i f e = + let sign, n = rawnum_of_coqint i in + let f = + try (rawnum_of_coquint f).NumTok.int with NotAValidPrimToken -> "" in + let e = match e with None -> "" | Some e -> match rawnum_of_coqint e with + | SPlus, e -> "e+" ^ e.NumTok.int + | SMinus, e -> "e-" ^ e.NumTok.int in + sign,{ n with NumTok.frac = f; exp = e } in + match Constr.kind c with + | App (_,[|i; f|]) -> of_ife i f None + | App (_,[|i; f; e|]) -> of_ife i f (Some e) + | _ -> raise NotAValidPrimToken (***********************************************************************) @@ -878,31 +924,42 @@ let bigint_of_int63 c = | _ -> raise NotAValidPrimToken let big2raw n = - if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) - else (Bigint.to_string (Bigint.neg n), false) + if Bigint.is_pos_or_zero n then + (SPlus, NumTok.int (Bigint.to_string n)) + else + (SMinus, NumTok.int (Bigint.to_string (Bigint.neg n))) -let raw2big (n,s) = - if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) +let raw2big s n = match s with + | SPlus -> Bigint.of_string n + | SMinus -> Bigint.neg (Bigint.of_string n) let interp o ?loc n = - begin match o.warning with - | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> + begin match o.warning, n with + | Warning threshold, (SPlus, { NumTok.int = n; frac = ""; exp = "" }) + when rawnum_compare n threshold >= 0 -> warn_large_num o.ty_name | _ -> () end; - let c = match fst o.to_kind with - | Int int_ty -> coqint_of_rawnum int_ty n - | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) - | UInt _ (* n <= 0 *) -> no_such_prim_token "number" ?loc o.ty_name - | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) - | Int63 -> interp_int63 ?loc (raw2big n) + let c = match fst o.to_kind, n with + | Int int_ty, (s, { NumTok.int = n; frac = ""; exp = "" }) -> + coqint_of_rawnum int_ty s n + | UInt uint_ty, (SPlus, { NumTok.int = n; frac = ""; exp = "" }) -> + coquint_of_rawnum uint_ty n + | Z z_pos_ty, (s, { NumTok.int = n; frac = ""; exp = "" }) -> + z_of_bigint z_pos_ty (raw2big s n) + | Int63, (s, { NumTok.int = n; frac = ""; exp = "" }) -> + interp_int63 ?loc (raw2big s n) + | (Int _ | UInt _ | Z _ | Int63), _ -> + no_such_prim_token "number" ?loc o.ty_name + | Decimal decimal_ty, (s,n) -> coqdecimal_of_rawnum decimal_ty s n in let env = Global.env () in let sigma = Evd.from_env env in let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in let to_ty = EConstr.Unsafe.to_constr to_ty in match o.warning, snd o.to_kind with - | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> + | Abstract threshold, Direct + when rawnum_compare (snd n).NumTok.int threshold >= 0 -> warn_abstract_large_num (o.ty_name,o.to_ty); glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) | _ -> @@ -915,9 +972,10 @@ let uninterp o n = PrimTokenNotation.uninterp begin function | (Int _, c) -> rawnum_of_coqint c - | (UInt _, c) -> (rawnum_of_coquint c, true) + | (UInt _, c) -> (SPlus, rawnum_of_coquint c) | (Z _, c) -> big2raw (bigint_of_z c) | (Int63, c) -> big2raw (bigint_of_int63 c) + | (Decimal _, c) -> rawnum_of_decimal c end o n end @@ -1242,8 +1300,8 @@ let find_notation ntn sc = (n.not_interp, n.not_location) let notation_of_prim_token = function - | Numeral (n,true) -> InConstrEntrySomeLevel, n - | Numeral (n,false) -> InConstrEntrySomeLevel, "- "^n + | Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.to_string n + | Numeral (SMinus,n) -> InConstrEntrySomeLevel, "- "^NumTok.to_string n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = @@ -1458,7 +1516,7 @@ let uninterp_prim_token c = with Not_found -> raise Notation_ops.No_match let uninterp_prim_token_cases_pattern c = - match glob_constr_of_closed_cases_pattern c with + match glob_constr_of_closed_cases_pattern (Global.env()) c with | exception Not_found -> raise Notation_ops.No_match | na,c -> let (sc,n) = uninterp_prim_token c in (na,sc,n) diff --git a/interp/notation.mli b/interp/notation.mli index 5dcc96dc29..57e2be16b9 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -70,14 +70,14 @@ val find_delimiters_scope : ?loc:Loc.t -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) -(** A numeral interpreter is the pair of an interpreter for **integer** +(** A numeral interpreter is the pair of an interpreter for **decimal** numbers in terms and an optional interpreter in pattern, if - negative numbers are not supported, the interpreter must fail with - an appropriate error message *) + non integer or negative numbers are not supported, the interpreter + must fail with an appropriate error message *) type notation_location = (DirPath.t * DirPath.t) * string type required_module = full_path * string list -type rawnum = Constrexpr.raw_natural_number * Constrexpr.sign +type rawnum = Constrexpr.sign * Constrexpr.raw_numeral (** The unique id string below will be used to refer to a particular registered interpreter/uninterpreter of numeral or string notation. @@ -112,8 +112,8 @@ exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_t type numnot_option = | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number + | Warning of string + | Abstract of string type int_ty = { uint : Names.inductive; @@ -123,11 +123,16 @@ type z_pos_ty = { z_ty : Names.inductive; pos_ty : Names.inductive } +type decimal_ty = + { int : int_ty; + decimal : Names.inductive } + type target_kind = | Int of int_ty (* Coq.Init.Decimal.int + uint *) | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Decimal of decimal_ty (* Coq.Init.Decimal.decimal + uint + int *) type string_target_kind = | ListByte diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7d7e10a05b..7f084fffdd 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -782,7 +782,7 @@ let rec pat_binder_of_term t = DAst.map (function | GApp (t, l) -> begin match DAst.get t with | GRef (ConstructRef cstr,_) -> - let nparams = Inductiveops.inductive_nparams (fst cstr) in + let nparams = Inductiveops.inductive_nparams (Global.env()) (fst cstr) in let _,l = List.chop nparams l in PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) | _ -> raise No_match @@ -909,7 +909,8 @@ let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) alp, add_env alp sigma var (DAst.make @@ GVar id) let bind_binding_as_term_env alp (terms,termlists,binders,binderlists as sigma) var c = - let pat = try cases_pattern_of_glob_constr Anonymous c with Not_found -> raise No_match in + let env = Global.env () in + let pat = try cases_pattern_of_glob_constr env Anonymous c with Not_found -> raise No_match in try (* If already bound to a binder, unify the term and the binder *) let patl' = Id.List.assoc var binders in @@ -956,7 +957,7 @@ let match_fix_kind fk1 fk2 = match (fk1,fk2) with | GCoFix n1, GCoFix n2 -> Int.equal n1 n2 | GFix (nl1,n1), GFix (nl2,n2) -> - let test (n1, _) (n2, _) = match n1, n2 with + let test n1 n2 = match n1, n2 with | _, None -> true | Some id1, Some id2 -> Int.equal id1 id2 | _ -> false @@ -1292,7 +1293,7 @@ let match_notation_constr u c (metas,pat) = | NtnTypeBinder (NtnBinderParsedAsConstr _) -> (match Id.List.assoc x binders with | [pat] -> - let v = glob_constr_of_cases_pattern pat in + let v = glob_constr_of_cases_pattern (Global.env()) pat in ((v,scl)::terms',termlists',binders',binderlists') | _ -> raise No_match) | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _) -> @@ -1333,11 +1334,11 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (ConstructRef r2) when eq_constructor r1 r2 -> - let l = try add_patterns_for_params_remove_local_defs r1 largs with Not_found -> raise No_match in + let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(0,l) | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (ConstructRef r2),l2) when eq_constructor r1 r2 -> - let l1 = try add_patterns_for_params_remove_local_defs r1 args1 with Not_found -> raise No_match in + let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length l1 then diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 6fe20486dc..5024f5c26f 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -38,7 +38,7 @@ type notation_constr = notation_constr * notation_constr | NIf of notation_constr * (Name.t * notation_constr option) * notation_constr * notation_constr - | NRec of fix_kind * Id.t array * + | NRec of glob_fix_kind * Id.t array * (Name.t * notation_constr option * notation_constr) list array * notation_constr array * notation_constr array | NSort of glob_sort diff --git a/interp/numTok.ml b/interp/numTok.ml new file mode 100644 index 0000000000..8f2004b889 --- /dev/null +++ b/interp/numTok.ml @@ -0,0 +1,52 @@ +type t = { + int : string; + frac : string; + exp : string +} + +let equal n1 n2 = + String.(equal n1.int n2.int && equal n1.frac n2.frac && equal n1.exp n2.exp) + +let int s = { int = s; frac = ""; exp = "" } + +let to_string n = n.int ^ (if n.frac = "" then "" else "." ^ n.frac) ^ n.exp + +let parse = + let buff = ref (Bytes.create 80) in + let store len x = + let open Bytes in + if len >= length !buff then + buff := cat !buff (create (length !buff)); + set !buff len x; + succ len in + let get_buff len = Bytes.sub_string !buff 0 len in + (* reads [0-9_]* *) + let rec number len s = match Stream.peek s with + | Some (('0'..'9' | '_') as c) -> Stream.junk s; number (store len c) s + | _ -> len in + fun s -> + let i = get_buff (number 0 s) in + let f = + match Stream.npeek 2 s with + | '.' :: (('0'..'9' | '_') as c) :: _ -> + Stream.junk s; Stream.junk s; get_buff (number (store 0 c) s) + | _ -> "" in + let e = + match (Stream.npeek 2 s) with + | (('e'|'E') as e) :: ('0'..'9' as c) :: _ -> + Stream.junk s; Stream.junk s; get_buff (number (store (store 0 e) c) s) + | (('e'|'E') as e) :: (('+'|'-') as sign) :: _ -> + begin match Stream.npeek 3 s with + | _ :: _ :: ('0'..'9' as c) :: _ -> + Stream.junk s; Stream.junk s; Stream.junk s; + get_buff (number (store (store (store 0 e) sign) c) s) + | _ -> "" + end + | _ -> "" in + { int = i; frac = f; exp = e } + +let of_string s = + if s = "" || s.[0] < '0' || s.[0] > '9' then None else + let strm = Stream.of_string (s ^ " ") in + let n = parse strm in + if Stream.count strm >= String.length s then Some n else None diff --git a/interp/numTok.mli b/interp/numTok.mli new file mode 100644 index 0000000000..0b6a877cbd --- /dev/null +++ b/interp/numTok.mli @@ -0,0 +1,18 @@ +type t = { + int : string; (** \[0-9\]\[0-9_\]* *) + frac : string; (** empty or \[0-9_\]+ *) + exp : string (** empty or \[eE\]\[+-\]?\[0-9\]\[0-9_\]* *) +} + +val equal : t -> t -> bool + +(** [int s] amounts to [\{ int = s; frac = ""; exp = "" \}] *) +val int : string -> t + +val to_string : t -> string + +val of_string : string -> t option + +(** Precondition: the first char on the stream is a digit (\[0-9\]). + Precondition: at least two extra chars after the numeral to parse. *) +val parse : char Stream.t -> t diff --git a/kernel/dune b/kernel/dune index a8a87a3e95..5b23a705ae 100644 --- a/kernel/dune +++ b/kernel/dune @@ -4,7 +4,7 @@ (public_name coq.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) - (libraries lib byterun)) + (libraries lib byterun dynlink)) (executable (name genOpcodeFiles) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 2dab14e732..d7ec2ecf72 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -51,7 +51,6 @@ let fresh_lname n = (** Global names **) type gname = | Gind of string * inductive (* prefix, inductive name *) - | Gconstruct of string * constructor (* prefix, constructor name *) | Gconstant of string * Constant.t (* prefix, constant name *) | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *) | Gcase of Label.t option * int @@ -67,8 +66,6 @@ let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> String.equal s1 s2 && eq_ind ind1 ind2 - | Gconstruct (s1, c1), Gconstruct (s2, c2) -> - String.equal s1 s2 && eq_constructor c1 c2 | Gconstant (s1, c1), Gconstant (s2, c2) -> String.equal s1 s2 && Constant.equal c1 c2 | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) -> @@ -88,7 +85,7 @@ let eq_gname gn1 gn2 = | Ginternal s1, Ginternal s2 -> String.equal s1 s2 | Grel i1, Grel i2 -> Int.equal i1 i2 | Gnamed id1, Gnamed id2 -> Id.equal id1 id2 - | (Gind _| Gconstruct _ | Gconstant _ | Gproj _ | Gcase _ | Gpred _ + | (Gind _| Gconstant _ | Gproj _ | Gcase _ | Gpred _ | Gfixtype _ | Gnorm _ | Gnormtbl _ | Ginternal _ | Grel _ | Gnamed _), _ -> false @@ -100,19 +97,17 @@ open Hashset.Combine let gname_hash gn = match gn with | Gind (s, ind) -> combinesmall 1 (combine (String.hash s) (ind_hash ind)) -| Gconstruct (s, c) -> - combinesmall 2 (combine (String.hash s) (constructor_hash c)) | Gconstant (s, c) -> - combinesmall 3 (combine (String.hash s) (Constant.hash c)) -| Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gnorm (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gnormtbl (l, i) -> combinesmall 8 (combine (Option.hash Label.hash l) (Int.hash i)) -| Ginternal s -> combinesmall 9 (String.hash s) -| Grel i -> combinesmall 10 (Int.hash i) -| Gnamed id -> combinesmall 11 (Id.hash id) -| Gproj (s, p, i) -> combinesmall 12 (combine (String.hash s) (combine (ind_hash p) i)) + combinesmall 2 (combine (String.hash s) (Constant.hash c)) +| Gcase (l, i) -> combinesmall 3 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gpred (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gfixtype (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gnorm (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gnormtbl (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) +| Ginternal s -> combinesmall 8 (String.hash s) +| Grel i -> combinesmall 9 (Int.hash i) +| Gnamed id -> combinesmall 10 (Id.hash id) +| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (ind_hash p) i)) let case_ctr = ref (-1) @@ -1280,9 +1275,6 @@ let ml_of_instance instance u = | Lmakeblock (prefix,(cn,_u),_,args) -> let args = Array.map (ml_of_lam env l) args in MLconstruct(prefix,cn,args) - | Lconstruct (prefix, (cn,u)) -> - let uargs = ml_of_instance env.env_univ u in - mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i @@ -1533,8 +1525,6 @@ let string_of_gname g = match g with | Gind (prefix, (mind, i)) -> Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i - | Gconstruct (prefix, ((mind, i), j)) -> - Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) | Gproj (prefix, (mind, n), i) -> @@ -1932,16 +1922,6 @@ let compile_mind mb mind stack = Glet(name, MLapp (MLprimitive Mk_ind, args)) in let nparams = mb.mind_nparams in - let params = - Array.init nparams (fun i -> {lname = param_name; luid = i}) in - let add_construct j acc (_,arity) = - let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in - let c = ind, (j+1) in - Glet(Gconstruct ("", c), - mkMLlam (Array.append params args) - (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc - in - let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in let add_proj proj_arg acc _pb = let tbl = ob.mind_reloc_tbl in (* Building info *) @@ -1958,7 +1938,7 @@ let compile_mind mb mind stack = let cargs = Array.init arity (fun i -> if Int.equal i proj_arg then Some ci_uid else None) in - let i = push_symbol (SymbProj (ind, j)) in + let i = push_symbol (SymbProj (ind, proj_arg)) in let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in @@ -1972,7 +1952,7 @@ let compile_mind mb mind stack = let _, _, _, pbs = info.(i) in Array.fold_left_i add_proj [] pbs in - projs @ constructors @ gtype :: accu :: stack + projs @ gtype :: accu :: stack in Array.fold_left_i f stack mb.mind_packets diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index baa290367f..d153f84e9c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors open Names open Nativelib open Reduction @@ -152,19 +151,15 @@ let native_conv_gen pb sigma env univs t1 t2 = else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in - match compile ml_filename code ~profile:false with - | (true, fn) -> - begin - if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); - let t0 = Sys.time () in - call_linker ~fatal:true prefix fn (Some upds); - let t1 = Sys.time () in - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - (* TODO change 0 when we can have de Bruijn *) - fst (conv_val env pb 0 !rt1 !rt2 univs) - end - | _ -> anomaly (Pp.str "Compilation failure.") + let fn = compile ml_filename code ~profile:false in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); + let t0 = Sys.time () in + call_linker ~fatal:true prefix fn (Some upds); + let t1 = Sys.time () in + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + (* TODO change 0 when we can have de Bruijn *) + fst (conv_val env pb 0 !rt1 !rt2 univs) (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index ec3a7b893d..d88be94b39 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -42,8 +42,6 @@ type lambda = | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor Name.t, constructor tag, arguments *) (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) - (* A partially applied constructor *) | Luint of Uint63.t | Lval of Nativevalues.t | Lsort of Sorts.t @@ -121,7 +119,7 @@ let get_const_prefix env c = let map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ - | Lconstruct _ | Llazy | Lforce | Lmeta _ -> lam + | Llazy | Lforce | Lmeta _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in @@ -222,7 +220,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ - | Lconstruct _ | Lmeta _ | Levar _ -> true + | Lmeta _ | Levar _ -> true | _ -> false let can_merge_if bt bf = @@ -337,9 +335,20 @@ let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) (* Translation of constructors *) +let expand_constructor prefix cstr tag nparams arity = + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make (nparams + arity) anon in + let args = make_args arity 1 in + Llam(ids, Lmakeblock (prefix, cstr, tag, args)) -let makeblock env cn u tag args = - if Array.for_all is_value args && Array.length args > 0 then +(* [nparams] is the number of parameters still expected *) +let makeblock env cn u tag nparams arity args = + let nargs = Array.length args in + if nparams > 0 || nargs < arity then + let prefix = get_mind_prefix env (fst (fst cn)) in + mkLapp (expand_constructor prefix (cn,u) tag nparams arity) args + else + if Array.for_all is_value args && nargs > 0 then let args = Array.map get_value args in Lval (Nativevalues.mk_block tag args) else @@ -573,16 +582,12 @@ and lambda_of_app cache env sigma f args = mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) end | Construct (c,u) -> - let tag, nparams, arity = Cache.get_construct_info cache env c in - let expected = nparams + arity in - let nargs = Array.length args in - let prefix = get_mind_prefix env (fst (fst c)) in - if Int.equal nargs expected then - let args = lambda_of_args cache env sigma nparams args in - makeblock env c u tag args - else - let args = lambda_of_args cache env sigma 0 args in - mkLapp (Lconstruct (prefix, (c,u))) args + let tag, nparams, arity = Cache.get_construct_info cache env c in + let nargs = Array.length args in + if nparams < nargs then (* got all parameters *) + let args = lambda_of_args cache env sigma nparams args in + makeblock env c u tag 0 arity args + else makeblock env c u tag (nparams - nargs) arity empty_args | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index b0de257a27..687789e82b 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -36,8 +36,6 @@ type lambda = | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor Name.t, constructor tag, arguments *) (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) - (* A partially applied constructor *) | Luint of Uint63.t | Lval of Nativevalues.t | Lsort of Sorts.t diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 833e4082f0..43c9676f05 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -56,14 +56,15 @@ let write_ml_code fn ?(header=[]) code = List.iter (pp_global fmt) (header@code); close_out ch_out -let warn_native_compiler_failed = - let print = function +let error_native_compiler_failed e = + let msg = match e with + | Inl (Unix.WEXITED 127) -> Pp.(strbrk "The OCaml compiler was not found. Make sure it is installed, together with findlib.") | Inl (Unix.WEXITED n) -> Pp.(strbrk "Native compiler exited with status" ++ str" " ++ int n) | Inl (Unix.WSIGNALED n) -> Pp.(strbrk "Native compiler killed by signal" ++ str" " ++ int n) | Inl (Unix.WSTOPPED n) -> Pp.(strbrk "Native compiler stopped by signal" ++ str" " ++ int n) | Inr e -> Pp.(strbrk "Native compiler failed with error: " ++ strbrk (Unix.error_message e)) in - CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print + CErrors.user_err msg let call_compiler ?profile:(profile=false) ml_filename = let load_path = !get_load_paths () in @@ -100,15 +101,12 @@ let call_compiler ?profile:(profile=false) ml_filename = if !Flags.debug then Feedback.msg_debug (Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (Envars.ocamlfind ()) args in - let res = match res with - | Unix.WEXITED 0 -> true - | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> - warn_native_compiler_failed (Inl res); false - in - res, link_filename + match res with + | Unix.WEXITED 0 -> link_filename + | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> + error_native_compiler_failed (Inl res) with Unix.Unix_error (e,_,_) -> - warn_native_compiler_failed (Inr e); - false, link_filename + error_native_compiler_failed (Inr e) let compile fn code ~profile:profile = write_ml_code fn code; @@ -128,9 +126,8 @@ let compile_library dir code fn = in let fn = dirname / basename in write_ml_code fn ~header code; - let r = fst (call_compiler fn) in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; - r + let _ = call_compiler fn in + if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 25adcf224b..e113350368 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -21,9 +21,14 @@ val load_obj : (string -> unit) ref val get_ml_filename : unit -> string * string -val compile : string -> global list -> profile:bool -> bool * string - -val compile_library : Names.DirPath.t -> global list -> string -> bool +(** [compile file code ~profile] will compile native [code] to [file], + and return the name of the object file; this name depends on + whether are in byte mode or not; file is expected to be .ml file *) +val compile : string -> global list -> profile:bool -> string + +(** [compile_library lib code file] is similar to [compile file code] + but will perform some extra tweaks to handle [code] as a Coq lib. *) +val compile_library : Names.DirPath.t -> global list -> string -> unit val call_linker : ?fatal:bool -> string -> string -> code_location_updates option -> unit diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 2f11f3dd6b..11ece78fe0 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -315,11 +315,19 @@ type conv_tab = { let push_relevance infos r = { infos with relevances = r.Context.binder_relevance :: infos.relevances } -let rec skip_pattern infos n c1 c2 = - if Int.equal n 0 then infos, c1, c2 +let push_relevances infos nas = + { infos with relevances = Array.fold_left (fun l x -> x.Context.binder_relevance :: l) infos.relevances nas } + +let rec skip_pattern infos relevances n c1 c2 = + if Int.equal n 0 then {infos with relevances}, c1, c2 else match kind c1, kind c2 with - | Lambda (x, _, c1), Lambda (_, _, c2) -> skip_pattern (push_relevance infos x) (pred n) c1 c2 - | _ -> raise IrregularPatternShape + | Lambda (x, _, c1), Lambda (_, _, c2) -> + skip_pattern infos (x.Context.binder_relevance :: relevances) (pred n) c1 c2 + | _ -> raise IrregularPatternShape + +let skip_pattern infos n c1 c2 = + if Int.equal n 0 then infos, c1, c2 + else skip_pattern infos infos.relevances n c1 c2 let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in @@ -589,7 +597,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - let infos = Array.fold_left push_relevance infos na1 in + let infos = push_relevances infos na1 in convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in @@ -608,7 +616,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - let infos = Array.fold_left push_relevance infos na1 in + let infos = push_relevances infos na1 in convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in diff --git a/lib/control.ml b/lib/control.ml index ffb3584f1e..9054507e46 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -89,3 +89,21 @@ let timeout_fun_ref = ref timeout_fun let set_timeout f = timeout_fun_ref := f let timeout n f e = !timeout_fun_ref.timeout n f e + +let protect_sigalrm f x = + let timed_out = ref false in + let timeout_handler _ = timed_out := true in + try + let old_handler = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in + try + let res = f x in + Sys.set_signal Sys.sigalrm old_handler; + match !timed_out, old_handler with + | true, Sys.Signal_handle f -> f Sys.sigalrm; res + | _, _ -> res + with e -> + let e = Backtrace.add_backtrace e in + Sys.set_signal Sys.sigalrm old_handler; + Exninfo.iraise e + with Invalid_argument _ -> (* This happens on Windows, as handling SIGALRM does not seem supported *) + f x diff --git a/lib/control.mli b/lib/control.mli index 59e2a15158..640d41a4f7 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -29,3 +29,14 @@ val timeout : int -> ('a -> 'b) -> 'a -> exn -> 'b API and it is scheduled to go away. *) type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } val set_timeout : timeout -> unit + +(** [protect_sigalrm f x] computes [f x], but if SIGALRM is received during that + computation, the signal handler is executed only once the computation is + terminated. Otherwise said, it makes the execution of [f] atomic w.r.t. + handling of SIGALRM. + + This is useful for example to prevent the implementation of `Timeout` to + interrupt I/O routines, generating ill-formed output. + +*) +val protect_sigalrm : ('a -> 'b) -> 'a -> 'b @@ -4,4 +4,4 @@ (public_name coq.lib) (wrapped false) (modules_without_implementation xml_datatype) - (libraries dynlink coq.clib coq.config)) + (libraries coq.clib coq.config)) diff --git a/lib/flags.ml b/lib/flags.ml index 6718e7a954..452433d271 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -62,14 +62,11 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_7 | V8_8 | V8_9 | Current +type compat_version = V8_8 | V8_9 | Current let compat_version = ref Current let version_compare v1 v2 = match v1, v2 with - | V8_7, V8_7 -> 0 - | V8_7, _ -> -1 - | _, V8_7 -> 1 | V8_8, V8_8 -> 0 | V8_8, _ -> -1 | _, V8_8 -> 1 @@ -82,7 +79,6 @@ let version_strictly_greater v = version_compare !compat_version v > 0 let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function - | V8_7 -> "8.7" | V8_8 -> "8.8" | V8_9 -> "8.9" | Current -> "current" diff --git a/lib/flags.mli b/lib/flags.mli index bf8846417b..a70a23b902 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -52,7 +52,7 @@ val we_are_parsing : bool ref (* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -type compat_version = V8_7 | V8_8 | V8_9 | Current +type compat_version = V8_8 | V8_9 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/lib/loc.ml b/lib/loc.ml index 66b7a7da70..6bcdcc0341 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -29,6 +29,8 @@ let create fname line_nb bol_pos bp ep = { line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } +let initial source = create source 1 0 0 0 + let make_loc (bp, ep) = { fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; diff --git a/lib/loc.mli b/lib/loc.mli index 23df1ebd9a..1eb3cc49e8 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -32,6 +32,9 @@ val create : source -> int -> int -> int -> int -> t (** Create a location from a filename, a line number, a position of the beginning of the line, a start and end position *) +val initial : source -> t +(** Create a location corresponding to the beginning of the given source *) + val unloc : t -> int * int (** Return the start and end position of a location *) diff --git a/lib/system.ml b/lib/system.ml index fd6579dd69..c408061852 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -304,7 +304,7 @@ let with_time ~batch ~header f x = raise e (* We use argv.[0] as we don't want to resolve symlinks *) -let get_toplevel_path ?(byte=not Dynlink.is_native) top = +let get_toplevel_path ?(byte=Sys.(backend_type = Bytecode)) top = let open Filename in let dir = if String.equal (basename Sys.argv.(0)) Sys.argv.(0) then "" else dirname Sys.argv.(0) ^ dir_sep in diff --git a/library/goptions.ml b/library/goptions.ml index 1b907fd966..b9c1802a72 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -57,7 +57,7 @@ module MakeTable = type key val compare : t -> t -> int val table : (string * key table_of_A) list ref - val encode : key -> t + val encode : Environ.env -> key -> t val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name @@ -111,10 +111,10 @@ module MakeTable = class table_of_A () = object - method add x = add_option (A.encode x) - method remove x = remove_option (A.encode x) + method add x = add_option (A.encode (Global.env()) x) + method remove x = remove_option (A.encode (Global.env()) x) method mem x = - let y = A.encode x in + let y = A.encode (Global.env()) x in let answer = MySet.mem y !t in Feedback.msg_info (A.member_message y answer) method print = print_table A.title A.printer !t @@ -142,7 +142,7 @@ struct type key = string let compare = String.compare let table = string_table - let encode x = x + let encode _env x = x let subst _ x = x let printer = str let key = A.key @@ -161,7 +161,7 @@ module type RefConvertArg = sig type t val compare : t -> t -> int - val encode : qualid -> t + val encode : Environ.env -> qualid -> t val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name diff --git a/library/goptions.mli b/library/goptions.mli index b91553bf3c..2e593e9d9e 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -89,8 +89,8 @@ module MakeRefTable : (A : sig type t val compare : t -> t -> int - val encode : qualid -> t - val subst : substitution -> t -> t + val encode : Environ.env -> qualid -> t + val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name val title : string @@ -172,6 +172,14 @@ type option_value = | StringValue of string | StringOptValue of string option +val set_option_value : ?locality:option_locality -> + ('a -> option_value -> option_value) -> option_name -> 'a -> unit +(** [set_option_value ?locality f name v] sets [name] to the result of + applying [f] to [v] and [name]'s current value. Use for behaviour + depending on the type of the option, eg erroring when ['a] doesn't + match it. Changing the type will result in errors later so don't do + that. *) + (** Summary of an option status *) type option_state = { opt_depr : bool; diff --git a/library/library.ml b/library/library.ml index 37dadadb76..04e38296d9 100644 --- a/library/library.ml +++ b/library/library.ml @@ -718,8 +718,7 @@ let save_library_to ?todo ~output_native_objects dir f otab = (* Writing native code files *) if output_native_objects then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in - if not (Nativelib.compile_library dir ast fn) then - user_err Pp.(str "Could not compile the library to native code.") + Nativelib.compile_library dir ast fn with reraise -> let reraise = CErrors.push reraise in let () = Feedback.msg_warning (str "Removed file " ++ str f') in diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 49d6cf01d9..42ca5f8c05 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -19,16 +19,19 @@ open Gramlib module CharOrd = struct type t = char let compare : char -> char -> int = compare end module CharMap = Map.Make (CharOrd) +type starts_quotation = NoQuotation | Quotation + type ttree = { - node : string option; - branch : ttree CharMap.t } + node : (string * starts_quotation) option; + branch : ttree CharMap.t; +} let empty_ttree = { node = None; branch = CharMap.empty } -let ttree_add ttree str = +let ttree_add ttree (str,quot) = let rec insert tt i = if i == String.length str then - {node = Some str; branch = tt.branch} + {node = Some (str,quot); branch = tt.branch} else let c = str.[i] in let br = @@ -75,7 +78,7 @@ let ttree_elements ttree = let rec elts tt accu = let accu = match tt.node with | None -> accu - | Some s -> CString.Set.add s accu + | Some (s,_) -> CString.Set.add s accu in CharMap.fold (fun _ tt accu -> elts tt accu) tt.branch accu in @@ -259,11 +262,11 @@ let is_keyword s = try match (ttree_find !token_tree s).node with None -> false | Some _ -> true with Not_found -> false -let add_keyword str = +let add_keyword ?(quotation=NoQuotation) str = if not (is_keyword str) then begin check_keyword str; - token_tree := ttree_add !token_tree str + token_tree := ttree_add !token_tree (str,quotation) end let remove_keyword str = @@ -315,10 +318,6 @@ let rec ident_tail loc len s = match Stream.peek s with warn_unrecognized_unicode ~loc (u,id); len | _ -> len -let rec number len s = match Stream.peek s with - | Some ('0'..'9' as c) -> Stream.junk s; number (store len c) s - | _ -> len - let warn_comment_terminator_in_string = CWarnings.create ~name:"comment-terminator-in-string" ~category:"parsing" (fun () -> @@ -383,9 +382,6 @@ let rec string loc ~comm_level bp len s = match Stream.peek s with let loc = set_loc_pos loc bp ep in err loc Unterminated_string -(* To associate locations to a file name *) -let current_file = ref Loc.ToplevelInput - (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -397,21 +393,20 @@ let current_comment = Buffer.create 8192 let between_commands = ref true (* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list * Loc.source +type lexer_state = int option * string * bool * ((int * int) * string) list -let init_lexer_state f = (None,"",true,[],f) -let set_lexer_state (o,s,b,c,f) = +let init_lexer_state () = (None,"",true,[]) +let set_lexer_state (o,s,b,c) = comment_begin := o; Buffer.clear current_comment; Buffer.add_string current_comment s; between_commands := b; - comments := c; - current_file := f + comments := c let get_lexer_state () = - (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) + (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) let drop_lexer_state () = - set_lexer_state (init_lexer_state Loc.ToplevelInput) + set_lexer_state (init_lexer_state ()) -let get_comment_state (_,_,_,c,_) = c +let get_comment_state (_,_,_,c) = c let real_push_char c = Buffer.add_char current_comment c @@ -533,11 +528,62 @@ and progress_utf8 loc last nj n c tt cs = and progress_from_byte loc last nj tt cs c = progress_utf8 loc last nj (utf8_char_size loc cs c) c tt cs +type marker = Delimited of int * char list * char list | ImmediateAsciiIdent + +let peek_marker_len b e s = + let rec peek n = + match stream_nth n s with + | c -> if c = b then peek (n+1) else n, List.make n b, List.make n e + | exception Stream.Failure -> n, List.make n b, List.make n e + in + let len, start, stop = peek 0 in + if len = 0 then raise Stream.Failure + else Delimited (len, start, stop) + +let peek_marker s = + match stream_nth 0 s with + | '(' -> peek_marker_len '(' ')' s + | '[' -> peek_marker_len '[' ']' s + | '{' -> peek_marker_len '{' '}' s + | ('a'..'z' | 'A'..'Z' | '_') -> ImmediateAsciiIdent + | _ -> raise Stream.Failure + +let parse_quotation loc s = + match peek_marker s with + | ImmediateAsciiIdent -> + let c = Stream.next s in + let len = + try ident_tail loc (store 0 c) s with + Stream.Failure -> raise (Stream.Error "") + in + get_buff len + | Delimited (lenmarker, bmarker, emarker) -> + let b = Buffer.create 80 in + let commit1 c = Buffer.add_char b c; Stream.junk s in + let commit l = List.iter commit1 l in + let rec quotation depth = + match Stream.npeek lenmarker s with + | l when l = bmarker -> + commit l; + quotation (depth + 1) + | l when l = emarker -> + commit l; + if depth > 1 then quotation (depth - 1) + | c :: cs -> + commit1 c; + quotation depth + | [] -> raise Stream.Failure + in + quotation 0; + Buffer.contents b + + let find_keyword loc id s = let tt = ttree_find !token_tree id in match progress_further loc tt.node 0 tt s with | None -> raise Not_found - | Some c -> KEYWORD c + | Some (c,NoQuotation) -> KEYWORD c + | Some (c,Quotation) -> QUOTATION(c, parse_quotation loc s) let process_sequence loc bp c cs = let rec aux n cs = @@ -552,7 +598,8 @@ let process_chars ~diff_mode loc bp c cs = let t = progress_from_byte loc None (-1) !token_tree cs c in let ep = Stream.count cs in match t with - | Some t -> (KEYWORD t, set_loc_pos loc bp ep) + | Some (t,NoQuotation) -> (KEYWORD t, set_loc_pos loc bp ep) + | Some (c,Quotation) -> (QUOTATION(c, parse_quotation loc cs), set_loc_pos loc bp ep) | None -> let ep' = bp + utf8_char_size loc cs c in if diff_mode then begin @@ -655,15 +702,11 @@ let rec next_token ~diff_mode loc s = let id = get_buff len in comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep - | Some ('0'..'9' as c) -> - Stream.junk s; - let len = - try number (store 0 c) s with - Stream.Failure -> raise (Stream.Error "") - in + | Some ('0'..'9') -> + let n = NumTok.parse s in let ep = Stream.count s in comment_stop bp; - (INT (get_buff len), set_loc_pos loc bp ep) + (NUMERAL n, set_loc_pos loc bp ep) | Some '\"' -> Stream.junk s; let (loc, len) = @@ -739,24 +782,29 @@ let loct_add loct i loc = Hashtbl.add loct i loc we unfreeze the state of the lexer. This restores the behaviour of the lexer. B.B. *) -type te = Tok.t - (** Names of tokens, for this lexer, used in Grammar error messages *) -let token_text = function - | ("", t) -> "'" ^ t ^ "'" - | ("IDENT", "") -> "identifier" - | ("IDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT", s) -> "'" ^ s ^ "'" - | ("STRING", "") -> "string" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" - -let func next_token cs = +let token_text : type c. c Tok.p -> string = function + | PKEYWORD t -> "'" ^ t ^ "'" + | PIDENT None -> "identifier" + | PIDENT (Some t) -> "'" ^ t ^ "'" + | PNUMERAL None -> "numeral" + | PNUMERAL (Some n) -> "'" ^ NumTok.to_string n ^ "'" + | PSTRING None -> "string" + | PSTRING (Some s) -> "STRING \"" ^ s ^ "\"" + | PLEFTQMARK -> "LEFTQMARK" + | PEOI -> "end of input" + | PPATTERNIDENT None -> "PATTERNIDENT" + | PPATTERNIDENT (Some s) -> "PATTERNIDENT \"" ^ s ^ "\"" + | PFIELD None -> "FIELD" + | PFIELD (Some s) -> "FIELD \"" ^ s ^ "\"" + | PBULLET None -> "BULLET" + | PBULLET (Some s) -> "BULLET \"" ^ s ^ "\"" + | PQUOTATION lbl -> "QUOTATION \"" ^ lbl ^ "\"" + +let func next_token ?loc cs = let loct = loct_create () in - let cur_loc = ref (Loc.create !current_file 1 0 0 0) in + let cur_loc = ref (Option.default Loc.(initial ToplevelInput) loc) in let ts = Stream.from (fun i -> @@ -766,29 +814,30 @@ let func next_token cs = in (ts, loct_func loct) -let make_lexer ~diff_mode = { - Plexing.tok_func = func (next_token ~diff_mode); - Plexing.tok_using = - (fun pat -> match Tok.of_pattern pat with - | KEYWORD s -> add_keyword s - | _ -> ()); - Plexing.tok_removing = (fun _ -> ()); - Plexing.tok_match = Tok.match_pattern; - Plexing.tok_text = token_text } +module MakeLexer (Diff : sig val mode : bool end) = struct + type te = Tok.t + type 'c pattern = 'c Tok.p + let tok_pattern_eq = Tok.equal_p + let tok_pattern_strings = Tok.pattern_strings + let tok_func = func (next_token ~diff_mode:Diff.mode) + let tok_using : type c. c pattern -> unit = function + | PKEYWORD s -> add_keyword ~quotation:NoQuotation s + | PQUOTATION s -> add_keyword ~quotation:Quotation s + | _ -> () + let tok_removing = (fun _ -> ()) + let tok_match = Tok.match_pattern + let tok_text = token_text +end + +module Lexer = MakeLexer (struct let mode = false end) -let lexer = make_lexer ~diff_mode:false +module LexerDiff = MakeLexer (struct let mode = true end) (** Terminal symbols interpretation *) let is_ident_not_keyword s = is_ident s && not (is_keyword s) -let is_number s = - let rec aux i = - Int.equal (String.length s) i || - match s.[i] with '0'..'9' -> aux (i+1) | _ -> false - in aux 0 - let strip s = let len = let rec loop i len = @@ -811,6 +860,10 @@ let strip s = let terminal s = let s = strip s in let () = match s with "" -> failwith "empty token." | _ -> () in - if is_ident_not_keyword s then IDENT s - else if is_number s then INT s - else KEYWORD s + if is_ident_not_keyword s then PIDENT (Some s) + else PKEYWORD s + +(* Precondition: the input is a numeral (c.f. [NumTok.t]) *) +let terminal_numeral s = match NumTok.of_string s with + | Some n -> PNUMERAL (Some n) + | None -> failwith "numeral token expected." diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index af3fd7f318..464bcf614d 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -8,8 +8,32 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** When one registers a keyword she can declare it starts a quotation. + In particular using QUOTATION("name:") in a grammar rule + declares "name:" as a keyword and the token QUOTATION is + matched whenever the keyword is followed by an identifier or a + parenthesized text. Eg + + constr:x + string:[....] + ltac:(....) + ltac:{....} + + The delimiter is made of 1 or more occurrences of the same parenthesis, + eg ((.....)) or [[[[....]]]]. The idea being that if the text happens to + contain the closing delimiter, one can make the delimiter longer and avoid + confusion (no escaping). Eg + + string:[[ .. ']' .. ]] + + + Nesting the delimiter is allowed, eg ((..((...))..)) is OK. + + Keywords don't need to end in ':' *) +type starts_quotation = NoQuotation | Quotation + (** This should be functional but it is not due to the interface *) -val add_keyword : string -> unit +val add_keyword : ?quotation:starts_quotation -> string -> unit val remove_keyword : string -> unit val is_keyword : string -> bool val keywords : unit -> CString.Set.t @@ -21,26 +45,17 @@ val get_keyword_state : unit -> keyword_state val check_ident : string -> unit val is_ident : string -> bool val check_keyword : string -> unit -val terminal : string -> Tok.t -(** The lexer of Coq: *) +(** When string is not an ident, returns a keyword. *) +val terminal : string -> string Tok.p -(* modtype Grammar.GLexerType: sig - type te val - lexer : te Plexing.lexer - end +(** Precondition: the input is a numeral (c.f. [NumTok.t]) *) +val terminal_numeral : string -> NumTok.t Tok.p -where +(** The lexer of Coq: *) - type lexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list location) } - *) -include Gramlib.Grammar.GLexerType with type te = Tok.t +module Lexer : + Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p module Error : sig type t @@ -51,7 +66,7 @@ end (* Mainly for comments state, etc... *) type lexer_state -val init_lexer_state : Loc.source -> lexer_state +val init_lexer_state : unit -> lexer_state val set_lexer_state : lexer_state -> unit val get_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit @@ -66,4 +81,5 @@ as if it was unquoted, possibly becoming multiple tokens it was not in a comment, possibly becoming multiple tokens - return any unrecognized Ascii or UTF-8 character as a string *) -val make_lexer : diff_mode:bool -> Tok.t Gramlib.Plexing.lexer +module LexerDiff : + Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p diff --git a/parsing/dune b/parsing/dune index e91740650f..2bb8611e09 100644 --- a/parsing/dune +++ b/parsing/dune @@ -2,7 +2,7 @@ (name parsing) (public_name coq.parsing) (wrapped false) - (libraries coq.gramlib proofs)) + (libraries coq.gramlib interp)) (rule (targets g_prim.ml) diff --git a/parsing/extend.ml b/parsing/extend.ml index 9b5537d7f6..dd7c301dfb 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,7 +10,7 @@ (** Entry keys for constr notations *) -type 'a entry = 'a Gramlib.Grammar.GMake(CLexer).Entry.e +type 'a entry = 'a Gramlib.Grammar.GMake(CLexer.Lexer).Entry.e type side = Left | Right @@ -44,7 +44,7 @@ type simple_constr_prod_entry_key = (** Entries used in productions (in right-hand-side of grammar rules), to parse non-terminals *) -type binder_entry_kind = ETBinderOpen | ETBinderClosed of Tok.t list +type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list type binder_target = ForBinder | ForTerm @@ -54,7 +54,7 @@ type constr_prod_entry_key = | ETProdBigint (* Parsed as an (unbounded) integer *) | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) - | ETProdConstrList of (production_level * production_position) * Tok.t list (* Parsed as non-empty list of constr *) + | ETProdConstrList of (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr *) | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) (** {5 AST for user-provided entries} *) @@ -79,30 +79,34 @@ type ('a,'b,'c) ty_user_symbol = (** {5 Type-safe grammar extension} *) -type ('self, 'a) symbol = -| Atoken : Tok.t -> ('self, string) symbol -| Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol -| Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol -| Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol -| Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol -| Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol -| Aself : ('self, 'self) symbol -| Anext : ('self, 'self) symbol -| Aentry : 'a entry -> ('self, 'a) symbol -| Aentryl : 'a entry * string -> ('self, 'a) symbol -| Arules : 'a rules list -> ('self, 'a) symbol - -and ('self, _, 'r) rule = -| Stop : ('self, 'r, 'r) rule -| Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule - -and ('a, 'r) norec_rule = { norec_rule : 's. ('s, 'a, 'r) rule } +type norec = NoRec (* just two *) +type mayrec = MayRec (* incompatible types *) + +type ('self, 'trec, 'a) symbol = +| Atoken : 'c Tok.p -> ('self, norec, 'c) symbol +| Alist1 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol +| Alist1sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol + -> ('self, 'trec, 'a list) symbol +| Alist0 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol +| Alist0sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol + -> ('self, 'trec, 'a list) symbol +| Aopt : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a option) symbol +| Aself : ('self, mayrec, 'self) symbol +| Anext : ('self, mayrec, 'self) symbol +| Aentry : 'a entry -> ('self, norec, 'a) symbol +| Aentryl : 'a entry * string -> ('self, norec, 'a) symbol +| Arules : 'a rules list -> ('self, norec, 'a) symbol + +and ('self, 'trec, _, 'r) rule = +| Stop : ('self, norec, 'r, 'r) rule +| Next : ('self, _, 'a, 'r) rule * ('self, _, 'b) symbol -> ('self, mayrec, 'b -> 'a, 'r) rule +| NextNoRec : ('self, norec, 'a, 'r) rule * ('self, norec, 'b) symbol -> ('self, norec, 'b -> 'a, 'r) rule and 'a rules = -| Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules +| Rules : (_, norec, 'act, Loc.t -> 'a) rule * 'act -> 'a rules type 'a production_rule = -| Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule +| Rule : ('a, _, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule type 'a single_extend_statement = string option * diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 6f73a3e4ed..4a9190c10a 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -56,10 +56,10 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) : fix_expr = (id,ann,bl,ty,body) let mk_cofixb (id,bl,ann,body,(loc,tyc)) : cofix_expr = - let _ = Option.map (fun { CAst.loc = aloc } -> + Option.iter (fun { CAst.loc = aloc } -> CErrors.user_err ?loc:aloc ~hdr:"Constr:mk_cofixb" - (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in + (Pp.str"Annotation forbidden in cofix expression.")) ann; let ty = match tyc with Some ty -> ty | None -> CAst.make @@ CHole (None, IntroAnonymous, None) in @@ -226,7 +226,7 @@ GRAMMAR EXTEND Gram | c=match_constr -> { c } | "("; c = operconstr LEVEL "200"; ")" -> { (match c.CAst.v with - | CPrim (Numeral (n,true)) -> + | CPrim (Numeral (SPlus,n)) -> CAst.make ~loc @@ CNotation((InConstrEntrySomeLevel,"( _ )"),([c],[],[],[])) | _ -> c) } | "{|"; c = record_declaration; "|}" -> { c } @@ -305,7 +305,7 @@ GRAMMAR EXTEND Gram atomic_constr: [ [ g=global; i=instance -> { CAst.make ~loc @@ CRef (g,i) } | s=sort -> { CAst.make ~loc @@ CSort s } - | n=INT -> { CAst.make ~loc @@ CPrim (Numeral (n,true)) } + | n=NUMERAL-> { CAst.make ~loc @@ CPrim (Numeral (SPlus,n)) } | s=string -> { CAst.make ~loc @@ CPrim (String s) } | "_" -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } | "?"; "["; id=ident; "]" -> { CAst.make ~loc @@ CHole (None, IntroIdentifier id, None) } @@ -413,18 +413,18 @@ GRAMMAR EXTEND Gram | "_" -> { CAst.make ~loc @@ CPatAtom None } | "("; p = pattern LEVEL "200"; ")" -> { (match p.CAst.v with - | CPatPrim (Numeral (n,true)) -> + | CPatPrim (Numeral (SPlus,n)) -> CAst.make ~loc @@ CPatNotation((InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) | _ -> p) } | "("; p = pattern LEVEL "200"; ":"; ty = lconstr; ")" -> { let p = match p with - | { CAst.v = CPatPrim (Numeral (n,true)) } -> + | { CAst.v = CPatPrim (Numeral (SPlus,n)) } -> CAst.make ~loc @@ CPatNotation((InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) | _ -> p in CAst.make ~loc @@ CPatCast (p, ty) } - | n = INT -> { CAst.make ~loc @@ CPatPrim (Numeral (n,true)) } + | n = NUMERAL-> { CAst.make ~loc @@ CPatPrim (Numeral (SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPatPrim (String s) } ] ] ; impl_ident_tail: @@ -440,10 +440,10 @@ GRAMMAR EXTEND Gram ] ] ; fixannot: - [ [ "{"; IDENT "struct"; id=identref; "}" -> { (Some id, CStructRec) } - | "{"; IDENT "wf"; rel=constr; id=OPT identref; "}" -> { (id, CWfRec rel) } + [ [ "{"; IDENT "struct"; id=identref; "}" -> { CAst.make ~loc @@ CStructRec id } + | "{"; IDENT "wf"; rel=constr; id=identref; "}" -> { CAst.make ~loc @@ CWfRec(id,rel) } | "{"; IDENT "measure"; m=constr; id=OPT identref; - rel=OPT constr; "}" -> { (id, CMeasureRec (m,rel)) } + rel=OPT constr; "}" -> { CAst.make ~loc @@ CMeasureRec (id,m,rel) } ] ] ; impl_name_head: @@ -452,9 +452,9 @@ GRAMMAR EXTEND Gram binders_fixannot: [ [ na = impl_name_head; assum = impl_ident_tail; bl = binders_fixannot -> { (assum na :: fst bl), snd bl } - | f = fixannot -> { [], f } + | f = fixannot -> { [], Some f } | b = binder; bl = binders_fixannot -> { b @ fst bl, snd bl } - | -> { [], (None, CStructRec) } + | -> { [], None } ] ] ; open_binders: diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index 6247a12640..80dd997860 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -21,6 +21,10 @@ let _ = List.iter CLexer.add_keyword prim_kw let local_make_qualid loc l id = make_qualid ~loc (DirPath.make l) id +let check_int loc = function + | { NumTok.int = i; frac = ""; exp = "" } -> i + | _ -> CErrors.user_err ~loc (Pp.str "This number is not an integer.") + let my_int_of_string loc s = try int_of_string s @@ -110,13 +114,13 @@ GRAMMAR EXTEND Gram [ [ s = string -> { CAst.make ~loc s } ] ] ; integer: - [ [ i = INT -> { my_int_of_string loc i } - | "-"; i = INT -> { - my_int_of_string loc i } ] ] + [ [ i = NUMERAL -> { my_int_of_string loc (check_int loc i) } + | "-"; i = NUMERAL -> { - my_int_of_string loc (check_int loc i) } ] ] ; natural: - [ [ i = INT -> { my_int_of_string loc i } ] ] + [ [ i = NUMERAL -> { my_int_of_string loc (check_int loc i) } ] ] ; bigint: (* Negative numbers are dealt with elsewhere *) - [ [ i = INT -> { i } ] ] + [ [ i = NUMERAL -> { check_int loc i } ] ] ; END diff --git a/parsing/notation_gram.ml b/parsing/notation_gram.ml index fc5feba58b..6df0d6f21a 100644 --- a/parsing/notation_gram.ml +++ b/parsing/notation_gram.ml @@ -21,7 +21,7 @@ type level = Constrexpr.notation_entry * precedence * tolerability list * constr (* first argument is InCustomEntry s for custom entries *) type grammar_constr_prod_item = - | GramConstrTerminal of Tok.t + | GramConstrTerminal of string Tok.p | GramConstrNonTerminal of Extend.constr_prod_entry_key * Id.t option | GramConstrListMark of int * bool * int (* tells action rule to make a list of the n previous parsed items; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 759e60fbca..8f38e437b4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -17,7 +17,7 @@ open Gramlib (** The parser of Coq *) module G : sig - include Grammar.S with type te = Tok.t + include Grammar.S with type te = Tok.t and type 'c pattern = 'c Tok.p (* where Grammar.S @@ -59,7 +59,7 @@ module type S = type coq_parsable - val coq_parsable : ?file:Loc.source -> char Stream.t -> coq_parsable + val coq_parsable : ?loc:Loc.t -> char Stream.t -> coq_parsable val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -67,14 +67,14 @@ module type S = end with type 'a Entry.e = 'a Extend.entry = struct - include Grammar.GMake(CLexer) + include Grammar.GMake(CLexer.Lexer) type coq_parsable = parsable * CLexer.lexer_state ref - let coq_parsable ?(file=Loc.ToplevelInput) c = - let state = ref (CLexer.init_lexer_state file) in + let coq_parsable ?loc c = + let state = ref (CLexer.init_lexer_state ()) in CLexer.set_lexer_state !state; - let a = parsable c in + let a = parsable ?loc c in state := CLexer.get_lexer_state (); (a,state) @@ -107,7 +107,7 @@ end module Entry = struct - type 'a t = 'a Grammar.GMake(CLexer).Entry.e + type 'a t = 'a Grammar.GMake(CLexer.Lexer).Entry.e let create = G.Entry.create let parse = G.entry_parse @@ -118,30 +118,6 @@ struct end -module Symbols : sig - val stoken : Tok.t -> ('s, string) G.ty_symbol - val slist0sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol - val slist1sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol -end = struct - - let stoken tok = - let pattern = match tok with - | Tok.KEYWORD s -> "", s - | Tok.IDENT s -> "IDENT", s - | Tok.PATTERNIDENT s -> "PATTERNIDENT", s - | Tok.FIELD s -> "FIELD", s - | Tok.INT s -> "INT", s - | Tok.STRING s -> "STRING", s - | Tok.LEFTQMARK -> "LEFTQMARK", "" - | Tok.BULLET s -> "BULLET", s - | Tok.EOI -> "EOI", "" - in - G.s_token pattern - - let slist0sep x y = G.s_list0sep x y false - let slist1sep x y = G.s_list1sep x y false -end - (** Grammar extensions *) (** NB: [extend_statement = @@ -155,43 +131,73 @@ end (** Binding general entry keys to symbol *) -type ('s, 'a, 'r) casted_rule = Casted : ('s, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, 'a, 'r) casted_rule - -let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> (s, a) G.ty_symbol = function -| Atoken t -> Symbols.stoken t -| Alist1 s -> G.s_list1 (symbol_of_prod_entry_key s) +type ('s, 'trec, 'a, 'r) casted_rule = +| CastedRNo : ('s, G.ty_norec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, norec, 'a, 'r) casted_rule +| CastedRMay : ('s, G.ty_mayrec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, mayrec, 'a, 'r) casted_rule + +type ('s, 'trec, 'a) casted_symbol = +| CastedSNo : ('s, G.ty_norec, 'a) G.ty_symbol -> ('s, norec, 'a) casted_symbol +| CastedSMay : ('s, G.ty_mayrec, 'a) G.ty_symbol -> ('s, mayrec, 'a) casted_symbol + +let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) casted_symbol = +function +| Atoken t -> CastedSNo (G.s_token t) +| Alist1 s -> + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list1 s) + | CastedSMay s -> CastedSMay (G.s_list1 s) end | Alist1sep (s,sep) -> - Symbols.slist1sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) -| Alist0 s -> G.s_list0 (symbol_of_prod_entry_key s) + let CastedSNo sep = symbol_of_prod_entry_key sep in + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list1sep s sep false) + | CastedSMay s -> CastedSMay (G.s_list1sep s sep false) end +| Alist0 s -> + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list0 s) + | CastedSMay s -> CastedSMay (G.s_list0 s) end | Alist0sep (s,sep) -> - Symbols.slist0sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) -| Aopt s -> G.s_opt (symbol_of_prod_entry_key s) -| Aself -> G.s_self -| Anext -> G.s_next -| Aentry e -> G.s_nterm e -| Aentryl (e, n) -> G.s_nterml e n + let CastedSNo sep = symbol_of_prod_entry_key sep in + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list0sep s sep false) + | CastedSMay s -> CastedSMay (G.s_list0sep s sep false) end +| Aopt s -> + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_opt s) + | CastedSMay s -> CastedSMay (G.s_opt s) end +| Aself -> CastedSMay G.s_self +| Anext -> CastedSMay G.s_next +| Aentry e -> CastedSNo (G.s_nterm e) +| Aentryl (e, n) -> CastedSNo (G.s_nterml e n) | Arules rs -> let warning msg = Feedback.msg_warning Pp.(str msg) in - G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs) + CastedSNo (G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs)) -and symbol_of_rule : type s a r. (s, a, Loc.t -> r) Extend.rule -> (s, a, Loc.t -> r) casted_rule = function -| Stop -> Casted (G.r_stop, fun act loc -> act loc) +and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) casted_rule = function +| Stop -> CastedRNo (G.r_stop, fun act loc -> act loc) | Next (r, s) -> - let Casted (r, cast) = symbol_of_rule r in - Casted (G.r_next r (symbol_of_prod_entry_key s), (fun act x -> cast (act x))) - -and symbol_of_rules : type a. a Extend.rules -> a G.ty_production = function + begin match symbol_of_rule r, symbol_of_prod_entry_key s with + | CastedRNo (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) + | CastedRNo (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) + | CastedRMay (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) + | CastedRMay (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) end +| NextNoRec (r, s) -> + let CastedRNo (r, cast) = symbol_of_rule r in + let CastedSNo s = symbol_of_prod_entry_key s in + CastedRNo (G.r_next_norec r s, (fun act x -> cast (act x))) + +and symbol_of_rules : type a. a Extend.rules -> a G.ty_rules = function | Rules (r, act) -> - let Casted (symb, cast) = symbol_of_rule r.norec_rule in - G.production (symb, cast act) + let CastedRNo (symb, cast) = symbol_of_rule r in + G.rules (symb, cast act) (** FIXME: This is a hack around a deficient camlp5 API *) -type 'a any_production = AnyProduction : ('a, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production +type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function | Rule (toks, act) -> - let Casted (symb, cast) = symbol_of_rule toks in - AnyProduction (symb, cast act) + match symbol_of_rule toks with + | CastedRNo (symb, cast) -> AnyProduction (symb, cast act) + | CastedRMay (symb, cast) -> AnyProduction (symb, cast act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, assoc, List.map of_coq_production_rule rule) @@ -303,7 +309,7 @@ let make_rule r = [None, None, r] let eoi_entry en = let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (Symbols.stoken Tok.EOI) in + let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (G.s_token Tok.PEOI) in let act = fun _ x loc -> x in let warning msg = Feedback.msg_warning Pp.(str msg) in Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.production (symbs, act)]); @@ -320,8 +326,9 @@ let map_entry f en = (* Parse a string, does NOT check if the entire string was read (use eoi_entry) *) -let parse_string f x = - let strm = Stream.of_string x in Gram.entry_parse f (Gram.coq_parsable strm) +let parse_string f ?loc x = + let strm = Stream.of_string x in + Gram.entry_parse f (Gram.coq_parsable ?loc strm) type gram_universe = string @@ -439,8 +446,11 @@ module Module = let module_expr = Entry.create "module_expr" let module_type = Entry.create "module_type" end -let epsilon_value f e = - let r = G.production (G.r_next G.r_stop (symbol_of_prod_entry_key e), (fun x _ -> f x)) in +let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = + let r = + match symbol_of_prod_entry_key e with + | CastedSNo s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) + | CastedSMay s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in let warning msg = Feedback.msg_warning Pp.(str msg) in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 3203a25b46..3a57c14a3b 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -19,7 +19,7 @@ open Libnames module Parsable : sig type t - val make : ?file:Loc.source -> char Stream.t -> t + val make : ?loc:Loc.t -> char Stream.t -> t (* Get comment parsing information from the Lexer *) val comment_state : t -> ((int * int) * string) list end @@ -121,7 +121,7 @@ end (** Parse a string *) -val parse_string : 'a Entry.t -> string -> 'a +val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a val eoi_entry : 'a Entry.t -> 'a Entry.t val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t @@ -157,7 +157,7 @@ module Prim : val pattern_identref : lident Entry.t val base_ident : Id.t Entry.t val natural : int Entry.t - val bigint : Constrexpr.raw_natural_number Entry.t + val bigint : string Entry.t val integer : int Entry.t val string : string Entry.t val lstring : lstring Entry.t @@ -191,7 +191,7 @@ module Constr : val binder : local_binder_expr list Entry.t (* closed_binder or variable *) val binders : local_binder_expr list Entry.t (* list of binder *) val open_binders : local_binder_expr list Entry.t - val binders_fixannot : (local_binder_expr list * (lident option * recursion_order_expr)) Entry.t + val binders_fixannot : (local_binder_expr list * recursion_order_expr option) Entry.t val typeclass_constraint : (lname * bool * constr_expr) Entry.t val record_declaration : constr_expr Entry.t val appl_arg : (constr_expr * explicitation CAst.t option) Entry.t @@ -203,7 +203,7 @@ module Module : val module_type : module_ast Entry.t end -val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option +val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Extend.symbol -> 'self option (** {5 Extending the parser without synchronization} *) diff --git a/parsing/tok.ml b/parsing/tok.ml index 03825e350f..71e2d4aa80 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -12,28 +12,73 @@ let string_equal (s1 : string) s2 = s1 = s2 +type 'c p = + | PKEYWORD : string -> string p + | PPATTERNIDENT : string option -> string p + | PIDENT : string option -> string p + | PFIELD : string option -> string p + | PNUMERAL : NumTok.t option -> NumTok.t p + | PSTRING : string option -> string p + | PLEFTQMARK : unit p + | PBULLET : string option -> string p + | PQUOTATION : string -> string p + | PEOI : unit p + +let pattern_strings : type c. c p -> string * string option = + function + | PKEYWORD s -> "", Some s + | PPATTERNIDENT s -> "PATTERNIDENT", s + | PIDENT s -> "IDENT", s + | PFIELD s -> "FIELD", s + | PNUMERAL None -> "NUMERAL", None + | PNUMERAL (Some n) -> "NUMERAL", Some (NumTok.to_string n) + | PSTRING s -> "STRING", s + | PLEFTQMARK -> "LEFTQMARK", None + | PBULLET s -> "BULLET", s + | PQUOTATION lbl -> "QUOTATION", Some lbl + | PEOI -> "EOI", None + type t = | KEYWORD of string | PATTERNIDENT of string | IDENT of string | FIELD of string - | INT of string + | NUMERAL of NumTok.t | STRING of string | LEFTQMARK | BULLET of string + | QUOTATION of string * string | EOI +let equal_p (type a b) (t1 : a p) (t2 : b p) : (a, b) Util.eq option = + let streq s1 s2 = match s1, s2 with None, None -> true + | Some s1, Some s2 -> string_equal s1 s2 | _ -> false in + match t1, t2 with + | PKEYWORD s1, PKEYWORD s2 when string_equal s1 s2 -> Some Util.Refl + | PPATTERNIDENT s1, PPATTERNIDENT s2 when streq s1 s2 -> Some Util.Refl + | PIDENT s1, PIDENT s2 when streq s1 s2 -> Some Util.Refl + | PFIELD s1, PFIELD s2 when streq s1 s2 -> Some Util.Refl + | PNUMERAL None, PNUMERAL None -> Some Util.Refl + | PNUMERAL (Some n1), PNUMERAL (Some n2) when NumTok.equal n1 n2 -> Some Util.Refl + | PSTRING s1, PSTRING s2 when streq s1 s2 -> Some Util.Refl + | PLEFTQMARK, PLEFTQMARK -> Some Util.Refl + | PBULLET s1, PBULLET s2 when streq s1 s2 -> Some Util.Refl + | PQUOTATION s1, PQUOTATION s2 when string_equal s1 s2 -> Some Util.Refl + | PEOI, PEOI -> Some Util.Refl + | _ -> None + let equal t1 t2 = match t1, t2 with | IDENT s1, KEYWORD s2 -> string_equal s1 s2 | KEYWORD s1, KEYWORD s2 -> string_equal s1 s2 | PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2 | IDENT s1, IDENT s2 -> string_equal s1 s2 | FIELD s1, FIELD s2 -> string_equal s1 s2 -| INT s1, INT s2 -> string_equal s1 s2 +| NUMERAL n1, NUMERAL n2 -> NumTok.equal n1 n2 | STRING s1, STRING s2 -> string_equal s1 s2 | LEFTQMARK, LEFTQMARK -> true | BULLET s1, BULLET s2 -> string_equal s1 s2 | EOI, EOI -> true +| QUOTATION(s1,t1), QUOTATION(s2,t2) -> string_equal s1 s2 && string_equal t1 t2 | _ -> false let extract_string diff_mode = function @@ -55,68 +100,43 @@ let extract_string diff_mode = function else s | PATTERNIDENT s -> s | FIELD s -> if diff_mode then "." ^ s else s - | INT s -> s + | NUMERAL n -> NumTok.to_string n | LEFTQMARK -> "?" | BULLET s -> s + | QUOTATION(_,s) -> s | EOI -> "" -let to_string = function - | KEYWORD s -> Format.sprintf "%S" s - | IDENT s -> Format.sprintf "IDENT %S" s - | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s - | FIELD s -> Format.sprintf "FIELD %S" s - | INT s -> Format.sprintf "INT %s" s - | STRING s -> Format.sprintf "STRING %S" s - | LEFTQMARK -> "LEFTQMARK" - | BULLET s -> Format.sprintf "BULLET %S" s - | EOI -> "EOI" - -let match_keyword kwd = function - | KEYWORD kwd' when kwd = kwd' -> true - | _ -> false - -(* Needed to fix Camlp5 signature. - Cannot use Pp because of silly Tox -> Compat -> Pp dependency *) -let print ppf tok = Format.pp_print_string ppf (to_string tok) - -(** For camlp5, conversion from/to [Plexing.pattern], - and a match function analoguous to [Plexing.default_match] *) - -let of_pattern = function - | "", s -> KEYWORD s - | "IDENT", s -> IDENT s - | "PATTERNIDENT", s -> PATTERNIDENT s - | "FIELD", s -> FIELD s - | "INT", s -> INT s - | "STRING", s -> STRING s - | "LEFTQMARK", _ -> LEFTQMARK - | "BULLET", s -> BULLET s - | "EOI", _ -> EOI - | _ -> failwith "Tok.of_pattern: not a constructor" - -let to_pattern = function - | KEYWORD s -> "", s - | IDENT s -> "IDENT", s - | PATTERNIDENT s -> "PATTERNIDENT", s - | FIELD s -> "FIELD", s - | INT s -> "INT", s - | STRING s -> "STRING", s - | LEFTQMARK -> "LEFTQMARK", "" - | BULLET s -> "BULLET", s - | EOI -> "EOI", "" +(* Invariant, txt is "ident" or a well parenthesized "{{....}}" *) +let trim_quotation txt = + let len = String.length txt in + if len = 0 then None, txt + else + let c = txt.[0] in + if c = '(' || c = '[' || c = '{' then + let rec aux n = + if n < len && txt.[n] = c then aux (n+1) + else Some c, String.sub txt n (len - (2*n)) + in + aux 0 + else None, txt -let match_pattern = +let match_pattern (type c) (p : c p) : t -> c = let err () = raise Stream.Failure in - function - | "", "" -> (function KEYWORD s -> s | _ -> err ()) - | "IDENT", "" -> (function IDENT s -> s | _ -> err ()) - | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) - | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) - | "INT", "" -> (function INT s -> s | _ -> err ()) - | "STRING", "" -> (function STRING s -> s | _ -> err ()) - | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) - | "BULLET", "" -> (function BULLET s -> s | _ -> err ()) - | "EOI", "" -> (function EOI -> "" | _ -> err ()) - | pat -> - let tok = of_pattern pat in - function tok' -> if equal tok tok' then snd pat else err () + let seq = string_equal in + match p with + | PKEYWORD s -> (function KEYWORD s' when seq s s' -> s' | NUMERAL n when seq s (NumTok.to_string n) -> s | _ -> err ()) + | PIDENT None -> (function IDENT s' -> s' | _ -> err ()) + | PIDENT (Some s) -> (function (IDENT s' | KEYWORD s') when seq s s' -> s' | _ -> err ()) + | PPATTERNIDENT None -> (function PATTERNIDENT s -> s | _ -> err ()) + | PPATTERNIDENT (Some s) -> (function PATTERNIDENT s' when seq s s' -> s' | _ -> err ()) + | PFIELD None -> (function FIELD s -> s | _ -> err ()) + | PFIELD (Some s) -> (function FIELD s' when seq s s' -> s' | _ -> err ()) + | PNUMERAL None -> (function NUMERAL s -> s | _ -> err ()) + | PNUMERAL (Some n) -> let s = NumTok.to_string n in (function NUMERAL n' when s = NumTok.to_string n' -> n' | _ -> err ()) + | PSTRING None -> (function STRING s -> s | _ -> err ()) + | PSTRING (Some s) -> (function STRING s' when seq s s' -> s' | _ -> err ()) + | PLEFTQMARK -> (function LEFTQMARK -> () | _ -> err ()) + | PBULLET None -> (function BULLET s -> s | _ -> err ()) + | PBULLET (Some s) -> (function BULLET s' when seq s s' -> s' | _ -> err ()) + | PQUOTATION lbl -> (function QUOTATION(lbl',s') when string_equal lbl lbl' -> s' | _ -> err ()) + | PEOI -> (function EOI -> () | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index 5750096a28..a5fb5ad9cd 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -10,26 +10,45 @@ (** The type of token for the Coq lexer and parser *) +type 'c p = + | PKEYWORD : string -> string p + | PPATTERNIDENT : string option -> string p + | PIDENT : string option -> string p + | PFIELD : string option -> string p + | PNUMERAL : NumTok.t option -> NumTok.t p + | PSTRING : string option -> string p + | PLEFTQMARK : unit p + | PBULLET : string option -> string p + | PQUOTATION : string -> string p + | PEOI : unit p + +val pattern_strings : 'c p -> string * string option + type t = | KEYWORD of string | PATTERNIDENT of string | IDENT of string | FIELD of string - | INT of string + | NUMERAL of NumTok.t | STRING of string | LEFTQMARK | BULLET of string + | QUOTATION of string * string | EOI +val equal_p : 'a p -> 'b p -> ('a, 'b) Util.eq option + val equal : t -> t -> bool (* pass true for diff_mode *) val extract_string : bool -> t -> string -val to_string : t -> string -(* Needed to fit Camlp5 signature *) -val print : Format.formatter -> t -> unit -val match_keyword : string -> t -> bool - -(** for camlp5 *) -val of_pattern : string*string -> t -val to_pattern : t -> string*string -val match_pattern : string*string -> t -> string + +(** Utility function for the test returned by a QUOTATION token: + It returns the delimiter parenthesis, if any, and the text + without delimiters. Eg `{{{ text }}}` -> Some '{', ` text ` *) +val trim_quotation : string -> char option * string + +(** for camlp5, + eg GRAMMAR EXTEND ..... [ IDENT "x" -> .... END + is a pattern (PIDENT (Some "x")) +*) +val match_pattern : 'c p -> t -> 'c diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 978969bf59..5066c3931d 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -255,5 +255,3 @@ val find_contradiction : UF.t -> (Names.Id.t * (int * int)) list -> (Names.Id.t * (int * int)) *) - - diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 50fc2448fc..0e3b9fc2b6 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -67,7 +67,7 @@ let rec decompose_term env sigma t= let canon_mind = MutInd.make1 (MutInd.canonical mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in - let nargs=constructor_nallargs_env env (canon_ind,i_con) in + let nargs=constructor_nallargs env (canon_ind,i_con) in Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index afdbfa1999..4425e41652 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -101,8 +101,7 @@ let start_deriving f suchthat lemma = in let terminator = Proof_global.make_terminator terminator in - let () = Proof_global.start_dependent_proof lemma kind goals terminator in - let _ = Proof_global.with_current_proof begin fun _ p -> + let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in + fst @@ Proof_global.with_current_proof begin fun _ p -> Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p - end in - () + end pstate diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 06ff9c48cf..6bb923118e 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,4 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> unit +val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 0cdf8fb5d8..214a9d8bb5 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -23,6 +23,6 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac } VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } -| [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { Derive.start_deriving f suchthat lemma } +| ![ proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> + { fun ~pstate -> Some Derive.(start_deriving f suchthat lemma) } END diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 0fa9be21c9..8f17f7b2dd 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -750,16 +750,19 @@ let extract_and_compile l = Feedback.msg_notice (str "Extracted code successfully compiled") (* Show the extraction of the current ongoing proof *) - -let show_extraction () = +let show_extraction ~pstate = + let pstate = match pstate with + | None -> CErrors.user_err Pp.(str "No ongoing proof") + | Some pstate -> pstate + in init ~inner:true false false; - let prf = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in + let prf = Proof_global.give_me_the_proof pstate in + let sigma, env = Pfedit.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_current_proof_name ()) in + let l = Label.of_id (Proof_global.get_current_proof_name pstate) in let fake_ref = ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 54fde2ca46..7ba7e05019 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : unit -> unit +val show_extraction : pstate:Proof_global.t option -> unit diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index c9cfd74362..9db7c8d8d3 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -854,7 +854,7 @@ and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args = and extract_case env sg mle ((kn,i) as ip,c,br) mlt = (* [br]: bodies of each branch (in functional form) *) (* [ni]: number of arguments without parameters in each branch *) - let ni = constructors_nrealargs_env env ip in + let ni = constructors_nrealargs env ip in let br_size = Array.length br in assert (Int.equal (Array.length ni) br_size); if Int.equal br_size 0 then begin diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index 1445dffefa..d7bb27f121 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -178,6 +178,6 @@ END (* Show the extraction of the current proof *) VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY -| [ "Show" "Extraction" ] - -> { show_extraction () } +| ![ proof ] [ "Show" "Extraction" ] + -> { fun ~pstate -> let () = show_extraction ~pstate in pstate } END diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 56b3dc97cf..4b7bc707d6 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -82,13 +82,13 @@ let pop t = Vars.lift (-1) t let kind_of_formula env sigma term = let normalize = special_nf env sigma in let cciterm = special_whd env sigma term in - match match_with_imp_term sigma cciterm with + match match_with_imp_term env sigma cciterm with Some (a,b)-> Arrow (a, pop b) |_-> - match match_with_forall_term sigma cciterm with + match match_with_forall_term env sigma cciterm with Some (_,a,b)-> Forall (a, b) |_-> - match match_with_nodep_ind sigma cciterm with + match match_with_nodep_ind env sigma cciterm with Some (i,l,n)-> let ind,u=EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in @@ -111,7 +111,7 @@ let kind_of_formula env sigma term = else Or((ind,u),l,is_trivial) | _ -> - match match_with_sigma_type sigma cciterm with + match match_with_sigma_type env sigma cciterm with Some (i,l)-> let (ind, u) = EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 01b18e2f30..9f2ceb2c28 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -188,7 +188,7 @@ let empty_seq depth= let expand_constructor_hints = List.map_append (function | GlobRef.IndRef ind -> - List.init (Inductiveops.nconstructors ind) + List.init (Inductiveops.nconstructors (Global.env()) ind) (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> [gr]) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 16f376931e..287a374ab1 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -722,7 +722,7 @@ let build_proof (treat_new_case ptes_infos nb_instantiate_partial - (build_proof env sigma do_finalize) + (build_proof do_finalize) t dyn_infos) g' @@ -733,7 +733,7 @@ let build_proof ] g in - build_proof env sigma do_finalize_t {dyn_infos with info = t} g + build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin match EConstr.kind sigma (pf_concl g) with @@ -749,7 +749,7 @@ let build_proof in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = - build_proof env sigma do_finalize + build_proof do_finalize {new_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps @@ -762,7 +762,7 @@ let build_proof do_finalize dyn_infos g end | Cast(t,_,_) -> - build_proof env sigma do_finalize {dyn_infos with info = t} g + build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> do_finalize dyn_infos g | App(_,_) -> @@ -792,7 +792,7 @@ let build_proof | Lambda _ -> let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof env sigma do_finalize {dyn_infos with info = new_term} + build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> let new_infos = @@ -805,11 +805,11 @@ let build_proof h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof env sigma do_finalize new_infos + build_proof do_finalize new_infos ] g | Cast(b,_,_) -> - build_proof env sigma do_finalize {dyn_infos with info = b } g + build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> let new_finalize dyn_infos = let new_infos = @@ -819,7 +819,7 @@ let build_proof in build_proof_args env sigma do_finalize new_infos in - build_proof env sigma new_finalize {dyn_infos with info = f } g + build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) @@ -839,12 +839,12 @@ let build_proof (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof env sigma do_finalize new_infos + build_proof do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof env sigma do_finalize dyn_infos g = + and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ pr_leconstr_env (pf_env g) (project g) dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -866,7 +866,7 @@ let build_proof {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in - build_proof env sigma do_finalize + build_proof do_finalize {dyn_infos with info = arg } g in @@ -879,19 +879,7 @@ let build_proof in (* observe_tac "build_proof" *) fun g -> - let env = pf_env g in - let sigma = project g in - build_proof env sigma (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g - - - - - - - - - - + build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g (* Proof of principles from structural functions *) @@ -1002,19 +990,18 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - Lemmas.start_proof + let pstate = Lemmas.start_proof ~ontop:None (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) evd - lemma_type; - ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); - evd - - + lemma_type + in + let pstate,_ = Pfedit.by (Proofview.V82.tactic prove_replacement) pstate in + let pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + pstate, evd let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = @@ -1028,7 +1015,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + evd := snd @@ generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with | Option.IsNone -> diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1217ba0eba..e9a2c285d0 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -308,31 +308,30 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in - begin - Lemmas.start_proof + let pstate = + Lemmas.start_proof ~ontop:None new_princ_name (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (EConstr.of_constr new_principle_type) - ; - (* let _tim1 = System.get_time () in *) - let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams))); - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) + in + (* let _tim1 = System.get_time () in *) + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + let pstate,_ = Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) pstate in + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) - let open Proof_global in - let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in - match entries with - | [entry] -> - discard_current (); - (id,(entry,persistence)), hook - | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") - end + let open Proof_global in + let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pstate in + match entries with + | [entry] -> + let pstate = discard_current pstate in + (id,(entry,persistence)), hook, pstate + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof @@ -382,7 +381,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort InProp; register_with_sort InSet in - let ((id,(entry,g_kind)),hook) = + let ((id,(entry,g_kind)),hook,pstate) = build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in @@ -390,25 +389,9 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - save false new_princ_name entry ~hook uctx g_kind + save new_princ_name entry ~hook uctx g_kind with e when CErrors.noncritical e -> - begin - begin - try - let id = Proof_global.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Proof_global.discard_current () - else () - else () - with e when CErrors.noncritical e -> () - end; - raise (Defining_principle e) - end -(* defined () *) - + raise (Defining_principle e) exception Not_Rec @@ -537,7 +520,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ s::l_schemes -> s,l_schemes | _ -> anomaly (Pp.str "") in - let ((_,(const,_)),_) = + let ((_,(const,_)),_,pstate) = try build_functional_principle evd false first_type @@ -547,21 +530,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ _ _ _ -> ()) with e when CErrors.noncritical e -> - begin - begin - try - let id = Proof_global.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Proof_global.discard_current () - else () - else () - with e when CErrors.noncritical e -> () - end; - raise (Defining_principle e) - end + raise (Defining_principle e) in incr i; @@ -611,7 +580,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let ((_,(const,_)),_) = + let ((_,(const,_)),_,pstate) = build_functional_principle evd false diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 6f67ab4d8b..a3973732ad 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -177,10 +177,12 @@ let () = (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function -| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function - | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true - | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in + | _,((_,(Some { CAst.v = CMeasureRec _ } + | Some { CAst.v = CWfRec _}),_,_,_),_) -> true + | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) + | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) @@ -223,37 +225,34 @@ let warning_error names e = } VERNAC COMMAND EXTEND NewFunctionalScheme -| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] +| ![ proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - { + { fun ~pstate -> begin - try - Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - begin - match fas with - | (_,fun_name,_)::_ -> - begin - begin - make_graph (Smartlocate.global_with_alias fun_name) - end - ; - try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - CErrors.user_err Pp.(str "Cannot generate induction principle(s)") - | e when CErrors.noncritical e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e - - end + try + Functional_principles_types.build_scheme fas; pstate + with + | Functional_principles_types.No_graph_found -> + begin + match fas with + | (_,fun_name,_)::_ -> + begin + let pstate = make_graph ~pstate (Smartlocate.global_with_alias fun_name) in + try Functional_principles_types.build_scheme fas; pstate + with + | Functional_principles_types.No_graph_found -> + CErrors.user_err Pp.(str "Cannot generate induction principle(s)") + | e when CErrors.noncritical e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e; pstate + end | _ -> assert false (* we can only have non empty list *) - end - | e when CErrors.noncritical e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e + end + | e when CErrors.noncritical e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e; pstate end - } END (***** debug only ***) @@ -266,5 +265,6 @@ END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -| ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } +| ![ proof ] ["Generate" "graph" "for" reference(c)] -> + { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index f4807954a7..45a4e61846 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -317,7 +317,7 @@ let build_constructors_of_type ind' argl = Impargs.implicits_of_global constructref in let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) construct in @@ -330,7 +330,7 @@ let build_constructors_of_type ind' argl = let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) in - cases_pattern_of_glob_constr Anonymous pat_as_term + cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term ) ind.Declarations.mind_consnames @@ -369,7 +369,7 @@ let add_pat_variables sigma pat typ env : Environ.env = let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in - let new_env = add_pat_variables env pat typ in + let new_env = add_pat_variables env pat typ in let res = fst ( Context.Rel.fold_outside @@ -415,7 +415,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) constr in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 13ff19a46b..7b758da8e8 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -361,7 +361,7 @@ let rec pattern_to_term pt = DAst.with_val (function mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) constr in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index b69ca7080c..6494e90a03 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -382,8 +382,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let _ = List.map_i (fun i x -> - let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in - let env = Global.env () in + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn,i) (InProp) in let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in @@ -410,11 +410,11 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error with e when CErrors.noncritical e -> on_error names e -let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = +let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition + ComDefinition.do_definition ~ontop:pstate ~program_mode:false fname (Decl_kinds.Global,false,Decl_kinds.Definition) pl @@ -432,9 +432,9 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - evd,List.rev rev_pconstants + pstate, evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global false fixpoint_exprl; + let pstate = ComFixpoint.do_fixpoint ~ontop:pstate Global false fixpoint_exprl in let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> @@ -448,8 +448,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - evd,List.rev rev_pconstants - + pstate,evd,List.rev rev_pconstants + let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -469,11 +469,6 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas CAst.(with_val (fun x -> x)) (Constrexpr_ops.names_of_local_assums args) in - match wf_arg with - | None -> - if Int.equal (List.length names) 1 then 1 - else error "Recursive argument must be specified" - | Some wf_arg -> List.index Name.equal (Name wf_arg) names in let unbounded_eq = @@ -575,7 +570,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas in wf_rel_with_mes,false in - register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) + register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body let map_option f = function @@ -623,27 +618,27 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let fixl,ntns = ComFixpoint.extract_fixpoint_components ~structonly:false fixpoint_exprl in let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = - List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> + List.map2 (fun ((lna,rec_order_opt,bl,ret_typ,opt_body),notation_list) fix_typ -> let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in - (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + (((lna,rec_order_opt,new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl -let do_generate_principle pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = +let do_generate_principle ~pstate pconstants on_error register_built interactive_proof + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; - let _is_struct = + let pstate, _is_struct = match fixpoint_exprl with - | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -665,9 +660,9 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; - false - |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + then register_wf name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false + else pstate, false + |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -689,12 +684,12 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; - true + then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true + else pstate, true | _ -> - List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> + List.iter (function ((_na,ord,_args,_body,_type),_not) -> match ord with - | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () @@ -707,10 +702,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let evd,pconstants = + let pstate,evd,pconstants = if register_built - then register_struct is_rec fixpoint_exprl - else (Evd.from_env (Global.env ()),pconstants) + then register_struct ~pstate is_rec fixpoint_exprl + else pstate, Evd.from_env (Global.env ()), pconstants in let evd = ref evd in generate_principle @@ -723,10 +718,11 @@ let do_generate_principle pconstants on_error register_built interactive_proof recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then begin derive_inversion fix_names; end; - true; + if register_built then + begin derive_inversion fix_names; end; + pstate, true in - () + pstate let rec add_args id new_args = CAst.map (function | CRef (qid,_) as b -> @@ -843,13 +839,14 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph (f_ref : GlobRef.t) = +let make_graph ~pstate (f_ref : GlobRef.t) = + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in let c,c_body = match f_ref with | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - let sigma, env = Pfedit.get_current_context () in raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) end | _ -> raise (UserError (None, str "Not a function reference") ) @@ -857,8 +854,7 @@ let make_graph (f_ref : GlobRef.t) = (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom!" | Some (body, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in + let env = Global.env () in let extern_body,extern_type = with_full_print (fun () -> (Constrextern.extern_constr false env sigma (EConstr.of_constr body), @@ -868,46 +864,49 @@ let make_graph (f_ref : GlobRef.t) = ) () in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let { CAst.loc; v=rec_id } = Option.get n in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - ((((id,None), ( Some CAst.(make rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) - ) - fixexprl - in - l + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) + in + let b' = add_args id.CAst.v new_args b in + ((((id,None), ( Some (CAst.make (CStructRec (CAst.make rec_id)))),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ) + fixexprl + in + l | _ -> let id = Label.to_id (Constant.label c) in - [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [((CAst.make id,None),None,nal_tas,t,Some b),[]] in let mp = Constant.modpath c in - do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; + let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in (* We register the infos *) List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + expr_list; + pstate) let do_generate_principle = do_generate_principle [] warning_error true - - diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index f209fb19fd..acf85f539e 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -5,18 +5,16 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle : - bool -> - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - unit - +val do_generate_principle : pstate:Proof_global.t option -> + bool -> + (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> + Proof_global.t option -val functional_induction : +val functional_induction : bool -> EConstr.constr -> (EConstr.constr * EConstr.constr bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma - -val make_graph : GlobRef.t -> unit +val make_graph : pstate:Proof_global.t option -> GlobRef.t -> Proof_global.t option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index e34323abf4..40f66ce5eb 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -129,7 +129,7 @@ let get_locality = function | Local -> true | Global -> false -let save with_clean id const ?hook uctx (locality,_,kind) = +let save id const ?hook uctx (locality,_,kind) = let fix_exn = Future.fix_exn_of const.const_entry_body in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> @@ -143,7 +143,6 @@ let save with_clean id const ?hook uctx (locality,_,kind) = let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in - if with_clean then Proof_global.discard_current (); Lemmas.call_hook ?hook ~fix_exn uctx [] l r; definition_message id diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 12facc5744..9670cf1fa7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -43,8 +43,7 @@ val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr val save - : bool - -> Id.t + : Id.t -> Safe_typing.private_constants Entries.definition_entry -> ?hook:Lemmas.declaration_hook -> UState.t @@ -78,15 +77,12 @@ val find_Function_infos : Constant.t -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit - val update_Function : function_info -> unit - (** debugging *) val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t val pr_table : Environ.env -> Evd.evar_map -> Pp.t - (* val function_debug : bool ref *) val do_observe : unit -> bool val do_rewrite_dependent : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 37dbfec4c9..edb698280f 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -802,16 +802,16 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - Lemmas.start_proof + let (typ,_) = lemmas_types_infos.(i) in + let pstate = Lemmas.start_proof ~ontop:None lem_id (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd - typ; - ignore (Pfedit.by + typ in + let pstate = fst @@ Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i)))); - (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); + (proving_tac i))) pstate in + let _ = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global @@ -865,13 +865,13 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - Lemmas.start_proof lem_id + let pstate = Lemmas.start_proof ~ontop:None lem_id (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma - (fst lemmas_types_infos.(i)); - ignore (Pfedit.by + (fst lemmas_types_infos.(i)) in + let pstate = fst (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i)))) ; - (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); + (proving_tac i))) pstate) in + let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index e19741a4e9..3c2b03dfe0 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -72,7 +72,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Proof_global.Transparent,None))) +let defined pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None let def_of_const t = match (Constr.kind t) with @@ -228,6 +228,7 @@ let observe strm = let do_observe_tac s tac g = let goal = Printer.pr_goal g in + let s = s (pf_env g) (project g) in let lmsg = (str "recdef : ") ++ s in observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; @@ -252,8 +253,8 @@ let observe_tclTHENLIST s tacl = then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (s ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (s ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl @@ -268,11 +269,11 @@ let tclUSER tac is_mes l g = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l) in - observe_tclTHENLIST (str "tclUSER1") + observe_tclTHENLIST (fun _ _ -> str "tclUSER1") [ clear_tac; if is_mes - then observe_tclTHENLIST (str "tclUSER2") + then observe_tclTHENLIST (fun _ _ -> str "tclUSER2") [ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force Indfun_common.ltof_ref))]); @@ -394,12 +395,12 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) [] rev_context in let rev_ids = pf_get_new_ids (List.rev ids) g in let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (str "treat_case1") + observe_tclTHENLIST (fun _ _ -> str "treat_case1") [ h_intros (List.rev rev_ids); Proofview.V82.of_tactic (intro_using teq_id); onLastHypId (fun heq -> - observe_tclTHENLIST (str "treat_case2")[ + observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> @@ -426,6 +427,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = let sigma = project g in + let env = pf_env g in match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") | Proj _ -> user_err Pp.(str "Function cannot treat projections") @@ -441,18 +443,18 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | Prod _ -> begin try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -480,8 +482,8 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> @@ -503,10 +505,9 @@ and travel_args jinfo is_final continuation_tac infos = travel jinfo new_continuation_tac {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = - fun g -> observe_tac - (str jinfo.message ++ Printer.pr_leconstr_env (pf_env g) (project g) expr_info.info) - (travel_aux jinfo continuation_tac expr_info) g + (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) + (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -527,16 +528,16 @@ let rec prove_lt hyple g = in let y = List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in - observe_tclTHENLIST (str "prove_lt1")[ + observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (str "prove_lt") (prove_lt hyple) + observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( - observe_tclTHENLIST (str "prove_lt2")[ + observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) + (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) end @@ -552,26 +553,26 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = let h' = next_ident_away_in_goal (h'_id) ids in let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (str "destruct_bounds_aux1")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin - observe_tac (str "destruct_bounds_aux") + observe_tac (fun _ _ -> str "destruct_bounds_aux") (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ - observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); + observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (str "destruct_bounds_aux2")[ - observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ + observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); h_intros [k;h';def]; - observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (str "unfold functional") + observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); + observe_tac (fun _ _ -> str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference infos.func)])); ( - observe_tclTHENLIST (str "test")[ + observe_tclTHENLIST (fun _ _ -> str "test")[ list_rewrite true (List.fold_right (fun e acc -> (mkVar e,true)::acc) @@ -582,16 +583,16 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) (* ; *) - (observe_tac (str "finishing") + (observe_tac (fun _ _ -> str "finishing") (tclORELSE (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (str "calling prove_lt") (prove_lt hyple))))]) + (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) ] ] )end)) ] g | (_,v_bound)::l -> - observe_tclTHENLIST (str "destruct_bounds_aux3")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); @@ -599,7 +600,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p_hyp -> (onNthHypId 2 (fun p -> - observe_tclTHENLIST (str "destruct_bounds_aux4")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -623,32 +624,33 @@ let destruct_bounds infos = let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app1")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ continuation_tac infos; - observe_tac (str "first split") + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) + observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_others")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ continuation_tac infos; - observe_tac (str "first split") + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (str "destruct_bounds") (destruct_bounds infos) + observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos let terminate_letin (na,b,t,e) expr_info continuation_tac info g = let sigma = project g in + let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -693,7 +695,7 @@ let mkDestructEq : let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (str "mkDestructEq") + observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars env sigma = @@ -705,9 +707,10 @@ let mkDestructEq : let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in + let env = pf_env g in let f_is_present = try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -721,45 +724,46 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') + observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS destruct_tac - (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) + (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) + (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) )) g let terminate_app_rec (f,args) expr_info continuation_tac _ g = let sigma = project g in - List.iter (check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids)) + let env = pf_env g in + List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (str "terminate_app_rec")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app_rec1")[ - observe_tac (str "first split") + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (str "destruct_bounds (3)") + observe_tac (fun _ _ -> str "destruct_bounds (3)") (destruct_bounds new_infos) ] else tclIDTAC ] g with Not_found -> - observe_tac (str "terminate_app_rec not found") (tclTHENS + observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) [ - observe_tclTHENLIST (str "terminate_app_rec2")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); Proofview.V82.of_tactic intro; onNthHypId 1 @@ -772,14 +776,14 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = (v,v_bound)::expr_info.values_and_bounds; args_assoc=(args,mkVar v)::expr_info.args_assoc } in - observe_tclTHENLIST (str "terminate_app_rec3")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app_rec4")[ - observe_tac (str "first split") + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (str "destruct_bounds (2)") + observe_tac (fun _ _ -> str "destruct_bounds (2)") (destruct_bounds new_infos) ] else @@ -789,12 +793,12 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = ) ) ]; - observe_tac (str "proving decreasing") ( + observe_tac (fun _ _ -> str "proving decreasing") ( tclTHENS (* proof of args < formal args *) (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) [ - observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (str "terminate_app_rec5") + observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") [ tclTRY(list_rewrite true (List.map @@ -830,7 +834,7 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) + observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in @@ -856,9 +860,9 @@ let rec prove_le g = let _,args = decompose_app sigma t in List.hd (List.tl args) in - observe_tclTHENLIST (str "prove_le")[ + observe_tclTHENLIST (fun _ _ -> str "prove_le")[ Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (str "prove_le (rec)") (prove_le) + observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) end; @@ -868,8 +872,8 @@ let rec prove_le g = let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC | (_,p,hp)::l -> - observe_tac (str "make_rewrite_list") (tclTHENS - (observe_tac (str "rewrite heq on " ++ Id.print p ) ( + observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS + (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( (fun g -> let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in @@ -886,16 +890,16 @@ let rec make_rewrite_list expr_info max = function CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; - observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) + observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (str "prove_le(2)") prove_le + observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ] ) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (str "make_rewrite") (tclTHENS + (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) + (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS (fun g -> let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in @@ -905,30 +909,30 @@ let make_rewrite expr_info l hp max = let def_na,_,_ = destProd sigma t in Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name in - observe_tac (str "general_rewrite_bindings") + observe_tac (fun _ _ -> str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(str "make_rewrite finalize") ( + [observe_tac(fun _ _ -> str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (str "make_rewrite")[ + (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (str "unfold functional") + observe_tac (fun _ _ -> str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference expr_info.func)])); (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (str "h_reflexivity") + (observe_tac (fun _ _ -> str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity) ) ])) ; - observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) + observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (str "prove_le (3)") prove_le + observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ]) ) @@ -937,7 +941,7 @@ let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_,p,_)::l -> - observe_tclTHENLIST (str "compute_max")[ + observe_tclTHENLIST (fun _ _ -> str "compute_max")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| max; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -954,17 +958,17 @@ let rec destruct_hex expr_info acc l = match List.rev acc with | [] -> tclIDTAC | (_,p,hp)::tl -> - observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) + observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end | (v,hex)::l -> - observe_tclTHENLIST (str "destruct_hex")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ Proofview.V82.of_tactic (simplest_case (mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> observe_tac - (str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) + (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v,p,hp)::acc) l) ) ) @@ -972,7 +976,7 @@ let rec destruct_hex expr_info acc l = let rec intros_values_eq expr_info acc = tclORELSE( - observe_tclTHENLIST (str "intros_values_eq")[ + observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hex -> (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) @@ -983,23 +987,17 @@ let rec intros_values_eq expr_info acc = )) let equation_others _ expr_info continuation_tac infos = - fun g -> - let env = pf_env g in - let sigma = project g in if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) + observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (fun g -> - let env = pf_env g in - let sigma = project g in - observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []) g)) g - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) g + (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) + then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos let equation_app_rec (f,args) expr_info continuation_tac info g = @@ -1008,19 +1006,19 @@ let equation_app_rec (f,args) expr_info continuation_tac info g = try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tac (str "app_rec found") (continuation_tac new_infos) g + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g with Not_found -> if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "equation_app_rec") + observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) + observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] g else - observe_tclTHENLIST (str "equation_app_rec1")[ + observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) + observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] g end @@ -1104,7 +1102,7 @@ let termination_proof_header is_mes input_type ids args_id relation (h_intros args_id) (tclTHENS (observe_tac - (str "first assert") + (fun _ _ -> str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) (mkApp (delayed_force acc_rel, @@ -1116,7 +1114,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* accesibility proof *) tclTHENS (observe_tac - (str "second assert") + (fun _ _ -> str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) @@ -1124,26 +1122,26 @@ let termination_proof_header is_mes input_type ids args_id relation ) [ (* interactive proof that the relation is well_founded *) - observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id)); + observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) observe_tac - (str "apply wf_thm") + (fun _ _ -> str "apply wf_thm") (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; (* rest of the proof *) - observe_tclTHENLIST (str "rest of proof") - [observe_tac (str "generalize") + observe_tclTHENLIST (fun _ _ -> str "rest of proof") + [observe_tac (fun _ _ -> str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; - observe_tac (str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); + observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); h_intros args_id; Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) + observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ] ) g @@ -1222,8 +1220,8 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a g end -let get_current_subgoals_types () = - let p = Proof_global.give_me_the_proof () in +let get_current_subgoals_types pstate = + let p = Proof_global.give_me_the_proof pstate in let sgs,_,_,_,sigma = Proof.proof p in sigma, List.map (Goal.V82.abstract_type sigma) sgs @@ -1283,8 +1281,8 @@ let clear_goals sigma = List.map clear_goal -let build_new_goal_type () = - let sigma, sub_gls_types = get_current_subgoals_types () in +let build_new_goal_type pstate = + let sigma, sub_gls_types = get_current_subgoals_types pstate in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) @@ -1299,9 +1297,9 @@ let is_opaque_constant c = | Declarations.Def _ -> Proof_global.Transparent | Declarations.Primitive _ -> Proof_global.Opaque -let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Proof_global.get_current_proof_name () in + let current_proof_name = Proof_global.get_current_proof_name pstate in let name = match goal_name with | Some s -> s | None -> @@ -1325,11 +1323,10 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in - Proof_global.discard_all (); - build_proof (Evd.from_env env) + let pstate = build_proof env (Evd.from_env env) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - observe_tclTHENLIST (str "") + observe_tclTHENLIST (fun _ _ -> str "") [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); @@ -1353,7 +1350,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; - (observe_tac (str "finishing using") + (observe_tac (fun _ _ -> str "finishing using") ( tclCOMPLETE( tclFIRST[ @@ -1369,20 +1366,19 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ) ) g) -; - Lemmas.save_proof (Vernacexpr.Proved(opacity,None)); + in + let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None in + () in - Lemmas.start_proof + let pstate = Lemmas.start_proof ~ontop:(Some pstate) na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) - sigma gls_type - ~hook:(Lemmas.mk_hook hook); - if Indfun_common.is_strict_tcc () + sigma gls_type ~hook:(Lemmas.mk_hook hook) in + let pstate = if Indfun_common.is_strict_tcc () then - ignore (by (Proofview.V82.tactic (tclIDTAC))) + fst @@ by (Proofview.V82.tactic (tclIDTAC)) pstate else - begin - ignore (by (Proofview.V82.tactic begin + fst @@ by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) @@ -1398,14 +1394,12 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ) using_lemmas) ) tclIDTAC) - g end)) - end; + g end) pstate + in try - ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *) + Some (fst @@ by (Proofview.V82.tactic tclIDTAC) pstate) (* raises UserError _ if the proof is complete *) with UserError _ -> - defined () - - + defined pstate let com_terminate tcc_lemma_name @@ -1418,32 +1412,26 @@ let com_terminate thm_name using_lemmas nb_args ctx hook = - let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evd, env = Pfedit.get_current_context () in (* XXX *) - Lemmas.start_proof thm_name + let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = + let pstate = Lemmas.start_proof ~ontop:None thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook; - - ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); - ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num )))) + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook in + let pstate = fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) pstate in + fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num ))) pstate in - start_proof ctx tclIDTAC tclIDTAC; + let pstate = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in try - let sigma, new_goal_type = build_new_goal_type () in + let sigma, new_goal_type = build_new_goal_type pstate in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal start_proof sigma + open_new_goal pstate start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) - (new_goal_type); + (new_goal_type) with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - defined () - - - - + defined pstate let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1453,33 +1441,27 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) let terminate_constr = EConstr.of_constr terminate_constr in let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in - observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ + observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (str "simplest_case") + observe_tac (fun _ _ -> str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); - observe_tac (str "prove_eq") (cont_tactic x)]) g;; + observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; -let (com_eqn : int -> Id.t -> - GlobRef.t -> GlobRef.t -> GlobRef.t - -> Constr.t -> unit) = - fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> +let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = let open CVars in let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let evd, env = Pfedit.get_current_context () in (* XXX *) - let evd = Evd.from_ctx (Evd.evar_universe_context evd) in + let evd = Evd.from_ctx uctx in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - (Lemmas.start_proof eq_name (Global, false, Proof Lemma) - ~sign:(Environ.named_context_val env) - evd - (EConstr.of_constr equation_lemma_type); - ignore (by + let pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd + (EConstr.of_constr equation_lemma_type) in + let pstate = fst @@ by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) @@ -1506,15 +1488,16 @@ let (com_eqn : int -> Id.t -> ih = Id.of_string "______"; } ) - ))); + )) pstate in (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; -(* Pp.msgnl (str "eqn finished"); *) - );; + let _ = Flags.silently (fun () -> Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None) () in + () +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : unit = + generate_induction_principle using_lemmas : Proof_global.t option = let open Term in let open Constr in let open CVars in @@ -1529,15 +1512,15 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) -(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) +(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) +(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) @@ -1562,14 +1545,16 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in - (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ _ _ = + (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) + let hook uctx _ _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in (* message "start second proof"; *) - let stop = - try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + let stop = + (* XXX: What is the correct way to get sign at hook time *) + let sign = Environ.named_context_val Global.(env ()) in + try com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> begin @@ -1601,14 +1586,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num in (* XXX STATE Why do we need this... why is the toplevel protection not enought *) funind_purify (fun () -> - com_terminate - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref - (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (Lemmas.mk_hook hook)) - () + let pstate = com_terminate + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + (EConstr.of_constr rec_arg_type) + relation rec_arg_num + term_id + using_lemmas + (List.length res_vars) + evd (Lemmas.mk_hook hook) + in pstate) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 549f1fc0e4..a006c2c354 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,6 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> unit + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.t option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0428f08138..f5098d2a34 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -53,6 +53,7 @@ let with_delayed_uconstr ist c tac = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -348,6 +349,7 @@ let constr_flags () = { Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } let refine_tac ist simple with_classes c = @@ -813,9 +815,9 @@ END TACTIC EXTEND transparent_abstract | [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> - Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end; } | [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> - Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end; } END (* ********************************************************************* *) @@ -913,9 +915,9 @@ END the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -| [ "Grab" "Existential" "Variables" ] +| ![ proof ] [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p)) pstate } END (* Shelves all the goals under focus. *) @@ -945,9 +947,9 @@ END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve -| [ "Unshelve" ] +| ![ proof ] [ "Unshelve" ] => { classify_as_proofstep } - -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p)) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1098,8 +1100,8 @@ END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { Proof_global.compact_the_proof () } +| ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> + { fun ~pstate -> Option.map Proof_global.compact_the_proof pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 3a4b0571d4..523c7c8305 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -58,6 +58,7 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let map c env sigma = c env sigma in List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 3f2fabeeee..049a699cbd 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -84,7 +84,7 @@ TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d l } | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { - typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] } + typeclasses_eauto ~only_classes:true ~depth:d [Class_tactics.typeclasses_db] } END TACTIC EXTEND head_of_constr diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index a348e2cea4..7eb34158e8 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -374,20 +374,21 @@ let () = declare_int_option { optwrite = fun n -> print_info_trace := n; } -let vernac_solve n info tcom b = +let vernac_solve ~pstate n info tcom b = let open Goal_select in - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Feedback.feedback Feedback.AddedAxiom + let pstate, status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + Some pstate let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s @@ -434,12 +435,12 @@ let is_explicit_terminator = function TacSolve _ -> true | _ -> false } VERNAC { tactic_mode } EXTEND VernacSolve -| [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| ![ proof ] [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in - vernac_solve g n t def + Vernacentries.vernac_require_open_proof vernac_solve g n t def } -| [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| ![ proof ] [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { let anon_abstracting_tac = is_anonymous_abstract t in let solving_tac = is_explicit_terminator t in @@ -449,7 +450,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve VtLater } -> { let t = rm_abstract t in - vernac_solve Goal_select.SelectAll n t def + Vernacentries.vernac_require_open_proof vernac_solve Goal_select.SelectAll n t def } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index a12dee48a8..de3a9c9fa9 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -80,25 +80,25 @@ GRAMMAR EXTEND Gram open Obligations -let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac -let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac +let obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.obligation ~ontop:pstate obl t) tac) +let next_obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.next_obligation ~ontop:pstate obl t) tac) let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) } VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| [ "Obligation" integer(num) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) withtac(tac) ] -> { obligation (num, None, None) tac } -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> +| ![ proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } -| [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } +| ![ proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 86a227415a..469551809c 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -180,34 +180,34 @@ TACTIC EXTEND setoid_rewrite END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts a aeq n None None None } END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None None (Some lemma3) } END @@ -234,64 +234,64 @@ GRAMMAR EXTEND Gram END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None None } END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } END VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { - add_setoid atts [] a aeq t n; + add_setoid atts [] a aeq t n } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { - add_setoid atts binders a aeq t n; + add_setoid atts binders a aeq t n } - | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => { VtUnknown, VtNow } -> { - add_morphism_infer atts m n; + add_morphism_infer atts m n } - | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { - add_morphism atts [] m s n; + add_morphism atts [] m s n } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { - add_morphism atts binders m s n; + add_morphism atts binders m s n } END @@ -310,7 +310,12 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY -| [ "Print" "Rewrite" "HintDb" preident(s) ] -> - { let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) } +| ![ proof ] [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { (* This command should not use the proof env, keeping previous + behavior as requested in review. *) + fun ~pstate -> + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s); + pstate } END diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 7bf705ffeb..a2dd51643b 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -72,7 +72,7 @@ let test_lpar_idnum_coloneq = match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with - | IDENT _ | INT _ -> + | IDENT _ | NUMERAL _ -> (match stream_nth 2 strm with | KEYWORD ":=" -> () | _ -> err ()) @@ -147,7 +147,8 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with end | _ -> ElimOnConstr clbind -let mkNumeral n = Numeral (string_of_int (abs n), 0<=n) +let mkNumeral n = + Numeral ((if 0<=n then SPlus else SMinus),NumTok.int (string_of_int (abs n))) let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 1bdba699f7..80070a7493 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1307,7 +1307,6 @@ let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) - let pr_glob_constr_pptac env sigma c = pr_glob_constr_env env c diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index b1d5c0252f..2d40ba6562 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -119,7 +119,7 @@ let app_poly_check env evars f args = (evars, cstrs), t let app_poly_nocheck env evars f args = - let evars, fc = f evars in + let evars, fc = f evars in evars, mkApp (fc, args) let app_poly_sort b = @@ -175,25 +175,29 @@ end) = struct let rewrite_relation_class = find_global relation_classes "RewriteRelation" - let proper_class = lazy (class_info (find_reference morphisms "Proper")) - let proper_proxy_class = lazy (class_info (find_reference morphisms "ProperProxy")) - - let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - - let proper_type = - let l = lazy (Lazy.force proper_class).cl_impl in - fun (evd,cstrs) -> - let (evd, c) = Evarutil.new_global evd (Lazy.force l) in - (evd, cstrs), c - - let proper_proxy_type = - let l = lazy (Lazy.force proper_proxy_class).cl_impl in - fun (evd,cstrs) -> - let (evd, c) = Evarutil.new_global evd (Lazy.force l) in - (evd, cstrs), c + let proper_class = + let r = lazy (find_reference morphisms "Proper") in + fun env sigma -> class_info env sigma (Lazy.force r) + + let proper_proxy_class = + let r = lazy (find_reference morphisms "ProperProxy") in + fun env sigma -> class_info env sigma (Lazy.force r) + + let proper_proj env sigma = + mkConst (Option.get (pi3 (List.hd (proper_class env sigma).cl_projs))) + + let proper_type env (sigma,cstrs) = + let l = (proper_class env sigma).cl_impl in + let (sigma, c) = Evarutil.new_global sigma l in + (sigma, cstrs), c + + let proper_proxy_type env (sigma,cstrs) = + let l = (proper_proxy_class env sigma).cl_impl in + let (sigma, c) = Evarutil.new_global sigma l in + (sigma, cstrs), c let proper_proof env evars carrier relation x = - let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in + let evars, goal = app_poly env evars (proper_proxy_type env) [| carrier ; relation; x |] in new_cstr_evar evars env goal let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env @@ -618,7 +622,9 @@ let solve_remaining_by env sigma holes by = in (* Only solve independent holes *) let indep = List.map_filter map holes in - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly = false + ; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with | Genarg.GenArg (Genarg.Glbwit tag, tac) -> Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) @@ -798,7 +804,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in - let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type env else TypeGlobal.proper_type env) cl_args in let env' = let dosub, appsub = @@ -1308,8 +1314,8 @@ module Strategies = in let evars, proof = let proxy = - if prop then PropGlobal.proper_proxy_type - else TypeGlobal.proper_proxy_type + if prop then PropGlobal.proper_proxy_type env + else TypeGlobal.proper_proxy_type env in let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty @@ -1790,15 +1796,15 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance atts binders instance fields = +let anew_instance ~pstate atts binders instance fields = let program_mode = atts.program in - new_instance ~program_mode atts.polymorphic + new_instance ~pstate ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info -let declare_instance_refl atts binders a aeq n lemma = +let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance atts binders instance + in anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] let declare_instance_sym atts binders a aeq n lemma = @@ -1811,56 +1817,53 @@ let declare_instance_trans atts binders a aeq n lemma = in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation atts ?(binders=[]) a aeq n refl symm trans = +let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance atts binders instance []); + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in + let _, pstate = anew_instance ~pstate atts binders instance [] in match (refl,symm,trans) with - (None, None, None) -> () + (None, None, None) -> pstate | (Some lemma1, None, None) -> - ignore (declare_instance_refl atts binders a aeq n lemma1) + snd @@ declare_instance_refl ~pstate atts binders a aeq n lemma1 | (None, Some lemma2, None) -> - ignore (declare_instance_sym atts binders a aeq n lemma2) + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (None, None, Some lemma3) -> - ignore (declare_instance_trans atts binders a aeq n lemma3) + snd @@ declare_instance_trans ~pstate atts binders a aeq n lemma3 | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl atts binders a aeq n lemma1); - ignore (declare_instance_sym atts binders a aeq n lemma2) + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance atts binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance atts binders instance + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance atts binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) -let proper_projection sigma r ty = +let proper_projection env sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in let ctx, inst = decompose_prod_assum sigma ty in let mor, args = destApp sigma inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force PropGlobal.proper_proj, + let app = mkApp (PropGlobal.proper_proj env sigma, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx @@ -1870,7 +1873,7 @@ let declare_projection n instance_id r = let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in - let term = proper_projection sigma c ty in + let term = proper_projection env sigma c ty in let sigma, typ = Typing.type_of env sigma term in let ctx, typ = decompose_prod_assum sigma typ in let typ = @@ -1925,7 +1928,7 @@ let build_morphism_signature env sigma m = rel) cstrs in - let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in + let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in let evd = Evd.minimize_universes evd in let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in @@ -1939,26 +1942,26 @@ let default_morphism sign m = let evars, _, sign, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in - let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in + let evars, morph = app_poly_check env evars (PropGlobal.proper_type env) [| t; sign; m |] in let evars, mor = resolve_one_typeclass env (goalevars evars) morph in - mor, proper_projection sigma mor morph + mor, proper_projection env sigma mor morph let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid atts binders a aeq t n = +let add_setoid ~pstate atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance atts binders instance + in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] let make_tactic name = @@ -1970,7 +1973,7 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer atts m n = +let add_morphism_infer ~pstate atts m n : Proof_global.t option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); (* NB: atts.program is ignored, program mode automatically set by vernacentries *) @@ -1981,45 +1984,47 @@ let add_morphism_infer atts m n = if Lib.is_modtype () then let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,(instance,uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,(instance,uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) + add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst); + pstate else let kind = Decl_kinds.Global, atts.polymorphic, - Decl_kinds.DefinitionBody Decl_kinds.Instance + Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ _ _ = function - | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + | Globnames.ConstRef cst -> + add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false + declare_projection n instance_id (ConstRef cst) + | _ -> assert false in let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance); - ignore (Pfedit.by (Tacinterp.interp tac))) () + Flags.silently + (fun () -> + let pstate = Lemmas.start_proof ~ontop:pstate ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () -let add_morphism atts binders m s n = +let add_morphism ~pstate atts binders m s n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), - [cHole; s; m])) + [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance - None - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + let _, pstate = new_instance ~pstate ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance + None + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in + pstate (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 2457b265f0..a200cb5ced 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -81,18 +81,18 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : rewrite_attributes -> +val declare_relation : pstate:Proof_global.t option -> rewrite_attributes -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> unit + constr_expr option -> constr_expr option -> constr_expr option -> Proof_global.t option -val add_setoid : +val add_setoid : pstate:Proof_global.t option -> rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> unit + Id.t -> Proof_global.t option -val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> unit +val add_morphism_infer : pstate:Proof_global.t option -> rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option -val add_morphism : - rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit +val add_morphism : pstate:Proof_global.t option -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index b770b97384..814be64f81 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -48,7 +48,7 @@ let atactic n = else Aentryl (Pltac.tactic_expr, string_of_int n) type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Extend.symbol -> entry_name (** Quite ad-hoc *) let get_tacentry n m = diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index eac84f0543..4398fb14ab 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -138,9 +138,10 @@ let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () (* Signature for interpretation: val_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } let extract_trace ist = if is_traced () then match TacStore.get ist.extra f_trace with @@ -544,12 +545,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = let (_, dummy_proofview) = Proofview.init sigma [] in (* Again this is called at times with no open proof! *) - let name, poly = - try - let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in - name, poly - with | Proof_global.NoCurrentProof -> Id.of_string "tacinterp", false - in + let name, poly = Id.of_string "tacinterp", ist.poly in let (trace,_,_,_) = Proofview.apply ~name ~poly env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) term @@ -566,11 +562,13 @@ let constr_flags () = { fail_evar = true; expand_evars = true; program_mode = false; + polymorphic = false; } (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = - interp_gen kind ist false (constr_flags ()) env sigma c + let flags = { (constr_flags ()) with polymorphic = ist.Geninterp.poly } in + interp_gen kind ist false flags env sigma c let interp_constr = interp_constr_gen WithoutTypeConstraint @@ -582,6 +580,7 @@ let open_constr_use_classes_flags () = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let open_constr_no_classes_flags () = { @@ -590,6 +589,7 @@ let open_constr_no_classes_flags () = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let pure_open_constr_flags = { @@ -598,6 +598,7 @@ let pure_open_constr_flags = { fail_evar = false; expand_evars = false; program_mode = false; + polymorphic = false; } (* Interprets an open constr *) @@ -1021,6 +1022,7 @@ let type_uconstr ?(flags = (constr_flags ())) ltac_idents = closure.idents; ltac_genargs = Id.Map.empty; } in + let flags = { flags with polymorphic = ist.Geninterp.poly } in understand_ltac flags env sigma vars expected_type term end @@ -1146,6 +1148,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (* For extensions *) | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = @@ -1153,8 +1156,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let lfun = List.fold_right2 addvar alias.Tacenv.alias_args l ist.lfun in Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in @@ -1207,12 +1211,13 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ids = extract_ids [] ist.lfun Id.Set.empty in let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> let extra = TacStore.set extra f_trace trace in - let ist = { lfun = Id.Map.empty; extra = extra; } in + 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)) @@ -1260,6 +1265,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = (* Interprets an application node *) and interp_app loc ist fv largs : Val.t Ftactic.t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in if has_type fv (topwit wit_tacvalue) then @@ -1277,9 +1283,11 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = if List.is_empty lvar then begin wrap_error begin - let ist = { - lfun = newlfun; - extra = TacStore.set ist.extra f_trace []; } in + let ist = + { lfun = newlfun + ; poly + ; extra = TacStore.set ist.extra f_trace [] + } in Profile_ltac.do_profile "interp_app" trace ~count_call:false (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) @@ -1317,8 +1325,10 @@ and tactic_of_value ist vle = if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl,trace,lfun,[],t) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ist = { lfun = lfun; + poly; extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) @@ -1388,6 +1398,7 @@ and interp_letin ist llc u = (** [interp_match_success lz ist succ] interprets a single matching success (of type {!Tactic_matching.t}). *) and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let lctxt = Id.Map.map interp_context context in let hyp_subst = Id.Map.map Value.of_constr terms in @@ -1396,9 +1407,11 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = val_interp ist lhs >>= fun v -> if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + let ist = + { lfun = lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace + } in let tac = eval_tactic 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)) @@ -1872,7 +1885,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let default_ist () = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - { lfun = Id.Map.empty; extra = extra } + { lfun = Id.Map.empty; poly = false; extra = extra } let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) @@ -1912,11 +1925,12 @@ end let interp_tac_gen lfun avoid_ids debug t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in - let ist = { lfun = lfun; extra = extra } in + let ist = { lfun; poly; extra } in let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) @@ -2057,20 +2071,15 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun env sigma ty tac = + let eval lfun poly env sigma ty tac = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - let ist = { lfun = lfun; extra; } in + let ist = { lfun; poly; extra; } in let tac = interp_tactic ist tac in - (* XXX: This depends on the global state which is bad; the hooking - mechanism should be modified. *) - let name, poly = - try - let (_, poly, _) = Proof_global.get_current_persistence () in - let name = Proof_global.get_current_proof_name () in - name, poly - with | Proof_global.NoCurrentProof -> - Id.of_string "ltac_gen", false - in + (* EJGA: We sould also pass the proof name if desired, for now + poly seems like enough to get reasonable behavior in practice + *) + let name, poly = Id.of_string "ltac_gen", poly in + let name, poly = Id.of_string "ltac_gen", poly in let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index d9c80bb835..22a092fa8b 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -39,9 +39,10 @@ module TacStore : Store.S with and type 'a field = 'a Geninterp.TacStore.field (** Signature for interpretation: val\_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } open Genintern diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index caaa547a07..e617f3d45e 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -30,7 +30,7 @@ let subst_quantified_hypothesis _ x = x let subst_declared_or_quantified_hypothesis _ x = x let subst_glob_constr_and_expr subst (c, e) = - (Detyping.subst_glob_constr subst c, e) + (Detyping.subst_glob_constr (Global.env()) subst c, e) let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) @@ -99,7 +99,9 @@ let subst_evaluable subst = let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) let subst_glob_constr_or_pattern subst (bvars,c,p) = - (bvars,subst_glob_constr subst c,subst_pattern subst p) + let env = Global.env () in + let sigma = Evd.from_env env in + (bvars,subst_glob_constr subst c,subst_pattern env sigma subst p) let subst_redexp subst = Redops.map_red_expr_gen diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 52a83a038f..04f3116664 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -370,7 +370,10 @@ let explain_ltac_call_trace last trace loc = strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - let sigma, env = Pfedit.get_current_context () in + (* XXX: This hooks into the ExplainErr extension API + so it is tricky to provide the right env for now. *) + let env = Global.env () in + let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 4c65445b89..d1951cc18d 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -98,16 +98,18 @@ let split = Tactics.split_with_bindings false [Tactypes.NoBindings] (** Test *) let is_empty _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> - if is_empty_type sigma (assoc_var "X1" ist) then idtac else fail + if is_empty_type genv sigma (assoc_var "X1" ist) then idtac else fail (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) let is_unit_or_eq _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test sigma (assoc_var "X1" ist) then idtac else fail + if test genv sigma (assoc_var "X1" ist) then idtac else fail let bugged_is_binary sigma t = isApp sigma t && @@ -121,23 +123,25 @@ let bugged_is_binary sigma t = (** Dealing with conjunction *) let is_conj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let ind = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma ind) && - is_conjunction sigma + is_conjunction genv sigma ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode ind then idtac else fail let flatten_contravariant_conj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in - match match_with_conjunction sigma + match match_with_conjunction genv sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with @@ -151,23 +155,25 @@ let flatten_contravariant_conj _ ist = (** Dealing with disjunction *) let is_disj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let t = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma t) && - is_disjunction sigma + is_disjunction genv sigma ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode t then idtac else fail let flatten_contravariant_disj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in - match match_with_disjunction sigma + match match_with_disjunction genv sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v new file mode 100644 index 0000000000..47fcac6481 --- /dev/null +++ b/plugins/micromega/DeclConstant.v @@ -0,0 +1,68 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2019 *) +(* *) +(************************************************************************) + +(** Declaring 'allowed' terms using type classes. + + Motivation: reification needs to know which terms are allowed. + For 'lia', the constant are only the integers built from Z0, Zpos, Zneg, xH, xO, xI. + However, if the term is ground it may be convertible to an integer. + Thus we could allow i.e. sqrt z for some integer z. + + Proposal: for each type, the user declares using type-classes the set of allowed ground terms. + *) + +Require Import List. + +(** Declarative definition of constants. + These are ground terms (without variables) of interest. + e.g. nat is built from O and S + NB: this does not need to be restricted to constructors. + *) + +(** Ground terms (see [GT] below) are built inductively from declared constants. *) + +Class DeclaredConstant {T : Type} (F : T). + +Class GT {T : Type} (F : T). + +Instance GT_O {T : Type} (F : T) {DC : DeclaredConstant F} : GT F. +Defined. + +Instance GT_APP1 {T1 T2 : Type} (F : T1 -> T2) (A : T1) : + DeclaredConstant F -> + GT A -> GT (F A). +Defined. + +Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3) + {A1 : T1} {A2 : T2} {DC:DeclaredConstant F} : + GT A1 -> GT A2 -> GT (F A1 A2). +Defined. + +Require Import ZArith. + +Instance DO : DeclaredConstant O := {}. +Instance DS : DeclaredConstant S := {}. +Instance DxH: DeclaredConstant xH := {}. +Instance DxI: DeclaredConstant xI := {}. +Instance DxO: DeclaredConstant xO := {}. +Instance DZO: DeclaredConstant Z0 := {}. +Instance DZpos: DeclaredConstant Zpos := {}. +Instance DZneg: DeclaredConstant Zneg := {}. +Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. + +Require Import QArith. + +Instance DQ : DeclaredConstant Qmake := {}. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index eb84b1203d..36ed0210e3 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -594,7 +594,7 @@ Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. - apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). @@ -1085,7 +1085,7 @@ Section POWER. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index dd6319d5c4..1582ec554e 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -18,6 +18,7 @@ Require Import ZMicromega. Require Import ZArith. Require Import RingMicromega. Require Import VarMap. +Require Import DeclConstant. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". @@ -25,18 +26,22 @@ Declare ML Module "micromega_plugin". Ltac preprocess := zify ; unfold Z.succ in * ; unfold Z.pred in *. -Ltac zchange := +Ltac zchange checker := intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit). + change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (checker __ff __wit). -Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. +Ltac zchecker_no_abstract checker := + zchange checker ; vm_compute ; reflexivity. -Ltac zchecker_abstract := abstract (zchange ; vm_cast_no_check (eq_refl true)). +Ltac zchecker_abstract checker := + abstract (zchange checker ; vm_cast_no_check (eq_refl true)). -Ltac zchecker := zchecker_no_abstract. +Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound. -Ltac lia := preprocess; xlia zchecker. +Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound. + +Ltac lia := preprocess; xlia zchecker_ext. Ltac nia := preprocess; xnlia zchecker. diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v index caaec541eb..f3cd24be8a 100644 --- a/plugins/micromega/Lqa.v +++ b/plugins/micromega/Lqa.v @@ -18,12 +18,13 @@ Require Import QMicromega. Require Import QArith. Require Import RingMicromega. Require Import VarMap. +Require Import DeclConstant. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac rchange := intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + change (Tauto.eval_bf (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit). Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v index 4ff483fbab..72e29319ff 100644 --- a/plugins/micromega/Lra.v +++ b/plugins/micromega/Lra.v @@ -24,7 +24,7 @@ Declare ML Module "micromega_plugin". Ltac rchange := intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + change (Tauto.eval_bf (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit). Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 5f01f981ef..6112eda200 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -54,8 +54,10 @@ Extract Constant Rinv => "fun x -> 1 / x". (** In order to avoid annoying build dependencies the actual extraction is only performed as a test in the test suite. *) (*Extraction "micromega.ml" -(*Recursive Extraction*) List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + List.map simpl_cone (*map_cone indexes*) + denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) (* Local Variables: *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index 62505453f9..e0e2232be5 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -87,40 +87,40 @@ Notation "x < y" := (rlt x y). Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. -exact sor.(SORle_wd). +exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. -exact sor.(SORlt_wd). +exact (SORlt_wd sor). Qed. -Add Ring SOR : sor.(SORrt). +Add Ring SOR : (SORrt sor). Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. intros x1 x2 H1 y1 y2 H2. -rewrite (sor.(SORrt).(Rsub_def) x1 y1). -rewrite (sor.(SORrt).(Rsub_def) x2 y2). +rewrite ((Rsub_def (SORrt sor)) x1 y1). +rewrite ((Rsub_def (SORrt sor)) x2 y2). rewrite H1; now rewrite H2. Qed. @@ -180,22 +180,22 @@ Qed. (* Relations *) Theorem Rle_refl : forall n : R, n <= n. -Proof sor.(SORle_refl). +Proof (SORle_refl sor). Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. -Proof sor.(SORle_antisymm). +Proof (SORle_antisymm sor). Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. -Proof sor.(SORle_trans). +Proof (SORle_trans sor). Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. -Proof sor.(SORlt_trichotomy). +Proof (SORlt_trichotomy sor). Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. -Proof sor.(SORlt_le_neq). +Proof (SORlt_le_neq sor). Theorem Rneq_0_1 : 0 ~= 1. -Proof sor.(SORneq_0_1). +Proof (SORneq_0_1 sor). Theorem Req_em : forall n m : R, n == m \/ n ~= m. Proof. @@ -274,8 +274,8 @@ Qed. Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. Proof. intros n m p; split. -apply sor.(SORplus_le_mono_l). -intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. +apply (SORplus_le_mono_l sor). +intro H. apply ((SORplus_le_mono_l sor) (p + n) (p + m) (- p)) in H. setoid_replace (- p + (p + n)) with n in H by ring. setoid_replace (- p + (p + m)) with m in H by ring. assumption. Qed. @@ -375,7 +375,7 @@ Qed. (* Times and order *) Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. -Proof sor.(SORtimes_pos_pos). +Proof (SORtimes_pos_pos sor). Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. Proof. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 2880a05d8d..0d593a321c 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -173,6 +173,7 @@ Qed. Require Import Coq.micromega.Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. + Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. @@ -182,30 +183,36 @@ Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Declare Equivalent Keys normQ RingMicromega.norm. +Definition cnfQ (Annot TX AF: Type) (f: TFormula (Formula Q) Annot TX AF) := + rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) + @tauto_checker (Formula Q) (NFormula Q) unit qunsat qdeduce - Qnormalise - Qnegate QWitness QWeakChecker f w. + (Qnormalise unit) + (Qnegate unit) QWitness (fun cl => QWeakChecker (List.map fst cl)) f w. -Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. +Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf (Qeval_formula env) f. Proof. intros f w. unfold QTautoChecker. - apply (tauto_checker_sound Qeval_formula Qeval_nformula). - apply Qeval_nformula_dec. - intros until env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). - intros t w0. - apply QWeakChecker_sound. + apply tauto_checker_sound with (eval:= Qeval_formula) (eval':= Qeval_nformula). + - apply Qeval_nformula_dec. + - intros until env. + unfold eval_nformula. unfold RingMicromega.eval_nformula. + destruct t. + apply (check_inconsistent_sound Qsor QSORaddon) ; auto. + - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). + - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_normalise_correct Qsor QSORaddon);eauto. + - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := Qeval_nformula env). + eapply QWeakChecker_sound; eauto. + tauto. Qed. (* Local Variables: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index c2b40c730f..7704e42d40 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -17,10 +17,11 @@ Require Import OrderedRing. Require Import RingMicromega. Require Import Refl. -Require Import Raxioms RIneq Rpow_def DiscrR. +Require Import Raxioms Rfunctions RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. Require Import Qreals. +Require Import DeclConstant. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -57,8 +58,6 @@ Proof. now apply Rmult_lt_0_compat. Qed. -Notation IQR := Q2R (only parsing). - Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. @@ -66,13 +65,13 @@ Proof. apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> Q2R x = Q2R y. Proof. intros. now apply Qeq_eqR, Qeq_bool_eq. Qed. -Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. +Lemma Qeq_false : forall x y, Qeq_bool x y = false -> Q2R x <> Q2R y. Proof. intros. apply Qeq_bool_neq in H. @@ -80,24 +79,24 @@ Proof. now apply eqR_Qeq. Qed. -Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. +Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> Q2R x <= Q2R y. Proof. intros. now apply Qle_Rle, Qle_bool_imp_le. Qed. -Lemma IQR_0 : IQR 0 = 0. +Lemma Q2R_0 : Q2R 0 = 0. Proof. apply Rmult_0_l. Qed. -Lemma IQR_1 : IQR 1 = 1. +Lemma Q2R_1 : Q2R 1 = 1. Proof. compute. apply Rinv_1. Qed. -Lemma IQR_inv_ext : forall x, - IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). +Lemma Q2R_inv_ext : forall x, + Q2R (/ x) = (if Qeq_bool x 0 then 0 else / Q2R x). Proof. intros. case_eq (Qeq_bool x 0). @@ -120,12 +119,12 @@ Lemma QSORaddon : R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) Qeq_bool Qle_bool - IQR nat to_nat pow. + Q2R nat to_nat pow. Proof. constructor. constructor ; intros ; try reflexivity. - apply IQR_0. - apply IQR_1. + apply Q2R_0. + apply Q2R_1. apply Q2R_plus. apply Q2R_minus. apply Q2R_mult. @@ -136,20 +135,27 @@ Proof. apply Qle_true. Qed. +(* Syntactic ring coefficients. *) -(* Syntactic ring coefficients. - For computing, we use Q. *) Inductive Rcst := -| C0 -| C1 -| CQ (r : Q) -| CZ (r : Z) -| CPlus (r1 r2 : Rcst) -| CMinus (r1 r2 : Rcst) -| CMult (r1 r2 : Rcst) -| CInv (r : Rcst) -| COpp (r : Rcst). - + | C0 + | C1 + | CQ (r : Q) + | CZ (r : Z) + | CPlus (r1 r2 : Rcst) + | CMinus (r1 r2 : Rcst) + | CMult (r1 r2 : Rcst) + | CPow (r1 : Rcst) (z:Z+nat) + | CInv (r : Rcst) + | COpp (r : Rcst). + + + +Definition z_of_exp (z : Z + nat) := + match z with + | inl z => z + | inr n => Z.of_nat n + end. Fixpoint Q_of_Rcst (r : Rcst) : Q := match r with @@ -160,42 +166,198 @@ Fixpoint Q_of_Rcst (r : Rcst) : Q := | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) - | CInv r => Qinv (Q_of_Rcst r) + | CPow r1 z => Qpower (Q_of_Rcst r1) (z_of_exp z) + | CInv r => Qinv (Q_of_Rcst r) | COpp r => Qopp (Q_of_Rcst r) end. +Definition is_neg (z: Z+nat) := + match z with + | inl (Zneg _) => true + | _ => false + end. + +Lemma is_neg_true : forall z, is_neg z = true -> (z_of_exp z < 0)%Z. +Proof. + destruct z ; simpl ; try congruence. + destruct z ; try congruence. + intros. + reflexivity. +Qed. + +Lemma is_neg_false : forall z, is_neg z = false -> (z_of_exp z >= 0)%Z. +Proof. + destruct z ; simpl ; try congruence. + destruct z ; try congruence. + compute. congruence. + compute. congruence. + generalize (Zle_0_nat n). auto with zarith. +Qed. + +Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1). + +Definition CPowR0 (z : Z) (r : Rcst) := + Z.ltb z Z0 && Qeq_bool (Q_of_Rcst r) (0 # 1). + Fixpoint R_of_Rcst (r : Rcst) : R := match r with | C0 => R0 | C1 => R1 | CZ z => IZR z - | CQ q => IQR q + | CQ q => Q2R q | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) + | CPow r1 z => + match z with + | inl z => + if CPowR0 z r1 + then R0 + else powerRZ (R_of_Rcst r1) z + | inr n => pow (R_of_Rcst r1) n + end | CInv r => - if Qeq_bool (Q_of_Rcst r) (0 # 1) - then R0 - else Rinv (R_of_Rcst r) - | COpp r => - (R_of_Rcst r) + if CInvR0 r then R0 + else Rinv (R_of_Rcst r) + | COpp r => - (R_of_Rcst r) end. -Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c. +Add Morphism Q2R with signature Qeq ==> @eq R as Q2R_m. + exact Qeq_eqR. +Qed. + +Lemma Q2R_pow_pos : forall q p, + Q2R (pow_pos Qmult q p) = pow_pos Rmult (Q2R q) p. +Proof. + induction p ; simpl;auto; + rewrite <- IHp; + repeat rewrite Q2R_mult; + reflexivity. +Qed. + +Lemma Q2R_pow_N : forall q n, + Q2R (pow_N 1%Q Qmult q n) = pow_N 1 Rmult (Q2R q) n. +Proof. + destruct n ; simpl. + - apply Q2R_1. + - apply Q2R_pow_pos. +Qed. + +Lemma Qmult_integral : forall q r, q * r == 0 -> q == 0 \/ r == 0. +Proof. + intros. + destruct (Qeq_dec q 0)%Q. + - left ; apply q0. + - apply Qmult_integral_l in H ; tauto. +Qed. + +Lemma Qpower_positive_eq_zero : forall q p, + Qpower_positive q p == 0 -> q == 0. +Proof. + unfold Qpower_positive. + induction p ; simpl; intros; + repeat match goal with + | H : _ * _ == 0 |- _ => + apply Qmult_integral in H; destruct H + end; tauto. +Qed. + +Lemma Qpower_positive_zero : forall p, + Qpower_positive 0 p == 0%Q. +Proof. + induction p ; simpl; + try rewrite IHp ; reflexivity. +Qed. + + +Lemma Q2RpowerRZ : + forall q z + (DEF : not (q == 0)%Q \/ (z >= Z0)%Z), + Q2R (q ^ z) = powerRZ (Q2R q) z. +Proof. + intros. + destruct Qpower_theory. + destruct R_power_theory. + unfold Qpower, powerRZ. + destruct z. + - apply Q2R_1. + - + change (Qpower_positive q p) + with (Qpower q (Zpos p)). + rewrite <- N2Z.inj_pos. + rewrite <- positive_N_nat. + rewrite rpow_pow_N. + rewrite rpow_pow_N0. + apply Q2R_pow_N. + - + rewrite Q2R_inv. + unfold Qpower_positive. + rewrite <- positive_N_nat. + rewrite rpow_pow_N0. + unfold pow_N. + rewrite Q2R_pow_pos. + auto. + intro. + apply Qpower_positive_eq_zero in H. + destruct DEF ; auto with arith. +Qed. + +Lemma Qpower0 : forall z, (z <> 0)%Z -> (0 ^ z == 0)%Q. Proof. - induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). - apply IQR_0. - apply IQR_1. + unfold Qpower. + destruct z;intros. + - congruence. + - apply Qpower_positive_zero. + - rewrite Qpower_positive_zero. reflexivity. - unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply Q2R_plus. - apply Q2R_minus. - apply Q2R_mult. - rewrite <- IHc. - apply IQR_inv_ext. - rewrite <- IHc. +Qed. + + +Lemma Q_of_RcstR : forall c, Q2R (Q_of_Rcst c) = R_of_Rcst c. +Proof. + induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). + - apply Q2R_0. + - apply Q2R_1. + - reflexivity. + - unfold Q2R. simpl. rewrite Rinv_1. reflexivity. + - apply Q2R_plus. + - apply Q2R_minus. + - apply Q2R_mult. + - destruct z. + destruct (CPowR0 z c) eqn:C; unfold CPowR0 in C. + + + rewrite andb_true_iff in C. + destruct C as (C1 & C2). + rewrite Z.ltb_lt in C1. + apply Qeq_bool_eq in C2. + rewrite C2. + simpl. + rewrite Qpower0 by auto with zarith. + apply Q2R_0. + + rewrite Q2RpowerRZ. + rewrite IHc. + reflexivity. + rewrite andb_false_iff in C. + destruct C. + simpl. apply Z.ltb_ge in H. + auto with zarith. + left ; apply Qeq_bool_neq; auto. + + simpl. + rewrite <- IHc. + destruct Qpower_theory. + rewrite <- nat_N_Z. + rewrite rpow_pow_N. + destruct R_power_theory. + rewrite <- (Nnat.Nat2N.id n) at 2. + rewrite rpow_pow_N0. + apply Q2R_pow_N. + - rewrite <- IHc. + unfold CInvR0. + apply Q2R_inv_ext. + - rewrite <- IHc. apply Q2R_opp. - Qed. +Qed. Require Import EnvRing. @@ -227,7 +389,7 @@ Definition Reval_formula' := eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. Definition QReval_formula := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow . + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow . Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. Proof. @@ -242,12 +404,12 @@ Proof. Qed. Definition Qeval_nformula := - eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IQR. + eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt Q2R. Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. - exact (fun env d =>eval_nformula_dec Rsor IQR env d). + exact (fun env d =>eval_nformula_dec Rsor Q2R env d). Qed. Definition RWitness := Psatz Q. @@ -279,32 +441,41 @@ Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) - runsat rdeduce - Rnormalise Rnegate - RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst) f) w. + unit runsat rdeduce + (Rnormalise unit) (Rnegate unit) + RWitness (fun cl => RWeakChecker (List.map fst cl)) (map_bformula (map_Formula Q_of_Rcst) f) w. -Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. +Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. Proof. intros f w. unfold RTautoChecker. intros TC env. - apply (tauto_checker_sound QReval_formula Qeval_nformula) with (env := env) in TC. - rewrite eval_f_map in TC. - rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. + apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. + - change (eval_f (fun x : Prop => x) (QReval_formula env)) + with + (eval_bf (QReval_formula env)) in TC. + rewrite eval_bf_map in TC. + unfold eval_bf in TC. + rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. intro. unfold QReval_formula. rewrite <- eval_formulaSC with (phiS := R_of_Rcst). rewrite Reval_formula_compat. tauto. intro. rewrite Q_of_RcstR. reflexivity. + - apply Reval_nformula_dec. - destruct t. + - destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). - now apply (cnf_normalise_correct Rsor QSORaddon). - intros. now apply (cnf_negate_correct Rsor QSORaddon). - intros t w0. - apply RWeakChecker_sound. + - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). + - now apply (cnf_normalise_correct Rsor QSORaddon). + - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := Qeval_nformula env0). + eapply RWeakChecker_sound; eauto. + tauto. Qed. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 952a1b91e7..898a3a1a28 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -36,6 +36,21 @@ trivial. intro; apply IH. Qed. + +Theorem make_impl_map : + forall (A B: Type) (eval : A -> Prop) (eval' : A*B -> Prop) (l : list (A*B)) r + (EVAL : forall x, eval' x <-> eval (fst x)), + make_impl eval' l r <-> make_impl eval (List.map fst l) r. +Proof. +induction l as [| a l IH]; simpl. +- tauto. +- intros. + rewrite EVAL. + rewrite IH. + tauto. + auto. +Qed. + Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := match l with | nil => True diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 782fab5e68..60931df517 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -81,30 +81,30 @@ Record SORaddon := mk_SOR_addon { Variable addon : SORaddon. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. - exact sor.(SORle_wd). + exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. - exact sor.(SORlt_wd). + exact (SORlt_wd sor). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. @@ -124,12 +124,12 @@ Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. Proof. - exact addon.(SORcleb_morph). + exact (SORcleb_morph addon). Qed. Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. Proof. -intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. +intros x y H1. apply (SORcneqb_morph addon). unfold cneqb, negb in H1. destruct (ceqb x y); now try discriminate. Qed. @@ -325,9 +325,9 @@ Definition map_option2 (A B C : Type) (f : A -> B -> option C) Arguments map_option2 [A B C] f o o'. Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor). Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := let (ef,o) := f in @@ -368,8 +368,8 @@ Proof. destruct f. intros. destruct o ; inversion H0 ; try discriminate. simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + rewrite (Pmul_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). rewrite H. apply (Rtimes_0_r sor). Qed. @@ -385,8 +385,8 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Pmul_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); apply OpMult_sound with (3:= H);assumption. Qed. @@ -402,8 +402,8 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Padd_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Padd_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); apply OpAdd_sound with (3:= H);assumption. Qed. @@ -422,12 +422,12 @@ Proof. (* index is out-of-bounds *) inversion H0. rewrite Heq. simpl. - now apply addon.(SORrm).(morph0). + now apply (morph0 (SORrm addon)). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Psquare_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. @@ -454,11 +454,11 @@ Proof. simpl. intro. case_eq (cO [<] c). intros. inversion H1. simpl. - rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. discriminate. (* PsatzZ *) simpl. intros. inversion H0. - simpl. apply addon.(SORrm).(morph0). + simpl. apply (morph0 (SORrm addon)). Qed. Fixpoint ge_bool (n m : nat) : bool := @@ -529,8 +529,8 @@ Proof. inv H. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Psquare_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl in *. @@ -570,12 +570,12 @@ Proof. case_eq (cO [<] c). intros. rewrite H1 in H. inv H. unfold eval_nformula. simpl. - rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. intros. rewrite H1 in H. discriminate. (* PsatzZ *) simpl in *. inv H. unfold eval_nformula. simpl. - apply addon.(SORrm).(morph0). + apply (morph0 (SORrm addon)). Qed. @@ -592,19 +592,19 @@ Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor) in + PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) + (SORrm addon). Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor) in + PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) + (SORrm addon). (* Check that a formula f is inconsistent by normalizing and comparing the @@ -631,9 +631,9 @@ intros p op H1 env. unfold check_inconsistent in H1. destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; -try rewrite <- addon.(SORrm).(morph0); trivial. +try rewrite <- (morph0 (SORrm addon)); trivial. now apply cneqb_sound. -apply addon.(SORrm).(morph_eq) in H1. congruence. +apply (morph_eq (SORrm addon)) in H1. congruence. apply cleb_sound in H1. now apply -> (Rle_ngt sor). apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. @@ -706,6 +706,8 @@ Definition psub := Psub cO cplus cminus copp ceqb. Definition padd := Padd cO cplus ceqb. +Definition pmul := Pmul cO cI cplus ctimes ceqb. + Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in @@ -736,21 +738,30 @@ let (lhs, op, rhs) := f in Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. - apply (Psub_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + apply (Psub_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. - apply (Padd_ok sor.(SORsetoid) Rops_wd + apply (Padd_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). +Qed. + +Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) == eval_pol env lhs * eval_pol env rhs. +Proof. + intros. + apply (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. + + Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). Proof. intros. - apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). + apply (norm_aux_spec (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon) (SORpower addon) ). Qed. @@ -801,29 +812,29 @@ Definition xnormalise (t:Formula C) : list (NFormula) := Import Coq.micromega.Tauto. -Definition cnf_normalise (t:Formula C) : cnf (NFormula) := - List.map (fun x => x::nil) (xnormalise t). +Definition cnf_normalise {T : Type} (t:Formula C) (tg : T) : cnf NFormula T := + List.map (fun x => (x,tg)::nil) (xnormalise t). -Add Ring SORRing : sor.(SORrt). +Add Ring SORRing : (SORrt sor). -Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t. +Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) -> eval_formula env t. Proof. - unfold cnf_normalise, xnormalise ; simpl ; intros env t. + unfold cnf_normalise, xnormalise ; simpl ; intros T env t tg. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; simpl; + destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; + simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. - (**) - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - now rewrite <- (Rminus_eq_0 sor). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + - apply (SORle_antisymm sor). + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + - now rewrite <- (Rminus_eq_0 sor). + - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. Qed. Definition xnegate (t:Formula C) : list (NFormula) := @@ -839,30 +850,27 @@ Definition xnegate (t:Formula C) : list (NFormula) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition cnf_negate (t:Formula C) : cnf (NFormula) := - List.map (fun x => x::nil) (xnegate t). +Definition cnf_negate {T : Type} (t:Formula C) (tg:T) : cnf NFormula T := + List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t. +Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) -> ~ eval_formula env t. Proof. - unfold cnf_negate, xnegate ; simpl ; intros env t. + unfold cnf_negate, xnegate ; simpl ; intros T env t tg. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; simpl; + destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. - (**) + - apply H0. rewrite H1 ; ring. - (**) - apply H1. - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - (**) - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + - apply H1. apply (SORle_antisymm sor). + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + - apply H0. now rewrite (Rle_le_minus sor) in H1. + - apply H0. now rewrite (Rle_le_minus sor) in H1. + - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + - apply H0. now rewrite (Rlt_lt_minus sor) in H1. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). @@ -912,7 +920,7 @@ Proof. unfold Env.nth. unfold jump at 2. rewrite <- Pos.add_1_l. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite (rpow_pow_N (SORpower addon)). unfold pow_N. ring. Qed. @@ -932,7 +940,7 @@ Proof. unfold Env.tail. rewrite xdenorm_correct. change (Pos.succ xH) with 2%positive. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite (rpow_pow_N (SORpower addon)). simpl. reflexivity. Qed. diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 587f2f1fa4..7b9b88c0fe 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -10,7 +10,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-20019 *) (* *) (************************************************************************) @@ -21,176 +21,363 @@ Require Import Bool. Set Implicit Arguments. +Section S. + Context {TA : Type}. (* type of interpreted atoms *) + Context {TX : Type}. (* type of uninterpreted terms (Prop) *) + Context {AA : Type}. (* type of annotations for atoms *) + Context {AF : Type}. (* type of formulae identifiers *) + #[universes(template)] - Inductive BFormula (A:Type) : Type := - | TT : BFormula A - | FF : BFormula A - | X : Prop -> BFormula A - | A : A -> BFormula A - | Cj : BFormula A -> BFormula A -> BFormula A - | D : BFormula A-> BFormula A -> BFormula A - | N : BFormula A -> BFormula A - | I : BFormula A-> BFormula A-> BFormula A. - - Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := - match f with - | TT _ => True - | FF _ => False - | A a => ev a - | X _ p => p - | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) - | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) - | N e => ~ (eval_f ev e) - | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) - end. + Inductive GFormula : Type := + | TT : GFormula + | FF : GFormula + | X : TX -> GFormula + | A : TA -> AA -> GFormula + | Cj : GFormula -> GFormula -> GFormula + | D : GFormula -> GFormula -> GFormula + | N : GFormula -> GFormula + | I : GFormula -> option AF -> GFormula -> GFormula. + + Section MAPX. + Variable F : TX -> TX. + + Fixpoint mapX (f : GFormula) : GFormula := + match f with + | TT => TT + | FF => FF + | X x => X (F x) + | A a an => A a an + | Cj f1 f2 => Cj (mapX f1) (mapX f2) + | D f1 f2 => D (mapX f1) (mapX f2) + | N f => N (mapX f) + | I f1 o f2 => I (mapX f1) o (mapX f2) + end. - Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A), - (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). - Proof. - induction f ; simpl ; try tauto. - intros. - assert (H' := H a). - auto. - Qed. + End MAPX. + + Section FOLDANNOT. + Variable ACC : Type. + Variable F : ACC -> AA -> ACC. + + Fixpoint foldA (f : GFormula) (acc : ACC) : ACC := + match f with + | TT => acc + | FF => acc + | X x => acc + | A a an => F acc an + | Cj f1 f2 + | D f1 f2 + | I f1 _ f2 => foldA f1 (foldA f2 acc) + | N f => foldA f acc + end. + End FOLDANNOT. - Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := + Definition cons_id (id : option AF) (l : list AF) := + match id with + | None => l + | Some id => id :: l + end. + + Fixpoint ids_of_formula f := match f with - | TT _ => TT _ - | FF _ => FF _ - | X _ p => X _ p - | A a => A (fct a) - | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) - | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) - | N f => N (map_bformula fct f) - | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2) + | I f id f' => cons_id id (ids_of_formula f') + | _ => nil end. - Lemma eval_f_map : forall T U (fct: T-> U) env f , - eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f. - Proof. - induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. - rewrite <- IHf. auto. - Qed. + Fixpoint collect_annot (f : GFormula) : list AA := + match f with + | TT | FF | X _ => nil + | A _ a => a ::nil + | Cj f1 f2 + | D f1 f2 + | I f1 _ f2 => collect_annot f1 ++ collect_annot f2 + | N f => collect_annot f + end. + Variable ex : TX -> Prop. (* [ex] will be the identity *) + Section EVAL. - Lemma map_simpl : forall A B f l, @map A B f l = match l with - | nil => nil - | a :: l=> (f a) :: (@map A B f l) - end. + Variable ea : TA -> Prop. + + Fixpoint eval_f (f:GFormula) {struct f}: Prop := + match f with + | TT => True + | FF => False + | A a _ => ea a + | X p => ex p + | Cj e1 e2 => (eval_f e1) /\ (eval_f e2) + | D e1 e2 => (eval_f e1) \/ (eval_f e2) + | N e => ~ (eval_f e) + | I f1 _ f2 => (eval_f f1) -> (eval_f f2) + end. + + + End EVAL. + + + + + + Lemma eval_f_morph : + forall (ev ev' : TA -> Prop) (f : GFormula), + (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). Proof. - destruct l ; reflexivity. + induction f ; simpl ; try tauto. + intros. + apply H. Qed. +End S. - Section S. - Variable Env : Type. - Variable Term : Type. - Variable eval : Env -> Term -> Prop. - Variable Term' : Type. - Variable eval' : Env -> Term' -> Prop. +(** Typical boolean formulae *) +Definition BFormula (A : Type) := @GFormula A Prop unit unit. +Section MAPATOMS. + Context {TA TA':Type}. + Context {TX : Type}. + Context {AA : Type}. + Context {AF : Type}. - Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). +Fixpoint map_bformula (fct : TA -> TA') (f : @GFormula TA TX AA AF ) : @GFormula TA' TX AA AF := + match f with + | TT => TT + | FF => FF + | X p => X p + | A a t => A (fct a) t + | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) + | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) + | N f => N (map_bformula fct f) + | I f1 a f2 => I (map_bformula fct f1) a (map_bformula fct f2) + end. - Variable unsat : Term' -> bool. +End MAPATOMS. - Variable unsat_prop : forall t, unsat t = true -> - forall env, eval' env t -> False. +Lemma map_simpl : forall A B f l, @map A B f l = match l with + | nil => nil + | a :: l=> (f a) :: (@map A B f l) + end. +Proof. + destruct l ; reflexivity. +Qed. - Variable deduce : Term' -> Term' -> option Term'. - Variable deduce_prop : forall env t t' u, - eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. +Section S. + (** A cnf tracking annotations of atoms. *) + + (** Type parameters *) + Variable Env : Type. + Variable Term : Type. + Variable Term' : Type. + Variable Annot : Type. + + Variable unsat : Term' -> bool. (* see [unsat_prop] *) + Variable deduce : Term' -> Term' -> option Term'. (* see [deduce_prop] *) - Definition clause := list Term'. - Definition cnf := list clause. + Definition clause := list (Term' * Annot). + Definition cnf := list clause. - Variable normalise : Term -> cnf. - Variable negate : Term -> cnf. + Variable normalise : Term -> Annot -> cnf. + Variable negate : Term -> Annot -> cnf. - Definition tt : cnf := @nil clause. - Definition ff : cnf := cons (@nil Term') nil. + Definition cnf_tt : cnf := @nil clause. + Definition cnf_ff : cnf := cons (@nil (Term' * Annot)) nil. + (** Our cnf is optimised and detects contradictions on the fly. *) - Fixpoint add_term (t: Term') (cl : clause) : option clause := + Fixpoint add_term (t: Term' * Annot) (cl : clause) : option clause := match cl with - | nil => - match deduce t t with - | None => Some (t ::nil) - | Some u => if unsat u then None else Some (t::nil) - end - | t'::cl => - match deduce t t' with - | None => - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - | Some u => - if unsat u then None else - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end + | nil => + match deduce (fst t) (fst t) with + | None => Some (t ::nil) + | Some u => if unsat u then None else Some (t::nil) + end + | t'::cl => + match deduce (fst t) (fst t') with + | None => + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') end + | Some u => + if unsat u then None else + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') + end + end end. Fixpoint or_clause (cl1 cl2 : clause) : option clause := match cl1 with - | nil => Some cl2 - | t::cl => match add_term t cl2 with - | None => None - | Some cl' => or_clause cl cl' - end + | nil => Some cl2 + | t::cl => match add_term t cl2 with + | None => None + | Some cl' => or_clause cl cl' + end end. -(* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. *) + (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := + List.map (fun x => (t++x)) f. *) Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_right (fun e acc => - match or_clause t e with - | None => acc - | Some cl => cl :: acc - end) nil f. + List.fold_right (fun e acc => + match or_clause t e with + | None => acc + | Some cl => cl :: acc + end) nil f. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with - | nil => tt - | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + | nil => cnf_tt + | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := f1 ++ f2. - Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := + (** TX is Prop in Coq and EConstr.constr in Ocaml. + AF i s unit in Coq and Names.Id.t in Ocaml + *) + Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF. + + Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF) {struct f}: cnf := match f with - | TT _ => if pol then tt else ff - | FF _ => if pol then ff else tt - | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) - | A x => if pol then normalise x else negate x - | N e => xcnf (negb pol) e - | Cj e1 e2 => - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + | TT => if pol then cnf_tt else cnf_ff + | FF => if pol then cnf_ff else cnf_tt + | X p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *) + | A x t => if pol then normalise x t else negate x t + | N e => xcnf (negb pol) e + | Cj e1 e2 => + (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) + | I e1 _ e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. - Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl. + Section CNFAnnot. + + (** Records annotations used to optimise the cnf. + Those need to be kept when pruning the formula. + For efficiency, this is a separate function. + *) + + + + Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot := + match cl with + | nil => (* if t is unsat, the clause is empty BUT t is needed. *) + match deduce (fst t) (fst t) with + | Some u => if unsat u then inr ((snd t)::nil) else inl (t::nil) + | None => inl (t::nil) + end + | t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *) + match deduce (fst t) (fst t') with + | Some u => if unsat u then inr ((snd t)::(snd t')::nil) + else match radd_term t cl with + | inl cl' => inl (t'::cl') + | inr l => inr l + end + | None => match radd_term t cl with + | inl cl' => inl (t'::cl') + | inr l => inr l + end + end + end. + + Fixpoint ror_clause cl1 cl2 := + match cl1 with + | nil => inl cl2 + | t::cl => match radd_term t cl2 with + | inl cl' => ror_clause cl cl' + | inr l => inr l + end + end. + + Definition ror_clause_cnf t f := + List.fold_right (fun e '(acc,tg) => + match ror_clause t e with + | inl cl => (cl :: acc,tg) + | inr l => (acc,tg++l) + end) (nil,nil) f . + + + Fixpoint ror_cnf f f' := + match f with + | nil => (cnf_tt,nil) + | e :: rst => + let (rst_f',t) := ror_cnf rst f' in + let (e_f', t') := ror_clause_cnf e f' in + (rst_f' ++ e_f', t ++ t') + end. + + Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) := + match f with + | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil) + | FF => if polarity then (cnf_ff,nil) else (cnf_tt,nil) + | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil) + | A x t => ((if polarity then normalise x t else negate x t),nil) + | N e => rxcnf (negb polarity) e + | Cj e1 e2 => + let (e1,t1) := rxcnf polarity e1 in + let (e2,t2) := rxcnf polarity e2 in + if polarity + then (e1 ++ e2, t1 ++ t2) + else let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + | D e1 e2 => + let (e1,t1) := rxcnf polarity e1 in + let (e2,t2) := rxcnf polarity e2 in + if polarity + then let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + else (e1 ++ e2, t1 ++ t2) + | I e1 _ e2 => + let (e1 , t1) := (rxcnf (negb polarity) e1) in + let (e2 , t2) := (rxcnf polarity e2) in + if polarity + then let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + else (and_cnf e1 e2, t1 ++ t2) + end. + + End CNFAnnot. + + + + Variable eval : Env -> Term -> Prop. + + Variable eval' : Env -> Term' -> Prop. + + Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). + + + Variable unsat_prop : forall t, unsat t = true -> + forall env, eval' env t -> False. + + + + Variable deduce_prop : forall env t t' u, + eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. + + + + Definition eval_tt (env : Env) (tt : Term' * Annot) := eval' env (fst tt). + + + Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval_tt env) cl. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - + Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. @@ -201,97 +388,107 @@ Set Implicit Arguments. Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with - | None => True - | Some cl => eval_clause env cl + | None => True + | Some cl => eval_clause env cl end. - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). - Proof. - induction cl. - (* BC *) - simpl. - case_eq (deduce t t) ; auto. - intros *. - case_eq (unsat t0) ; auto. - unfold eval_clause. - rewrite make_conj_cons. - intros. intro. - apply unsat_prop with (1:= H) (env := env). - apply deduce_prop with (3:= H0) ; tauto. - (* IC *) - simpl. - case_eq (deduce t a). - intro u. - case_eq (unsat u). - simpl. intros. - unfold eval_clause. - intro. - apply unsat_prop with (1:= H) (env:= env). - repeat rewrite make_conj_cons in H2. - apply deduce_prop with (3:= H0); tauto. - intro. - case_eq (add_term t cl) ; intros. - simpl in H2. - rewrite H0 in IHcl. - simpl in IHcl. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - rewrite H0 in IHcl ; simpl in *. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - case_eq (add_term t cl) ; intros. - simpl in H1. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - rewrite H in IHcl. - simpl in IHcl. - tauto. - simpl in *. - rewrite H in IHcl. - simpl in IHcl. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - Qed. - - - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). Proof. induction cl. - simpl. tauto. + - (* BC *) + simpl. + case_eq (deduce (fst t) (fst t)) ; auto. intros *. + case_eq (unsat t0) ; auto. + unfold eval_clause. + rewrite make_conj_cons. + intros. intro. + apply unsat_prop with (1:= H) (env := env). + apply deduce_prop with (3:= H0) ; tauto. + - (* IC *) simpl. - assert (HH := add_term_correct env a cl'). - case_eq (add_term a cl'). - simpl in *. + case_eq (deduce (fst t) (fst a)). + intro u. + case_eq (unsat u). + simpl. intros. + unfold eval_clause. + intro. + apply unsat_prop with (1:= H) (env:= env). + repeat rewrite make_conj_cons in H2. + apply deduce_prop with (3:= H0); tauto. + intro. + case_eq (add_term t cl) ; intros. + simpl in H2. + rewrite H0 in IHcl. + simpl in IHcl. + unfold eval_clause in *. intros. - apply IHcl in H0. - rewrite H in HH. - simpl in HH. + repeat rewrite make_conj_cons in *. + tauto. + rewrite H0 in IHcl ; simpl in *. unfold eval_clause in *. - destruct H0. + intros. repeat rewrite make_conj_cons in *. tauto. - apply HH in H0. - apply not_make_conj_cons in H0 ; auto. + case_eq (add_term t cl) ; intros. + simpl in H1. + unfold eval_clause in *. repeat rewrite make_conj_cons in *. + rewrite H in IHcl. + simpl in IHcl. tauto. - simpl. - intros. - rewrite H in HH. - simpl in HH. + simpl in *. + rewrite H in IHcl. + simpl in IHcl. unfold eval_clause in *. - assert (HH' := HH Coq.Init.Logic.I). - apply not_make_conj_cons in HH'; auto. repeat rewrite make_conj_cons in *. tauto. Qed. - + + + Lemma no_middle_eval_tt : forall env a, + eval_tt env a \/ ~ eval_tt env a. + Proof. + unfold eval_tt. + auto. + Qed. + + Hint Resolve no_middle_eval_tt : tauto. + + Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Proof. + induction cl. + - simpl. tauto. + - intros *. + simpl. + assert (HH := add_term_correct env a cl'). + case_eq (add_term a cl'). + + + intros. + apply IHcl in H0. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + destruct H0. + * + repeat rewrite make_conj_cons in *. + tauto. + * apply HH in H0. + apply not_make_conj_cons in H0 ; auto with tauto. + repeat rewrite make_conj_cons in *. + tauto. + + + intros. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + assert (HH' := HH Coq.Init.Logic.I). + apply not_make_conj_cons in HH'; auto with tauto. + repeat rewrite make_conj_cons in *. + tauto. + Qed. + Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). Proof. @@ -299,39 +496,38 @@ Set Implicit Arguments. unfold or_clause_cnf. intros until t. set (F := (fun (e : clause) (acc : list clause) => - match or_clause t e with - | Some cl => cl :: acc - | None => acc - end)). - induction f. - auto. - (**) + match or_clause t e with + | Some cl => cl :: acc + | None => acc + end)). + induction f;auto. simpl. intros. destruct f. - simpl in H. - simpl in IHf. - unfold F in H. - revert H. - intros. - apply or_clause_correct. - destruct (or_clause t a) ; simpl in * ; auto. - unfold F in H at 1. - revert H. - assert (HH := or_clause_correct t a env). - destruct (or_clause t a); simpl in HH ; - rewrite make_conj_cons in * ; intuition. - rewrite make_conj_cons in *. - tauto. + - simpl in H. + simpl in IHf. + unfold F in H. + revert H. + intros. + apply or_clause_correct. + destruct (or_clause t a) ; simpl in * ; auto. + - + unfold F in H at 1. + revert H. + assert (HH := or_clause_correct t a env). + destruct (or_clause t a); simpl in HH ; + rewrite make_conj_cons in * ; intuition. + rewrite make_conj_cons in *. + tauto. Qed. - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - Qed. + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a) -> eval_cnf env f -> eval_cnf env (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + Qed. Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). Proof. @@ -352,12 +548,11 @@ Set Implicit Arguments. right ; auto. Qed. - Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t. - - Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t. + Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. + Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t. - Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). + Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit) pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (eval env) (if pol then f else N f). Proof. induction f. (* TT *) @@ -385,10 +580,10 @@ Set Implicit Arguments. simpl. destruct pol ; simpl. intros. - apply normalise_correct ; auto. + eapply normalise_correct ; eauto. (* A 2 *) intros. - apply negate_correct ; auto. + eapply negate_correct ; eauto. auto. (* Cj *) destruct pol ; simpl. @@ -462,21 +657,21 @@ Set Implicit Arguments. Variable Witness : Type. - Variable checker : list Term' -> Witness -> bool. + Variable checker : list (Term'*Annot) -> Witness -> bool. - Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. + Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval_tt env) t False. Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := match f with - | nil => true - | e::f => match l with - | nil => false - | c::l => match checker e c with - | true => cnf_checker f l - | _ => false - end - end - end. + | nil => true + | e::f => match l with + | nil => false + | c::l => match checker e c with + | true => cnf_checker f l + | _ => false + end + end + end. Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. @@ -501,22 +696,32 @@ Set Implicit Arguments. Qed. - Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := + Definition tauto_checker (f:@GFormula Term Prop Annot unit) (w:list Witness) : bool := cnf_checker (xcnf true f) w. - Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. + Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (fun x => x) (eval env) t. Proof. unfold tauto_checker. intros. - change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). + change (eval_f (fun x => x) (eval env) t) with (eval_f (fun x => x) (eval env) (if true then t else TT)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. Qed. + Definition eval_bf {A : Type} (ea : A -> Prop) (f: BFormula A) := eval_f (fun x => x) ea f. + + + Lemma eval_bf_map : forall T U (fct: T-> U) env f , + eval_bf env (map_bformula fct f) = eval_bf (fun x => env (fct x)) f. +Proof. + induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. + rewrite <- IHf. auto. +Qed. End S. + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index c888f9af45..8148c7033c 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -33,14 +33,14 @@ Section MakeVarMap. #[universes(template)] Inductive t : Type := | Empty : t - | Leaf : A -> t - | Node : t -> A -> t -> t . + | Elt : A -> t + | Branch : t -> A -> t -> t . Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with | Empty => default - | Leaf i => i - | Node l e r => match p with + | Elt i => i + | Branch l e r => match p with | xH => e | xO p => find l p | xI p => find r p @@ -50,25 +50,25 @@ Section MakeVarMap. Fixpoint singleton (x:positive) (v : A) : t := match x with - | xH => Leaf v - | xO p => Node (singleton p v) default Empty - | xI p => Node Empty default (singleton p v) + | xH => Elt v + | xO p => Branch (singleton p v) default Empty + | xI p => Branch Empty default (singleton p v) end. Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := match m with | Empty => singleton x v - | Leaf vl => + | Elt vl => match x with - | xH => Leaf v - | xO p => Node (singleton p v) vl Empty - | xI p => Node Empty vl (singleton p v) + | xH => Elt v + | xO p => Branch (singleton p v) vl Empty + | xI p => Branch Empty vl (singleton p v) end - | Node l o r => + | Branch l o r => match x with - | xH => Node l v r - | xI p => Node l o (vm_add p v r) - | xO p => Node (vm_add p v l) o r + | xH => Branch l v r + | xI p => Branch l o (vm_add p v r) + | xO p => Branch (vm_add p v l) o r end end. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index 137453a9ed..9ff6850fdf 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -43,48 +43,48 @@ Notation "x < y" := (rlt x y). Lemma req_refl : forall x, req x x. Proof. - destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_). + destruct (SORsetoid sor) as (Equivalence_Reflexive,_,_). apply Equivalence_Reflexive. Qed. Lemma req_sym : forall x y, req x y -> req y x. Proof. - destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_). + destruct (SORsetoid sor) as (_,Equivalence_Symmetric,_). apply Equivalence_Symmetric. Qed. Lemma req_trans : forall x y z, req x y -> req y z -> req x z. Proof. - destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive). + destruct (SORsetoid sor) as (_,_,Equivalence_Transitive). apply Equivalence_Transitive. Qed. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. -exact sor.(SORle_wd). +exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. -exact sor.(SORlt_wd). +exact (SORlt_wd sor). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. @@ -115,7 +115,7 @@ Lemma Zring_morph : 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool gen_order_phi_Z. Proof. -exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). +exact (gen_phiZ_morph (SORsetoid sor) ring_ops_wd (SORrt sor)). Qed. Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. @@ -127,8 +127,8 @@ Qed. Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. Proof. -exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd - (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). +exact (ARgen_phiPOS_Psucc (SORsetoid sor) ring_ops_wd + (Rth_ARth (SORsetoid sor) ring_ops_wd (SORrt sor))). Qed. Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. @@ -142,7 +142,7 @@ Qed. Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. Proof. intros x y H. -do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); +do 2 rewrite (same_genZ (SORsetoid sor) ring_ops_wd (SORrt sor)); destruct x; destruct y; simpl in *; try discriminate. apply phi_pos1_pos. now apply clt_pos_morph. @@ -157,7 +157,7 @@ Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. Proof. unfold Z.leb; intros x y H. case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. -le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. +le_equal. apply (morph_eq Zring_morph). unfold Zeq_bool; now rewrite H1. le_less. now apply clt_morph. discriminate. Qed. @@ -172,5 +172,3 @@ apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. Qed. End InitialMorphism. - - diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index f341a04e03..ab218a1778 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -14,13 +14,14 @@ (* *) (************************************************************************) +Require Import List. +Require Import Bool. Require Import OrderedRing. Require Import RingMicromega. +Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. Require Import ZArith. -Require Import List. -Require Import Bool. (*Declare ML Module "micromega_plugin".*) Ltac flatten_bool := @@ -162,6 +163,8 @@ Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. +Definition pmul := pmul 0 1 Z.add Z.mul Zeq_bool. + Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. Declare Equivalent Keys normZ RingMicromega.norm. @@ -180,6 +183,13 @@ Proof. apply (eval_pol_add Zsor ZSORaddon). Qed. +Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) = eval_pol env lhs * eval_pol env rhs. +Proof. + intros. + apply (eval_pol_mul Zsor ZSORaddon). +Qed. + + Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . Proof. intros. @@ -202,13 +212,13 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) := Require Import Coq.micromega.Tauto BinNums. -Definition normalise (t:Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnormalise t). +Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + List.map (fun x => (x,tg)::nil) (xnormalise t). -Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t. +Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t. Proof. - unfold normalise, xnormalise; cbn -[padd]; intros env t. + unfold normalise, xnormalise; cbn -[padd]; intros T env t tg. rewrite Zeval_formula_compat. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; @@ -236,18 +246,18 @@ Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnegate t). +Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma negate_correct : forall env t, eval_cnf eval_nformula env (negate t) <-> ~ Zeval_formula env t. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. Proof. Proof. Opaque padd. - intros env t. + intros T env t tg. rewrite Zeval_formula_compat. unfold negate, xnegate ; simpl. unfold eval_cnf,eval_clause. - destruct t as [lhs o rhs]; case_eq o; simpl; + destruct t as [lhs o rhs]; case_eq o; unfold eval_tt ; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; @@ -264,9 +274,11 @@ Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. +Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) := + rxcnf Zunsat Zdeduce normalise negate true f. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := - @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZWitness ZWeakChecker f w. + @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. (* To get a complete checker, the proof format has to be enriched *) @@ -326,7 +338,9 @@ Inductive ZArithProof := | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). +(*| ExProof : positive -> positive -> positive -> ZArithProof ExProof z t x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) +. +(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) @@ -600,6 +614,186 @@ Definition valid_cut_sign (op:Op1) := | _ => false end. +Module Vars. + Import FSetPositive. + Include PositiveSet. + + Module Facts := FSetEqProperties.EqProperties(PositiveSet). + + Lemma mem_union_l : forall x s s', + mem x s = true -> + mem x (union s s') = true. + Proof. + intros. + rewrite Facts.union_mem. + rewrite H. reflexivity. + Qed. + + Lemma mem_union_r : forall x s s', + mem x s' = true -> + mem x (union s s') = true. + Proof. + intros. + rewrite Facts.union_mem. + rewrite H. rewrite orb_comm. reflexivity. + Qed. + + Lemma mem_singleton : forall p, + mem p (singleton p) = true. + Proof. + apply Facts.singleton_mem_1. + Qed. + + Lemma mem_elements : forall x v, + mem x v = true <-> List.In x (PositiveSet.elements v). + Proof. + intros. + rewrite Facts.MP.FM.elements_b. + rewrite existsb_exists. + unfold Facts.MP.FM.eqb. + split ; intros. + - destruct H as (x' & IN & EQ). + destruct (PositiveSet.E.eq_dec x x') ; try congruence. + subst ; auto. + - exists x. + split ; auto. + destruct (PositiveSet.E.eq_dec x x) ; congruence. + Qed. + + Definition max_element (vars : t) := + fold Pos.max vars xH. + + Lemma max_element_max : + forall x vars, mem x vars = true -> Pos.le x (max_element vars). + Proof. + unfold max_element. + intros. + rewrite mem_elements in H. + rewrite PositiveSet.fold_1. + set (F := (fun (a : positive) (e : PositiveSet.elt) => Pos.max e a)). + revert H. + assert (((x <= 1 -> x <= fold_left F (PositiveSet.elements vars) 1) + /\ + (List.In x (PositiveSet.elements vars) -> + x <= fold_left F (PositiveSet.elements vars) 1))%positive). + { + revert x. + generalize xH as acc. + induction (PositiveSet.elements vars). + - simpl. tauto. + - simpl. + intros. + destruct (IHl (F acc a) x). + split ; intros. + apply H. + unfold F. + rewrite Pos.max_le_iff. + tauto. + destruct H1 ; subst. + apply H. + unfold F. + rewrite Pos.max_le_iff. + simpl. + left. + apply Pos.le_refl. + tauto. + } + tauto. + Qed. + + Definition is_subset (v1 v2 : t) := + forall x, mem x v1 = true -> mem x v2 = true. + + Lemma is_subset_union_l : forall v1 v2, + is_subset v1 (union v1 v2). + Proof. + unfold is_subset. + intros. + apply mem_union_l; auto. + Qed. + + Lemma is_subset_union_r : forall v1 v2, + is_subset v1 (union v2 v1). + Proof. + unfold is_subset. + intros. + apply mem_union_r; auto. + Qed. + + + End Vars. + + +Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t := + match e with + | PEc _ => Vars.empty + | PEX _ x => Vars.singleton x + | PEadd e1 e2 | PEsub e1 e2 | PEmul e1 e2 => + let v1 := vars_of_pexpr e1 in + let v2 := vars_of_pexpr e2 in + Vars.union v1 v2 + | PEopp c => vars_of_pexpr c + | PEpow e n => vars_of_pexpr e + end. + +Definition vars_of_formula (f : Formula Z) := + match f with + | Build_Formula l o r => + let v1 := vars_of_pexpr l in + let v2 := vars_of_pexpr r in + Vars.union v1 v2 + end. + +Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type} + (F : @GFormula (Formula Z) TX TG ID) : Vars.t := + match F with + | TT => Vars.empty + | FF => Vars.empty + | X p => Vars.empty + | A a t => vars_of_formula a + | Cj f1 f2 | D f1 f2 | I f1 _ f2 => + let v1 := vars_of_bformula f1 in + let v2 := vars_of_bformula f2 in + Vars.union v1 v2 + | Tauto.N f => vars_of_bformula f + end. + +Definition bound_var (v : positive) : Formula Z := + Build_Formula (PEX _ v) OpGe (PEc 0). + +Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := + Build_Formula (PEX _ x) OpEq (PEsub (PEX _ y) (PEX _ t)). + +Section BOUND. + Context {TX TG ID : Type}. + + Variable tag_of_var : positive -> positive -> option bool -> TG. + + Definition bound_vars (fr : positive) + (v : Vars.t) : @GFormula (Formula Z) TX TG ID := + Vars.fold (fun k acc => + let y := (xO (fr + k)) in + let z := (xI (fr + k)) in + Cj + (Cj (A (mk_eq_pos k y z) (tag_of_var fr k None)) + (Cj (A (bound_var y) (tag_of_var fr k (Some false))) + (A (bound_var z) (tag_of_var fr k (Some true))))) + acc) v TT. + + Definition bound_problem (F : @GFormula (Formula Z) TX TG ID) : GFormula := + let v := vars_of_bformula F in + I (bound_vars (Pos.succ (Vars.max_element v)) v) None F. + + + Definition bound_problem_fr (fr : positive) (F : @GFormula (Formula Z) TX TG ID) : GFormula := + let v := vars_of_bformula F in + I (bound_vars fr v) None F. + + +End BOUND. + + + Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false @@ -619,6 +813,10 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end +(* | SplitProof e pf1 pf2 => + match ZChecker ((e,NonStrict)::l) pf1 , ZChecker (( +*) + | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with | Some f1 , Some f2 => @@ -993,26 +1191,299 @@ Proof. apply genCuttingPlaneNone with (2:= H2) ; auto. Qed. + + Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := - @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZArithProof ZChecker f w. + @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w. -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. +Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (fun x => x) (Zeval_formula env) f. Proof. intros f w. unfold ZTautoChecker. - apply (tauto_checker_sound Zeval_formula eval_nformula). - apply Zeval_nformula_dec. - intros until env. + apply tauto_checker_sound with (eval' := eval_nformula). + - apply Zeval_nformula_dec. + - intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). - intros env t. - rewrite normalise_correct ; auto. - intros env t. - rewrite negate_correct ; auto. - intros t w0. - apply ZChecker_sound. + - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). + - + intros env t tg. + rewrite normalise_correct ; auto. + - + intros env t tg. + rewrite negate_correct ; auto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := eval_nformula env). + eapply ZChecker_sound; eauto. + tauto. +Qed. + +Record is_diff_env_elt (fr : positive) (env env' : positive -> Z) (x:positive):= + { + eq_env : env x = env' x; + eq_diff : env x = env' (xO (fr+ x)) - env' (xI (fr + x)); + pos_xO : env' (xO (fr+x)) >= 0; + pos_xI : env' (xI (fr+x)) >= 0; + }. + + +Definition is_diff_env (s : Vars.t) (env env' : positive -> Z) := + let fr := Pos.succ (Vars.max_element s) in + forall x, Vars.mem x s = true -> + is_diff_env_elt fr env env' x. + +Definition mk_diff_env (s : Vars.t) (env : positive -> Z) := + let fr := Vars.max_element s in + fun x => + if Pos.leb x fr + then env x + else + let fr' := Pos.succ fr in + match x with + | xO x => if Z.leb (env (x - fr')%positive) 0 + then 0 else env (x -fr')%positive + | xI x => if Z.leb (env (x - fr')%positive) 0 + then - (env (x - fr')%positive) else 0 + | xH => 0 + end. + +Lemma le_xO : forall x, (x <= xO x)%positive. +Proof. + intros. + change x with (1 * x)%positive at 1. + change (xO x) with (2 * x)%positive. + apply Pos.mul_le_mono. + compute. congruence. + apply Pos.le_refl. +Qed. + +Lemma leb_xO_false : + (forall x y, x <=? y = false -> + xO x <=? y = false)%positive. +Proof. + intros. + rewrite Pos.leb_nle in *. + intro. apply H. + eapply Pos.le_trans ; eauto. + apply le_xO. +Qed. + +Lemma leb_xI_false : + (forall x y, x <=? y = false -> + xI x <=? y = false)%positive. +Proof. + intros. + rewrite Pos.leb_nle in *. + intro. apply H. + eapply Pos.le_trans ; eauto. + generalize (le_xO x). + intros. + eapply Pos.le_trans ; eauto. + change (xI x) with (Pos.succ (xO x))%positive. + apply Pos.lt_le_incl. + apply Pos.lt_succ_diag_r. +Qed. + +Lemma is_diff_env_ex : forall s env, + is_diff_env s env (mk_diff_env s env). +Proof. + intros. + unfold is_diff_env, mk_diff_env. + intros. + assert + ((Pos.succ (Vars.max_element s) + x <=? Vars.max_element s = false)%positive). + { + rewrite Pos.leb_nle. + intro. + eapply (Pos.lt_irrefl (Pos.succ (Vars.max_element s) + x)). + eapply Pos.le_lt_trans ; eauto. + generalize (Pos.lt_succ_diag_r (Vars.max_element s)). + intro. + eapply Pos.lt_trans ; eauto. + apply Pos.lt_add_r. + } + constructor. + - apply Vars.max_element_max in H. + rewrite <- Pos.leb_le in H. + rewrite H. auto. + - + rewrite leb_xO_false by auto. + rewrite leb_xI_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0); ring. + - rewrite leb_xO_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0) eqn:EQ. + apply Z.le_ge. + apply Z.le_refl. + rewrite Z.leb_gt in EQ. + apply Z.le_ge. + apply Z.lt_le_incl. + auto. + - rewrite leb_xI_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0) eqn:EQ. + rewrite Z.leb_le in EQ. + apply Z.le_ge. + apply Z.opp_nonneg_nonpos; auto. + apply Z.le_ge. + apply Z.le_refl. +Qed. + +Lemma env_bounds : forall tg env s, + let fr := Pos.succ (Vars.max_element s) in + exists env', is_diff_env s env env' + /\ + eval_bf (Zeval_formula env') (bound_vars tg fr s). +Proof. + intros. + assert (DIFF:=is_diff_env_ex s env). + exists (mk_diff_env s env). split ; auto. + unfold bound_vars. + rewrite FSetPositive.PositiveSet.fold_1. + revert DIFF. + set (env' := mk_diff_env s env). + intro. + assert (ACC : eval_bf (Zeval_formula env') TT ). + { + simpl. auto. + } + revert ACC. + match goal with + | |- context[@TT ?A ?B ?C ?D] => generalize (@TT A B C D) as acc + end. + unfold is_diff_env in DIFF. + assert (DIFFL : forall x, In x (FSetPositive.PositiveSet.elements s) -> + (x < fr)%positive /\ + is_diff_env_elt fr env env' x). + { + intros. + rewrite <- Vars.mem_elements in H. + split. + apply Vars.max_element_max in H. + unfold fr in *. + eapply Pos.le_lt_trans ; eauto. + apply Pos.lt_succ_diag_r. + apply DIFF; auto. + } + clear DIFF. + match goal with + | |- context[fold_left ?F _ _] => + set (FUN := F) + end. + induction (FSetPositive.PositiveSet.elements s). + - simpl; auto. + - simpl. + intros. + eapply IHl ; eauto. + + intros. apply DIFFL. + simpl ; auto. + + unfold FUN. + simpl. + split ; auto. + assert (HYP : (a < fr /\ is_diff_env_elt fr env env' a)%positive). + { + apply DIFFL. + simpl. tauto. + } + destruct HYP as (LT & DIFF). + destruct DIFF. + rewrite <- eq_env0. + tauto. +Qed. + +Definition agree_env (v : Vars.t) (env env' : positive -> Z) : Prop := + forall x, Vars.mem x v = true -> env x = env' x. + +Lemma agree_env_subset : forall s1 s2 env env', + agree_env s1 env env' -> + Vars.is_subset s2 s1 -> + agree_env s2 env env'. +Proof. + unfold agree_env. + intros. + apply H. apply H0; auto. +Qed. + +Lemma agree_env_union : forall s1 s2 env env', + agree_env (Vars.union s1 s2) env env' -> + agree_env s1 env env' /\ agree_env s2 env env'. +Proof. + split; + eapply agree_env_subset; eauto. + apply Vars.is_subset_union_l. + apply Vars.is_subset_union_r. +Qed. + + + +Lemma agree_env_eval_expr : + forall env env' e + (AGREE : agree_env (vars_of_pexpr e) env env'), + Zeval_expr env e = Zeval_expr env' e. +Proof. + induction e; simpl;intros; + try (apply agree_env_union in AGREE; destruct AGREE); try f_equal ; auto. + - intros ; apply AGREE. + apply Vars.mem_singleton. +Qed. + +Lemma agree_env_eval_bf : + forall env env' f + (AGREE: agree_env (vars_of_bformula f) env env'), + eval_bf (Zeval_formula env') f <-> + eval_bf (Zeval_formula env) f. +Proof. + induction f; simpl; intros ; + try (apply agree_env_union in AGREE; destruct AGREE) ; try intuition fail. + - + unfold Zeval_formula. + destruct t. + simpl in * ; intros. + apply agree_env_union in AGREE ; destruct AGREE. + rewrite <- agree_env_eval_expr with (env:=env) by auto. + rewrite <- agree_env_eval_expr with (e:= Frhs) (env:=env) by auto. + tauto. +Qed. + +Lemma bound_problem_sound : forall tg f, + (forall env' : PolEnv Z, + eval_bf (Zeval_formula env') + (bound_problem tg f)) -> + forall env, + eval_bf (Zeval_formula env) f. +Proof. + intros. + unfold bound_problem in H. + destruct (env_bounds tg env (vars_of_bformula f)) + as (env' & DIFF & EVAL). + simpl in H. + apply H in EVAL. + eapply agree_env_eval_bf ; eauto. + unfold is_diff_env, agree_env in *. + intros. + apply DIFF in H0. + destruct H0. + intuition. +Qed. + + + +Definition ZTautoCheckerExt (f : BFormula (Formula Z)) (w : list ZArithProof) : bool := + ZTautoChecker (bound_problem (fun _ _ _ => tt) f) w. + +Lemma ZTautoCheckerExt_sound : forall f w, ZTautoCheckerExt f w = true -> forall env, eval_bf (Zeval_formula env) f. +Proof. + intros. + unfold ZTautoCheckerExt in H. + specialize (ZTautoChecker_sound _ _ H). + intros ; apply bound_problem_sound with (tg:= fun _ _ _ => tt); auto. Qed. Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := @@ -1028,18 +1499,10 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. -(*Lemma hyps_of_pt_correct : forall pt l, *) - - - - - - Open Scope Z_scope. (** To ease bindings from ml code **) -(*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. @@ -1047,9 +1510,9 @@ Require VarMap. (*Definition varmap_type := VarMap.t Z. *) Definition env := PolEnv Z. -Definition node := @VarMap.Node Z. +Definition node := @VarMap.Branch Z. Definition empty := @VarMap.Empty Z. -Definition leaf := @VarMap.Leaf Z. +Definition leaf := @VarMap.Elt Z. Definition coneMember := ZWitness. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index af292c088f..3f9f4726e7 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -19,7 +19,6 @@ let debug = false -open Util open Big_int open Num open Polynomial @@ -31,6 +30,16 @@ module C2Ml = Mutils.CoqToCaml let use_simplex = ref true +type ('prf,'model) res = + | Prf of 'prf + | Model of 'model + | Unknown + +type zres = (Mc.zArithProof , (int * Mc.z list)) res + +type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res + + open Mutils type 'a number_spec = { bigint_to_number : big_int -> 'a; @@ -181,7 +190,7 @@ let build_dual_linear_system l = {coeffs = Vect.from_list ([Big_int zero_big_int ;Big_int unit_big_int]) ; op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@c::s0) - +open Util (** [direct_linear_prover l] does not handle strict inegalities *) let fourier_linear_prover l = @@ -201,11 +210,11 @@ let direct_linear_prover l = else fourier_linear_prover l let find_point l = - if !use_simplex - then Simplex.find_point l - else match Mfourier.Fourier.find_point l with - | Inr _ -> None - | Inl cert -> Some cert + if !use_simplex + then Simplex.find_point l + else match Mfourier.Fourier.find_point l with + | Inr _ -> None + | Inl cert -> Some cert let optimise v l = if !use_simplex @@ -253,9 +262,6 @@ let simple_linear_prover l = (* Fourier elimination should handle > *) dual_raw_certificate l -open ProofFormat - - let env_of_list l = snd (List.fold_left (fun (i,m) p -> (i+1,IMap.add i p m)) (0,IMap.empty) l) @@ -268,7 +274,7 @@ let linear_prover_cstr sys = match simple_linear_prover sysi with | None -> None - | Some cert -> Some (proof_of_farkas (env_of_list prfi) cert) + | Some cert -> Some (ProofFormat.proof_of_farkas (env_of_list prfi) cert) let linear_prover_cstr = if debug @@ -301,15 +307,14 @@ let develop_constraint z_spec (e,k) = - 0 = c for c a non-zero constant - e = c when the coeffs of e are all integers and c is rational *) -open ProofFormat type checksat = | Tauto (* Tautology *) - | Unsat of prf_rule (* Unsatisfiable *) - | Cut of cstr * prf_rule (* Cutting plane *) - | Normalise of cstr * prf_rule (* Coefficients may be normalised i.e relatively prime *) + | Unsat of ProofFormat.prf_rule (* Unsatisfiable *) + | Cut of cstr * ProofFormat.prf_rule (* Cutting plane *) + | Normalise of cstr * ProofFormat.prf_rule (* Coefficients may be normalised i.e relatively prime *) -exception FoundProof of prf_rule +exception FoundProof of ProofFormat.prf_rule (** [check_sat] @@ -336,17 +341,17 @@ let check_int_sat (cstr,prf) = coeffs = Vect.div gcd coeffs; op = op ; cst = cst // gcd } in - Normalise(cstr,Gcd(gcdi,prf)) + Normalise(cstr,ProofFormat.Gcd(gcdi,prf)) (* Normalise(cstr,CutPrf prf)*) end else match op with - | Eq -> Unsat (CutPrf prf) + | Eq -> Unsat (ProofFormat.CutPrf prf) | Ge -> let cstr = { coeffs = Vect.div gcd coeffs; op = op ; cst = ceiling_num (cst // gcd) - } in Cut(cstr,CutPrf prf) + } in Cut(cstr,ProofFormat.CutPrf prf) | Gt -> failwith "check_sat : Unexpected operator" @@ -363,29 +368,6 @@ let apply_and_normalise check f psys = ) [] psys -let simplify f sys = - let (sys',b) = - List.fold_left (fun (sys',b) c -> - match f c with - | None -> (c::sys',b) - | Some c' -> - (c'::sys',true) - ) ([],false) sys in - if b then Some sys' else None - -let saturate f sys = - List.fold_left (fun sys' c -> match f c with - | None -> sys' - | Some c' -> c'::sys' - ) [] sys - -let is_substitution strict ((p,o),prf) = - let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in - - match o with - | Eq -> LinPoly.search_linear pred p - | _ -> None - let is_linear_for v pc = LinPoly.is_linear (fst (fst pc)) || LinPoly.is_linear_for v (fst (fst pc)) @@ -393,11 +375,11 @@ let is_linear_for v pc = -let non_linear_pivot sys pc v pc' = +(*let non_linear_pivot sys pc v pc' = if LinPoly.is_linear (fst (fst pc')) then None (* There are other ways to deal with those *) else WithProof.linear_pivot sys pc v pc' - + *) let is_linear_substitution sys ((p,o),prf) = let pred v = v =/ Int 1 || v =/ Int (-1) in @@ -423,7 +405,33 @@ let elim_simple_linear_equality sys0 = iterate_until_stable elim sys0 -let saturate_linear_equality_non_linear sys0 = + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let subst sys = + let sys' = WithProof.subst sys in + if debug then Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + sys' + + + +(** [saturate_linear_equality sys] generate new constraints + obtained by eliminating linear equalities by pivoting. + For integers, the obtained constraints are sound but not complete. + *) + let saturate_by_linear_equalities sys0 = + WithProof.saturate_subst false sys0 + + +let saturate_by_linear_equalities sys = + let sys' = saturate_by_linear_equalities sys in + if debug then Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + sys' + + + +(* let saturate_linear_equality_non_linear sys0 = let (l,_) = extract_all (is_substitution false) sys0 in let rec elim l acc = match l with @@ -432,18 +440,51 @@ let saturate_linear_equality_non_linear sys0 = let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in elim l' (nc@acc) in elim l [] + *) +let bounded_vars (sys: WithProof.t list) = + let l = (fst (extract_all (fun ((p,o),prf) -> + LinPoly.is_variable p + ) sys)) in + List.fold_left (fun acc (i,wp) -> IMap.add i wp acc) IMap.empty l + +let rec power n p = + if n = 1 then p + else WithProof.product p (power (n-1) p) + +let bound_monomial mp m = + if Monomial.is_var m || Monomial.is_const m + then None + else + try + Some (Monomial.fold + (fun v i acc -> + let wp = IMap.find v mp in + WithProof.product (power i wp) acc) m (WithProof.const (Int 1)) + ) + with Not_found -> None + + +let bound_monomials (sys:WithProof.t list) = + let mp = bounded_vars sys in + let m = + List.fold_left (fun acc ((p,_),_) -> + Vect.fold (fun acc v _ -> let m = LinPoly.MonT.retrieve v in + match bound_monomial mp m with + | None -> acc + | Some r -> IMap.add v r acc) acc p) IMap.empty sys in + IMap.fold (fun _ e acc -> e::acc) m [] let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth ; let sys = List.map (develop_constraint n_spec) sys in - List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),Hyp i)) sys + List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),ProofFormat.Hyp i)) sys let square_of_var i = let x = LinPoly.var i in - ((LinPoly.product x x,Ge),(Square x)) + ((LinPoly.product x x,Ge),(ProofFormat.Square x)) (** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. @@ -462,7 +503,7 @@ let nlinear_preprocess (sys:WithProof.t list) = let sys = MonMap.fold (fun s m acc -> let s = LinPoly.of_monomial s in let m = LinPoly.of_monomial m in - ((m, Ge), (Square s))::acc) collect_square sys in + ((m, Ge), (ProofFormat.Square s))::acc) collect_square sys in let collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in @@ -482,16 +523,16 @@ let nlinear_preprocess (sys:WithProof.t list) = let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in - let sys2 = saturate_linear_equality_non_linear sys1 in + let sys2 = saturate_by_linear_equalities sys1 in let sys = nlinear_preprocess sys1@sys2 in let sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in let id = (List.fold_left (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in let env = CList.interval 0 id in match linear_prover_cstr sys with - | None -> None + | None -> Unknown | Some cert -> - Some (cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) + Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) let linear_prover_with_cert prfdepth sys = @@ -500,9 +541,9 @@ let linear_prover_with_cert prfdepth sys = let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in match linear_prover_cstr sys with - | None -> None + | None -> Unknown | Some cert -> - Some (cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) + Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) (* The prover is (probably) incomplete -- only searching for naive cutting planes *) @@ -643,7 +684,7 @@ open Polynomial -type prf_sys = (cstr * prf_rule) list +type prf_sys = (cstr * ProofFormat.prf_rule) list @@ -661,7 +702,7 @@ let pivot v (c1,p1) (c2,p2) = op = opAdd op1 op2 ; cst = n1 */ cv1 +/ n2 */ cv2 }, - AddPrf(mul_cst_proof cv1 p1,mul_cst_proof cv2 p2)) in + ProofFormat.add_proof (ProofFormat.mul_cst_proof cv1 p1) (ProofFormat.mul_cst_proof cv2 p2)) in match Vect.get v v1 , Vect.get v v2 with | Int 0 , _ | _ , Int 0 -> None @@ -747,7 +788,7 @@ let reduce_coprime psys = op = Eq ; cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) } in - let prf = add_proof (mul_cst_proof l1' p1) (mul_cst_proof l2' p2) in + let prf = ProofFormat.add_proof (ProofFormat.mul_cst_proof l1' p1) (ProofFormat.mul_cst_proof l2' p2) in Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) @@ -798,7 +839,7 @@ let reduce_var_change psys = let m = minus_num (vx */ l1 +/ vx' */ l2) in Some ({coeffs = Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , - AddPrf(MulC((LinPoly.constant m),p),p')) in + ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p') in Some (apply_and_normalise check_int_sat pivot_eq sys) @@ -871,40 +912,42 @@ let get_bound sys = let check_sys sys = List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys +open ProofFormat let xlia (can_enum:bool) reduction_equations sys = - let rec enum_proof (id:int) (sys:prf_sys) : ProofFormat.proof option = + let rec enum_proof (id:int) (sys:prf_sys) = if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; assert (check_sys sys) ; let nsys,prf = List.split sys in match get_bound nsys with - | None -> None (* Is the systeme really unbounded ? *) + | None -> Unknown (* Is the systeme really unbounded ? *) | Some(prf1,(lb,e,ub),prf2) -> if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e (string_of_num lb) (string_of_num ub) ; (match start_enum id e (ceiling_num lb) (floor_num ub) sys with - | Some prfl -> - Some(Enum(id,proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e, - proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl)) - | None -> None + | Prf prfl -> + Prf(ProofFormat.Enum(id,ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e, + ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl)) + | _ -> Unknown ) - and start_enum id e clb cub sys = + and start_enum id e clb cub sys = if clb >/ cub - then Some [] + then Prf [] else let eq = {coeffs = e ; op = Eq ; cst = clb} in - match aux_lia (id+1) ((eq, Def id) :: sys) with - | None -> None - | Some prf -> + match aux_lia (id+1) ((eq, ProofFormat.Def id) :: sys) with + | Unknown | Model _ -> Unknown + | Prf prf -> match start_enum id e (clb +/ (Int 1)) cub sys with - | None -> None - | Some l -> Some (prf::l) + | Prf l -> Prf (prf::l) + | _ -> Unknown - and aux_lia (id:int) (sys:prf_sys) : ProofFormat.proof option = + + and aux_lia (id:int) (sys:prf_sys) = assert (check_sys sys) ; if debug then Printf.printf "xlia: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; try @@ -912,11 +955,11 @@ let xlia (can_enum:bool) reduction_equations sys = if debug then Printf.printf "after reduction: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; match linear_prover_cstr sys with - | Some prf -> Some (Step(id,prf,Done)) - | None -> if can_enum then enum_proof id sys else None + | Some prf -> Prf (Step(id,prf,Done)) + | None -> if can_enum then enum_proof id sys else Unknown with FoundProof prf -> (* [reduction_equations] can find a proof *) - Some(Step(id,prf,Done)) in + Prf(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) let id = 1 + (List.fold_left @@ -925,10 +968,10 @@ let xlia (can_enum:bool) reduction_equations sys = try let sys = simpl_sys sys in aux_lia id sys - with FoundProof pr -> Some(Step(id,pr,Done)) in + with FoundProof pr -> Prf(Step(id,pr,Done)) in match orpf with - | None -> None - | Some prf -> + | Unknown | Model _ -> Unknown + | Prf prf -> let env = CList.interval 0 (id - 1) in if debug then begin Printf.fprintf stdout "direct proof %a\n" output_proof prf; @@ -939,21 +982,25 @@ let xlia (can_enum:bool) reduction_equations sys = if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) - *) Some prf + *) Prf prf -let xlia_simplex env sys = - match Simplex.integer_solver sys with - | None -> None - | Some prf -> - (*let _ = ProofFormat.eval_proof (env_of_list env) prf in *) +let xlia_simplex env red sys = + let compile_prf sys prf = + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let env = CList.interval 0 (id - 1) in + Prf (compile_proof env prf) in - let id = 1 + (List.fold_left - (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in - let env = CList.interval 0 (id - 1) in - Some (compile_proof env prf) + try + let sys = red sys in + + match Simplex.integer_solver sys with + | None -> Unknown + | Some prf -> compile_prf sys prf + with FoundProof prf -> compile_prf sys (Step(0,prf,Done)) let xlia env0 en red sys = - if !use_simplex then xlia_simplex env0 sys + if !use_simplex then xlia_simplex env0 red sys else xlia en red sys @@ -971,9 +1018,9 @@ let gen_bench (tac, prover) can_enum prfdepth sys = Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; begin match res with - | None -> + | Unknown | Model _ -> Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac - | Some res -> + | Prf res -> Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac end ; @@ -987,7 +1034,14 @@ let lia (can_enum:bool) (prfdepth:int) sys = if debug then begin Printf.fprintf stdout "Input problem\n"; List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "Input problem\n"; + let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" in + List.iter (fun ((p,op),_) -> Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt p) sys; end; + let sys = subst sys in + let bnd = bound_monomials sys in (* To deal with non-linear monomials *) + let sys = bnd@(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' @@ -1013,7 +1067,7 @@ let nlia enum prfdepth sys = It would only be safe if the variable is linear... *) let sys1 = elim_simple_linear_equality sys in - let sys2 = saturate_linear_equality_non_linear sys1 in + let sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1@sys2) in let sys4 = make_cstr_system ((*sys2@*)sys3) in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index e925f1bc5e..3428428441 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -15,6 +15,15 @@ module Mc = Micromega If set, use the Simplex method, otherwise use Fourier *) val use_simplex : bool ref +type ('prf,'model) res = + | Prf of 'prf + | Model of 'model + | Unknown + +type zres = (Mc.zArithProof , (int * Mc.z list)) res + +type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res + (** [dump_file] is bound to the Coq option Dump Arith. If set to some [file], arithmetic goals are dumped in filexxx.v *) val dump_file : string option ref @@ -27,16 +36,16 @@ val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz (** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys]. If the Simplex option is set, any failure to find a proof should be considered as a bug. *) -val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incomplete -- the problem is undecidable *) -val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys]. Over the rationals, the solver is complete. *) -val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Micromega.psatz option +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incompete -- the problem is decidable. *) -val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Mc.psatz option +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7db47e13a5..ef6af16036 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -14,7 +14,7 @@ (* *) (* - Modules M, Mc, Env, Cache, CacheZ *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-2019 *) (* *) (************************************************************************) @@ -103,6 +103,7 @@ let () = *) type tag = Tag.t +module Mc = Micromega (** * An atom is of the form: @@ -111,205 +112,30 @@ type tag = Tag.t * parametrized by 'cst, which is used as the type of constants. *) -type 'cst atom = 'cst Micromega.formula +type 'cst atom = 'cst Mc.formula -(** - * Micromega's encoding of formulas. - * By order of appearance: boolean constants, variables, atoms, conjunctions, - * disjunctions, negation, implication. -*) - -type 'cst formula = - | TT - | FF - | X of EConstr.constr - | A of 'cst atom * tag * EConstr.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.Id.t option * 'cst formula +type 'cst formula = ('cst atom, EConstr.constr,tag * EConstr.constr,Names.Id.t) Mc.gFormula -(** - * Formula pretty-printer. - *) +type 'cst clause = ('cst Mc.nFormula, tag * EConstr.constr) Mc.clause +type 'cst cnf = ('cst Mc.nFormula, tag * EConstr.constr) Mc.cnf -let rec pp_formula o f = + +let rec pp_formula o (f:'cst formula) = + Mc.( match f with | TT -> output_string o "tt" | FF -> output_string o "ff" | X c -> output_string o "X " - | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t - | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 + | A(_,(t,_)) -> Printf.fprintf o "A(%a)" Tag.pp t + | Cj(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 + | I(f1,n,f2) -> Printf.fprintf o "I(%a,%s,%a)" + pp_formula f1 + (match n with + | Some id -> Names.Id.to_string id + | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - - -let rec map_atoms fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X x - | A (at,tg,cstr) -> A(fct at,tg,cstr) - | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) - | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) - | N f -> N(map_atoms fct f) - | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) - -let rec map_prop fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X (fct x) - | A (at,tg,cstr) -> A(at,tg,cstr) - | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) - | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) - | N f -> N(map_prop fct f) - | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) - -(** - * Collect the identifiers of a (string of) implications. Implication labels - * are inherited from Coq/CoC's higher order dependent type constructor (Pi). - *) - -let rec ids_of_formula f = - match f with - | I(f1,Some id,f2) -> id::(ids_of_formula f2) - | _ -> [] - -(** - * A clause is a list of (tagged) nFormulas. - * nFormulas are normalized formulas, i.e., of the form: - * cPol \{=,<>,>,>=\} 0 - * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). - *) - -type 'cst clause = ('cst Micromega.nFormula * tag) list - -(** - * A CNF is a list of clauses. - *) - -type 'cst cnf = ('cst clause) list - -(** - * True and False are empty cnfs and clauses. - *) - -let tt : 'cst cnf = [] - -let ff : 'cst cnf = [ [] ] - -(** - * A refinement of cnf with tags left out. This is an intermediary form - * between the cnf tagged list representation ('cst cnf) used to solve psatz, - * and the freeform formulas ('cst formula) that is retrieved from Coq. - *) - -module Mc = Micromega - -type 'cst mc_cnf = ('cst Mc.nFormula) list list - -(** - * From a freeform formula, build a cnf. - * The parametric functions negate and normalize are theory-dependent, and - * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v - * and RingMicromega.v). - *) - -type 'a tagged_option = T of tag list | S of 'a - -let cnf - (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) - (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = - - let negate a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in - - let normalise a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in - - let and_cnf x y = x @ y in - -let rec add_term t0 = function - | [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then T [snd t0] else S (t0::[]) - | None -> S (t0::[])) - | t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then T [snd t0 ; snd t'] - else (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l) - | None -> - (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l)) in - - - let rec or_clause cl1 cl2 = - match cl1 with - | [] -> S cl2 - | t0::cl -> - (match add_term t0 cl2 with - | S cl' -> or_clause cl cl' - | T l -> T l) in - - - - let or_clause_cnf t f = - List.fold_right (fun e (acc,tg) -> - match or_clause t e with - | S cl -> (cl :: acc,tg) - | T l -> (acc,tg@l)) f ([],[]) in - - - let rec or_cnf f f' = - match f with - | [] -> tt,[] - | e :: rst -> - let (rst_f',t) = or_cnf rst f' in - let (e_f', t') = or_clause_cnf e f' in - (rst_f' @ e_f', t @ t') in - - - let rec xcnf (polarity : bool) f = - match f with - | TT -> if polarity then (tt,[]) else (ff,[]) - | FF -> if polarity then (ff,[]) else (tt,[]) - | X p -> if polarity then (ff,[]) else (ff,[]) - | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) - | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then and_cnf e1 e2, t1 @ t2 - else let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - | D(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 - | I(e1,_,e2) -> - let e1 , t1 = (xcnf (not polarity) e1) in - let e2 , t2 = (xcnf polarity e2) in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 in - - xcnf true f + ) (** @@ -344,10 +170,11 @@ struct let mic_modules = [ ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; + ["Coq"; "micromega";"ZMicromega"]; + ["Coq"; "micromega";"Tauto"]; + ["Coq"; "micromega"; "DeclConstant"]; + ["Coq"; "micromega";"RingMicromega"]; + ["Coq"; "micromega";"EnvRing"]; ["Coq"; "micromega"; "ZMicromega"]; ["Coq"; "micromega"; "RMicromega"]; ["Coq" ; "micromega" ; "Tauto"]; @@ -405,6 +232,15 @@ struct let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") + let coq_nat = lazy (init_constant "nat") + let coq_unit = lazy (init_constant "unit") + (* let coq_option = lazy (init_constant "option")*) + let coq_None = lazy (init_constant "None") + let coq_tt = lazy (init_constant "tt") + let coq_Inl = lazy (init_constant "inl") + let coq_Inr = lazy (init_constant "inr") + + let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") @@ -431,6 +267,7 @@ struct let coq_CPlus = lazy (m_constant "CPlus") let coq_CMinus = lazy (m_constant "CMinus") let coq_CMult = lazy (m_constant "CMult") + let coq_CPow = lazy (m_constant "CPow") let coq_CInv = lazy (m_constant "CInv") let coq_COpp = lazy (m_constant "COpp") @@ -477,6 +314,7 @@ struct let coq_Rmult = lazy (r_constant "Rmult") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") + let coq_powerZR = lazy (r_constant "powerRZ") let coq_IZR = lazy (r_constant "IZR") let coq_IQR = lazy (r_constant "Q2R") @@ -508,6 +346,8 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_GT = lazy (m_constant "GT") + let coq_TT = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") @@ -615,6 +455,22 @@ struct | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) + (** [is_ground_term env sigma term] holds if the term [term] + is an instance of the typeclass [DeclConstant.GT term] + i.e. built from user-defined constants and functions. + NB: This mechanism is used to customise the reification process to decide + what to consider as a constant (see [parse_constant]) + *) + + let is_ground_term env sigma term = + let typ = Retyping.get_type_of env sigma term in + try + ignore (Typeclasses.resolve_one_typeclass env sigma (EConstr.mkApp(Lazy.force coq_GT,[| typ;term|]))) ; + true + with + | Not_found -> false + + let parse_z sigma term = let (i,c) = get_left_construct sigma term in match i with @@ -652,6 +508,7 @@ struct | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y + | Mc.CPow(x,y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t @@ -665,6 +522,11 @@ struct | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) + | Mc.CPow(x,y) -> EConstr.mkApp(Lazy.force coq_CPow, [| dump_Rcst x ; + match y with + | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_Inl,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_z z|]) + | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Inr,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_nat n|]) + |]) | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) @@ -718,9 +580,18 @@ struct | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e - let pp_cnf pp_c o f = - let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in - List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f +(* let pp_clause pp_c o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *) + + let pp_clause_tag o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f + +(* let pp_cnf pp_c o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *) + + let pp_cnf_tag o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause_tag l) f + let dump_psatz typ dump_z e = let z = Lazy.force typ in @@ -842,34 +713,74 @@ struct module Env = struct - let compute_rank_add env sigma v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if EConstr.eq_constr_nounivs sigma e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.positive n) - let get_rank env sigma v = + type t = { + vars : EConstr.t list ; + (* The list represents a mapping from EConstr.t to indexes. *) + gl : gl; + (* The evar_map may be updated due to unification of universes *) + } + + let empty gl = + { + vars = []; + gl = gl + } + + + (** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *) + let eq_constr gl x y = + let evd = gl.sigma in + match EConstr.eq_constr_universes gl.env evd x y with + | Some csts -> + let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in + begin + match Evd.add_constraints evd csts with + | evd -> Some {gl with sigma = evd} + | exception Univ.UniverseInconsistency _ -> None + end + | None -> None + + let compute_rank_add env v = + let rec _add gl vars n v = + match vars with + | [] -> (gl, [v] ,n) + | e::l -> + match eq_constr gl e v with + | Some gl' -> (gl', vars , n) + | None -> + let (gl,l',n) = _add gl l ( n+1) v in + (gl,e::l',n) in + let (gl',vars', n) = _add env.gl env.vars 1 v in + ({vars=vars';gl=gl'}, CamlToCoq.positive n) + + let get_rank env v = + let evd = env.gl.sigma in let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if EConstr.eq_constr sigma e v + if EConstr.eq_constr evd e v then n else _get_rank l (n+1) in - _get_rank env 1 + _get_rank env.vars 1 - - let empty = [] + let elements env = env.vars - let elements env = env +(* let string_of_env gl env = + let rec string_of_env i env acc = + match env with + | [] -> acc + | e::env -> string_of_env (i+1) env + (IMap.add i + (Pp.string_of_ppcmds + (Printer.pr_econstr_env gl.env gl.sigma e)) acc) in + string_of_env 1 env IMap.empty + *) + let pp gl env = + let ppl = List.mapi (fun i e -> Pp.str "x" ++ Pp.int (i+1) ++ Pp.str ":" ++ Printer.pr_econstr_env gl.env gl.sigma e)env in + List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p ) ppl (Pp.str "\n") end (* MODULE END: Env *) @@ -877,20 +788,13 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr cenv sigma parse_constant parse_exp ops_spec env term = + let parse_expr gl parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env cenv sigma term); + then ( + Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term)); -(* - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in -*) let parse_variable env term = - let (env,n) = Env.compute_rank_add env sigma term in + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in let rec parse_expr env term = @@ -899,32 +803,32 @@ struct let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in - try (Mc.PEc (parse_constant term) , env) + try (Mc.PEc (parse_constant gl term) , env) with ParseError -> - match EConstr.kind sigma term with + match EConstr.kind gl.sigma term with | App(t,args) -> ( - match EConstr.kind sigma t with + match EConstr.kind gl.sigma t with | Const c -> - ( match assoc_ops sigma t ops_spec with + ( match assoc_ops gl.sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin + | Opp -> let (expr,env) = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> + begin try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in - (power , env) + (power , env) with e when CErrors.noncritical e -> (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - ) + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + end + | Ukn s -> + if debug + then (Printf.printf "unknown op: %s\n" s; flush stdout;); + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + ) | _ -> parse_variable env term ) | _ -> parse_variable env term in @@ -954,9 +858,23 @@ struct coq_Ropp , Opp ; coq_Rpower , Power] - let zconstant = parse_z - let qconstant = parse_q + (** [parse_constant parse gl t] returns the reification of term [t]. + If [t] is a ground term, then it is first reduced to normal form + before using a 'syntactic' parser *) + let parse_constant parse gl t = + if is_ground_term gl.env gl.sigma t + then + parse gl.sigma (Redexpr.cbv_vm gl.env gl.sigma t) + else raise ParseError + + let zconstant = parse_constant parse_z + let qconstant = parse_constant parse_q + let nconstant = parse_constant parse_nat + (* NB: R is a different story. + Because it is axiomatised, reducing would not be effective. + Therefore, there is a specific parser for constant over R + *) let rconst_assoc = [ @@ -966,60 +884,69 @@ struct (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] - let rec rconstant sigma term = - match EConstr.kind sigma term with - | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 + let rconstant gl term = + + let sigma = gl.sigma in + + let rec rconstant term = + match EConstr.kind sigma term with + | Const x -> + if EConstr.eq_constr sigma term (Lazy.force coq_R0) + then Mc.C0 else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant sigma args.(0) in - let b = rconstant sigma args.(1) in - f a b - with + then Mc.C1 + else raise ParseError + | App(op,args) -> + begin + try + (* the evaluation order is important in the following *) + let f = assoc_const sigma op rconst_assoc in + let a = rconstant args.(0) in + let b = rconstant args.(1) in + f a b + with ParseError -> match op with | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant sigma args.(0) in + let arg = rconstant args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> + Mc.CPow(rconstant args.(0) , Mc.Inr (nconstant gl args.(1))) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> + Mc.CQ (qconstant gl args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> + Mc.CZ (zconstant gl args.(0)) | _ -> raise ParseError end + | _ -> raise ParseError in - | _ -> raise ParseError + rconstant term - let rconstant env sigma term = + let rconstant gl term = if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); - let res = rconstant sigma term in + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ()); + let res = rconstant gl term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res - let parse_zexpr env sigma = parse_expr env sigma - (zconstant sigma) + let parse_zexpr gl = parse_expr gl + zconstant (fun expr x -> - let exp = (parse_z sigma x) in + let exp = (zconstant gl x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr env sigma = parse_expr env sigma - (qconstant sigma) + let parse_qexpr gl = parse_expr gl + qconstant (fun expr x -> - let exp = parse_z sigma x in + let exp = zconstant gl x in match exp with | Mc.Zneg _ -> begin @@ -1031,10 +958,10 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr env sigma = parse_expr env sigma - (rconstant env sigma) + let parse_rexpr gl = parse_expr gl + rconstant (fun expr x -> - let exp = Mc.N.of_nat (parse_nat sigma x) in + let exp = Mc.N.of_nat (parse_nat gl.sigma x) in Mc.PEpow(expr,exp)) rop_spec @@ -1045,8 +972,8 @@ struct match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr gl.env sigma env lhs in - let (e2,env) = parse_expr gl.env sigma env rhs in + let (e1,env) = parse_expr gl env lhs in + let (e2,env) = parse_expr gl env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" @@ -1058,14 +985,14 @@ struct (* generic parsing of arithmetic expressions *) - let mkC f1 f2 = C(f1,f2) - let mkD f1 f2 = D(f1,f2) - let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) - let mkI f1 f2 = I(f1,None,f2) + let mkC f1 f2 = Mc.Cj(f1,f2) + let mkD f1 f2 = Mc.D(f1,f2) + let mkIff f1 f2 = Mc.Cj(Mc.I(f1,None,f2),Mc.I(f2,None,f1)) + let mkI f1 f2 = Mc.I(f1,None,f2) let mkformula_binary g term f1 f2 = match f1 , f2 with - | X _ , X _ -> X(term) + | Mc.X _ , Mc.X _ -> Mc.X(term) | _ -> g f1 f2 (** @@ -1078,8 +1005,8 @@ struct let parse_atom env tg t = try let (at,env) = parse_atom env t gl in - (A(at,tg,t), env,Tag.next tg) - with e when CErrors.noncritical e -> (X(t),env,tg) in + (Mc.A(at,(tg,t)), env,Tag.next tg) + with e when CErrors.noncritical e -> (Mc.X(t),env,tg) in let is_prop term = let sort = Retyping.get_sort_of gl.env gl.sigma term in @@ -1098,7 +1025,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) + let (f,env,tg) = xparse_formula env tg a in (Mc.N(f), env,tg) | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in @@ -1108,36 +1035,41 @@ struct let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) - | _ when is_prop term -> X(term),env,tg + | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (Mc.TT,env,tg) + | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> Mc.(FF,env,tg) + | _ when is_prop term -> Mc.X(term),env,tg | _ -> raise ParseError in xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = - let rec xdump f = + let app_ctor c args = + EConstr.mkApp(Lazy.force c, Array.of_list (typ::EConstr.mkProp::Lazy.force coq_unit :: Lazy.force coq_unit :: args)) in + + let rec xdump f = match f with - | TT -> EConstr.mkApp(Lazy.force coq_TT,[|typ|]) - | FF -> EConstr.mkApp(Lazy.force coq_FF,[|typ|]) - | C(x,y) -> EConstr.mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) - | I(x,_,y) -> EConstr.mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) - | N(x) -> EConstr.mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) - | A(x,_,_) -> EConstr.mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) - | X(t) -> EConstr.mkApp(Lazy.force coq_X,[|typ ; t|]) in + | Mc.TT -> app_ctor coq_TT [] + | Mc.FF -> app_ctor coq_FF [] + | Mc.Cj(x,y) -> app_ctor coq_And [xdump x ; xdump y] + | Mc.D(x,y) -> app_ctor coq_Or [xdump x ; xdump y] + | Mc.I(x,_,y) -> app_ctor coq_Impl [xdump x ; EConstr.mkApp(Lazy.force coq_None,[|Lazy.force coq_unit|]); xdump y] + | Mc.N(x) -> app_ctor coq_Neg [xdump x] + | Mc.A(x,_) -> app_ctor coq_Atom [dump_atom x;Lazy.force coq_tt] + | Mc.X(t) -> app_ctor coq_X [t] in xdump f - let prop_env_of_formula sigma form = + let prop_env_of_formula gl form = + Mc.( let rec doit env = function - | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env sigma t) - | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> + | TT | FF | A(_,_) -> env + | X t -> fst (Env.compute_rank_add env t) + | Cj(f1,f2) | D(f1,f2) | I(f1,_,f2) -> doit (doit env f1) f2 - | N f -> doit env f in + | N f -> doit env f + in - doit [] form + doit (Env.empty gl) form) let var_env_of_formula form = @@ -1151,14 +1083,14 @@ struct let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - + Mc.( let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,t,c) -> vars_of_atom a - | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) + | TT | FF | X _ -> ISet.empty + | A (a,(t,c)) -> vars_of_atom a + | Cj(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) | N f -> doit f in - doit form + doit form) @@ -1211,6 +1143,12 @@ let rec dump_Rcst_as_R cst = | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CPow(x,y) -> + begin + match y with + | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_powerZR,[| dump_Rcst_as_R x ; dump_z z|]) + | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Rpower,[| dump_Rcst_as_R x ; dump_nat n|]) + end | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) @@ -1246,17 +1184,17 @@ let prodn n env b = in prodrec (n,env,b) -let make_goal_of_formula sigma dexpr form = +let make_goal_of_formula gl dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - let props = prop_env_of_formula sigma form in + let props = prop_env_of_formula gl form in let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) props in + let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) (Env.elements props) in let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in @@ -1287,14 +1225,14 @@ let make_goal_of_formula sigma dexpr form = let rec xdump pi xi f = match f with - | TT -> Lazy.force coq_True - | FF -> Lazy.force coq_False - | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) - | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props sigma t in + | Mc.TT -> Lazy.force coq_True + | Mc.FF -> Lazy.force coq_False + | Mc.Cj(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) + | Mc.D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) + | Mc.I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) + | Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) + | Mc.A(x,_) -> dump_cstr xi x + | Mc.X(t) -> let idx = Env.get_rank props t in EConstr.mkRel (pi+idx) in let nb_vars = List.length vars_n in @@ -1303,10 +1241,10 @@ let make_goal_of_formula sigma dexpr form = (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) let subst_prop p = - let idx = Env.get_rank props sigma p in + let idx = Env.get_rank props p in EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - let form' = map_prop subst_prop form in + let form' = Mc.mapX subst_prop form in (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) @@ -1335,12 +1273,12 @@ end (** open M -let coq_Node = +let coq_Branch = lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Branch") +let coq_Elt = lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt") let coq_Empty = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") @@ -1353,9 +1291,9 @@ let coq_VarMap = let rec dump_varmap typ m = match m with | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Leaf v -> EConstr.mkApp(Lazy.force coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) + | Mc.Elt v -> EConstr.mkApp(Lazy.force coq_Elt,[| typ; v|]) + | Mc.Branch(l,o,r) -> + EConstr.mkApp (Lazy.force coq_Branch, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) let vm_of_list env = @@ -1425,7 +1363,9 @@ let rec parse_hyps gl parse_arith env tg hyps = (*exception ParseError*) -let parse_goal gl parse_arith env hyps term = + + +let parse_goal gl parse_arith (env:Env.t) hyps term = (* try*) let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in @@ -1459,6 +1399,40 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } +let max_tag f = 1 + (Tag.to_int (Mc.foldA (fun t1 (t2,_) -> Tag.max t1 t2) f (Tag.from 0))) + + +(** For completeness of the cutting-plane procedure, + each variable 'x' is replaced by 'y' - 'z' where + 'y' and 'z' are positive *) +let pre_processZ mt f = + + let x0 i = 2 * i in + let x1 i = 2 * i + 1 in + + let tag_of_var fr p b = + + let ip = CoqToCaml.positive fr + (CoqToCaml.positive p) in + + match b with + | None -> + let y = Mc.XO (Mc.Coq_Pos.add fr p) in + let z = Mc.XI (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x0 (x0 ip)) in + let constr = Mc.mk_eq_pos p y z in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) + | Some false -> + let y = Mc.XO (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x0 (x1 ip)) in + let constr = Mc.bound_var (Mc.XO y) in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) + | Some true -> + let z = Mc.XI (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x1 (x1 ip)) in + let constr = Mc.bound_var (Mc.XI z) in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) in + + Mc.bound_problem_fr tag_of_var mt f (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if @@ -1494,10 +1468,12 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* * The datastructures that aggregate prover attributes. *) -type ('option,'a,'prf) prover = { +open Certificate + +type ('option,'a,'prf,'model) prover = { name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : 'option * 'a list -> 'prf option ; (* the prover itself *) + get_option : unit ->'option ; (* find the options of the prover *) + prover : ('option * 'a list) -> ('prf, 'model) Certificate.res ; (* the prover itself *) hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) @@ -1507,37 +1483,37 @@ type ('option,'a,'prf) prover = { (** - * Given a list of provers and a disjunction of atoms, find a proof of any of + * Given a prover and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover * datastructure. *) -let find_witness provers polys1 = - let provers = List.map (fun p -> - (fun l -> - match p.prover (p.get_option (),l) with - | None -> None - | Some prf -> Some(prf,p)) , p.name) provers in - try_any provers (List.map fst polys1) +let find_witness p polys1 = + let polys1 = List.map fst polys1 in + match p.prover (p.get_option (), polys1) with + | Model m -> Model m + | Unknown -> Unknown + | Prf prf -> Prf(prf,p) (** - * Given a list of provers and a CNF, find a proof for each of the clauses. + * Given a prover and a CNF, find a proof for each of the clauses. * Return the proofs as a list. *) -let witness_list prover l = +let witness_list prover l = let rec xwitness_list l = match l with - | [] -> Some [] + | [] -> Prf [] | e :: l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w :: l) - ) in - xwitness_list l + match xwitness_list l with + | Model (m,e) -> Model (m,e) + | Unknown -> Unknown + | Prf l -> + match find_witness prover e with + | Model m -> Model (m,e) + | Unknown -> Unknown + | Prf w -> Prf (w::l) in + xwitness_list l let witness_list_tags = witness_list @@ -1545,6 +1521,7 @@ let witness_list_tags = witness_list * Prune the proof object, according to the 'diff' between two cnf formulas. *) + let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = @@ -1563,9 +1540,9 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let res = try prover.compact prf remap with x when CErrors.noncritical x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option () ,List.map fst new_cl) with - | None -> failwith "proof compaction error" - | Some p -> p + match prover.prover (prover.get_option (), List.map fst new_cl) with + | Unknown | Model _ -> failwith "proof compaction error" + | Prf p -> p in if debug then begin @@ -1580,11 +1557,31 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let hyps = selecti hyps_idx old_cl in is_sublist Pervasives.(=) hyps new_cl in + + let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) + if debug then + begin + Printf.printf "CNFRES\n"; flush stdout; + List.iter (fun (cl,(prf,prover)) -> + let hyps_idx = prover.hyps prf in + let hyps = selecti hyps_idx cl in + Printf.printf "\nProver %a -> %a\n" + pp_clause_tag cl pp_clause_tag hyps;flush stdout) cnf_res; + Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff'; + + end; List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' + let (o,p) = + try + List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + with Not_found -> + begin + Printf.printf "ERROR: no compatible proof" ; flush stdout; + failwith "Cannot find compatible proof" end + in + compact_proof o p x) cnf_ff' (** @@ -1593,14 +1590,15 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = *) let abstract_formula hyps f = + Mc.( let rec xabs f = match f with | X c -> X c - | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> + | A(a,(t,term)) -> if TagSet.mem t hyps then A(a,(t,term)) else X(term) + | Cj(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> C(f1,f2) ) + | f1 , f2 -> Cj(f1,f2) ) | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) @@ -1617,21 +1615,22 @@ let abstract_formula hyps f = ) | FF -> FF | TT -> TT - in xabs f + in xabs f) (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) let rec abstract_wrt_formula f1 f2 = + Mc.( match f1 , f2 with | X c , _ -> X c | A _ , A _ -> f2 - | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') + | Cj(a,b) , Cj(a',b') -> Cj(abstract_wrt_formula a a', abstract_wrt_formula b b') | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') | FF , FF -> FF | TT , TT -> TT | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula" + | _ -> failwith "abstract_wrt_formula") (** * This exception is raised by really_call_csdpcert if Coq's configure didn't @@ -1650,52 +1649,46 @@ let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) + Mc.X _ -> (cc,ids) + | _ -> (Mc.I(f,Some id,cc), id::ids)) hyps (concl,[]) -let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = +let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = (* Express the goal as one big implication *) let (ff,ids) = formula_hyps_concl polys1 polys2 in + let mt = CamlToCoq.positive (max_tag ff) in - (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in - - if debug then - begin - Feedback.msg_notice (Pp.str "Formula....\n") ; - let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff - end; + (* Construction of cnf *) + let pre_ff = (pre_process mt ff) in + let (cnf_ff,cnf_ff_tags) = cnf pre_ff in match witness_list_tags prover cnf_ff with - | None -> None - | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; + | Model m -> Model m + | Unknown -> Unknown + | Prf res -> (*Printf.printf "\nList %i" (List.length `res); *) + let hyps = List.fold_left + (fun s (cl,(prf,p)) -> + let tags = ISet.fold (fun i s -> + let t = fst (snd (List.nth cl i)) in + if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; + (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in + TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty (List.map fst cnf_ff_tags)) (List.combine cnf_ff res) in let ff' = abstract_formula hyps ff in - let cnf_ff',_ = cnf negate normalise unsat deduce ff' in + + let pre_ff' = pre_process mt ff' in + let cnf_ff',_ = cnf pre_ff' in + if debug then begin - Feedback.msg_notice (Pp.str "\nAFormula\n") ; - let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' + output_string stdout "\n"; + Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; + Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout; + Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout; + Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout; end; (* Even if it does not work, this does not mean it is not provable @@ -1709,10 +1702,18 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in - let (ff',res',ids) = (ff',res', ids_of_formula ff') in + let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Some (ids,ff',res') + Prf (ids,ff',res') + +let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = + try micromega_tauto pre_process cnf spec prover env polys1 polys2 gl + with Not_found -> + begin + Printexc.print_backtrace stdout; flush stdout; + Unknown + end (** @@ -1724,9 +1725,8 @@ let fresh_id avoid id gl = let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce + pre_process + cnf spec dumpexpr prover tac = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1734,15 +1734,19 @@ let micromega_gen let hyps = Tacmach.New.pf_hyps_types gl in try let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in + let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let dumpexpr = Lazy.force dumpexpr in + + + if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ; - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in + match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with + | Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids,ff',res') -> + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1755,7 +1759,7 @@ let micromega_gen micromega_order_change spec res' (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula sigma ff') in + let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -1785,16 +1789,10 @@ let micromega_gen ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - -let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec prover = - (micromega_gen parse_arith negate normalise unsat deduce spec prover) - - + | x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) + else raise x + end + end let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) @@ -1825,10 +1823,6 @@ let micromega_order_changer cert env ff = let micromega_genr prover tac = let parse_arith = parse_rarith in - let negate = Mc.rnegate in - let normalise = Mc.rnormalise in - let unsat = Mc.runsat in - let deduce = Mc.rdeduce in let spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; @@ -1843,21 +1837,21 @@ let micromega_genr prover tac = try let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in + let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in + let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in + let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> + match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with + | Unknown | Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids,ff',res') -> let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1869,7 +1863,7 @@ let micromega_genr prover tac = let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula sigma ff') in + let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -1910,8 +1904,8 @@ let micromega_genr prover = (micromega_genr prover) let lift_ratproof prover l = match prover l with - | None -> None - | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) + | Unknown | Model _ -> Unknown + | Prf c -> Prf (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list @@ -1982,22 +1976,22 @@ let rec z_to_q_pol e = let call_csdpcert_q provername poly = match call_csdpcert provername poly with - | None -> None + | None -> Unknown | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate") ;None) + then Prf cert + else ((print_string "buggy certificate") ;Unknown) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with - | None -> None + | None -> Unknown | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) + then Prf cert + else ((print_string "buggy certificate" ; flush stdout) ;Unknown) let xhyps_of_cone base acc prf = let rec xtract e acc = @@ -2040,12 +2034,6 @@ let hyps_of_pt pt = xhyps 0 pt ISet.empty -let hyps_of_pt pt = - let res = hyps_of_pt pt in - if debug - then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); - res - let compact_pt pt f = let translate ofset x = if x < ofset then x @@ -2140,8 +2128,8 @@ let non_linear_prover_R str o = { let non_linear_prover_Z str o = { name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -2174,52 +2162,65 @@ let nlinear_Z = { *) let lra_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ linear_prover_Q ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + linear_prover_Q let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "real_nonlinear_prover" (Some i) ) let lra_R = - micromega_genr [ linear_prover_R ] + micromega_genr linear_prover_R let psatz_R i = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] + micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i)) let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "real_nonlinear_prover" (Some i) ) let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "pure_sos" None ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "pure_sos" None) let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "pure_sos" None ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "pure_sos" None) let sos_R = - micromega_genr [ non_linear_prover_R "pure_sos" None ] + micromega_genr (non_linear_prover_R "pure_sos" None) -let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ linear_Z ] +let xlia = + micromega_gen parse_zarith pre_processZ Mc.cnfZ zz_domain_spec dump_zexpr + linear_Z + let xnlia = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ nlinear_Z ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + nlinear_Z let nra = - micromega_genr [ nlinear_prover_R ] + micromega_genr nlinear_prover_R let nqa = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ nlinear_prover_R ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + nlinear_prover_R + +(** Let expose [is_ground_tac] *) + +let is_ground_tac t = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + if is_ground_term env sigma t + then Tacticals.New.tclIDTAC + else Tacticals.New.tclFAIL 0 (Pp.str "Not ground") + end + - (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index d1776b8ca4..075594cffc 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +val is_ground_tac : EConstr.constr -> unit Proofview.tactic val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index 21f0414e9c..6bf5f76a04 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -30,6 +30,9 @@ TACTIC EXTEND RED | [ "myred" ] -> { Tactics.red_in_concl } END +TACTIC EXTEND ISGROUND +| [ "is_ground" constr(t) ] -> { Coq_micromega.is_ground_tac t } +END TACTIC EXTEND PsatzZ diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index f67f1da146..b34c3b2b7d 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1,4 +1,9 @@ +type __ = Obj.t + +type unit0 = +| Tt + (** val negb : bool -> bool **) let negb = function @@ -9,6 +14,20 @@ type nat = | O | S of nat +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +(** val fst : ('a1 * 'a2) -> 'a1 **) + +let fst = function +| x,_ -> x + +(** val snd : ('a1 * 'a2) -> 'a2 **) + +let snd = function +| _,y -> y + (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = @@ -37,6 +56,29 @@ module Coq__1 = struct end include Coq__1 +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) + +let rec nth n0 l default = + match n0 with + | O -> (match l with + | [] -> default + | x::_ -> x) + | S m -> (match l with + | [] -> default + | _::t0 -> nth m t0 default) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) + +let rec map f = function +| [] -> [] +| a::t0 -> (f a)::(map f t0) + +(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) + +let rec fold_right f a0 = function +| [] -> a0 +| b::t0 -> f b (fold_right f a0 t0) + type positive = | XI of positive | XO of positive @@ -269,29 +311,6 @@ let rec pow_pos rmul x = function | XO i0 -> let p = pow_pos rmul x i0 in rmul p p | XH -> x -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> (match l with - | [] -> default - | x::_ -> x) - | S m -> (match l with - | [] -> default - | _::t0 -> nth m t0 default) - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function -| [] -> [] -| a::t0 -> (f a)::(map f t0) - -(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - -let rec fold_right f a0 = function -| [] -> a0 -| b::t0 -> f b (fold_right f a0 t0) - module Z = struct (** val double : z -> z **) @@ -435,6 +454,12 @@ module Z = | Zpos p -> Npos p | _ -> N0 + (** val of_nat : nat -> z **) + + let of_nat = function + | O -> Z0 + | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = @@ -889,53 +914,105 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function ppow_N cO cI cadd cmul ceqb (fun p -> p) (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 -type 'a bFormula = +type ('tA, 'tX, 'aA, 'aF) gFormula = | TT | FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula - -(** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) +| X of 'tX +| A of 'tA * 'aA +| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| N of ('tA, 'tX, 'aA, 'aF) gFormula +| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option + * ('tA, 'tX, 'aA, 'aF) gFormula + +(** val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) + gFormula **) + +let rec mapX f = function +| X x -> X (f x) +| Cj (f1, f2) -> Cj ((mapX f f1), (mapX f f2)) +| D (f1, f2) -> D ((mapX f f1), (mapX f f2)) +| N f1 -> N (mapX f f1) +| I (f1, o, f2) -> I ((mapX f f1), o, (mapX f f2)) +| x -> x + +(** val foldA : + ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 **) + +let rec foldA f f0 acc = + match f0 with + | A (_, an) -> f acc an + | Cj (f1, f2) -> foldA f f1 (foldA f f2 acc) + | D (f1, f2) -> foldA f f1 (foldA f f2 acc) + | N f1 -> foldA f f1 acc + | I (f1, _, f2) -> foldA f f1 (foldA f f2 acc) + | _ -> acc + +(** val cons_id : 'a1 option -> 'a1 list -> 'a1 list **) + +let cons_id id l = + match id with + | Some id0 -> id0::l + | None -> l + +(** val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list **) + +let rec ids_of_formula = function +| I (_, id, f') -> cons_id id (ids_of_formula f') +| _ -> [] + +(** val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list **) + +let rec collect_annot = function +| A (_, a) -> a::[] +| Cj (f1, f2) -> app (collect_annot f1) (collect_annot f2) +| D (f1, f2) -> app (collect_annot f1) (collect_annot f2) +| N f0 -> collect_annot f0 +| I (f1, _, f2) -> app (collect_annot f1) (collect_annot f2) +| _ -> [] + +type 'a bFormula = ('a, __, unit0, unit0) gFormula + +(** val map_bformula : + ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) + gFormula **) let rec map_bformula fct = function | TT -> TT | FF -> FF -| X -> X -| A a -> A (fct a) +| X p -> X p +| A (a, t0) -> A ((fct a), t0) | Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) | D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) | N f0 -> N (map_bformula fct f0) -| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) +| I (f1, a, f2) -> I ((map_bformula fct f1), a, (map_bformula fct f2)) -type 'x clause = 'x list +type ('x, 'annot) clause = ('x * 'annot) list -type 'x cnf = 'x clause list +type ('x, 'annot) cnf = ('x, 'annot) clause list -(** val tt : 'a1 cnf **) +(** val cnf_tt : ('a1, 'a2) cnf **) -let tt = +let cnf_tt = [] -(** val ff : 'a1 cnf **) +(** val cnf_ff : ('a1, 'a2) cnf **) -let ff = +let cnf_ff = []::[] (** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) + clause -> ('a1, 'a2) clause option **) let rec add_term unsat deduce t0 = function | [] -> - (match deduce t0 t0 with + (match deduce (fst t0) (fst t0) with | Some u -> if unsat u then None else Some (t0::[]) | None -> Some (t0::[])) | t'::cl0 -> - (match deduce t0 t' with + (match deduce (fst t0) (fst t') with | Some u -> if unsat u then None @@ -948,8 +1025,8 @@ let rec add_term unsat deduce t0 = function | None -> None)) (** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause - -> 'a1 clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) clause -> ('a1, 'a2) clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with @@ -960,8 +1037,8 @@ let rec or_clause unsat deduce cl1 cl2 = | None -> None) (** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> - 'a1 cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) let or_clause_cnf unsat deduce t0 f = fold_right (fun e acc -> @@ -970,29 +1047,32 @@ let or_clause_cnf unsat deduce t0 f = | None -> acc) [] f (** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 - cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) let rec or_cnf unsat deduce f f' = match f with - | [] -> tt + | [] -> cnf_tt | e::rst -> app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') -(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) +(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) let and_cnf = app +type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula + (** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) + tFormula -> ('a2, 'a3) cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function -| TT -> if pol0 then tt else ff -| FF -> if pol0 then ff else tt -| X -> ff -| A x -> if pol0 then normalise0 x else negate0 x +| TT -> if pol0 then cnf_tt else cnf_ff +| FF -> if pol0 then cnf_ff else cnf_tt +| X _ -> cnf_ff +| A (x, t0) -> if pol0 then normalise0 x t0 else negate0 x t0 | Cj (e1, e2) -> if pol0 then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) @@ -1006,7 +1086,7 @@ let rec xcnf unsat deduce normalise0 negate0 pol0 = function else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e -| I (e1, e2) -> +| I (e1, _, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) @@ -1014,8 +1094,95 @@ let rec xcnf unsat deduce normalise0 negate0 pol0 = function else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) +(** val radd_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) + clause -> (('a1, 'a2) clause, 'a2 list) sum **) + +let rec radd_term unsat deduce t0 = function +| [] -> + (match deduce (fst t0) (fst t0) with + | Some u -> if unsat u then Inr ((snd t0)::[]) else Inl (t0::[]) + | None -> Inl (t0::[])) +| t'::cl0 -> + (match deduce (fst t0) (fst t') with + | Some u -> + if unsat u + then Inr ((snd t0)::((snd t')::[])) + else (match radd_term unsat deduce t0 cl0 with + | Inl cl' -> Inl (t'::cl') + | Inr l -> Inr l) + | None -> + (match radd_term unsat deduce t0 cl0 with + | Inl cl' -> Inl (t'::cl') + | Inr l -> Inr l)) + +(** val ror_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum **) + +let rec ror_clause unsat deduce cl1 cl2 = + match cl1 with + | [] -> Inl cl2 + | t0::cl -> + (match radd_term unsat deduce t0 cl2 with + | Inl cl' -> ror_clause unsat deduce cl cl' + | Inr l -> Inr l) + +(** val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) + +let ror_clause_cnf unsat deduce t0 f = + fold_right (fun e pat -> + let acc,tg = pat in + (match ror_clause unsat deduce t0 e with + | Inl cl -> (cl::acc),tg + | Inr l -> acc,(app tg l))) ([],[]) f + +(** val ror_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> + ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 list **) + +let rec ror_cnf unsat deduce f f' = + match f with + | [] -> cnf_tt,[] + | e::rst -> + let rst_f',t0 = ror_cnf unsat deduce rst f' in + let e_f',t' = ror_clause_cnf unsat deduce e f' in + (app rst_f' e_f'),(app t0 t') + +(** val rxcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) + tFormula -> ('a2, 'a3) cnf * 'a3 list **) + +let rec rxcnf unsat deduce normalise0 negate0 polarity = function +| TT -> if polarity then cnf_tt,[] else cnf_ff,[] +| FF -> if polarity then cnf_ff,[] else cnf_tt,[] +| X _ -> cnf_ff,[] +| A (x, t0) -> (if polarity then normalise0 x t0 else negate0 x t0),[] +| Cj (e1, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then (app e3 e4),(app t1 t2) + else let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) +| D (e1, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + else (app e3 e4),(app t1 t2) +| N e -> rxcnf unsat deduce normalise0 negate0 (negb polarity) e +| I (e1, _, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 (negb polarity) e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + else (and_cnf e3 e4),(app t1 t2) + (** val cnf_checker : - ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) let rec cnf_checker checker f l = match f with @@ -1026,9 +1193,9 @@ let rec cnf_checker checker f l = | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> - bool **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> + bool) -> ('a1, __, 'a3, unit0) gFormula -> 'a4 list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w @@ -1243,11 +1410,12 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = (** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> + ('a1 nFormula, 'a2) cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 tg = + map (fun x -> (x,tg)::[]) + (xnormalise cO cI cplus ctimes cminus copp ceqb t0) (** val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 @@ -1271,11 +1439,11 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t0 = (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> + ('a1 nFormula, 'a2) cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) +let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 tg = + map (fun x -> (x,tg)::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -1366,6 +1534,13 @@ let simpl_cone cO cI ctimes ceqb e = match e with | _ -> PsatzAdd (t1, t2))) | _ -> e +module PositiveSet = + struct + type tree = + | Leaf + | Node of tree * bool * tree + end + type q = { qnum : z; qden : positive } (** val qnum : q -> z **) @@ -1429,16 +1604,16 @@ let qpower q0 = function type 'a t = | Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t +| Elt of 'a +| Branch of 'a t * 'a * 'a t (** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) let rec find default vm p = match vm with | Empty -> default - | Leaf i -> i - | Node (l, e, r) -> + | Elt i -> i + | Branch (l, e, r) -> (match p with | XI p2 -> find default r p2 | XO p2 -> find default l p2 @@ -1448,24 +1623,24 @@ let rec find default vm p = let rec singleton default x v = match x with - | XI p -> Node (Empty, default, (singleton default p v)) - | XO p -> Node ((singleton default p v), default, Empty) - | XH -> Leaf v + | XI p -> Branch (Empty, default, (singleton default p v)) + | XO p -> Branch ((singleton default p v), default, Empty) + | XH -> Elt v (** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) let rec vm_add default x v = function | Empty -> singleton default x v -| Leaf vl -> +| Elt vl -> (match x with - | XI p -> Node (Empty, vl, (singleton default p v)) - | XO p -> Node ((singleton default p v), vl, Empty) - | XH -> Leaf v) -| Node (l, o, r) -> + | XI p -> Branch (Empty, vl, (singleton default p v)) + | XO p -> Branch ((singleton default p v), vl, Empty) + | XH -> Elt v) +| Branch (l, o, r) -> (match x with - | XI p -> Node (l, o, (vm_add default p v r)) - | XO p -> Node ((vm_add default p v l), o, r) - | XH -> Node (l, v, r)) + | XI p -> Branch (l, o, (vm_add default p v r)) + | XO p -> Branch ((vm_add default p v l), o, r) + | XH -> Branch (l, v, r)) type zWitness = z psatz @@ -1507,10 +1682,10 @@ let xnormalise0 t0 = | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) -(** val normalise : z formula -> z nFormula cnf **) +(** val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let normalise t0 = - map (fun x -> x::[]) (xnormalise0 t0) +let normalise t0 tg = + map (fun x -> (x,tg)::[]) (xnormalise0 t0) (** val xnegate0 : z formula -> z nFormula list **) @@ -1530,10 +1705,10 @@ let xnegate0 t0 = | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) -(** val negate : z formula -> z nFormula cnf **) +(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let negate t0 = - map (fun x -> x::[]) (xnegate0 t0) +let negate t0 tg = + map (fun x -> (x,tg)::[]) (xnegate0 t0) (** val zunsat : z nFormula -> bool **) @@ -1545,6 +1720,12 @@ let zunsat = let zdeduce = nformula_plus_nformula Z0 Z.add zeq_bool +(** val cnfZ : + (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list **) + +let cnfZ f = + rxcnf zunsat zdeduce normalise negate true f + (** val ceiling : z -> z -> z **) let ceiling a b = @@ -1629,6 +1810,145 @@ let valid_cut_sign = function | NonStrict -> true | _ -> false +module Vars = + struct + type elt = positive + + type tree = PositiveSet.tree = + | Leaf + | Node of tree * bool * tree + + type t = tree + + (** val empty : t **) + + let empty = + Leaf + + (** val add : elt -> t -> t **) + + let rec add i = function + | Leaf -> + (match i with + | XI i0 -> Node (Leaf, false, (add i0 Leaf)) + | XO i0 -> Node ((add i0 Leaf), false, Leaf) + | XH -> Node (Leaf, true, Leaf)) + | Node (l, o, r) -> + (match i with + | XI i0 -> Node (l, o, (add i0 r)) + | XO i0 -> Node ((add i0 l), o, r) + | XH -> Node (l, true, r)) + + (** val singleton : elt -> t **) + + let singleton i = + add i empty + + (** val union : t -> t -> t **) + + let rec union m m' = + match m with + | Leaf -> m' + | Node (l, o, r) -> + (match m' with + | Leaf -> m + | Node (l', o', r') -> + Node ((union l l'), (if o then true else o'), (union r r'))) + + (** val rev_append : elt -> elt -> elt **) + + let rec rev_append y x = + match y with + | XI y0 -> rev_append y0 (XI x) + | XO y0 -> rev_append y0 (XO x) + | XH -> x + + (** val rev : elt -> elt **) + + let rev x = + rev_append x XH + + (** val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 **) + + let rec xfold f m v i = + match m with + | Leaf -> v + | Node (l, b, r) -> + if b + then xfold f r (f (rev i) (xfold f l v (XO i))) (XI i) + else xfold f r (xfold f l v (XO i)) (XI i) + + (** val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 **) + + let fold f m i = + xfold f m i XH + end + +(** val vars_of_pexpr : z pExpr -> Vars.t **) + +let rec vars_of_pexpr = function +| PEc _ -> Vars.empty +| PEX x -> Vars.singleton x +| PEadd (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEsub (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEmul (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEopp c -> vars_of_pexpr c +| PEpow (e0, _) -> vars_of_pexpr e0 + +(** val vars_of_formula : z formula -> Vars.t **) + +let vars_of_formula f = + let { flhs = l; fop = _; frhs = r } = f in + let v1 = vars_of_pexpr l in let v2 = vars_of_pexpr r in Vars.union v1 v2 + +(** val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t **) + +let rec vars_of_bformula = function +| A (a, _) -> vars_of_formula a +| Cj (f1, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| D (f1, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| N f0 -> vars_of_bformula f0 +| I (f1, _, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| _ -> Vars.empty + +(** val bound_var : positive -> z formula **) + +let bound_var v = + { flhs = (PEX v); fop = OpGe; frhs = (PEc Z0) } + +(** val mk_eq_pos : positive -> positive -> positive -> z formula **) + +let mk_eq_pos x y t0 = + { flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) } + +(** val bound_vars : + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z + formula, 'a1, 'a2, 'a3) gFormula **) + +let bound_vars tag_of_var fr v = + Vars.fold (fun k acc -> + let y = XO (Coq_Pos.add fr k) in + let z0 = XI (Coq_Pos.add fr k) in + Cj ((Cj ((A ((mk_eq_pos k y z0), (tag_of_var fr k None))), (Cj ((A + ((bound_var y), (tag_of_var fr k (Some false)))), (A ((bound_var z0), + (tag_of_var fr k (Some true)))))))), acc)) v TT + +(** val bound_problem_fr : + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, + 'a1, 'a2, 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula **) + +let bound_problem_fr tag_of_var fr f = + let v = vars_of_bformula f in I ((bound_vars tag_of_var fr v), None, f) + (** val zChecker : z nFormula list -> zArithProof -> bool **) let rec zChecker l = function @@ -1675,7 +1995,8 @@ let rec zChecker l = function (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise negate zChecker f w + tauto_checker zunsat zdeduce normalise negate (fun cl -> + zChecker (map fst cl)) f w type qWitness = q psatz @@ -1685,17 +2006,17 @@ let qWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool -(** val qnormalise : q formula -> q nFormula cnf **) +(** val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let qnormalise = +let qnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool + qplus qmult qminus qopp qeq_bool t0 tg -(** val qnegate : q formula -> q nFormula cnf **) +(** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let qnegate = +let qnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + qmult qminus qopp qeq_bool t0 tg (** val qunsat : q nFormula -> bool **) @@ -1713,10 +2034,17 @@ let normQ = norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool +(** val cnfQ : + (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list **) + +let cnfQ f = + rxcnf qunsat qdeduce qnormalise qnegate true f + (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = - tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w + tauto_checker qunsat qdeduce qnormalise qnegate (fun cl -> + qWeakChecker (map fst cl)) f w type rcst = | C0 @@ -1726,9 +2054,16 @@ type rcst = | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst +| CPow of rcst * (z, nat) sum | CInv of rcst | COpp of rcst +(** val z_of_exp : (z, nat) sum -> z **) + +let z_of_exp = function +| Inl z1 -> z1 +| Inr n0 -> Z.of_nat n0 + (** val q_of_Rcst : rcst -> q **) let rec q_of_Rcst = function @@ -1739,6 +2074,7 @@ let rec q_of_Rcst = function | CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) | CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) | CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) +| CPow (r1, z0) -> qpower (q_of_Rcst r1) (z_of_exp z0) | CInv r0 -> qinv (q_of_Rcst r0) | COpp r0 -> qopp (q_of_Rcst r0) @@ -1750,17 +2086,17 @@ let rWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool -(** val rnormalise : q formula -> q nFormula cnf **) +(** val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let rnormalise = +let rnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool + qplus qmult qminus qopp qeq_bool t0 tg -(** val rnegate : q formula -> q nFormula cnf **) +(** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let rnegate = +let rnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + qmult qminus qopp qeq_bool t0 tg (** val runsat : q nFormula -> bool **) @@ -1775,5 +2111,5 @@ let rdeduce = (** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) let rTautoChecker f w = - tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker - (map_bformula (map_Formula q_of_Rcst) f) w + tauto_checker runsat rdeduce rnormalise rnegate (fun cl -> + rWeakChecker (map fst cl)) (map_bformula (map_Formula q_of_Rcst) f) w diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 72c2bf7da3..5de6caac0b 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,10 +1,23 @@ +type __ = Obj.t + +type unit0 = +| Tt + val negb : bool -> bool type nat = | O | S of nat +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val fst : ('a1 * 'a2) -> 'a1 + +val snd : ('a1 * 'a2) -> 'a2 + val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = @@ -16,6 +29,12 @@ val compOpp : comparison -> comparison val add : nat -> nat -> nat +val nth : nat -> 'a1 list -> 'a1 -> 'a1 + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 + type positive = | XI of positive | XO of positive @@ -87,12 +106,6 @@ module N : val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -val nth : nat -> 'a1 list -> 'a1 -> 'a1 - -val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 - module Z : sig val double : z -> z @@ -125,6 +138,8 @@ module Z : val to_N : z -> n + val of_nat : nat -> z + val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z @@ -163,27 +178,47 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol -val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 + pol -> 'a1 pol -val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 + pol -val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> + 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol -> 'a1 pol -val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol +val psquare : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -197,49 +232,104 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol -val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol +val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol -type 'a bFormula = +type ('tA, 'tX, 'aA, 'aF) gFormula = | TT | FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula +| X of 'tX +| A of 'tA * 'aA +| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| N of ('tA, 'tX, 'aA, 'aF) gFormula +| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula + +val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula + +val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 + +val cons_id : 'a1 option -> 'a1 list -> 'a1 list + +val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list + +val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list + +type 'a bFormula = ('a, __, unit0, unit0) gFormula + +val map_bformula : + ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula + +type ('x, 'annot) clause = ('x * 'annot) list + +type ('x, 'annot) cnf = ('x, 'annot) clause list + +val cnf_tt : ('a1, 'a2) cnf -val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula +val cnf_ff : ('a1, 'a2) cnf -type 'x clause = 'x list +val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> + ('a1, 'a2) clause option -type 'x cnf = 'x clause list +val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause -> ('a1, 'a2) clause option -val tt : 'a1 cnf +val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf -val ff : 'a1 cnf +val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> + ('a1, 'a2) cnf -val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option +val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option +type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula -val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf +val xcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, + 'a3) cnf -val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val radd_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> + (('a1, 'a2) clause, 'a2 list) sum -val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val ror_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause + -> (('a1, 'a2) clause, 'a2 list) sum -val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf +val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause + list -> ('a1, 'a2) clause list * 'a2 list -val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool +val ror_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> ('a1, 'a2) + clause list -> ('a1, 'a2) cnf * 'a2 list + +val rxcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, + 'a3) cnf * 'a3 list + +val cnf_checker : + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, + 'a3, unit0) gFormula -> 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -273,21 +363,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option -val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option +val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula + -> 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option -val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool +val check_inconsistent : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -300,27 +396,31 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol -val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val psub0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -330,7 +430,15 @@ val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula -val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz +val simpl_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz + +module PositiveSet : + sig + type tree = + | Leaf + | Node of tree * bool * tree + end type q = { qnum : z; qden : positive } @@ -358,8 +466,8 @@ val qpower : q -> z -> q type 'a t = | Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t +| Elt of 'a +| Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 @@ -379,16 +487,18 @@ val normZ : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list -val normalise : z formula -> z nFormula cnf +val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf val xnegate0 : z formula -> z nFormula list -val negate : z formula -> z nFormula cnf +val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf val zunsat : z nFormula -> bool val zdeduce : z nFormula -> z nFormula -> z nFormula option +val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list + val ceiling : z -> z -> z type zArithProof = @@ -415,6 +525,51 @@ val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option val valid_cut_sign : op1 -> bool +module Vars : + sig + type elt = positive + + type tree = PositiveSet.tree = + | Leaf + | Node of tree * bool * tree + + type t = tree + + val empty : t + + val add : elt -> t -> t + + val singleton : elt -> t + + val union : t -> t -> t + + val rev_append : elt -> elt -> elt + + val rev : elt -> elt + + val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 + + val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 + end + +val vars_of_pexpr : z pExpr -> Vars.t + +val vars_of_formula : z formula -> Vars.t + +val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t + +val bound_var : positive -> z formula + +val mk_eq_pos : positive -> positive -> positive -> z formula + +val bound_vars : + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, + 'a1, 'a2, 'a3) gFormula + +val bound_problem_fr : + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, + 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula + val zChecker : z nFormula list -> zArithProof -> bool val zTautoChecker : z formula bFormula -> zArithProof list -> bool @@ -423,9 +578,9 @@ type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool -val qnormalise : q formula -> q nFormula cnf +val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf -val qnegate : q formula -> q nFormula cnf +val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf val qunsat : q nFormula -> bool @@ -433,6 +588,8 @@ val qdeduce : q nFormula -> q nFormula -> q nFormula option val normQ : q pExpr -> q pol +val cnfQ : (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list + val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = @@ -443,18 +600,21 @@ type rcst = | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst +| CPow of rcst * (z, nat) sum | CInv of rcst | COpp of rcst +val z_of_exp : (z, nat) sum -> z + val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool -val rnormalise : q formula -> q nFormula cnf +val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf -val rnegate : q formula -> q nFormula cnf +val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf val runsat : q nFormula -> bool diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 809731ecc4..084ea39c27 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,8 +19,18 @@ (* *) (************************************************************************) +module Int = struct + type t = int + let compare : int -> int -> int = Pervasives.compare + let equal : int -> int -> bool = (=) +end -module ISet = Set.Make(Int) +module ISet = + struct + include Set.Make(Int) + + let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s + end module IMap = struct @@ -82,12 +92,69 @@ let extract pred l = | _ -> (fd, e::sys) ) (None,[]) l +let extract_best red lt l = + let rec extractb c e rst l = + match l with + [] -> Some (c,e) , rst + | e'::l' -> match red e' with + | None -> extractb c e (e'::rst) l' + | Some c' -> if lt c' c + then extractb c' e' (e::rst) l' + else extractb c e (e'::rst) l' in + match extract red l with + | None , _ -> None,l + | Some(c,e), rst -> extractb c e [] rst + + +let rec find_some pred l = + match l with + | [] -> None + | e::l -> match pred e with + | Some r -> Some r + | None -> find_some pred l + + let extract_all pred l = List.fold_left (fun (s1,s2) e -> match pred e with | None -> s1,e::s2 | Some v -> (v,e)::s1 , s2) ([],[]) l +let simplify f sys = + let (sys',b) = + List.fold_left (fun (sys',b) c -> + match f c with + | None -> (c::sys',b) + | Some c' -> + (c'::sys',true) + ) ([],false) sys in + if b then Some sys' else None + +let generate_acc f acc sys = + List.fold_left (fun sys' c -> match f c with + | None -> sys' + | Some c' -> c'::sys' + ) acc sys + + +let generate f sys = generate_acc f [] sys + + +let saturate p f sys = + let rec sat acc l = + match extract p l with + | None,_ -> acc + | Some r,l' -> + let n = generate (f r) (l'@acc) in + sat (n@acc) l' in + try sat [] sys with + x -> + begin + Printexc.print_backtrace stdout ; + raise x + end + + open Num open Big_int @@ -276,7 +343,8 @@ sig val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int - + val max : t -> t -> t + val to_int : t -> int end module Tag : Tag = @@ -286,8 +354,10 @@ struct let from i = i let next i = i + 1 + let max : int -> int -> int = Pervasives.max let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Int.compare + let to_int x = x end diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index e92f086886..739d1a73da 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,8 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Int : sig type t = int val compare : int -> int -> int val equal : int -> int -> bool end -module ISet : Set.S with type elt = int + +module ISet : sig + include Set.S with type elt = int + val pp : out_channel -> t -> unit +end module IMap : sig @@ -36,7 +41,9 @@ module Tag : sig val pp : out_channel -> t -> unit val next : t -> t + val max : t -> t -> t val from : int -> t + val to_int : t -> int end @@ -78,8 +85,18 @@ val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list val extract_all : ('a -> 'b option) -> 'a list -> ('b * 'a) list * 'a list +val extract_best : ('a -> 'b option) -> ('b -> 'b -> bool) -> 'a list -> ('b *'a) option * 'a list + +val find_some : ('a -> 'b option) -> 'a list -> 'b option + val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a +val simplify : ('a -> 'a option) -> 'a list -> 'a list option + +val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list + +val generate : ('a -> 'b option) -> 'a list -> 'b list + val app_funs : ('a -> 'b option) list -> 'a -> 'b option val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 76e7769e82..d406560fb8 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -378,6 +378,7 @@ module LinPoly = struct let pp o p = Vect.pp_gen pp_var o p + let constant c = if sign_num c = 0 then Vect.null @@ -389,6 +390,12 @@ module LinPoly = struct let mn = (MonT.retrieve v) in Monomial.is_var mn || Monomial.is_const mn) p + let is_variable p = + let ((x,v),r) = Vect.decomp_fst p in + if Vect.is_null r && v >/ Int 0 + then Monomial.get_var (MonT.retrieve x) + else None + let factorise x p = let (px,cx) = Poly.factorise x (pol_of_linpol p) in @@ -399,20 +406,6 @@ module LinPoly = struct let (a,b) = factorise x p in Vect.is_constant a - let search_linear p l = - - Vect.find (fun x v -> - if p v - then - let x' = MonT.retrieve x in - match Monomial.get_var x' with - | None -> None - | Some x -> if is_linear_for x l - then Some x - else None - else None) l - - let search_all_linear p l = Vect.fold (fun acc x v -> if p v @@ -426,12 +419,24 @@ module LinPoly = struct else acc else acc) [] l + let min_list (l:int list) = + match l with + | [] -> None + | e::l -> Some (List.fold_left Pervasives.min e l) + + let search_linear p l = + min_list (search_all_linear p l) + let product p1 p2 = linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2)) let addition p1 p2 = Vect.add p1 p2 + + let of_vect v = + Vect.fold (fun acc v vl -> addition (product (var v) (constant vl)) acc) Vect.null v + let variables p = Vect.fold (fun acc v _ -> ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p @@ -489,8 +494,8 @@ module ProofFormat = struct | Cst c -> Printf.fprintf o "Cst %s" (string_of_num c) | Zero -> Printf.fprintf o "Zero" | Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s) - | MulC(p,pr) -> Printf.fprintf o "(%a) * %a" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr - | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 + | MulC(p,pr) -> Printf.fprintf o "(%a) * (%a)" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr + | MulPrf(p1,p2) -> Printf.fprintf o "(%a) * (%a)" output_prf_rule p1 output_prf_rule p2 | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) @@ -502,6 +507,18 @@ module ProofFormat = struct output_prf_rule p1 Vect.pp v output_prf_rule p2 (pp_list ";" output_proof) pl + let rec pr_size = function + | Annot(_,p) -> pr_size p + | Zero| Square _ -> Int 0 + | Hyp _ -> Int 1 + | Def _ -> Int 1 + | Cst n -> n + | Gcd(i, p) -> pr_size p // (Big_int i) + | MulPrf(p1,p2) | AddPrf(p1,p2) -> pr_size p1 +/ pr_size p2 + | CutPrf p -> pr_size p + | MulC(v, p) -> pr_size p + + let rec pr_rule_max_id = function | Annot(_,p) -> pr_rule_max_id p | Hyp i | Def i -> i @@ -613,6 +630,48 @@ module ProofFormat = struct if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; res + module OrdPrfRule = + struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1,x2) (y1,y2) = + match c1 x1 y1 with + | 0 -> c2 x2 y2 + | i -> i + + + let rec compare p1 p2 = + match p1, p2 with + | Annot(s1,p1) , Annot(s2,p2) -> if s1 = s2 then compare p1 p2 + else Pervasives.compare s1 s2 + | Hyp i , Hyp j -> Pervasives.compare i j + | Def i , Def j -> Pervasives.compare i j + | Cst n , Cst m -> Num.compare_num n m + | Zero , Zero -> 0 + | Square v1 , Square v2 -> Vect.compare v1 v2 + | MulC(v1,p1) , MulC(v2,p2) -> cmp_pair Vect.compare compare (v1,p1) (v2,p2) + | Gcd(b1,p1) , Gcd(b2,p2) -> cmp_pair Big_int.compare_big_int compare (b1,p1) (b2,p2) + | MulPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) + | AddPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) + | CutPrf p , CutPrf p' -> compare p p' + | _ , _ -> Pervasives.compare (id_of_constr p1) (id_of_constr p2) + + end + + let add_proof x y = @@ -621,23 +680,91 @@ module ProofFormat = struct | _ -> AddPrf(x,y) - let mul_cst_proof c p = - match sign_num c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> MulC(LinPoly.constant c,p) (* [p] should represent an equality *) - | 1 -> - if eq_num (Int 1) c - then p - else MulPrf(Cst c,p) - | _ -> assert false + let rec mul_cst_proof c p = + match p with + | Annot(s,p) -> Annot(s,mul_cst_proof c p) + | MulC(v,p') -> MulC(Vect.mul c v,p') + | _ -> + match sign_num c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> MulC(LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> + if eq_num (Int 1) c + then p + else MulPrf(Cst c,p) + | _ -> assert false + + + let sMulC v p = + let (c,v') = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p + else MulC(v,p) let mul_proof p1 p2 = match p1 , p2 with | Zero , _ | _ , Zero -> Zero - | Cst (Int 1) , p | p , Cst (Int 1) -> p - | _ , _ -> MulPrf(p1,p2) + | Cst c , p | p , Cst c -> mul_cst_proof c p + | _ , _ -> + MulPrf(p1,p2) + + module PrfRuleMap = Map.Make(OrdPrfRule) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + + let rec dev_prf_rule p = + match p with + | Annot(s,p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + | MulC(v,p) -> PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf(p1,p2) -> PrfRuleMap.merge (fun k o1 o2 -> + match o1 , o2 with + | None , None -> None + | None , Some v | Some v, None -> Some v + | Some v1 , Some v2 -> Some (LinPoly.addition v1 v2)) (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf(p1, p2) -> + begin + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf(p1'',p2'')) (LinPoly.constant (Int 1)) + end + | _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + + let simplify_prf_rule p = + prf_rule_of_map (dev_prf_rule p) + + + (* + let mul_proof p1 p2 = + let res = mul_proof p1 p2 in + Printf.printf "mul_proof %a %a = %a\n" + output_prf_rule p1 output_prf_rule p2 output_prf_rule res; res + + let add_proof p1 p2 = + let res = add_proof p1 p2 in + Printf.printf "add_proof %a %a = %a\n" + output_prf_rule p1 output_prf_rule p2 output_prf_rule res; res + + + let sMulC v p = + let res = sMulC v p in + Printf.printf "sMulC %a %a = %a\n" Vect.pp v output_prf_rule p output_prf_rule res ; + res + + let mul_cst_proof c p = + let res = mul_cst_proof c p in + Printf.printf "mul_cst_proof %s %a = %a\n" (Num.string_of_num c) output_prf_rule p output_prf_rule res ; + res + *) let proof_of_farkas env vect = Vect.fold (fun prf x n -> @@ -645,6 +772,7 @@ module ProofFormat = struct + module Env = struct let rec string_of_int_list l = @@ -768,10 +896,14 @@ module WithProof = struct let output o ((lp,op),prf) = Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) ProofFormat.output_prf_rule prf + let output_sys o l = + List.iter (Printf.fprintf o "%a\n" output) l + exception InvalidProof let zero = ((Vect.null,Eq), ProofFormat.Zero) + let const n = ((LinPoly.constant n,Ge), ProofFormat.Cst n) let of_cstr (c,prf) = (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf @@ -784,7 +916,7 @@ module WithProof = struct let mult p ((p1,o1),prf1) = match o1 with - | Eq -> ((LinPoly.product p p1,o1), ProofFormat.MulC(p, prf1)) + | Eq -> ((LinPoly.product p p1,o1), ProofFormat.sMulC p prf1) | Gt| Ge -> let (n,r) = Vect.decomp_cst p in if Vect.is_null r && n >/ Int 0 then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) @@ -890,6 +1022,51 @@ module WithProof = struct end | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" + let linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = + match linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) with + | None -> None + | Some (c,p) -> Some(c, ProofFormat.simplify_prf_rule p) + + +let is_substitution strict ((p,o),prf) = + let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in + + match o with + | Eq -> LinPoly.search_linear pred p + | _ -> None + + +let subst1 sys0 = + let (oeq,sys') = extract (is_substitution true) sys0 in + match oeq with + | None -> sys0 + | Some(v,pc) -> + match simplify (linear_pivot sys0 pc v) sys' with + | None -> sys0 + | Some sys' -> sys' + + + +let subst sys0 = + let elim sys = + let (oeq,sys') = extract (is_substitution true) sys in + match oeq with + | None -> None + | Some(v,pc) -> simplify (linear_pivot sys0 pc v) sys' in + + iterate_until_stable elim sys0 + + +let saturate_subst b sys0 = + let select = is_substitution b in + let gen (v,pc) ((c,op),prf) = + if ISet.mem v (LinPoly.variables c) + then linear_pivot sys0 pc v ((c,op),prf) + else None + in + saturate select gen sys0 + + end diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 23f3470d77..b5c6fefbb5 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -28,6 +28,8 @@ module Monomial : sig @return the empty monomial i.e. without any variable *) val const : t + val is_const : t -> bool + (** [var x] @return the monomial x^1 *) val var : var -> t @@ -40,6 +42,11 @@ module Monomial : sig @return [true] iff m = x^1 for some variable x *) val is_var : t -> bool + (** [get_var m] + @return [x] iff m = x^1 for variable x *) + val get_var : t -> var option + + (** [div m1 m2] @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) val div : t -> t -> t * int @@ -141,6 +148,10 @@ module LinPoly : sig @return the monomial corresponding to the variable [x] *) val retrieve : int -> Monomial.t + (** [register m] + @return the variable index for the monomial m *) + val register : Monomial.t -> int + end (** [linpol_of_pol p] linearise the polynomial p *) @@ -161,11 +172,21 @@ module LinPoly : sig @returns 1.x where x is the variable (index) for monomial m *) val of_monomial : Monomial.t -> t + (** [of_vect v] + @returns a1.x1 + ... + an.xn + This is not the identity because xi is the variable index of xi^1 + *) + val of_vect : Vect.t -> t + (** [variables p] @return the set of variables of the polynomial p interpreted as a multi-variate polynomial *) val variables : t -> ISet.t + (** [is_variable p] + @return Some x if p = a.x for a >= 0 *) + val is_variable : t -> var option + (** [is_linear p] @return whether the multi-variate polynomial is linear. *) val is_linear : t -> bool @@ -245,6 +266,8 @@ module ProofFormat : sig | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list + val pr_size : prf_rule -> Num.num + val pr_rule_max_id : prf_rule -> int val proof_max_id : proof -> int @@ -294,9 +317,14 @@ sig (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) val output : out_channel -> t -> unit + val output_sys : out_channel -> t list -> unit + (** [zero] represents the tautology (0=0) *) val zero : t + (** [const n] represents the tautology (n>=0) *) + val const : Num.num -> t + (** [product p q] @return the polynomial p*q with its sign and proof *) val product : t -> t -> t @@ -321,4 +349,24 @@ sig *) val linear_pivot : t list -> t -> Vect.var -> t -> t option + +(** [subst sys] performs the equivalent of the 'subst' tactic of Coq. + For every p=0 \in sys such that p is linear in x with coefficient +/- 1 + i.e. p = 0 <-> x = e and x \notin e. + Replace x by e in sys + + NB: performing this transformation may hinders the non-linear prover to find a proof. + [elim_simple_linear_equality] is much more careful. + *) + + val subst : t list -> t list + + (** [subst1 sys] performs a single substitution *) + val subst1 : t list -> t list + + val saturate_subst : bool -> t list -> t list + + + val is_substitution : bool -> t -> var option + end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 4465aa1ee1..4ddeb6c2c0 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -11,9 +11,11 @@ (** A naive simplex *) open Polynomial open Num -open Util +(*open Util*) open Mutils +type ('a,'b) sum = Inl of 'a | Inr of 'b + let debug = false type iset = unit IMap.t @@ -130,12 +132,6 @@ let is_maximised rst v = violating a restriction. *) -(* let is_unbounded rst tbl vr = - IMap.for_all (fun x v -> if Vect.get vr v </ Int 0 - then not (IMap.mem vr rst) - else true - ) tbl - *) type result = | Max of num (** Maximum is reached *) @@ -335,6 +331,8 @@ let normalise_row (t : tableau) (v: Vect.t) = let add_row (nw :var) (t : tableau) (v : Vect.t) : tableau = IMap.add nw (normalise_row t v) t + + (** [push_real] performs reasoning over the rationals *) let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tableau) : certificate = if debug @@ -361,7 +359,7 @@ let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tabl Unsat (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) -(** One complication is that equalities needs some pre-processing.contents +(** One complication is that equalities needs some pre-processing. *) open Mutils open Polynomial @@ -406,25 +404,21 @@ let find_solution rst tbl = let choose_conflict (sol:Vect.t) (l: (var * Vect.t) list) = let esol = Vect.set 0 (Int 1) sol in - let is_conflict (x,v) = - if Vect.dotproduct esol v >=/ Int 0 - then None else Some(x,v) in - let (c,r) = extract is_conflict l in - match c with - | Some (c,_) -> Some (c,r) - | None -> match l with - | [] -> None - | e::l -> Some(e,l) - -(*let remove_redundant rst t = - IMap.fold (fun k v m -> if Restricted.is_restricted k rst && Vect.for_all (fun x _ -> x == 0 || Restricted.is_restricted x rst) v - then begin - if debug then - Printf.printf "%a is redundant\n" LinPoly.pp_var k; - IMap.remove k m - end - else m) t t - *) + + let rec most_violating l e (x,v) rst = + match l with + | [] -> Some((x,v),rst) + | (x',v')::l -> + let e' = Vect.dotproduct esol v' in + if e' <=/ e + then most_violating l e' (x',v') ((x,v)::rst) + else most_violating l e (x,v) ((x',v')::rst) in + + match l with + | [] -> None + | (x,v)::l -> let e = Vect.dotproduct esol v in + most_violating l e (x,v) [] + let rec solve opt l (rst:Restricted.t) (t:tableau) = @@ -515,65 +509,117 @@ let make_farkas_proof (env: WithProof.t IMap.t) vm v = WithProof.mult (Vect.cst n) (IMap.find x env) end) WithProof.zero v -(* -let incr_cut rmin x = - match rmin with - | None -> true - | Some r -> Int.compare x r = 1 - *) -let cut env rmin sol vm (rst:Restricted.t) (x,v) = -(* if not (incr_cut rmin x) - then None - else *) - let (n,r) = Vect.decomp_cst v in +let frac_num n = n -/ Num.floor_num n - let nf = Num.floor_num n in - if nf =/ n + +(* [resolv_var v rst tbl] returns (if it exists) a restricted variable vr such that v = vr *) +exception FoundVar of int + +let resolve_var v rst tbl = + let v = Vect.set v (Int 1) Vect.null in + try + IMap.iter (fun k vect -> + if Restricted.is_restricted k rst + then if Vect.equal v vect then raise (FoundVar k) + else ()) tbl ; None + with FoundVar k -> Some k + +let prepare_cut env rst tbl x v = + (* extract the unrestricted part *) + let (unrst,rstv) = Vect.partition (fun x vl -> not (Restricted.is_restricted x rst) && frac_num vl <>/ Int 0) (Vect.set 0 (Int 0) v) in + if Vect.is_null unrst + then Some rstv + else Some (Vect.fold (fun acc k i -> + match resolve_var k rst tbl with + | None -> acc (* Should not happen *) + | Some v' -> Vect.set v' i acc) + rstv unrst) + +let cut env rmin sol vm (rst:Restricted.t) tbl (x,v) = + begin + (* Printf.printf "Trying to cut %i\n" x;*) + let (n,r) = Vect.decomp_cst v in + + + let f = frac_num n in + + if f =/ Int 0 then None (* The solution is integral *) else (* This is potentially a cut *) - let cut = Vect.normalise - (Vect.fold (fun acc x n -> - if Restricted.is_restricted x rst then - Vect.set x (n -/ (Num.floor_num n)) acc - else acc - ) Vect.null r) in - if debug then Printf.fprintf stdout "Cut vector for %a : %a\n" LinPoly.pp_var x LinPoly.pp cut ; - let cut = make_farkas_proof env vm cut in - - match WithProof.cutting_plane cut with - | None -> None - | Some (v,prf) -> - if debug then begin - Printf.printf "This is a cutting plane:\n" ; - Printf.printf "%a -> %a\n" WithProof.output cut WithProof.output (v,prf); - end; - if Pervasives.(=) (snd v) Eq - then (* Unsat *) Some (x,(v,prf)) - else if eval_op Ge (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) (Int 0) - then begin - (* Can this happen? *) - if debug then Printf.printf "The cut is feasible - drop it\n"; - None - end - else Some(x,(v,prf)) - -let find_cut env u sol vm rst tbl = - (* find first *) - IMap.fold (fun x v acc -> - match acc with - | None -> cut env u sol vm rst (x,v) - | Some c -> acc) tbl None - -(* -let find_cut env u sol vm rst tbl = - IMap.fold (fun x v acc -> - match acc with - | Some c -> Some c - | None -> cut env u sol vm rst (x,v) - ) tbl None - *) + let t = + if f </ (Int 1) // (Int 2) + then + let t' = ((Int 1) // f) in + if Num.is_integer_num t' + then t' -/ Int 1 + else Num.floor_num t' + else Int 1 in + + let cut_coeff1 v = + let fv = frac_num v in + if fv <=/ (Int 1 -/ f) + then fv // (Int 1 -/ f) + else (Int 1 -/ fv) // f in + + let cut_coeff2 v = frac_num (t */ v) in + + let cut_vector ccoeff = + match prepare_cut env rst tbl x v with + | None -> Vect.null + | Some r -> + (*Printf.printf "Potential cut %a\n" LinPoly.pp r;*) + Vect.fold (fun acc x n -> Vect.set x (ccoeff n) acc) Vect.null r + in + + let lcut = List.map (fun cv -> Vect.normalise (cut_vector cv)) [cut_coeff1 ; cut_coeff2] in + + let lcut = List.map (make_farkas_proof env vm) lcut in + + let check_cutting_plane c = + match WithProof.cutting_plane c with + | None -> + if debug then Printf.printf "This is not cutting plane for %a\n%a:" LinPoly.pp_var x WithProof.output c; + None + | Some(v,prf) -> + if debug then begin + Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; + Printf.printf " %a\n" WithProof.output (v,prf); + end; + if Pervasives.(=) (snd v) Eq + then (* Unsat *) Some (x,(v,prf)) + else + let vl = (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) in + if eval_op Ge vl (Int 0) + then begin + (* Can this happen? *) + if debug then Printf.printf "The cut is feasible %s >= 0 ??\n" (Num.string_of_num vl); + None + end + else Some(x,(v,prf)) in + + find_some check_cutting_plane lcut + end + +let find_cut nb env u sol vm rst tbl = + if nb = 0 + then + IMap.fold (fun x v acc -> + match acc with + | None -> cut env u sol vm rst tbl (x,v) + | Some c -> Some c) tbl None + else + IMap.fold (fun x v acc -> + match cut env u sol vm rst tbl (x,v) , acc with + | None , Some r | Some r , None -> Some r + | None , None -> None + | Some (v,((lp,o),p1)) , Some (v',((lp',o'),p2)) -> + Some (if ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 + then (v,((lp,o),p1)) else (v',((lp',o'),p2))) + ) tbl None + + let integer_solver lp = let (l,_) = List.split lp in @@ -587,7 +633,10 @@ let integer_solver lp = | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) | Unsat c -> Inr c in + let nb = ref 0 in + let rec isolve env cr vr res = + incr nb; match res with | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) | Inl (rst,tbl,x) -> @@ -595,10 +644,11 @@ let integer_solver lp = Printf.fprintf stdout "Looking for a cut\n"; Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; + (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) end; let sol = find_solution rst tbl in - match find_cut env cr (*x*) sol vm rst tbl with + match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with | None -> None | Some(cr,((v,op),cut)) -> if Pervasives.(=) op Eq @@ -615,6 +665,8 @@ let integer_solver lp = isolve env None vr res let integer_solver lp = + if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp); + match integer_solver lp with | None -> None | Some prf -> if debug diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index b188ab4278..b80d5536eb 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -54,6 +54,17 @@ let pp_var_num pp_var o (v,n) = | Int 0 -> () | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v +let pp_var_num_smt pp_var o (v,n) = + if Int.equal v 0 + then if eq_num (Int 0) n then () + else Printf.fprintf o "%s" (string_of_num n) + else + match n with + | Int 1 -> pp_var o v + | Int -1 -> Printf.fprintf o "(- %a)" pp_var v + | Int 0 -> () + | _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v + let rec pp_gen pp_var o v = match v with @@ -66,6 +77,9 @@ let pp_var o v = Printf.fprintf o "x%i" v let pp o v = pp_gen pp_var o v +let pp_smt o v = + let list o v = List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v in + Printf.fprintf o "(+ %a)" list v let from_list (l: num list) = let rec xfrom_list i l = @@ -222,6 +236,19 @@ let decomp_cst v = | (0,vl)::v -> vl,v | _ -> Int 0,v +let rec decomp_at i v = + match v with + | [] -> (Int 0 , null) + | (vr,vl)::r -> if i = vr then (vl,r) + else if i < vr then (Int 0,v) + else decomp_at i r + +let decomp_fst v = + match v with + | [] -> ((0,Int 0),[]) + | x::v -> (x,v) + + let fold f acc v = List.fold_left (fun acc (v,i) -> f acc v i) acc v @@ -293,3 +320,19 @@ let dotproduct v1 v2 = then dot acc v1' v2 else dot acc v1 v2' in dot (Int 0) v1 v2 + + +let map f v = List.map (fun (x,v) -> f x v) v + +let abs_min_elt v = + match v with + | [] -> None + | (v,vl)::r -> + Some (List.fold_left (fun (v1,vl1) (v2,vl2) -> + if abs_num vl1 </ abs_num vl2 + then (v1,vl1) else (v2,vl2) ) (v,vl) r) + + +let partition p = List.partition (fun (vr,vl) -> p vr vl) + +let mkvar x = set x (Int 1) null diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index da6b1e8e9b..4c9b140aad 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -40,6 +40,9 @@ val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit (** [pp o v] prints the representation of the vector [v] over the channel [o] *) val pp : out_channel -> t -> unit +(** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *) +val pp_smt : out_channel -> t -> unit + (** [variables v] returns the set of variables with non-zero coefficients *) val variables : t -> ISet.t @@ -49,6 +52,11 @@ val get_cst : t -> num (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> num * t +(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : int -> t -> num * t + +val decomp_fst : t -> (var * num) * t + (** [cst c] returns the vector v=c+0.x1+...+0.xn *) val cst : num -> t @@ -70,10 +78,13 @@ val get : var -> t -> num i.e. the coefficient of the variable xi is set to ai' *) val set : var -> num -> t -> t +(** [mkvar xi] returns 1.xi *) +val mkvar : var -> t + (** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) val update : var -> (num -> num) -> t -> t -(** [fresh v] return the fresh variable with inded 1+ max (variables v) *) +(** [fresh v] return the fresh variable with index 1+ max (variables v) *) val fresh : t -> int (** [choose v] decomposes a vector [v] depending on whether it is [null] or not. @@ -154,3 +165,9 @@ val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option (** [dotproduct v1 v2] is the dot product of v1 and v2. *) val dotproduct : t -> t -> num + +val map : (var -> num -> 'a) -> t -> 'a list + +val abs_min_elt : t -> (var * num) option + +val partition : (var -> num -> bool) -> t -> t * t diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index f5d13053b1..813c521ab0 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -54,10 +54,10 @@ Record almost_field_theory : Prop := mk_afield { Section AlmostField. Variable AFth : almost_field_theory. -Let ARth := AFth.(AF_AR). -Let rI_neq_rO := AFth.(AF_1_neq_0). -Let rdiv_def := AFth.(AFdiv_def). -Let rinv_l := AFth.(AFinv_l). +Let ARth := (AF_AR AFth). +Let rI_neq_rO := (AF_1_neq_0 AFth). +Let rdiv_def := (AFdiv_def AFth). +Let rinv_l := (AFinv_l AFth). Add Morphism radd with signature (req ==> req ==> req) as radd_ext. Proof. exact (Radd_ext Reqe). Qed. @@ -115,12 +115,12 @@ Notation "- x" := (copp x) : C_scope. Infix "=?" := ceqb : C_scope. Notation "[ x ]" := (phi x) (at level 0). -Let phi_0 := CRmorph.(morph0). -Let phi_1 := CRmorph.(morph1). +Let phi_0 := (morph0 CRmorph). +Let phi_1 := (morph1 CRmorph). Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. Proof. -generalize (CRmorph.(morph_eq) c c'). +generalize ((morph_eq CRmorph) c c'). destruct (c =? c')%coef; auto. Qed. @@ -137,7 +137,7 @@ Variable get_sign_spec : sign_theory copp ceqb get_sign. Variable cdiv:C -> C -> C*C. Variable cdiv_th : div_theory req cadd cmul phi cdiv. -Let rpow_pow := pow_th.(rpow_pow_N). +Let rpow_pow := (rpow_pow_N pow_th). (* Polynomial expressions : (PExpr C) *) @@ -428,7 +428,7 @@ Qed. Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. Proof. -induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp. +induction p;simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. Qed. Lemma pow_pos_mul_l x y p : @@ -1587,7 +1587,7 @@ Section FieldAndSemiField. Definition F2AF f := mk_afield - (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). + (Rth_ARth Rsth Reqe (F_R f)) (F_1_neq_0 f) (Fdiv_def f) (Finv_l f). Record semi_field_theory : Prop := mk_sfield { SF_SR : semi_ring_theory rO rI radd rmul req; @@ -1603,10 +1603,10 @@ End MakeFieldPol. Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ - (SRth_ARth Rsth sf.(SF_SR)) - sf.(SF_1_neq_0) - sf.(SFdiv_def) - sf.(SFinv_l). + (SRth_ARth Rsth (SF_SR sf)) + (SF_1_neq_0 sf) + (SFdiv_def sf) + (SFinv_l sf). Section Complete. @@ -1621,9 +1621,9 @@ Section Complete. Notation "x == y" := (req x y) (at level 70, no associativity). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid3. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. @@ -1636,10 +1636,10 @@ Section Complete. Section AlmostField. Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). + Let ARth := (AF_AR AFth). + Let rI_neq_rO := (AF_1_neq_0 AFth). + Let rdiv_def := (AFdiv_def AFth). + Let rinv_l := (AFinv_l AFth). Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. @@ -1705,10 +1705,10 @@ End AlmostField. Section Field. Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := Fth.(F_R). - Let rI_neq_rO := Fth.(F_1_neq_0). - Let rdiv_def := Fth.(Fdiv_def). - Let rinv_l := Fth.(Finv_l). + Let Rth := (F_R Fth). + Let rI_neq_rO := (F_1_neq_0 Fth). + Let rdiv_def := (Fdiv_def Fth). + Let rinv_l := (Finv_l Fth). Let AFth := F2AF Rsth Reqe Fth. Let ARth := Rth_ARth Rsth Reqe Rth. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 15d490a6ab..4886c8b9aa 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -51,9 +51,9 @@ Section ZMORPHISM. Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid3. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. @@ -267,9 +267,9 @@ Section NMORPHISM. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. @@ -392,9 +392,9 @@ Section NWORDMORPHISM. Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid5. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. @@ -581,9 +581,9 @@ Section GEN_DIV. (* Useful tactics *) Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd with signature (req ==> req ==> req) as radd_ext. @@ -614,7 +614,7 @@ Section GEN_DIV. Proof. constructor. intros a b;unfold triv_div. - assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). + assert (X:= morph_eq morph a b);destruct (ceqb a b). Esimpl. rewrite X; trivial. rsimpl. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 38bc58a659..e12bf36339 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -141,6 +141,11 @@ Ltac IZR_tac t := match t with | R0 => constr:(0%Z) | R1 => constr:(1%Z) + | IZR (Z.pow_pos 10 ?p) => + match isPcst p with + | true => constr:(Z.pow_pos 10 p) + | _ => constr:(InitialRing.NotConstant) + end | IZR ?u => match isZcst u with | true => u diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 12f716c496..f7cb6b688b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -600,7 +600,7 @@ Section MakeRingPol. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. - apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). @@ -810,7 +810,7 @@ Section MakeRingPol. Proof. revert l. induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). + - assert (H := (div_eucl_th div_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. @@ -827,7 +827,7 @@ Section MakeRingPol. try (case Pos.compare_spec; intros He); rewrite ?He; destr_factor; simpl; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). + - assert (H := div_eucl_th div_th c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - now rewrite <- jump_add, Pos.sub_add. @@ -1073,7 +1073,7 @@ Section POWER. - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - rewrite IHpe. Esimpl. - rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. @@ -1329,7 +1329,7 @@ Section POWER. case_eq (get_sign c);intros. assert (H1 := (morph_eq CRmorph) c0 cI). destruct (c0 ?=! cI). - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H)). Esimpl. rewrite H1;trivial. rewrite <- r_list_pow_rev;trivial;Esimpl. apply mkmultm1_ok. rewrite <- r_list_pow_rev; apply mkmult_rec_ok. @@ -1340,7 +1340,7 @@ Qed. Proof. intros;unfold mkadd_mult. case_eq (get_sign c);intros. - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. Qed. @@ -1421,7 +1421,7 @@ Qed. | xO _ => rpow r (Cp_phi (Npos p)) | 1 => r end == pow_pos rmul r p. - Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed. + Proof. destruct p; now rewrite ?(rpow_pow_N pow_th). Qed. Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 6c782269ab..3e835f5c9f 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -358,7 +358,7 @@ Section ALMOST_RING. rewrite <-(Radd_0_l Rth (- x * y)). rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). - rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth). + rewrite (Radd_comm Rth (-x)), (Ropp_def Rth). now rewrite Rmul_0_l, (Radd_0_l Rth). Qed. @@ -407,9 +407,9 @@ Section ALMOST_RING. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. Add Parametric Relation : C ceq - reflexivity proved by Csth.(@Equivalence_Reflexive _ _) - symmetry proved by Csth.(@Equivalence_Symmetric _ _) - transitivity proved by Csth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Csth) + symmetry proved by (@Equivalence_Symmetric _ _ Csth) + transitivity proved by (@Equivalence_Transitive _ _ Csth) as C_setoid. Add Morphism cadd with signature (ceq ==> ceq ==> ceq) as cadd_ext. @@ -430,7 +430,7 @@ Section ALMOST_RING. Lemma Smorph_opp x : [-!x] == -[x]. Proof. - rewrite <- (Rth.(Radd_0_l) [-!x]). + rewrite <- (Radd_0_l Rth [-!x]). rewrite <- ((Ropp_def Rth) [x]). rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). @@ -498,12 +498,12 @@ Qed. Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. Proof. - mrewrite. now rewrite !(ARth.(ARmul_comm) z). + mrewrite. now rewrite !(ARmul_comm ARth z). Qed. Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. Proof. - now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x). + now rewrite <-(ARadd_assoc ARth x), (ARadd_comm ARth x). Qed. Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index 3ce6478700..6be556b2ae 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -86,15 +86,20 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_theory id t l } - | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + | ![proof] [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + fun ~pstate -> Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> - let sigma, env = Pfedit.get_current_context () in + (* We should use the global env here as this shouldn't contain proof + data, however preserving behavior as requested in review. *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name } + ) !from_name; + pstate } END TACTIC EXTEND ring_lookup @@ -130,15 +135,20 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } -| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { +| ![proof] [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { + fun ~pstate -> Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> - let sigma, env = Pfedit.get_current_context () in + (* We should use the global env here as this shouldn't + contain proof data. *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name } + ) !field_from_name; + pstate } END TACTIC EXTEND field_lookup diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 6956120a6a..2a84469af0 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -246,6 +246,7 @@ let interp_refine ist gl rc = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in @@ -1175,7 +1176,7 @@ let genstac (gens, clr) = tclTHENLIST (old_cleartac clr :: List.rev_map gentac gens) let gen_tmp_ids - ?(ist=Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty })) gl + ?(ist=Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })) gl = let gl, ctx = pull_ctx gl in push_ctxs ctx @@ -1232,7 +1233,7 @@ let abs_wgen keep_let f gen (gl,args,c) = let evar_closed t p = if occur_existential sigma t then CErrors.user_err ?loc:(loc_of_cpattern p) ~hdr:"ssreflect" - (pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) ++ + (pr_econstr_pat env sigma t ++ str" contains holes and matches no subterm of the goal") in match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 94f7d24242..675e4d2457 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -194,7 +194,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let sort = Tacticals.elimination_sort_of_goal gl in let gl, elim = if not is_case then - let t,gl= pf_fresh_global (Indrec.lookup_eliminator (kn,i) sort) gl in + let t,gl= pf_fresh_global (Indrec.lookup_eliminator env (kn,i) sort) gl in gl, t else Tacmach.pf_eapply (fun env sigma () -> @@ -239,8 +239,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elimty = Reductionops.whd_all env (project gl) elimty in seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in - ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elim))); - ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elimty))); + let () = + let sigma = project gl in + ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) | _ -> assert false in @@ -304,7 +306,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = * looking at the ones provided by the user and the inferred ones looking at * the type of the elimination principle *) let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern env p) in - let pp_inf_pat gl (_,_,t,_) = pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl t)) in + let pp_inf_pat gl (_,_,t,_) = pr_econstr_pat env (project gl) (fire_subst gl t) in let patterns, clr, gl = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl @@ -318,7 +320,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr c))); + ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -341,7 +343,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elim_pred, gen_eq_tac, clr, gl = let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ spc()++pp_term gl t++spc()++str"while the inferred pattern"++ - spc()++pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in + spc()++pr_econstr_pat env (project gl) (fire_subst gl inf_t)++spc()++ str"doesn't") in let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then @@ -426,7 +428,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = if not (Evar.Set.is_empty inter) then begin let i = Evar.Set.choose inter in let pat = List.find (fun t -> Evar.Set.mem i (evars_of_term t)) patterns in - errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr pat)++spc()++ + errorstrm Pp.(str"Pattern"++spc()++pr_econstr_pat env (project gl) pat++spc()++ str"was not completely instantiated and one of its variables"++spc()++ str"occurs in the type of another non-instantiated pattern variable"); end diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 902098c8ce..4433f2fce7 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -205,7 +205,7 @@ let rec get_evalref env sigma c = match EConstr.kind sigma c with | App (c', _) -> get_evalref env sigma c' | Cast (c', _, _) -> get_evalref env sigma c' | Proj(c,_) -> EvalConstRef(Projection.constant c) - | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") + | _ -> errorstrm Pp.(str "The term " ++ pr_econstr_pat (Global.env ()) sigma c ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with @@ -244,7 +244,7 @@ let unfoldintac occ rdx t (kt,_) gl = try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " - ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), + ++ pr_econstr_pat env sigma0 t ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), (fun () -> try end_T () with | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") @@ -270,12 +270,12 @@ let unfoldintac occ rdx t (kt,_) gl = else try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) with _ -> errorstrm Pp.(str "The term " ++ - pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t))), + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_econstr_pat env sigma t)), fake_pmatcher_end in let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) - with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat env0 sigma (EConstr.Unsafe.to_constr t)) in + with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl concl) gl ;; @@ -340,7 +340,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in let sort = elimination_sort_of_goal gl in - let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator env ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) let elim, _ = destConst elim in let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in @@ -415,7 +415,7 @@ let rwcltac cl rdx dir sr gl = let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> - errorstrm Pp.(str "no cast from " ++ pr_constr_pat (pf_env gl) (project gl) (EConstr.Unsafe.to_constr (snd sr)) + errorstrm Pp.(str "no cast from " ++ pr_econstr_pat (pf_env gl) (project gl) (snd sr) ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in @@ -433,9 +433,8 @@ let rwcltac cl rdx dir sr gl = if occur_existential (project gl) (Tacmach.pf_concl gl) then errorstrm Pp.(str "Rewriting impacts evars" ++ error) else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_constr_env (pf_env gl) (project gl) - (Term.mkNamedLambda (make_annot pattern_id Sorts.Relevant) - (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl)) + ++ pr_econstr_env (pf_env gl) (project gl) + (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl) ++ error) in tclTHEN cvtac' rwtac gl @@ -480,7 +479,7 @@ let rwprocess_rule dir rule gl = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat env sigma (EConstr.Unsafe.to_constr t))); + ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -505,9 +504,9 @@ let rwprocess_rule dir rule gl = let sigma, rs2 = loop d sigma s a.(1) rs 0 in let s, sigma = sr sigma 1 in loop d sigma s a.(0) rs2 0 - | App (r_eq, a) when Hipattern.match_with_equality_type sigma t != None -> + | App (r_eq, a) when Hipattern.match_with_equality_type env sigma t != None -> let (ind, u) = EConstr.destInd sigma r_eq and rhs = Array.last a in - let np = Inductiveops.inductive_nparamdecls ind in + let np = Inductiveops.inductive_nparamdecls env ind in let indu = (ind, EConstr.EInstance.kind sigma u) in let ind_ct = Inductiveops.type_of_constructors env indu in let lhs0 = last_arg sigma (EConstr.of_constr (strip_prod_assum ind_ct.(0))) in @@ -539,8 +538,8 @@ let rwprocess_rule dir rule gl = sigma, (d, r', lhs, rhs) :: rs | _ -> if red = 0 then loop d sigma r t rs 1 - else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) - ++ spc() ++ str "in rule " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr (snd rule))) + else errorstrm Pp.(str "not a rewritable relation: " ++ pr_econstr_pat env sigma t + ++ spc() ++ str "in rule " ++ pr_econstr_pat env sigma (snd rule)) in let sigma, r = rule in let t = Retyping.get_type_of env sigma r in @@ -554,9 +553,9 @@ let rwrxtac occ rdx_pat dir rule gl = let find_rule rdx = let rec rwtac = function | [] -> - errorstrm Pp.(str "pattern " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr rdx) ++ + errorstrm Pp.(str "pattern " ++ pr_econstr_pat env (project gl) rdx ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (snd rule))) + str " of " ++ pr_econstr_pat env (project gl) (snd rule)) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index be9586fdd7..3cadc92bcc 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -50,7 +50,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = let c = EConstr.of_constr c in let cl = EConstr.of_constr cl in if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ - pr_constr_pat env sigma (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ + pr_econstr_pat env sigma c++spc()++str"did not match and has holes."++spc()++ str"Did you mean pose?") else let c, (gl, cty) = match EConstr.kind sigma c with | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 0ec5f1673a..f44962f213 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -224,20 +224,20 @@ let test_ssrslashnum b1 b2 strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "/" -> (match Util.stream_nth 1 strm with - | Tok.INT _ when b1 -> + | Tok.NUMERAL _ when b1 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" | Tok.KEYWORD "/=" when not b2 -> () | Tok.KEYWORD "/" -> if not b2 then () else begin match Util.stream_nth 3 strm with - | Tok.INT _ -> () + | Tok.NUMERAL _ -> () | _ -> raise Stream.Failure end | _ -> raise Stream.Failure) | Tok.KEYWORD "/" when not b1 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" when not b2 -> () - | Tok.INT _ when b2 -> + | Tok.NUMERAL _ when b2 -> (match Util.stream_nth 3 strm with | Tok.KEYWORD "=" -> () | _ -> raise Stream.Failure) @@ -248,7 +248,7 @@ let test_ssrslashnum b1 b2 strm = | Tok.KEYWORD "//" when not b1 -> (match Util.stream_nth 1 strm with | Tok.KEYWORD "=" when not b2 -> () - | Tok.INT _ when b2 -> + | Tok.NUMERAL _ when b2 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" -> () | _ -> raise Stream.Failure) @@ -360,8 +360,8 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with - | _, Constrexpr.Numeral (s,b) -> - let n = int_of_string s in if b then n else -n + | _, Constrexpr.Numeral (b,{NumTok.int = s; frac = ""; exp = ""}) -> + let n = int_of_string s in (match b with SPlus -> n | SMinus -> -n) | _ -> raise Not_found end | None -> raise Not_found @@ -1200,7 +1200,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, - { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> + { v = CFix ( _, [_, Some {CAst.v = CStructRec locn}, bl, t, c]) } -> let bs = format_local_binders h bl in let bstr = if has_str then [Bstruct (Name locn.CAst.v)] else [] in bs @ bstr @ (if has_cast then [Bcast t] else []), c @@ -1424,7 +1424,7 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS (ident * ssrfwd) PRINTED BY { pr_ssrfixfwd } | [] -> CErrors.user_err (Pp.str "Bad structural argument") in loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in - let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in + let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some (CAst.make (CStructRec i))), lb, t', c']) in id, ((fk, h'), { ac with body = fix }) } END diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index d3f89147fa..bf7f082192 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -183,7 +183,7 @@ GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> - { Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) } + { Vernacexpr.VernacSetOption (false, ["Printing"; "Implicit"; "Defensive"], Vernacexpr.OptionUnset) } ] ] ; END @@ -566,17 +566,21 @@ let print_view_hints env sigma kind l = } VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY -| [ "Print" "Hint" "View" ssrviewpos(i) ] -> +| ![proof] [ "Print" "Hint" "View" ssrviewpos(i) ] -> { - let sigma, env = Pfedit.get_current_context () in - match i with + fun ~pstate -> + (* XXX this is incorrect *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + (match i with | Some k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k) | None -> List.iter (fun k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; - Ssrview.AdaptorDb.Equivalence ] + Ssrview.AdaptorDb.Equivalence ]); + pstate } END diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 537fd7d7b4..075ebf006a 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -43,7 +43,7 @@ module AdaptorDb = struct term_view_adaptor_db := AdaptorMap.add k (t :: lk) !term_view_adaptor_db let subst_adaptor ( subst, (k, t as a)) = - let t' = Detyping.subst_glob_constr subst t in + let t' = Detyping.subst_glob_constr (Global.env()) subst t in if t' == t then a else k, t' let in_db = diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 5eb106cc26..1deb935d5c 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -373,6 +373,12 @@ let pr_constr_pat env sigma c0 = if isEvar c then hole_var else map wipe_evar c in pr_constr_env env sigma (wipe_evar c0) +let ehole_var = EConstr.mkVar (Id.of_string "_") +let pr_econstr_pat env sigma c0 = + let rec wipe_evar c = let open EConstr in + if isEvar sigma c then ehole_var else map sigma wipe_evar c in + pr_econstr_env env sigma (wipe_evar c0) + (* Turn (new) evars into metas *) let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = let ise = ref ise0 in @@ -694,8 +700,7 @@ let source env = match upats_origin, upats with (if fixed_upat ise p then str"term " else str"partial term ") ++ pr_constr_pat env ise (p2t p) ++ spc() | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ - pr_constr_pat env ise (p2t p) ++ fnl() + pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ pr_constr_pat env ise (p2t p) ++ fnl() | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat env ise rule ++ spc() | _, [] | None, _::_::_ -> @@ -732,13 +737,13 @@ let rec uniquize = function env, 0, uniquize (instances ()) | NoMatch when (not raise_NoMatch) -> if !failed_because_of_TC then - errorstrm (source env++strbrk"matches but type classes inference fails") + errorstrm (source env ++ strbrk"matches but type classes inference fails") else errorstrm (source env ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in - errorstrm (str"all matches of "++source env++ + errorstrm (str"all matches of "++ source env ++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); let sigma, _, ({up_f = pf; up_a = pa} as u) = @@ -823,7 +828,7 @@ let pr_pattern_aux pr_constr = function | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern env (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat env sigma (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p + pr_pattern_aux (fun t -> pr_econstr_pat env sigma (pi3 (nf_open_term sigma sigma (EConstr.of_constr t)))) p let pr_cpattern = pr_term let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) @@ -1253,10 +1258,8 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> - errorstrm (str "partial term " ++ - pr_constr_pat env sigma - (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) ++ - str " does not match any subterm of the goal") + errorstrm (str "partial term " ++ pr_econstr_pat env sigma t + ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in @@ -1264,7 +1267,7 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty }) + ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 1143bcc813..25975c84e8 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -223,6 +223,7 @@ val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.Id.t -> cpattern val pr_constr_pat : env -> evar_map -> constr -> Pp.t +val pr_econstr_pat : env -> evar_map -> econstr -> Pp.t val pf_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 73a2b99434..baa4ae0306 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -35,8 +35,23 @@ ARGUMENT EXTEND numnotoption END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] ![proof][ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - { let (sigma, env) = Pfedit.get_current_context () in - vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + + { (* It is a bug to use the proof context here, but at the request of + * the reviewers we keep this broken behavior for now. The Global env + * should be used instead, and the `env, sigma` parameteter to the + * numeral notation command removed. + *) + fun ~pstate -> + let sigma, env = match pstate with + | None -> + let env = Global.env () in + let sigma = Evd.from_env env in + sigma, env + | Some pstate -> + Pfedit.get_current_context pstate + in + vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o; + pstate } END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg index 171e0e213d..cc8c13a84b 100644 --- a/plugins/syntax/g_string.mlg +++ b/plugins/syntax/g_string.mlg @@ -19,8 +19,22 @@ open Stdarg } VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] ![proof] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) ] -> - { let (sigma, env) = Pfedit.get_current_context () in - vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) } + { (* It is a bug to use the proof context here, but at the request of + * the reviewers we keep this broken behavior for now. The Global env + * should be used instead, and the `env, sigma` parameteter to the + * numeral notation command removed. + *) + fun ~pstate -> + let sigma, env = match pstate with + | None -> + let env = Global.env () in + let sigma = Evd.from_env env in + sigma, env + | Some pstate -> + Pfedit.get_current_context pstate + in + vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc); + pstate } END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 525056e5f1..ec8c2338fb 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -56,17 +56,24 @@ let locate_z () = }, mkRefC q_z) else None -let locate_int () = +let locate_decimal () = let int = "num.int.type" in let uint = "num.uint.type" in - if Coqlib.has_ref int && Coqlib.has_ref uint + let dec = "num.decimal.type" in + if Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref dec then let q_int = qualid_of_ref int in let q_uint = qualid_of_ref uint in - Some ({ + let q_dec = qualid_of_ref dec in + let int_ty = { int = unsafe_locate_ind q_int; uint = unsafe_locate_ind q_uint; - }, mkRefC q_int, mkRefC q_uint) + } in + let dec_ty = { + int = int_ty; + decimal = unsafe_locate_ind q_dec; + } in + Some (int_ty, mkRefC q_int, mkRefC q_uint, dec_ty, mkRefC q_dec) else None let locate_int63 () = @@ -86,16 +93,16 @@ let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Decimal.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first).") let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ - str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") + str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first).") let vernac_numeral_notation env sigma local ty f g scope opts = - let int_ty = locate_int () in + let dec_ty = locate_decimal () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in let tyc = Smartlocate.global_inductive_with_alias ty in @@ -110,11 +117,13 @@ let vernac_numeral_notation env sigma local ty f g scope opts = let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = - match int_ty with - | Some (int_ty, cint, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint cty) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + match dec_ty with + | Some (int_ty, cint, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + | Some (_, _, _, dec_ty, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal dec_ty, Direct + | Some (_, _, _, dec_ty, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal dec_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct @@ -127,11 +136,13 @@ let vernac_numeral_notation env sigma local ty f g scope opts = in (* Check the type of g *) let of_kind = - match int_ty with - | Some (int_ty, cint, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty cuint) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + match dec_ty with + | Some (int_ty, cint, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + | Some (_, _, _, dec_ty, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal dec_ty, Direct + | Some (_, _, _, dec_ty, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal dec_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index d90b7d754c..b9062dd16b 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -13,6 +13,7 @@ open Names open Globnames open Glob_term open Bigint +open Constrexpr (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -104,22 +105,76 @@ let r_modpath = MPfile (make_dir rdefinitions) let r_path = make_path rdefinitions "R" let glob_IZR = ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") - -let r_of_int ?loc z = - DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) +let glob_Rmult = ConstRef (Constant.make2 r_modpath @@ Label.make "Rmult") +let glob_Rdiv = ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") + +let binintdef = ["Coq";"ZArith";"BinIntDef"] +let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") + +let glob_pow_pos = ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") + +let r_of_rawnum ?loc (sign,n) = + let n, f, e = NumTok.(n.int, n.frac, n.exp) in + let izr z = + DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z]) in + let rmult r r' = + DAst.make @@ GApp (DAst.make @@ GRef(glob_Rmult,None), [r; r']) in + let rdiv r r' = + DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in + let pow10 e = + let ten = z_of_int ?loc (Bigint.of_int 10) in + let e = pos_of_bignat e in + DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [ten; e]) in + let n = + let n = Bigint.of_string (n ^ f) in + let n = match sign with SPlus -> n | SMinus -> Bigint.(neg n) in + izr (z_of_int ?loc n) in + let e = + let e = if e = "" then Bigint.zero else match e.[1] with + | '+' -> Bigint.of_string (String.sub e 2 (String.length e - 2)) + | '-' -> Bigint.(neg (of_string (String.sub e 2 (String.length e - 2)))) + | _ -> Bigint.of_string (String.sub e 1 (String.length e - 1)) in + Bigint.(sub e (of_int (String.length f))) in + if Bigint.is_strictly_pos e then rmult n (izr (pow10 e)) + else if Bigint.is_strictly_neg e then rdiv n (izr (pow10 (neg e))) + else n (* e = 0 *) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bigint_of_r c = match DAst.get c with +let rawnum_of_r c = match DAst.get c with | GApp (r, [a]) when is_gr r glob_IZR -> - bigint_of_z a + let n = bigint_of_z a in + let s, n = + if is_strictly_neg n then SMinus, neg n else SPlus, n in + s, NumTok.int (to_string n) + | GApp (md, [l; r]) when is_gr md glob_Rmult || is_gr md glob_Rdiv -> + begin match DAst.get l, DAst.get r with + | GApp (i, [l]), GApp (i', [r]) + when is_gr i glob_IZR && is_gr i' glob_IZR -> + begin match DAst.get r with + | GApp (p, [t; e]) when is_gr p glob_pow_pos -> + let t = bigint_of_z t in + if not (Bigint.(equal t (of_int 10))) then + raise Non_closed_number + else + let i = bigint_of_z l in + let e = bignat_of_pos e in + let s, i = if is_pos_or_zero i then SPlus, i else SMinus, neg i in + let i = Bigint.to_string i in + let se = if is_gr md glob_Rdiv then "-" else "" in + let e = se ^ Bigint.to_string e in + s, { NumTok.int = i; frac = ""; exp = e } + | _ -> raise Non_closed_number + end + | _ -> raise Non_closed_number + end | _ -> raise Non_closed_number let uninterp_r (AnyGlobConstr p) = try - Some (bigint_of_r p) + Some (rawnum_of_r p) with Non_closed_number -> None @@ -131,11 +186,11 @@ let at_declare_ml_module f x = let r_scope = "R_scope" let _ = - register_bignumeral_interpretation r_scope (r_of_int,uninterp_r); + register_rawnumeral_interpretation r_scope (r_of_rawnum,uninterp_r); at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = r_scope; pt_interp_info = Uid r_scope; pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); - pt_refs = [glob_IZR]; + pt_refs = [glob_IZR; glob_Rmult; glob_Rdiv]; pt_in_match = false } diff --git a/pretyping/cases.ml b/pretyping/cases.ml index e22368d5e5..d7a6c4c832 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -284,7 +284,7 @@ let rec find_row_ind = function let inductive_template env sigma tmloc ind = let sigma, indu = Evd.fresh_inductive_instance env sigma ind in - let arsign = inductive_alldecls_env env indu in + let arsign = inductive_alldecls env indu in let indu = on_snd EInstance.make indu in let hole_source i = match tmloc with | Some loc -> Loc.tag ~loc @@ Evar_kinds.TomatchTypeParameter (ind,i) @@ -313,7 +313,7 @@ let try_find_ind env sigma typ realnames = | Some names -> names | None -> let ind = fst (fst (dest_ind_family indf)) in - List.make (inductive_nrealdecls ind) Anonymous in + List.make (inductive_nrealdecls env ind) Anonymous in IsInd (typ,ind,names) let inh_coerce_to_ind env sigma0 loc ty tyi = @@ -1796,7 +1796,7 @@ let build_inversion_problem ~program_mode loc env sigma tms t = | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in - let n = constructor_nrealargs_env !!env cstr in + let n = constructor_nrealargs !!env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_right_map reveal_pattern l acc in DAst.make (PatCstr (cstr,l,Anonymous)), acc @@ -1929,7 +1929,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in - let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in + let nrealargs_ctxt = inductive_nrealdecls env0 ind in let arsign, inds = get_arity env0 indf' in let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = diff --git a/pretyping/classops.ml b/pretyping/classops.ml index ef918a614e..90ce1cc594 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -15,7 +15,6 @@ open Names open Constr open Libnames open Globnames -open Libobject open Mod_subst (* usage qque peu general: utilise aussi dans record *) @@ -288,7 +287,7 @@ let get_coercion_constructor env coe = let red x = fst (Reductionops.whd_all_stack env evd x) in match EConstr.kind evd (red (mkNamed coe.coe_value)) with | Constr.Construct (c, _) -> - c, Inductiveops.constructor_nrealargs c -1 + c, Inductiveops.constructor_nrealargs env c -1 | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = @@ -305,42 +304,43 @@ let install_path_printer f = path_printer := f let print_path x = !path_printer x -let message_ambig l = - str"Ambiguous paths:" ++ spc () ++ - prlist_with_sep fnl print_path l +let path_comparator : (Environ.env -> Evd.evar_map -> inheritance_path -> inheritance_path -> bool) ref = + ref (fun _ _ _ _ -> false) + +let install_path_comparator f = path_comparator := f + +let compare_path p q = !path_comparator p q + +let warn_ambiguous_path = + CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" + (fun l -> strbrk"Ambiguous paths: " ++ prlist_with_sep fnl print_path l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) -let different_class_params i = +let different_class_params env i = let ci = class_info_from_index i in if (snd ci).cl_param > 0 then true else match fst ci with - | CL_IND i -> Global.is_polymorphic (IndRef i) - | CL_CONST c -> Global.is_polymorphic (ConstRef c) + | CL_IND i -> Environ.is_polymorphic env (IndRef i) + | CL_CONST c -> Environ.is_polymorphic env (ConstRef c) | _ -> false -let add_coercion_in_graph (ic,source,target) = +let add_coercion_in_graph env sigma (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = - try - if Bijint.Index.equal i j then begin - if different_class_params i then begin - let _ = lookup_path_between_class ij in - ambig_paths := (ij,p)::!ambig_paths - end - end else begin - let _ = lookup_path_between_class ij in - ambig_paths := (ij,p)::!ambig_paths - end; + if not (Bijint.Index.equal i j) || different_class_params env i then + match lookup_path_between_class ij with + | q -> + if not (compare_path env sigma p q) then + ambig_paths := (ij,p)::!ambig_paths; + false + | exception Not_found -> (add_new_path ij p; true) + else false - with Not_found -> begin - add_new_path ij p; - true - end in let try_add_new_path1 ij p = let _ = try_add_new_path ij p in () @@ -361,9 +361,7 @@ let add_coercion_in_graph (ic,source,target) = end) old_inheritance_graph end; - let is_ambig = match !ambig_paths with [] -> false | _ -> true in - if is_ambig && not !Flags.quiet then - Feedback.msg_info (message_ambig !ambig_paths) + match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths type coercion = { coercion_type : coe_typ; @@ -375,31 +373,42 @@ type coercion = { coercion_params : int; } +let subst_coercion subst c = + let coe = subst_coe_typ subst c.coercion_type in + let cls = subst_cl_typ subst c.coercion_source in + let clt = subst_cl_typ subst c.coercion_target in + let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in + if c.coercion_type == coe && c.coercion_source == cls && + c.coercion_target == clt && c.coercion_is_proj == clp + then c + else { c with coercion_type = coe; coercion_source = cls; + coercion_target = clt; coercion_is_proj = clp; } + (* Computation of the class arity *) -let reference_arity_length ref = - let t, _ = Typeops.type_of_global_in_context (Global.env ()) ref in - List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty (EConstr.of_constr t))) (** FIXME *) +let reference_arity_length env sigma ref = + let t, _ = Typeops.type_of_global_in_context env ref in + List.length (fst (Reductionops.splay_arity env sigma (EConstr.of_constr t))) -let projection_arity_length p = - let len = reference_arity_length (ConstRef (Projection.Repr.constant p)) in +let projection_arity_length env sigma p = + let len = reference_arity_length env sigma (ConstRef (Projection.Repr.constant p)) in len - Projection.Repr.npars p -let class_params = function +let class_params env sigma = function | CL_FUN | CL_SORT -> 0 - | CL_CONST sp -> reference_arity_length (ConstRef sp) - | CL_PROJ sp -> projection_arity_length sp - | CL_SECVAR sp -> reference_arity_length (VarRef sp) - | CL_IND sp -> reference_arity_length (IndRef sp) + | CL_CONST sp -> reference_arity_length env sigma (ConstRef sp) + | CL_PROJ sp -> projection_arity_length env sigma sp + | CL_SECVAR sp -> reference_arity_length env sigma (VarRef sp) + | CL_IND sp -> reference_arity_length env sigma (IndRef sp) (* add_class : cl_typ -> locality_flag option -> bool -> unit *) -let add_class cl = - add_new_class cl { cl_param = class_params cl } +let add_class env sigma cl = + add_new_class cl { cl_param = class_params env sigma cl } -let cache_coercion (_, c) = - let () = add_class c.coercion_source in - let () = add_class c.coercion_target in +let declare_coercion env sigma c = + let () = add_class env sigma c.coercion_source in + let () = add_class env sigma c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in let xf = @@ -410,65 +419,7 @@ let cache_coercion (_, c) = coe_param = c.coercion_params; } in let () = add_new_coercion c.coercion_type xf in - add_coercion_in_graph (xf,is,it) - -let open_coercion i o = - if Int.equal i 1 then - cache_coercion o - -let subst_coercion (subst, c) = - let coe = subst_coe_typ subst c.coercion_type in - let cls = subst_cl_typ subst c.coercion_source in - let clt = subst_cl_typ subst c.coercion_target in - let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in - if c.coercion_type == coe && c.coercion_source == cls && - c.coercion_target == clt && c.coercion_is_proj == clp - then c - else { c with coercion_type = coe; coercion_source = cls; - coercion_target = clt; coercion_is_proj = clp; } - -let discharge_coercion (_, c) = - if c.coercion_local then None - else - let n = - try - let ins = Lib.section_instance c.coercion_type in - Array.length (snd ins) - with Not_found -> 0 - in - let nc = { c with - coercion_params = n + c.coercion_params; - coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; - } in - Some nc - -let classify_coercion obj = - if obj.coercion_local then Dispose else Substitute obj - -let inCoercion : coercion -> obj = - declare_object {(default_object "COERCION") with - open_function = open_coercion; - cache_function = cache_coercion; - subst_function = subst_coercion; - classify_function = classify_coercion; - discharge_function = discharge_coercion } - -let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = - let isproj = - match coef with - | ConstRef c -> Recordops.find_primitive_projection c - | _ -> None - in - let c = { - coercion_type = coef; - coercion_local = local; - coercion_is_id = isid; - coercion_is_proj = isproj; - coercion_source = cls; - coercion_target = clt; - coercion_params = ps; - } in - Lib.add_anonymous_leaf (inCoercion c) + add_coercion_in_graph env sigma (xf,is,it) (* For printing purpose *) let pr_cl_index = Bijint.Index.print @@ -491,7 +442,7 @@ module CoercionPrinting = struct type t = coe_typ let compare = GlobRef.Ordered.compare - let encode = coercion_of_reference + let encode _env = coercion_of_reference let subst = subst_coe_typ let printer x = Nametab.pr_global_env Id.Set.empty x let key = ["Printing";"Coercion"] diff --git a/pretyping/classops.mli b/pretyping/classops.mli index ed2c5478f0..c04182930e 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -75,9 +75,19 @@ val inductive_class_of : inductive -> cl_index val class_args_of : env -> evar_map -> types -> constr list (** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) -val declare_coercion : - coe_typ -> ?local:bool -> isid:bool -> - src:cl_typ -> target:cl_typ -> params:int -> unit +type coercion = { + coercion_type : coe_typ; + coercion_local : bool; + coercion_is_id : bool; + coercion_is_proj : Projection.Repr.t option; + coercion_source : cl_typ; + coercion_target : cl_typ; + coercion_params : int; +} + +val subst_coercion : substitution -> coercion -> coercion + +val declare_coercion : env -> evar_map -> coercion -> unit (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool @@ -100,6 +110,8 @@ val lookup_pattern_path_between : (* Crade *) val install_path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit +val install_path_comparator : + (env -> evar_map -> inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index ac7c3d30d5..062e3ca8b2 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -29,6 +29,93 @@ open Decl_kinds open Context.Named.Declaration open Ltac_pretype +type detyping_flags = { + flg_lax : bool; + flg_isgoal : bool; +} + +module Avoid : +sig + type t + val make : fast:bool -> Id.Set.t -> t + val compute_name : Evd.evar_map -> let_in:bool -> pattern:bool -> + detyping_flags -> t -> Name.t list * 'a -> Name.t -> + EConstr.constr -> Name.t * t + val next_name_away : detyping_flags -> Name.t -> t -> Id.t * t +end = +struct + +open Nameops + +type t = +| Nice of Id.Set.t +| Fast of Subscript.t Id.Map.t + (** Overapproximation of the set of names to avoid. If [(id ↦ s) ∈ m] then for + all subscript [s'] smaller than [s], [add_subscript id s'] needs to be + avoided. *) + +let make ~fast ids = + if fast then + let fold id accu = + let id, ss = get_subscript id in + let old_ss = try Id.Map.find id accu with Not_found -> Subscript.zero in + if Subscript.compare ss old_ss <= 0 then accu else Id.Map.add id ss accu + in + let avoid = Id.Set.fold fold ids Id.Map.empty in + Fast avoid + else Nice ids + +let fresh_id_in id avoid = + let id, _ = get_subscript id in + (* Find the first free subscript for that identifier *) + let ss = try Subscript.succ (Id.Map.find id avoid) with Not_found -> Subscript.zero in + let avoid = Id.Map.add id ss avoid in + (add_subscript id ss, avoid) + +let compute_name sigma ~let_in ~pattern flags avoid env na c = +match avoid with +| Nice avoid -> + let flags = + if flags.flg_isgoal then RenamingForGoal + else if pattern then RenamingForCasesPattern (fst env, c) + else RenamingElsewhereFor (fst env, c) + in + let na, avoid = + if let_in then compute_displayed_let_name_in sigma flags avoid na c + else compute_displayed_name_in sigma flags avoid na c + in + na, Nice avoid +| Fast avoid -> + (* In fast mode, we use a dumber algorithm but algorithmically more + efficient algorithm that doesn't iterate through the term to find the + used constants and variables. *) + let id = match na with + | Name id -> id + | Anonymous -> + if flags.flg_isgoal then default_non_dependent_ident + else if pattern then default_dependent_ident + else default_non_dependent_ident + in + let id, avoid = fresh_id_in id avoid in + (Name id, Fast avoid) + +let next_name_away flags na avoid = match avoid with +| Nice avoid -> + let id = next_name_away na avoid in + id, Nice (Id.Set.add id avoid) +| Fast avoid -> + let id = match na with + | Anonymous -> default_non_dependent_ident + | Name id -> id + in + let id, avoid = fresh_id_in id avoid in + (id, Fast avoid) + +end + +let compute_name = Avoid.compute_name +let next_name_away = Avoid.next_name_away + type _ delay = | Now : 'a delay | Later : [ `thunk ] delay @@ -58,9 +145,9 @@ let add_name_opt na b t (nenv, env) = (****************************************************************************) (* Tools for printing of Cases *) -let encode_inductive r = +let encode_inductive env r = let indsp = Nametab.global_inductive r in - let constr_lengths = constructors_nrealargs indsp in + let constr_lengths = constructors_nrealargs env indsp in (indsp,constr_lengths) (* Parameterization of the translation from constr to ast *) @@ -72,15 +159,15 @@ let has_two_constructors lc = let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 -let encode_bool ({CAst.loc} as r) = - let (x,lc) = encode_inductive r in +let encode_bool env ({CAst.loc} as r) = + let (x,lc) = encode_inductive env r in if not (has_two_constructors lc) then user_err ?loc ~hdr:"encode_if" (str "This type has not exactly two constructors."); x -let encode_tuple ({CAst.loc} as r) = - let (x,lc) = encode_inductive r in +let encode_tuple env ({CAst.loc} as r) = + let (x,lc) = encode_inductive env r in if not (isomorphic_to_tuple lc) then user_err ?loc ~hdr:"encode_tuple" (str "This type cannot be seen as a tuple type."); @@ -88,7 +175,7 @@ let encode_tuple ({CAst.loc} as r) = module PrintingInductiveMake = functor (Test : sig - val encode : qualid -> inductive + val encode : Environ.env -> qualid -> inductive val member_message : Pp.t -> bool -> Pp.t val field : string val title : string @@ -147,6 +234,16 @@ let () = declare_bool_option optread = force_wildcard; optwrite = (:=) wildcard_value } +let fast_name_generation = ref false + +let () = declare_bool_option { + optdepr = false; + optname = "fast bound name generation algorithm"; + optkey = ["Fast";"Name";"Printing"]; + optread = (fun () -> !fast_name_generation); + optwrite = (:=) fast_name_generation; +} + let synth_type_value = ref true let synthetize_type () = !synth_type_value @@ -210,7 +307,7 @@ let lookup_name_as_displayed env sigma t s = | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with + (match Namegen.compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c @@ -220,7 +317,7 @@ let lookup_name_as_displayed env sigma t s = let lookup_index_as_renamed env sigma t n = let rec lookup n d c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with + (match Namegen.compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -230,7 +327,7 @@ let lookup_index_as_renamed env sigma t n = else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with + (match Namegen.compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -339,24 +436,23 @@ let update_name sigma na ((_,(e,_)),c) = | _ -> na -let rec decomp_branch tags nal b (avoid,env as e) sigma c = - let flag = if b then RenamingForGoal else RenamingForCasesPattern (fst env,c) in +let rec decomp_branch tags nal flags (avoid,env as e) sigma c = match tags with | [] -> (List.rev nal,(e,c)) | b::tags -> - let na,c,f,body,t = + let na,c,let_in,body,t = match EConstr.kind sigma (strip_outer_cast sigma c), b with - | Lambda (na,t,c),false -> na.binder_name,c,compute_displayed_let_name_in,None,Some t + | Lambda (na,t,c),false -> na.binder_name,c,true,None,Some t | LetIn (na,b,t,c),true -> - na.binder_name,c,compute_displayed_name_in,Some b,Some t + na.binder_name,c,false,Some b,Some t | _, false -> Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])), - compute_displayed_name_in,None,None + false,None,None | _, true -> - Anonymous,lift 1 c,compute_displayed_name_in,None,None + Anonymous,lift 1 c,false,None,None in - let na',avoid' = f sigma flag avoid na c in - decomp_branch tags (na'::nal) b + let na',avoid' = compute_name sigma ~let_in ~pattern:true flags avoid env na c in + decomp_branch tags (na'::nal) flags (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = @@ -490,37 +586,37 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = let eqnl = detype_eqns constructs constagsl bl in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) -let rec share_names detype n l avoid env sigma c t = +let rec share_names detype flags n l avoid env sigma c t = match EConstr.kind sigma c, EConstr.kind sigma t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> let na = Nameops.Name.pick_annot na na' in - let t' = detype avoid env sigma t in - let id = next_name_away na.binder_name avoid in - let avoid = Id.Set.add id avoid and env = add_name (Name id) None t env in - share_names detype (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' + let t' = detype flags avoid env sigma t in + let id, avoid = next_name_away flags na.binder_name avoid in + let env = add_name (Name id) None t env in + share_names detype flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> - let t'' = detype avoid env sigma t' in - let b' = detype avoid env sigma b in - let id = next_name_away na.binder_name avoid in - let avoid = Id.Set. add id avoid and env = add_name (Name id) (Some b) t' env in - share_names detype n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) + let t'' = detype flags avoid env sigma t' in + let b' = detype flags avoid env sigma b in + let id, avoid = next_name_away flags na.binder_name avoid in + let env = add_name (Name id) (Some b) t' env in + share_names detype flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) (* Only if built with the f/n notation or w/o let-expansion in types *) | _, LetIn (_,b,_,t) when n > 0 -> - share_names detype n l avoid env sigma c (subst1 b t) + share_names detype flags n l avoid env sigma c (subst1 b t) (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> - let t'' = detype avoid env sigma t' in - let id = next_name_away na'.binder_name avoid in - let avoid = Id.Set.add id avoid and env = add_name (Name id) None t' env in + let t'' = detype flags avoid env sigma t' in + let id, avoid = next_name_away flags na'.binder_name avoid in + let env = add_name (Name id) None t' env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in - share_names detype (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' + share_names detype flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' (* If built with the f/n notation: we renounce to share names *) | _ -> if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough"); - let c = detype avoid env sigma c in - let t = detype avoid env sigma t in + let c = detype flags avoid env sigma c in + let t = detype flags avoid env sigma t in (List.rev l,c,t) let rec share_pattern_names detype n l avoid env sigma c t = @@ -536,7 +632,7 @@ let rec share_pattern_names detype n l avoid env sigma c t = | _, Name _ -> na' | _ -> na in let t' = detype avoid env sigma t in - let id = next_name_away na avoid in + let id = Namegen.next_name_away na avoid in let avoid = Id.Set.add id avoid in let env = Name id :: env in share_pattern_names detype (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' @@ -546,32 +642,32 @@ let rec share_pattern_names detype n l avoid env sigma c t = let t = detype avoid env sigma t in (List.rev l,c,t) -let detype_fix detype avoid env sigma (vn,_ as nvn) (names,tys,bodies) = +let detype_fix detype flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> - let id = next_name_away na.binder_name avoid in - (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) + let id, avoid = next_name_away flags na.binder_name avoid in + (avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let n = Array.length tys in let v = Array.map3 - (fun c t i -> share_names detype (i+1) [] def_avoid def_env sigma c (lift n t)) + (fun c t i -> share_names detype flags (i+1) [] def_avoid def_env sigma c (lift n t)) bodies tys vn in - GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) -let detype_cofix detype avoid env sigma n (names,tys,bodies) = +let detype_cofix detype flags avoid env sigma n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> - let id = next_name_away na.binder_name avoid in - (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) + let id, avoid = next_name_away flags na.binder_name avoid in + (avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let ntys = Array.length tys in let v = Array.map2 - (fun c t -> share_names detype 0 [] def_avoid def_env sigma c (lift ntys t)) + (fun c t -> share_names detype flags 0 [] def_avoid def_env sigma c (lift ntys t)) bodies tys in GRec(GCoFix n,Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, @@ -685,7 +781,7 @@ and detype_r d flags avoid env sigma t = GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), (args @ [detype d flags avoid env sigma c])) in - if fst flags || !Flags.in_debugger || !Flags.in_toplevel then + if flags.flg_lax || !Flags.in_debugger || !Flags.in_toplevel then try noparams () with _ -> (* lax mode, used by debug printers only *) @@ -736,14 +832,14 @@ and detype_r d flags avoid env sigma t = (ci.ci_ind,ci.ci_pp_info.style, ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) p c bl - | Fix (nvn,recdef) -> detype_fix (detype d flags) avoid env sigma nvn recdef - | CoFix (n,recdef) -> detype_cofix (detype d flags) avoid env sigma n recdef + | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef + | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef | Int i -> GInt i and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; - let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in + let mat = build_tree Anonymous flags (avoid,env) sigma ci bl in List.map (fun (ids,pat,((avoid,env),c)) -> CAst.make (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) mat @@ -751,13 +847,12 @@ and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = Array.to_list (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) -and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = +and detype_eqn d flags avoid env sigma constr construct_nargs branch = let make_pat x avoid env b body ty ids = if force_wildcard () && noccurn sigma 1 b then DAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids else - let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in - let na,avoid' = compute_displayed_name_in sigma flag avoid x b in + let na,avoid' = compute_name sigma ~let_in:false ~pattern:true flags avoid env x b in DAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na in let rec buildrec ids patlist avoid env l b = @@ -793,23 +888,22 @@ and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs br in buildrec Id.Set.empty [] avoid env construct_nargs branch -and detype_binder d (lax,isgoal as flags) bk avoid env sigma {binder_name=na} body ty c = - let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (fst env,c) in +and detype_binder d flags bk avoid env sigma {binder_name=na} body ty c = let na',avoid' = match bk with - | BLetIn -> compute_displayed_let_name_in sigma flag avoid na c - | _ -> compute_displayed_name_in sigma flag avoid na c in + | BLetIn -> compute_name sigma ~let_in:true ~pattern:false flags avoid env na c + | _ -> compute_name sigma ~let_in:false ~pattern:false flags avoid env na c in let r = detype d flags avoid' (add_name na' body ty env) sigma c in match bk with - | BProd -> GProd (na',Explicit,detype d (lax,false) avoid env sigma ty, r) - | BLambda -> GLambda (na',Explicit,detype d (lax,false) avoid env sigma ty, r) + | BProd -> GProd (na',Explicit,detype d { flags with flg_isgoal = false } avoid env sigma ty, r) + | BLambda -> GLambda (na',Explicit,detype d { flags with flg_isgoal = false } avoid env sigma ty, r) | BLetIn -> - let c = detype d (lax,false) avoid env sigma (Option.get body) in + let c = detype d { flags with flg_isgoal = false } avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in - let t = if s != InProp && not !Flags.raw_print then None else Some (detype d (lax,false) avoid env sigma ty) in + let t = if s != InProp && not !Flags.raw_print then None else Some (detype d { flags with flg_isgoal = false } avoid env sigma ty) in GLetIn (na', c, t, r) -let detype_rel_context d ?(lax=false) where avoid env sigma sign = +let detype_rel_context d flags where avoid env sigma sign = let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] @@ -821,28 +915,30 @@ let detype_rel_context d ?(lax=false) where avoid env sigma sign = match where with | None -> na,avoid | Some c -> - if is_local_def decl then - compute_displayed_let_name_in sigma - (RenamingElsewhereFor (fst env,c)) avoid na c - else - compute_displayed_name_in sigma - (RenamingElsewhereFor (fst env,c)) avoid na c in + compute_name sigma ~let_in:(is_local_def decl) ~pattern:false flags avoid env na c + in let b = match decl with | LocalAssum _ -> None | LocalDef (_,b,_) -> Some b in - let b' = Option.map (detype d (lax,false) avoid env sigma) b in - let t' = detype d (lax,false) avoid env sigma t in + let b' = Option.map (detype d flags avoid env sigma) b in + let t' = detype d flags avoid env sigma t in (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest in aux avoid env (List.rev sign) let detype_names isgoal avoid nenv env sigma t = - detype Now (false,isgoal) avoid (nenv,env) sigma t + let flags = { flg_isgoal = isgoal; flg_lax = false } in + let avoid = Avoid.make ~fast:!fast_name_generation avoid in + detype Now flags avoid (nenv,env) sigma t let detype d ?(lax=false) isgoal avoid env sigma t = - detype d (lax,isgoal) avoid (names_of_rel_context env, env) sigma t + let flags = { flg_isgoal = isgoal; flg_lax = lax } in + let avoid = Avoid.make ~fast:!fast_name_generation avoid in + detype d flags avoid (names_of_rel_context env, env) sigma t -let detype_rel_context d ?lax where avoid env sigma sign = - detype_rel_context d ?lax where avoid env sigma sign +let detype_rel_context d ?(lax = false) where avoid env sigma sign = + let flags = { flg_isgoal = false; flg_lax = lax } in + let avoid = Avoid.make ~fast:!fast_name_generation avoid in + detype_rel_context d flags where avoid env sigma sign let detype_closed_glob ?lax isgoal avoid env sigma t = let open Context.Rel.Declaration in @@ -918,13 +1014,12 @@ let rec subst_cases_pattern subst = DAst.map (function let (f_subst_genarg, subst_genarg_hook) = Hook.make () -let rec subst_glob_constr subst = DAst.map (function +let rec subst_glob_constr env subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in if ref' == ref then raw else (match t with | None -> GRef (ref', u) | Some t -> - let env = Global.env () in let evd = Evd.from_env env in let t = t.Univ.univ_abstracted_value in (* XXX This seems dangerous *) DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t))) @@ -936,33 +1031,33 @@ let rec subst_glob_constr subst = DAst.map (function | GPatVar _ as raw -> raw | GApp (r,rl) as raw -> - let r' = subst_glob_constr subst r - and rl' = List.Smart.map (subst_glob_constr subst) rl in + let r' = subst_glob_constr env subst r + and rl' = List.Smart.map (subst_glob_constr env subst) rl in if r' == r && rl' == rl then raw else GApp(r',rl') | GLambda (n,bk,r1,r2) as raw -> - let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in + let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in if r1' == r1 && r2' == r2 then raw else GLambda (n,bk,r1',r2') | GProd (n,bk,r1,r2) as raw -> - let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in + let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in if r1' == r1 && r2' == r2 then raw else GProd (n,bk,r1',r2') | GLetIn (n,r1,t,r2) as raw -> - let r1' = subst_glob_constr subst r1 in - let r2' = subst_glob_constr subst r2 in - let t' = Option.Smart.map (subst_glob_constr subst) t in + let r1' = subst_glob_constr env subst r1 in + let r2' = subst_glob_constr env subst r2 in + let t' = Option.Smart.map (subst_glob_constr env subst) t in if r1' == r1 && t == t' && r2' == r2 then raw else GLetIn (n,r1',t',r2') | GCases (sty,rtno,rl,branches) as raw -> let open CAst in - let rtno' = Option.Smart.map (subst_glob_constr subst) rtno + let rtno' = Option.Smart.map (subst_glob_constr env subst) rtno and rl' = List.Smart.map (fun (a,x as y) -> - let a' = subst_glob_constr subst a in + let a' = subst_glob_constr env subst a in let (n,topt) = x in let topt' = Option.Smart.map (fun ({loc;v=((sp,i),y)} as t) -> @@ -973,7 +1068,7 @@ let rec subst_glob_constr subst = DAst.map (function (fun ({loc;v=(idl,cpl,r)} as branch) -> let cpl' = List.Smart.map (subst_cases_pattern subst) cpl - and r' = subst_glob_constr subst r in + and r' = subst_glob_constr env subst r in if cpl' == cpl && r' == r then branch else CAst.(make ?loc (idl,cpl',r'))) branches @@ -982,27 +1077,27 @@ let rec subst_glob_constr subst = DAst.map (function GCases (sty,rtno',rl',branches') | GLetTuple (nal,(na,po),b,c) as raw -> - let po' = Option.Smart.map (subst_glob_constr subst) po - and b' = subst_glob_constr subst b - and c' = subst_glob_constr subst c in + let po' = Option.Smart.map (subst_glob_constr env subst) po + and b' = subst_glob_constr env subst b + and c' = subst_glob_constr env subst c in if po' == po && b' == b && c' == c then raw else GLetTuple (nal,(na,po'),b',c') | GIf (c,(na,po),b1,b2) as raw -> - let po' = Option.Smart.map (subst_glob_constr subst) po - and b1' = subst_glob_constr subst b1 - and b2' = subst_glob_constr subst b2 - and c' = subst_glob_constr subst c in + let po' = Option.Smart.map (subst_glob_constr env subst) po + and b1' = subst_glob_constr env subst b1 + and b2' = subst_glob_constr env subst b2 + and c' = subst_glob_constr env subst c in if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else GIf (c',(na,po'),b1',b2') | GRec (fix,ida,bl,ra1,ra2) as raw -> - let ra1' = Array.Smart.map (subst_glob_constr subst) ra1 - and ra2' = Array.Smart.map (subst_glob_constr subst) ra2 in + let ra1' = Array.Smart.map (subst_glob_constr env subst) ra1 + and ra2' = Array.Smart.map (subst_glob_constr env subst) ra2 in let bl' = Array.Smart.map (List.Smart.map (fun (na,k,obd,ty as dcl) -> - let ty' = subst_glob_constr subst ty in - let obd' = Option.Smart.map (subst_glob_constr subst) obd in + let ty' = subst_glob_constr env subst ty in + let obd' = Option.Smart.map (subst_glob_constr env subst) obd in if ty'==ty && obd'==obd then dcl else (na,k,obd',ty'))) bl in if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else @@ -1020,8 +1115,8 @@ let rec subst_glob_constr subst = DAst.map (function else GHole (nknd, naming, nsolve) | GCast (r1,k) as raw -> - let r1' = subst_glob_constr subst r1 in - let k' = smartmap_cast_type (subst_glob_constr subst) k in + let r1' = subst_glob_constr env subst r1 in + let k' = smartmap_cast_type (subst_glob_constr env subst) k in if r1' == r1 && k' == k then raw else GCast (r1',k') ) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 8695d52b12..1a8e97efb8 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -37,7 +37,7 @@ val print_allow_match_default_clause : bool ref val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern -val subst_glob_constr : substitution -> glob_constr -> glob_constr +val subst_glob_constr : env -> substitution -> glob_constr -> glob_constr val factorize_eqns : 'a cases_clauses_g -> 'a disjunctive_cases_clauses_g @@ -87,7 +87,7 @@ val subst_genarg_hook : module PrintingInductiveMake : functor (Test : sig - val encode : Libnames.qualid -> Names.inductive + val encode : Environ.env -> Libnames.qualid -> Names.inductive val member_message : Pp.t -> bool -> Pp.t val field : string val title : string @@ -95,7 +95,7 @@ module PrintingInductiveMake : sig type t = Names.inductive val compare : t -> t -> int - val encode : Libnames.qualid -> Names.inductive + val encode : Environ.env -> Libnames.qualid -> Names.inductive val subst : substitution -> t -> t val printer : t -> Pp.t val key : Goptions.option_name diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index a4a078bfa0..4a941a68b1 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -73,11 +73,11 @@ let normalize_evar evd ev = | Evar (evk,args) -> (evk,args) | _ -> assert false -let get_polymorphic_positions sigma f = +let get_polymorphic_positions env sigma f = let open Declarations in match EConstr.kind sigma f with - | Ind (ind, u) | Construct ((ind, _), u) -> - let mib,oib = Global.lookup_inductive ind in + | Ind (ind, u) | Construct ((ind, _), u) -> + let mib,oib = Inductive.lookup_mind_specif env ind in (match oib.mind_arity with | RegularArity _ -> assert false | TemplateArity templ -> templ.template_param_levels) @@ -128,7 +128,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) let rec refresh_term_evars ~onevars ~top t = match EConstr.kind !evdref t with | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> - let pos = get_polymorphic_positions !evdref f in + let pos = get_polymorphic_positions env !evdref f in refresh_polymorphic_positions args pos; t | App (f, args) when top && isEvar !evdref f -> let f' = refresh_term_evars ~onevars:true ~top:false f in @@ -1203,17 +1203,17 @@ exception CannotProject of evar_map * EConstr.existential of subterms to eventually discard so as to be allowed to keep ti. *) -let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = +let rec is_constrainable_in top env evd k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect evd t in match EConstr.kind evd f with | Construct ((ind,_),u) -> - let n = Inductiveops.inductive_nparams ind in + let n = Inductiveops.inductive_nparams env ind in if n > Array.length args then true (* We don't try to be more clever *) else let params = fst (Array.chop n args) in - Array.for_all (is_constrainable_in false evd k g) params - | Ind _ -> Array.for_all (is_constrainable_in false evd k g) args - | Prod (na,t1,t2) -> is_constrainable_in false evd k g t1 && is_constrainable_in false evd k g t2 + Array.for_all (is_constrainable_in false env evd k g) params + | Ind _ -> Array.for_all (is_constrainable_in false env evd k g) args + | Prod (na,t1,t2) -> is_constrainable_in false env evd k g t1 && is_constrainable_in false env evd k g t2 | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*) | Var id -> Id.Set.mem id fv_ids | Rel n -> n <= k || Int.Set.mem n fv_rels @@ -1238,7 +1238,7 @@ let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_r | None -> (* t is an instance for a proper variable; we filter it along *) (* the free variables allowed to occur *) - (not force || noccur_evar env evd ev t) && is_constrainable_in true evd k (ev,(fv_rels,fv_ids)) t + (not force || noccur_evar env evd ev t) && is_constrainable_in true env evd k (ev,(fv_rels,fv_ids)) t exception EvarSolvedOnTheFly of evar_map * EConstr.constr diff --git a/pretyping/geninterp.ml b/pretyping/geninterp.ml index 1f8b926365..32152ad0e4 100644 --- a/pretyping/geninterp.ml +++ b/pretyping/geninterp.ml @@ -82,9 +82,10 @@ let register_val0 wit tag = (** Interpretation functions *) -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t diff --git a/pretyping/geninterp.mli b/pretyping/geninterp.mli index 606a6ebead..49d874289d 100644 --- a/pretyping/geninterp.mli +++ b/pretyping/geninterp.mli @@ -62,9 +62,10 @@ val register_val0 : ('raw, 'glb, 'top) genarg_type -> 'top Val.tag option -> uni module TacStore : Store.S -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index cd82b1993b..e76eb2a7de 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -183,7 +183,7 @@ let interp_ltac_id env id = ltac_interp_id env.lvar id module ConstrInterpObj = struct type ('r, 'g, 't) obj = - unbound_ltac_var_map -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map let name = "constr_interp" let default _ = None end @@ -192,8 +192,8 @@ module ConstrInterp = Genarg.Register(ConstrInterpObj) let register_constr_interp0 = ConstrInterp.register0 -let interp_glob_genarg env sigma ty arg = +let interp_glob_genarg env poly sigma ty arg = let open Genarg in let GenArg (Glbwit tag, arg) = arg in let interp = ConstrInterp.obj tag in - interp env.lvar.ltac_genargs env.renamed_env sigma ty arg + interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 65ae495135..cdd36bbba6 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -19,7 +19,7 @@ open Evarutil val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit (** {6 Pretyping name management} *) @@ -85,5 +85,5 @@ val interp_ltac_id : t -> Id.t -> Id.t (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) -val interp_glob_genarg : t -> evar_map -> constr -> +val interp_glob_genarg : t -> bool -> evar_map -> constr -> Genarg.glob_generic_argument -> constr * evar_map diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 74432cc010..85b9faac77 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -106,19 +106,9 @@ let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = Name.equal na1 na2 && binding_kind_eq bk1 bk2 && Option.equal f c1 c2 && f t1 t2 -let fix_recursion_order_eq f o1 o2 = match o1, o2 with - | GStructRec, GStructRec -> true - | GWfRec c1, GWfRec c2 -> f c1 c2 - | GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> - f c1 c2 && Option.equal f o1 o2 - | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false - -let fix_kind_eq f k1 k2 = match k1, k2 with +let fix_kind_eq k1 k2 = match k1, k2 with | GFix (a1, i1), GFix (a2, i2) -> - let eq (i1, o1) (i2, o2) = - Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2 - in - Int.equal i1 i2 && Array.equal eq a1 a2 + Int.equal i1 i2 && Array.equal (Option.equal Int.equal) a1 a2 | GCoFix i1, GCoFix i2 -> Int.equal i1 i2 | (GFix _ | GCoFix _), _ -> false @@ -150,7 +140,7 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with f m1 m2 && Name.equal pat1 pat2 && Option.equal f p1 p2 && f c1 c2 && f t1 t2 | GRec (kn1, id1, decl1, t1, c1), GRec (kn2, id2, decl2, t2, c2) -> - fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 && + fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 && Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && Array.equal f c1 c2 && Array.equal f t1 t2 | GSort s1, GSort s2 -> glob_sort_eq s1 s2 @@ -492,7 +482,7 @@ let is_gvar id c = match DAst.get c with | GVar id' -> Id.equal id id' | _ -> false -let rec cases_pattern_of_glob_constr na c = +let rec cases_pattern_of_glob_constr env na c = (* Forcing evaluation to ensure that the possible raising of Not_found is not delayed *) let c = DAst.force c in @@ -509,14 +499,14 @@ let rec cases_pattern_of_glob_constr na c = | GApp (c, l) -> begin match DAst.get c with | GRef (ConstructRef cstr,_) -> - let nparams = Inductiveops.inductive_nparams (fst cstr) in + let nparams = Inductiveops.inductive_nparams env (fst cstr) in let _,l = List.chop nparams l in - PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + PatCstr (cstr,List.map (cases_pattern_of_glob_constr env Anonymous) l,na) | _ -> raise Not_found end | GLetIn (Name id as na',b,None,e) when is_gvar id e && na = Anonymous -> (* A canonical encoding of aliases *) - DAst.get (cases_pattern_of_glob_constr na' b) + DAst.get (cases_pattern_of_glob_constr env na' b) | _ -> raise Not_found ) c @@ -539,8 +529,8 @@ let drop_local_defs params decls args = | _ -> assert false in aux decls args -let add_patterns_for_params_remove_local_defs (ind,j) l = - let (mib,mip) = Global.lookup_inductive ind in +let add_patterns_for_params_remove_local_defs env (ind,j) l = + let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.Declarations.mind_nparams in let l = if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then @@ -556,12 +546,12 @@ let add_alias ?loc na c = | Name id -> GLetIn (na,DAst.make ?loc c,None,DAst.make ?loc (GVar id)) (* Turn a closed cases pattern into a glob_constr *) -let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?loc -> function +let rec glob_constr_of_cases_pattern_aux env isclosed x = DAst.map_with_loc (fun ?loc -> function | PatCstr (cstr,[],na) -> add_alias ?loc na (GRef (ConstructRef cstr,None)) | PatCstr (cstr,l,na) -> let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in - let l = add_patterns_for_params_remove_local_defs cstr l in - add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux isclosed) l)) + let l = add_patterns_for_params_remove_local_defs env cstr l in + add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux env isclosed) l)) | PatVar (Name id) when not isclosed -> GVar id | PatVar Anonymous when not isclosed -> @@ -571,14 +561,14 @@ let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?lo | _ -> raise Not_found ) x -let glob_constr_of_closed_cases_pattern p = match DAst.get p with +let glob_constr_of_closed_cases_pattern env p = match DAst.get p with | PatCstr (cstr,l,na) -> let loc = p.CAst.loc in - na,glob_constr_of_cases_pattern_aux true (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) + na,glob_constr_of_cases_pattern_aux env true (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found -let glob_constr_of_cases_pattern p = glob_constr_of_cases_pattern_aux false p +let glob_constr_of_cases_pattern env p = glob_constr_of_cases_pattern_aux env false p (* This has to be in some file... *) diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 2f0ac76235..df902a8fa7 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -94,14 +94,15 @@ val map_pattern : (glob_constr -> glob_constr) -> Evaluation is forced. Take the current alias as parameter, @raise Not_found if translation is impossible *) -val cases_pattern_of_glob_constr : Name.t -> 'a glob_constr_g -> 'a cases_pattern_g +val cases_pattern_of_glob_constr : Environ.env -> Name.t -> 'a glob_constr_g -> 'a cases_pattern_g -val glob_constr_of_closed_cases_pattern : 'a cases_pattern_g -> Name.t * 'a glob_constr_g +val glob_constr_of_closed_cases_pattern : Environ.env -> 'a cases_pattern_g -> Name.t * 'a glob_constr_g (** A canonical encoding of cases pattern into constr such that composed with [cases_pattern_of_glob_constr Anonymous] gives identity *) -val glob_constr_of_cases_pattern : 'a cases_pattern_g -> 'a glob_constr_g +val glob_constr_of_cases_pattern : Environ.env -> 'a cases_pattern_g -> 'a glob_constr_g -val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list +val add_patterns_for_params_remove_local_defs : Environ.env -> constructor -> + 'a cases_pattern_g list -> 'a cases_pattern_g list val empty_lvar : Ltac_pretype.ltac_var_map diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index c57cf88cc6..02cb294f6d 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -41,6 +41,12 @@ type glob_constraint = glob_level * Univ.constraint_type * glob_level type sort_info = (Libnames.qualid * int) option list type glob_sort = sort_info glob_sort_gen +type glob_recarg = int option + +and glob_fix_kind = + | GFix of (glob_recarg array * int) + | GCoFix of int + (** Casts *) type 'a cast_type = @@ -78,7 +84,7 @@ type 'a glob_constr_r = (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) | GLetTuple of Name.t list * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GIf of 'a glob_constr_g * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g - | GRec of 'a fix_kind_g * Id.t array * 'a glob_decl_g list array * + | GRec of glob_fix_kind * Id.t array * 'a glob_decl_g list array * 'a glob_constr_g array * 'a glob_constr_g array | GSort of glob_sort | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option @@ -88,15 +94,6 @@ and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g -and 'a fix_recursion_order_g = - | GStructRec - | GWfRec of 'a glob_constr_g - | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option - -and 'a fix_kind_g = - | GFix of ((int option * 'a fix_recursion_order_g) array * int) - | GCoFix of int - and 'a predicate_pattern_g = Name.t * (inductive * Name.t list) CAst.t option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) @@ -117,9 +114,7 @@ type tomatch_tuples = [ `any ] tomatch_tuples_g type cases_clause = [ `any ] cases_clause_g type cases_clauses = [ `any ] cases_clauses_g type glob_decl = [ `any ] glob_decl_g -type fix_kind = [ `any ] fix_kind_g type predicate_pattern = [ `any ] predicate_pattern_g -type fix_recursion_order = [ `any ] fix_recursion_order_g type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr diff --git a/pretyping/heads.ml b/pretyping/heads.ml index cdeec875a2..ef27ca9b4e 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -12,10 +12,7 @@ open Util open Names open Constr open Vars -open Mod_subst open Environ -open Libobject -open Lib open Context.Named.Declaration (** Characterization of the head of a term *) @@ -35,40 +32,32 @@ type head_approximation = | FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) | NotImmediatelyComputableHead -(** Registration as global tables and rollback. *) - -module Evalreford = struct - type t = evaluable_global_reference - let compare gr1 gr2 = match gr1, gr2 with - | EvalVarRef id1, EvalVarRef id2 -> Id.compare id1 id2 - | EvalVarRef _, EvalConstRef _ -> -1 - | EvalConstRef c1, EvalConstRef c2 -> - Constant.CanOrd.compare c1 c2 - | EvalConstRef _, EvalVarRef _ -> 1 -end - -module Evalrefmap = - Map.Make (Evalreford) - - -let head_map = Summary.ref Evalrefmap.empty ~name:"Head_decl" - -let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map -let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map +(* FIXME: maybe change interface here *) +let rec compute_head env = function + | EvalConstRef cst -> + let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in + (match body with + | None -> RigidHead (RigidParameter cst) + | Some c -> kind_of_head env c) + | EvalVarRef id -> + (match lookup_named id env with + | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> + kind_of_head env c + | _ -> RigidHead RigidOther) -let kind_of_head env t = +and kind_of_head env t = let rec aux k l t b = match kind (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> - (try on_subterm k l b (variable_head id) + (try on_subterm k l b (compute_head env (EvalVarRef id)) with Not_found -> (* a goal variable *) match lookup_named id env with | LocalDef (_,c,_) -> aux k l c b | LocalAssum _ -> NotImmediatelyComputableHead) | Const (cst,_) -> - (try on_subterm k l b (constant_head cst) + (try on_subterm k l b (compute_head env (EvalConstRef cst)) with Not_found -> CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ @@ -119,69 +108,7 @@ let kind_of_head env t = | x -> x in aux 0 [] t false -(* FIXME: maybe change interface here *) -let compute_head = function -| EvalConstRef cst -> - let env = Global.env() in - let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in - (match body with - | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head env c) -| EvalVarRef id -> - (match Global.lookup_named id with - | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> - kind_of_head (Global.env()) c - | _ -> RigidHead RigidOther) - let is_rigid env t = match kind_of_head env t with | RigidHead _ | ConstructorHead -> true | _ -> false - -(** Registration of heads as an object *) - -let load_head _ (_,(ref,(k:head_approximation))) = - head_map := Evalrefmap.add ref k !head_map - -let cache_head o = - load_head 1 o - -let subst_head_approximation subst = function - | RigidHead (RigidParameter cst) as k -> - let cst',c = subst_con subst cst in - if cst == cst' then k - else - (match c with - | None -> - (* A change of the prefix of the constant *) - RigidHead (RigidParameter cst') - | Some c -> - (* A substitution of the constant by a functor argument *) - kind_of_head (Global.env()) c.Univ.univ_abstracted_value) - | x -> x - -let subst_head (subst,(ref,k)) = - (subst_evaluable_reference subst ref, subst_head_approximation subst k) - -let discharge_head (_,(ref,k)) = - match ref with - | EvalConstRef cst -> Some (ref, k) - | EvalVarRef id -> None - -let rebuild_head (ref,k) = - (ref, compute_head ref) - -type head_obj = evaluable_global_reference * head_approximation - -let inHead : head_obj -> obj = - declare_object {(default_object "HEAD") with - cache_function = cache_head; - load_function = load_head; - subst_function = subst_head; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_head; - rebuild_function = rebuild_head } - -let declare_head c = - let hd = compute_head c in - add_anonymous_leaf (inHead (c,hd)) diff --git a/pretyping/heads.mli b/pretyping/heads.mli index 421242996c..e5f9967590 100644 --- a/pretyping/heads.mli +++ b/pretyping/heads.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open Constr open Environ @@ -17,11 +16,6 @@ open Environ provides the function to compute the head symbols and a table to store the heads *) -(** [declared_head] computes and registers the head symbol of a - possibly evaluable constant or variable *) - -val declare_head : evaluable_global_reference -> unit - (** [is_rigid] tells if some term is known to ultimately reduce to a term with a rigid head symbol *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 4f940fa16a..7615a17514 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -610,16 +610,20 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s) (* Look up function for the default elimination constant *) -let lookup_eliminator ind_sp s = +let lookup_eliminator env ind_sp s = let kn,i = ind_sp in - let mp,l = KerName.repr (MutInd.canonical kn) in - let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in + let mpu = KerName.modpath @@ MutInd.user kn in + let mpc = KerName.modpath @@ MutInd.canonical kn in + let ind_id = (lookup_mind kn env).mind_packets.(i).mind_typename in let id = add_suffix ind_id (elimination_suffix s) in + let l = Label.of_id id in + let knu = KerName.make mpu l in + let knc = KerName.make mpc l in (* Try first to get an eliminator defined in the same section as the *) (* inductive type *) try - let cst =Global.constant_of_delta_kn (KerName.make mp (Label.of_id id)) in - let _ = Global.lookup_constant cst in + let cst = Constant.make knu knc in + let _ = lookup_constant cst env in ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 91a5651f7f..8eb571a8be 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -62,7 +62,7 @@ val weaken_sort_scheme : env -> evar_map -> bool -> Sorts.t -> int -> constr -> (** Recursor names utilities *) -val lookup_eliminator : inductive -> Sorts.family -> GlobRef.t +val lookup_eliminator : env -> inductive -> Sorts.family -> GlobRef.t val elimination_suffix : Sorts.family -> string val make_elimination_ident : Id.t -> Sorts.family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 678aebfbe6..b1c98da2c7 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -112,162 +112,145 @@ let mis_nf_constructor_type ((ind,u),mib,mip) j = (* Number of constructors *) -let nconstructors ind = - let (_,mip) = Global.lookup_inductive ind in - Array.length mip.mind_consnames - -let nconstructors_env env ind = +let nconstructors env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in Array.length mip.mind_consnames -(* Arity of constructors excluding parameters, excluding local defs *) +let nconstructors_env env ind = nconstructors env ind +[@@ocaml.deprecated "Alias for Inductiveops.nconstructors"] -let constructors_nrealargs ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealargs +(* Arity of constructors excluding parameters, excluding local defs *) -let constructors_nrealargs_env env ind = +let constructors_nrealargs env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealargs -(* Arity of constructors excluding parameters, including local defs *) +let constructors_nrealargs_env env ind = constructors_nrealargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealargs"] -let constructors_nrealdecls ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealdecls +(* Arity of constructors excluding parameters, including local defs *) -let constructors_nrealdecls_env env ind = +let constructors_nrealdecls env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls +let constructors_nrealdecls_env env ind = constructors_nrealdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealdecls"] + (* Arity of constructors including parameters, excluding local defs *) -let constructor_nallargs (indsp,j) = - let (mib,mip) = Global.lookup_inductive indsp in +let constructor_nallargs env (ind,j) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealargs.(j-1) + mib.mind_nparams -let constructor_nallargs_env env ((kn,i),j) = - let mib = Environ.lookup_mind kn env in - let mip = mib.mind_packets.(i) in - mip.mind_consnrealargs.(j-1) + mib.mind_nparams +let constructor_nallargs_env env (indsp,j) = constructor_nallargs env (indsp,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nallargs"] (* Arity of constructors including params, including local defs *) -let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *) - let (mib,mip) = Global.lookup_inductive indsp in +let constructor_nalldecls env (ind,j) = (* TOCHANGE en decls *) + let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) -let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *) - let mib = Environ.lookup_mind kn env in - let mip = mib.mind_packets.(i) in - mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) +let constructor_nalldecls_env env (indsp,j) = constructor_nalldecls env (indsp,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nalldecls"] (* Arity of constructors excluding params, excluding local defs *) -let constructor_nrealargs (ind,j) = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealargs.(j-1) - -let constructor_nrealargs_env env (ind,j) = +let constructor_nrealargs env (ind,j) = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealargs.(j-1) -(* Arity of constructors excluding params, including local defs *) +let constructor_nrealargs_env env (ind,j) = constructor_nrealargs env (ind,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealargs"] -let constructor_nrealdecls (ind,j) = (* TOCHANGE en decls *) - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealdecls.(j-1) +(* Arity of constructors excluding params, including local defs *) -let constructor_nrealdecls_env env (ind,j) = (* TOCHANGE en decls *) +let constructor_nrealdecls env (ind,j) = (* TOCHANGE en decls *) let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls.(j-1) -(* Length of arity, excluding params, excluding local defs *) +let constructor_nrealdecls_env env (ind,j) = constructor_nrealdecls env (ind,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] -let inductive_nrealargs ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_nrealargs +(* Length of arity, excluding params, excluding local defs *) -let inductive_nrealargs_env env ind = +let inductive_nrealargs env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_nrealargs -(* Length of arity, excluding params, including local defs *) +let inductive_nrealargs_env env ind = inductive_nrealargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealargs"] -let inductive_nrealdecls ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_nrealdecls +(* Length of arity, excluding params, including local defs *) -let inductive_nrealdecls_env env ind = +let inductive_nrealdecls env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_nrealdecls -(* Full length of arity (w/o local defs) *) +let inductive_nrealdecls_env env ind = inductive_nrealdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealdecls"] -let inductive_nallargs ind = - let (mib,mip) = Global.lookup_inductive ind in - mib.mind_nparams + mip.mind_nrealargs +(* Full length of arity (w/o local defs) *) -let inductive_nallargs_env env ind = +let inductive_nallargs env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in mib.mind_nparams + mip.mind_nrealargs -(* Length of arity (w/o local defs) *) +let inductive_nallargs_env env ind = inductive_nallargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nallargs"] -let inductive_nparams ind = - let (mib,mip) = Global.lookup_inductive ind in - mib.mind_nparams +(* Length of arity (w/o local defs) *) -let inductive_nparams_env env ind = +let inductive_nparams env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in mib.mind_nparams -(* Length of arity (with local defs) *) +let inductive_nparams_env env ind = inductive_nparams env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparams"] -let inductive_nparamdecls ind = - let (mib,mip) = Global.lookup_inductive ind in - Context.Rel.length mib.mind_params_ctxt +(* Length of arity (with local defs) *) -let inductive_nparamdecls_env env ind = +let inductive_nparamdecls env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in Context.Rel.length mib.mind_params_ctxt -(* Full length of arity (with local defs) *) +let inductive_nparamdecls_env env ind = inductive_nparamdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparamsdecls"] -let inductive_nalldecls ind = - let (mib,mip) = Global.lookup_inductive ind in - Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls +(* Full length of arity (with local defs) *) -let inductive_nalldecls_env env ind = +let inductive_nalldecls env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls -(* Others *) +let inductive_nalldecls_env env ind = inductive_nalldecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nalldecls"] -let inductive_paramdecls (ind,u) = - let (mib,mip) = Global.lookup_inductive ind in - Inductive.inductive_paramdecls (mib,u) +(* Others *) -let inductive_paramdecls_env env (ind,u) = +let inductive_paramdecls env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in Inductive.inductive_paramdecls (mib,u) -let inductive_alldecls (ind,u) = - let (mib,mip) = Global.lookup_inductive ind in - Vars.subst_instance_context u mip.mind_arity_ctxt +let inductive_paramdecls_env env (ind,u) = inductive_paramdecls env (ind,u) +[@@ocaml.deprecated "Alias for Inductiveops.inductive_paramsdecls"] -let inductive_alldecls_env env (ind,u) = +let inductive_alldecls env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in Vars.subst_instance_context u mip.mind_arity_ctxt -let constructor_has_local_defs (indsp,j) = - let (mib,mip) = Global.lookup_inductive indsp in +let inductive_alldecls_env env (ind,u) = inductive_alldecls env (ind,u) +[@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] + +let constructor_has_local_defs env (indsp,j) = + let (mib,mip) = Inductive.lookup_mind_specif env indsp in let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in not (Int.equal l1 l2) -let inductive_has_local_defs ind = - let (mib,mip) = Global.lookup_inductive ind in +let inductive_has_local_defs env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in let l2 = mib.mind_nparams + mip.mind_nrealargs in not (Int.equal l1 l2) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index c74bbfe98b..cfc650938e 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -61,70 +61,85 @@ val mis_nf_constructor_type : (** {6 Extract information from an inductive name} *) (** @return number of constructors *) -val nconstructors : inductive -> int +val nconstructors : env -> inductive -> int val nconstructors_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.nconstructors"] (** @return arity of constructors excluding parameters, excluding local defs *) -val constructors_nrealargs : inductive -> int array +val constructors_nrealargs : env -> inductive -> int array val constructors_nrealargs_env : env -> inductive -> int array +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealargs"] (** @return arity of constructors excluding parameters, including local defs *) -val constructors_nrealdecls : inductive -> int array +val constructors_nrealdecls : env -> inductive -> int array val constructors_nrealdecls_env : env -> inductive -> int array +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealdecls"] (** @return the arity, excluding params, excluding local defs *) -val inductive_nrealargs : inductive -> int +val inductive_nrealargs : env -> inductive -> int val inductive_nrealargs_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealargs"] (** @return the arity, excluding params, including local defs *) -val inductive_nrealdecls : inductive -> int +val inductive_nrealdecls : env -> inductive -> int val inductive_nrealdecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealdecls"] (** @return the arity, including params, excluding local defs *) -val inductive_nallargs : inductive -> int +val inductive_nallargs : env -> inductive -> int val inductive_nallargs_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nallargs"] (** @return the arity, including params, including local defs *) -val inductive_nalldecls : inductive -> int +val inductive_nalldecls : env -> inductive -> int val inductive_nalldecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nalldecls"] (** @return nb of params without local defs *) -val inductive_nparams : inductive -> int +val inductive_nparams : env -> inductive -> int val inductive_nparams_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparams"] (** @return nb of params with local defs *) -val inductive_nparamdecls : inductive -> int +val inductive_nparamdecls : env -> inductive -> int val inductive_nparamdecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparamsdecls"] (** @return params context *) -val inductive_paramdecls : pinductive -> Constr.rel_context +val inductive_paramdecls : env -> pinductive -> Constr.rel_context val inductive_paramdecls_env : env -> pinductive -> Constr.rel_context +[@@ocaml.deprecated "Alias for Inductiveops.inductive_paramsdecl"] (** @return full arity context, hence with letin *) -val inductive_alldecls : pinductive -> Constr.rel_context +val inductive_alldecls : env -> pinductive -> Constr.rel_context val inductive_alldecls_env : env -> pinductive -> Constr.rel_context +[@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] (** {7 Extract information from a constructor name} *) (** @return param + args without letin *) -val constructor_nallargs : constructor -> int +val constructor_nallargs : env -> constructor -> int val constructor_nallargs_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nallargs"] (** @return param + args with letin *) -val constructor_nalldecls : constructor -> int +val constructor_nalldecls : env -> constructor -> int val constructor_nalldecls_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nalldecls"] (** @return args without letin *) -val constructor_nrealargs : constructor -> int +val constructor_nrealargs : env -> constructor -> int val constructor_nrealargs_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealargs"] (** @return args with letin *) -val constructor_nrealdecls : constructor -> int +val constructor_nrealdecls : env -> constructor -> int val constructor_nrealdecls_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] (** Is there local defs in params or args ? *) -val constructor_has_local_defs : constructor -> bool -val inductive_has_local_defs : inductive -> bool +val constructor_has_local_defs : env -> constructor -> bool +val inductive_has_local_defs : env -> inductive -> bool val allowed_sorts : env -> inductive -> Sorts.family list diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0b2d760ca8..e694502231 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -222,7 +222,12 @@ and nf_type_sort env sigma v = match kind_of_value v with | Vaccu accu -> let t,s = nf_accu_type env sigma accu in - let s = try destSort s with DestKO -> assert false in + let s = + try + destSort (whd_all env s) + with DestKO -> + CErrors.anomaly (Pp.str "Value should be a sort") + in t, s | _ -> assert false @@ -487,25 +492,23 @@ let native_norm env sigma c ty = Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) - let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in - let profile = get_profiling_enabled () in - match Nativelib.compile ml_filename code ~profile:profile with - | true, fn -> - if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); - let profiler_pid = if profile then start_profiler () else None in - let t0 = Sys.time () in - Nativelib.call_linker ~fatal:true prefix fn (Some upd); - let t1 = Sys.time () in - if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - let res = nf_val env sigma !Nativelib.rt1 ty in - let t2 = Sys.time () in - let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - EConstr.of_constr res - | _ -> anomaly (Pp.str "Compilation failure.") + let ml_filename, prefix = Nativelib.get_ml_filename () in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in + let profile = get_profiling_enabled () in + let fn = Nativelib.compile ml_filename code ~profile:profile in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let profiler_pid = if profile then start_profiler () else None in + let t0 = Sys.time () in + Nativelib.call_linker ~fatal:true prefix fn (Some upd); + let t1 = Sys.time () in + if profile then stop_profiler profiler_pid; + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + let res = nf_val env sigma !Nativelib.rt1 ty in + let t2 = Sys.time () in + let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + EConstr.of_constr res let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 4e3c77cb1a..c788efda48 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -280,66 +280,64 @@ let rec liftn_pattern k n = function let lift_pattern k = liftn_pattern k 1 -let rec subst_pattern subst pat = +let rec subst_pattern env sigma subst pat = match pat with | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else (match t with | None -> PRef ref' | Some t -> - let env = Global.env () in - let evd = Evd.from_env env in - pattern_of_constr env evd t.Univ.univ_abstracted_value) + pattern_of_constr env sigma t.Univ.univ_abstracted_value) | PVar _ | PEvar _ | PRel _ | PInt _ -> pat | PProj (p,c) -> let p' = Projection.map (subst_mind subst) p in - let c' = subst_pattern subst c in + let c' = subst_pattern env sigma subst c in if p' == p && c' == c then pat else PProj(p',c') | PApp (f,args) -> - let f' = subst_pattern subst f in - let args' = Array.Smart.map (subst_pattern subst) args in + let f' = subst_pattern env sigma subst f in + let args' = Array.Smart.map (subst_pattern env sigma subst) args in if f' == f && args' == args then pat else PApp (f',args') | PSoApp (i,args) -> - let args' = List.Smart.map (subst_pattern subst) args in + let args' = List.Smart.map (subst_pattern env sigma subst) args in if args' == args then pat else PSoApp (i,args') | PLambda (name,c1,c2) -> - let c1' = subst_pattern subst c1 in - let c2' = subst_pattern subst c2 in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in if c1' == c1 && c2' == c2 then pat else PLambda (name,c1',c2') | PProd (name,c1,c2) -> - let c1' = subst_pattern subst c1 in - let c2' = subst_pattern subst c2 in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in if c1' == c1 && c2' == c2 then pat else PProd (name,c1',c2') | PLetIn (name,c1,t,c2) -> - let c1' = subst_pattern subst c1 in - let t' = Option.Smart.map (subst_pattern subst) t in - let c2' = subst_pattern subst c2 in + let c1' = subst_pattern env sigma subst c1 in + let t' = Option.Smart.map (subst_pattern env sigma subst) t in + let c2' = subst_pattern env sigma subst c2 in if c1' == c1 && t' == t && c2' == c2 then pat else PLetIn (name,c1',t',c2') | PSort _ | PMeta _ -> pat | PIf (c,c1,c2) -> - let c' = subst_pattern subst c in - let c1' = subst_pattern subst c1 in - let c2' = subst_pattern subst c2 in + let c' = subst_pattern env sigma subst c in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in if c' == c && c1' == c1 && c2' == c2 then pat else PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in let ind' = Option.Smart.map (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in - let typ' = subst_pattern subst typ in - let c' = subst_pattern subst c in + let typ' = subst_pattern env sigma subst typ in + let c' = subst_pattern env sigma subst c in let subst_branch ((i,n,c) as br) = - let c' = subst_pattern subst c in + let c' = subst_pattern env sigma subst c in if c' == c then br else (i,n,c') in let branches' = List.Smart.map subst_branch branches in @@ -347,13 +345,13 @@ let rec subst_pattern subst pat = then pat else PCase(cip', typ', c', branches') | PFix (lni,(lna,tl,bl)) -> - let tl' = Array.Smart.map (subst_pattern subst) tl in - let bl' = Array.Smart.map (subst_pattern subst) bl in + let tl' = Array.Smart.map (subst_pattern env sigma subst) tl in + let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in if bl' == bl && tl' == tl then pat else PFix (lni,(lna,tl',bl')) | PCoFix (ln,(lna,tl,bl)) -> - let tl' = Array.Smart.map (subst_pattern subst) tl in - let bl' = Array.Smart.map (subst_pattern subst) bl in + let tl' = Array.Smart.map (subst_pattern env sigma subst) tl in + let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in if bl' == bl && tl' == tl then pat else PCoFix (ln,(lna,tl',bl')) @@ -472,17 +470,19 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PCase (info, pred, pat_of_raw metas vars c, brs) | GRec (GFix (ln,n), ids, decls, tl, cl) -> - if Array.exists (function (Some n, GStructRec) -> false | _ -> true) ln then - err ?loc (Pp.str "\"struct\" annotation is expected.") - else - let ln = Array.map (fst %> Option.get) ln in - let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in - let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in - let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in - let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in - let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in - let names = Array.map (fun id -> Name id) ids in - PFix ((ln,n), (names, tl, cl)) + let get_struct_arg = function + | Some n -> n + | None -> err ?loc (Pp.str "\"struct\" annotation is expected.") + (* TODO why can't the annotation be omitted? *) + in + let ln = Array.map get_struct_arg ln in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in + let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in + let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in + let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in + let names = Array.map (fun id -> Name id) ids in + PFix ((ln,n), (names, tl, cl)) | GRec (GCoFix n, ids, decls, tl, cl) -> let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 36317b3acf..3821fbf1a0 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -21,7 +21,7 @@ val constr_pattern_eq : constr_pattern -> constr_pattern -> bool val occur_meta_pattern : constr_pattern -> bool -val subst_pattern : substitution -> constr_pattern -> constr_pattern +val subst_pattern : Environ.env -> Evd.evar_map -> substitution -> constr_pattern -> constr_pattern val noccurn_pattern : int -> constr_pattern -> bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 8e9a2e114b..48d981082c 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -198,6 +198,7 @@ type inference_flags = { fail_evar : bool; expand_evars : bool; program_mode : bool; + polymorphic : bool; } (* Compute the set of still-undefined initial evars up to restriction @@ -265,8 +266,8 @@ let apply_inference_hook hook env sigma frozen = match frozen with let apply_heuristics env sigma fail_evar = (* Resolve eagerly, potentially making wrong choices *) - try solve_unif_constraints_with_heuristics - ~flags:(default_flags_of (Typeclasses.classes_transparent_state ())) env sigma + let flags = default_flags_of (Typeclasses.classes_transparent_state ()) in + try solve_unif_constraints_with_heuristics ~flags env sigma with e when CErrors.noncritical e -> let e = CErrors.push e in if fail_evar then iraise e else sigma @@ -474,10 +475,10 @@ let mark_obligation_evar sigma k evc = (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = +let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode k0 resolve_tc in - let pretype = pretype ~program_mode k0 resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in + let pretype = pretype ~program_mode ~poly k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -497,7 +498,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -530,7 +531,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo match tycon with | Some ty -> sigma, ty | None -> new_type_evar env sigma loc in - let c, sigma = GlobEnv.interp_glob_genarg env sigma ty arg in + let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in sigma, { uj_val = c; uj_type = ty } | GRec (fixkind,names,bl,lar,vdef) -> @@ -606,10 +607,10 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo fixpoints ?) *) let possible_indexes = Array.to_list (Array.mapi - (fun i (n,_) -> match n with + (fun i annot -> match annot with | Some n -> [n] | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) + vn) in let fixdecls = (names,ftys,fdefs) in let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in @@ -643,7 +644,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | None -> [] | Some ty -> let ((ind, i), u) = destConstruct sigma fj.uj_val in - let npars = inductive_nparams ind in + let npars = inductive_nparams !!env ind in if Int.equal npars 0 then [] else try @@ -983,7 +984,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -1015,7 +1016,7 @@ and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype ~program_mode k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1040,7 +1041,7 @@ and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1067,7 +1068,7 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1082,6 +1083,7 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = let ise_pretype_gen flags env sigma lvar kind c = let program_mode = flags.program_mode in + let poly = flags.polymorphic in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in @@ -1089,13 +1091,13 @@ let ise_pretype_gen flags env sigma lvar kind c = let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype ~program_mode k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) @@ -1106,6 +1108,7 @@ let default_inference_flags fail = { fail_evar = fail; expand_evars = true; program_mode = false; + polymorphic = false; } let no_classes_no_fail_inference_flags = { @@ -1114,6 +1117,7 @@ let no_classes_no_fail_inference_flags = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let all_and_fail_flags = default_inference_flags true @@ -1141,3 +1145,38 @@ let understand_tcc ?flags env sigma ?expected_type c = let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) + +let path_convertible env sigma p q = + let open Classops in + let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in + let mkGVar id = DAst.make @@ Glob_term.GVar(id) in + let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in + let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Decl_kinds.Explicit,t,b) in + let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in + let path_to_gterm p = + match p with + | ic :: p' -> + let names = + List.map (fun n -> Id.of_string ("x" ^ string_of_int n)) + (List.interval 0 ic.coe_param) + in + List.fold_right + (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ + List.fold_left + (fun t ic -> + mkGApp (mkGRef ic.coe_value, + List.make ic.coe_param (mkGHole ()) @ [t])) + (mkGApp (mkGRef ic.coe_value, List.map (fun i -> mkGVar i) names)) + p' + | [] -> anomaly (str "A coercion path shouldn't be empty.") + in + try + let sigma,tp = understand_tcc env sigma (path_to_gterm p) in + let sigma,tq = understand_tcc env sigma (path_to_gterm q) in + if Evd.has_undefined sigma then + false + else + let _ = Evarconv.unify_delay env sigma tp tq in true + with Evarconv.UnableToUnify _ | PretypeError _ -> false + +let _ = Classops.install_path_comparator path_convertible diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 3c875e69d2..1037cf6cc5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -38,6 +38,7 @@ type inference_flags = { fail_evar : bool; expand_evars : bool; program_mode : bool; + polymorphic : bool; } val default_inference_flags : bool -> inference_flags diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 6d9e3230a4..1feb8acd5f 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -21,7 +21,6 @@ open Pp open Names open Globnames open Constr -open Libobject open Mod_subst open Reductionops @@ -45,15 +44,15 @@ let structure_table = let projection_table = Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" -(* TODO: could be unify struc_typ and struc_tuple ? in particular, - is the inductive always (fst constructor) ? It seems so... *) +(* TODO: could be unify struc_typ and struc_tuple ? *) type struc_tuple = - inductive * constructor * (Name.t * bool) list * Constant.t option list + constructor * (Name.t * bool) list * Constant.t option list -let load_structure i (_,(ind,id,kl,projs)) = +let register_structure env (id,kl,projs) = let open Declarations in - let mib, mip = Global.lookup_inductive ind in + let ind = fst id in + let mib, mip = Inductive.lookup_mind_specif env ind in let n = mib.mind_nparams in let struc = { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in @@ -62,11 +61,7 @@ let load_structure i (_,(ind,id,kl,projs)) = List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc)) projs !projection_table -let cache_structure o = - load_structure 1 o - -let subst_structure (subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_mind subst kn in +let subst_structure subst (id, kl, projs as obj) = let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) @@ -75,21 +70,8 @@ let subst_structure (subst,((kn,i),id,kl,projs as obj)) = projs in let id' = subst_constructor subst id in - if projs' == projs && kn' == kn && id' == id then obj else - ((kn',i),id',kl,projs') - -let discharge_structure (_,x) = Some x - -let inStruc : struc_tuple -> obj = - declare_object {(default_object "STRUCTURE") with - cache_function = cache_structure; - load_function = load_structure; - subst_function = subst_structure; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_structure } - -let declare_structure (s,c,kl,pl) = - Lib.add_anonymous_leaf (inStruc (s,c,kl,pl)) + if projs' == projs && id' == id then obj else + (id',kl,projs') let lookup_structure indsp = Indmap.find indsp !structure_table @@ -103,29 +85,14 @@ let find_projection = function | ConstRef cst -> Cmap.find cst !projection_table | _ -> raise Not_found +let is_projection cst = Cmap.mem cst !projection_table + let prim_table = Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" -let load_prim i (_,(p,c)) = +let register_primitive_projection p c = prim_table := Cmap_env.add c p !prim_table -let cache_prim p = load_prim 1 p - -let subst_prim (subst,(p,c)) = subst_proj_repr subst p, subst_constant subst c - -let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) - -let inPrim : (Projection.Repr.t * Constant.t) -> obj = - declare_object { - (default_object "PRIMPROJS") with - cache_function = cache_prim ; - load_function = load_prim; - subst_function = subst_prim; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_prim } - -let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) - let is_primitive_projection c = Cmap_env.mem c !prim_table let find_primitive_projection c = @@ -223,7 +190,7 @@ let warn_projection_no_head_constant = ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) -let compute_canonical_projections env warn (con,ind) = +let compute_canonical_projections env ~warn (con,ind) = let ctx = Environ.constant_context env con in let u = Univ.make_abstract_instance ctx in let v = (mkConstU (con,u)) in @@ -273,51 +240,30 @@ let warn_redundant_canonical_projection = ++ strbrk " by " ++ prj ++ strbrk " in " ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s) -let add_canonical_structure warn o = - (* XXX: Undesired global access to env *) - let env = Global.env () in - let sigma = Evd.from_env env in - let lo = compute_canonical_projections env warn o in - List.iter (fun ((proj,(cs_pat,_ as pat)),s) -> +let register_canonical_structure ~warn env sigma o = + compute_canonical_projections env ~warn o |> + List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in - let ocs = try Some (assoc_pat cs_pat l) - with Not_found -> None - in match ocs with - | None -> object_table := GlobRef.Map.add proj ((pat,s)::l) !object_table; - | Some (c, cs) -> - let old_can_s = (Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF)) - and new_can_s = (Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF)) - in - let prj = (Nametab.pr_global_env Id.Set.empty proj) - and hd_val = (pr_cs_pattern cs_pat) in - if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s)) - lo - -let open_canonical_structure i (_, o) = - if Int.equal i 1 then add_canonical_structure false o - -let cache_canonical_structure (_, o) = - add_canonical_structure true o - -let subst_canonical_structure (subst,(cst,ind as obj)) = + match assoc_pat cs_pat l with + | exception Not_found -> + object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table + | _, cs -> + if warn + then + let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in + let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in + let prj = Nametab.pr_global_env Id.Set.empty proj in + let hd_val = pr_cs_pattern cs_pat in + warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) + ) + +let subst_canonical_structure subst (cst,ind as obj) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) let cst' = subst_constant subst cst in let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') -let discharge_canonical_structure (_,x) = Some x - -let inCanonStruc : Constant.t * inductive -> obj = - declare_object {(default_object "CANONICAL-STRUCTURE") with - open_function = open_canonical_structure; - cache_function = cache_canonical_structure; - subst_function = subst_canonical_structure; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_canonical_structure } - -let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) - (*s High-level declaration of a canonical structure *) let error_not_structure ref description = @@ -326,20 +272,17 @@ let error_not_structure ref description = (Id.print (Nametab.basename_of_global ref) ++ str"." ++ spc() ++ description)) -let check_and_decompose_canonical_structure ref = +let check_and_decompose_canonical_structure env sigma ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in - let env = Global.env () in let u = Univ.make_abstract_instance (Environ.constant_context env sp) in let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref (str "Could not find its value in the global environment.") in - let env = Global.env () in - let evd = Evd.from_env env in - let body = snd (splay_lam (Global.env()) evd (EConstr.of_constr vc)) in + let body = snd (splay_lam env sigma (EConstr.of_constr vc)) in let body = EConstr.Unsafe.to_constr body in let f,args = match kind body with | App (f,args) -> f,args @@ -352,15 +295,12 @@ let check_and_decompose_canonical_structure ref = try lookup_structure indsp with Not_found -> error_not_structure ref - (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env evd (EConstr.mkInd indsp)) in + (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (sp,indsp) -let declare_canonical_structure ref = - add_canonical_structure (check_and_decompose_canonical_structure ref) - let lookup_canonical_conversion (proj,pat) = assoc_pat pat (GlobRef.Map.find proj !object_table) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 3e43372b65..f0594d513a 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -24,9 +24,10 @@ type struc_typ = { s_PROJ : Constant.t option list } type struc_tuple = - inductive * constructor * (Name.t * bool) list * Constant.t option list + constructor * (Name.t * bool) list * Constant.t option list -val declare_structure : struc_tuple -> unit +val register_structure : Environ.env -> struc_tuple -> unit +val subst_structure : Mod_subst.substitution -> struc_tuple -> struc_tuple (** [lookup_structure isp] returns the struc_typ associated to the inductive path [isp] if it corresponds to a structure, otherwise @@ -44,8 +45,10 @@ val find_projection_nparams : GlobRef.t -> int (** raise [Not_found] if not a projection *) val find_projection : GlobRef.t -> struc_typ +val is_projection : Constant.t -> bool + (** Sets up the mapping from constants to primitive projections *) -val declare_primitive_projection : Projection.Repr.t -> Constant.t -> unit +val register_primitive_projection : Projection.Repr.t -> Constant.t -> unit val is_primitive_projection : Constant.t -> bool @@ -78,8 +81,12 @@ val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * co val pr_cs_pattern : cs_pattern -> Pp.t val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ -val declare_canonical_structure : GlobRef.t -> unit +val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> + Constant.t * inductive -> unit +val subst_canonical_structure : Mod_subst.substitution -> Constant.t * inductive -> Constant.t * inductive val is_open_canonical_projection : Environ.env -> Evd.evar_map -> Reductionops.state -> bool val canonical_projections : unit -> ((GlobRef.t * cs_pattern) * obj_typ) list + +val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> Constant.t * inductive diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 71fbfe8716..1871609e18 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -53,7 +53,7 @@ type effect_name = string let constant_effect_table = Summary.ref ~name:"reduction-side-effect" Cmap.empty (* Table bindings function key to effective functions *) -let effect_table = Summary.ref ~name:"reduction-function-effect" String.Map.empty +let effect_table = ref String.Map.empty (** a test to know whether a constant is actually the effect function *) let reduction_effect_hook env sigma con c = diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 20120f4182..38e254a5b4 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -121,7 +121,7 @@ let retype ?(polyprop=true) sigma = Inductiveops.find_rectype env sigma t with Not_found -> retype_error BadRecursiveType in - let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in + let n = inductive_nrealdecls env (fst (fst (dest_ind_family indf))) in let t = betazetaevar_applist sigma n p realargs in (match EConstr.kind sigma (whd_all env sigma (type_of env t)) with | Prod _ -> whd_beta sigma (applist (t, [c])) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 1496712bbc..ee27aea93f 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -17,11 +17,8 @@ open Vars open Evd open Util open Typeclasses_errors -open Libobject open Context.Rel.Declaration -module RelDecl = Context.Rel.Declaration -module NamedDecl = Context.Named.Declaration (*i*) (* Core typeclasses hints *) @@ -38,12 +35,6 @@ let get_typeclasses_unique_solutions = ~key:["Typeclasses";"Unique";"Solutions"] ~value:false -let (add_instance_hint, add_instance_hint_hook) = Hook.make () -let add_instance_hint id = Hook.get add_instance_hint id - -let (remove_instance_hint, remove_instance_hint_hook) = Hook.make () -let remove_instance_hint id = Hook.get remove_instance_hint id - let (set_typeclass_transparency, set_typeclass_transparency_hook) = Hook.make () let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency gr local c @@ -97,18 +88,6 @@ let instance_impl is = is.is_impl let hint_priority is = is.is_info.hint_priority -let new_instance cl info glob impl = - let global = - if glob then Some (Lib.sections_depth ()) - else None - in - if match global with Some n -> n>0 && isVarRef impl | _ -> false then - CErrors.user_err (Pp.str "Cannot set Global an instance referring to a section variable."); - { is_class = cl.cl_impl; - is_info = info ; - is_global = global ; - is_impl = impl } - (* * states management *) @@ -122,11 +101,10 @@ let typeclass_univ_instance (cl, u) = { cl with cl_context = on_snd subst_ctx cl.cl_context; cl_props = subst_ctx cl.cl_props} -let class_info c = +let class_info env sigma c = try GlobRef.Map.find c !classes with Not_found -> - let env = Global.env() in - not_a_class env (Evd.from_env env) (EConstr.of_constr (printable_constr_of_global c)) + not_a_class env sigma (EConstr.of_constr (printable_constr_of_global c)) let global_class_of_constr env sigma c = try let gr, u = Termops.global_of_constr sigma c in @@ -142,8 +120,8 @@ let dest_class_arity env sigma c = let rels, c = decompose_prod_assum sigma c in rels, dest_class_app env sigma c -let class_of_constr sigma c = - try Some (dest_class_arity (Global.env ()) sigma c) +let class_of_constr env sigma c = + try Some (dest_class_arity env sigma c) with e when CErrors.noncritical e -> None let is_class_constr sigma c = @@ -176,103 +154,9 @@ let rec is_maybe_class_type evd c = let () = Hook.set Evd.is_maybe_typeclass_hook (fun evd c -> is_maybe_class_type evd (EConstr.of_constr c)) -(* - * classes persistent object - *) - -let load_class (_, cl) = +let load_class cl = classes := GlobRef.Map.add cl.cl_impl cl !classes -let cache_class = load_class - -let subst_class (subst,cl) = - let do_subst_con c = Mod_subst.subst_constant subst c - and do_subst c = Mod_subst.subst_mps subst c - and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx = List.Smart.map (RelDecl.map_constr do_subst) in - let do_subst_context (grs,ctx) = - List.Smart.map (Option.Smart.map do_subst_gr) grs, - do_subst_ctx ctx in - let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> - (x, y, Option.Smart.map do_subst_con z)) projs in - { cl_univs = cl.cl_univs; - cl_impl = do_subst_gr cl.cl_impl; - cl_context = do_subst_context cl.cl_context; - cl_props = do_subst_ctx cl.cl_props; - cl_projs = do_subst_projs cl.cl_projs; - cl_strict = cl.cl_strict; - cl_unique = cl.cl_unique } - -let discharge_class (_,cl) = - let repl = Lib.replacement_context () in - let rel_of_variable_context ctx = List.fold_right - ( fun (decl,_) (ctx', subst) -> - let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in - (decl' :: ctx', NamedDecl.get_id decl :: subst) - ) ctx ([], []) in - let discharge_rel_context (subst, usubst) n rel = - let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in - let fold decl (ctx, k) = - let map c = subst_univs_level_constr usubst (substn_vars k subst c) in - RelDecl.map_constr map decl :: ctx, succ k - in - let ctx, _ = List.fold_right fold rel ([], n) in - ctx - in - let abs_context cl = - match cl.cl_impl with - | VarRef _ | ConstructRef _ -> assert false - | ConstRef cst -> Lib.section_segment_of_constant cst - | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in - let discharge_context ctx' subst (grs, ctx) = - let grs' = - let newgrs = List.map (fun decl -> - match decl |> RelDecl.get_type |> EConstr.of_constr |> class_of_constr Evd.empty with - | None -> None - | Some (_, ((tc,_), _)) -> Some tc.cl_impl) - ctx' - in - grs @ newgrs - in grs', discharge_rel_context subst 1 ctx @ ctx' in - try - let info = abs_context cl in - let ctx = info.Lib.abstr_ctx in - let ctx, subst = rel_of_variable_context ctx in - let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in - let context = discharge_context ctx (subst, usubst) cl.cl_context in - let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in - let discharge_proj x = x in - { cl_univs = cl_univs'; - cl_impl = cl.cl_impl; - cl_context = context; - cl_props = props; - cl_projs = List.Smart.map discharge_proj cl.cl_projs; - cl_strict = cl.cl_strict; - cl_unique = cl.cl_unique - } - with Not_found -> (* not defined in the current section *) - cl - -let rebuild_class cl = - try - let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in - set_typeclass_transparency cst false false; cl - with e when CErrors.noncritical e -> cl - -let class_input : typeclass -> obj = - declare_object - { (default_object "type classes state") with - cache_function = cache_class; - load_function = (fun _ -> load_class); - open_function = (fun _ -> load_class); - classify_function = (fun x -> Substitute x); - discharge_function = (fun a -> Some (discharge_class a)); - rebuild_function = rebuild_class; - subst_function = subst_class } - -let add_class cl = - Lib.add_anonymous_leaf (class_input cl) - (** Build the subinstances hints. *) let check_instance env sigma c = @@ -295,7 +179,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = let ty = EConstr.of_constr ty in let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let rec aux pri c ty path = - match class_of_constr sigma ty with + match class_of_constr env sigma ty with | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = @@ -336,136 +220,23 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = aux pri term ty [glob] (* - * instances persistent object + * interface functions *) -type instance_action = - | AddInstance - | RemoveInstance - -let load_instance inst = - let insts = +let load_instance inst = + let insts = try GlobRef.Map.find inst.is_class !instances with Not_found -> GlobRef.Map.empty in let insts = GlobRef.Map.add inst.is_impl inst insts in instances := GlobRef.Map.add inst.is_class insts !instances let remove_instance inst = - let insts = + let insts = try GlobRef.Map.find inst.is_class !instances with Not_found -> assert false in let insts = GlobRef.Map.remove inst.is_impl insts in instances := GlobRef.Map.add inst.is_class insts !instances -let cache_instance (_, (action, i)) = - match action with - | AddInstance -> load_instance i - | RemoveInstance -> remove_instance i - -let subst_instance (subst, (action, inst)) = action, - { inst with - is_class = fst (subst_global subst inst.is_class); - is_impl = fst (subst_global subst inst.is_impl) } - -let discharge_instance (_, (action, inst)) = - match inst.is_global with - | None -> None - | Some n -> - assert (not (isVarRef inst.is_impl)); - Some (action, - { inst with - is_global = Some (pred n); - is_class = inst.is_class; - is_impl = inst.is_impl }) - - -let is_local i = (i.is_global == None) - -let is_local_for_hint i = - match i.is_global with - | None -> true (* i.e. either no Global keyword not in section, or in section *) - | Some n -> n <> 0 (* i.e. in a section, declare the hint as local - since discharge is managed by rebuild_instance which calls again - add_instance_hint; don't ask hints to take discharge into account - itself *) - -let add_instance check inst = - let poly = Global.is_polymorphic inst.is_impl in - let local = is_local_for_hint inst in - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local - inst.is_info poly; - List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - local pri poly) - (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) - (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) - -let rebuild_instance (action, inst) = - let () = match action with - | AddInstance -> add_instance true inst - | _ -> () - in - (action, inst) - -let classify_instance (action, inst) = - if is_local inst then Dispose - else Substitute (action, inst) - -let instance_input : instance_action * instance -> obj = - declare_object - { (default_object "type classes instances state") with - cache_function = cache_instance; - load_function = (fun _ x -> cache_instance x); - open_function = (fun _ x -> cache_instance x); - classify_function = classify_instance; - discharge_function = discharge_instance; - rebuild_function = rebuild_instance; - subst_function = subst_instance } - -let add_instance i = - Lib.add_anonymous_leaf (instance_input (AddInstance, i)); - add_instance true i - -let remove_instance i = - Lib.add_anonymous_leaf (instance_input (RemoveInstance, i)); - remove_instance_hint i.is_impl - -let warning_not_a_class = - let name = "not-a-class" in - let category = "typeclasses" in - CWarnings.create ~name ~category (fun (n, ty) -> - let env = Global.env () in - let evd = Evd.from_env env in - Pp.(str "Ignored instance declaration for “" - ++ Nametab.pr_global_env Id.Set.empty n - ++ str "â€: “" - ++ Termops.Internal.print_constr_env env evd (EConstr.of_constr ty) - ++ str "†is not a class") - ) - -let declare_instance ?(warn = false) info local glob = - let ty, _ = Typeops.type_of_global_in_context (Global.env ()) glob in - let info = Option.default {hint_priority = None; hint_pattern = None} info in - match class_of_constr Evd.empty (EConstr.of_constr ty) with - | Some (rels, ((tc,_), args) as _cl) -> - assert (not (isVarRef glob) || local); - add_instance (new_instance tc info (not local) glob) - | None -> if warn then warning_not_a_class (glob, ty) - -let add_class cl = - add_class cl; - List.iter (fun (n, inst, body) -> - match inst with - | Some (Backward, info) -> - (match body with - | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") - | Some b -> declare_instance ~warn:true (Some info) false (ConstRef b)) - | _ -> ()) - cl.cl_projs - - -(* - * interface functions - *) let instance_constructor (cl,u) args = let lenpars = List.count is_local_assum (snd cl.cl_context) in @@ -497,8 +268,8 @@ let all_instances () = GlobRef.Map.fold (fun k v acc -> v :: acc) v acc) !instances [] -let instances r = - let cl = class_info r in instances_of cl +let instances env sigma r = + let cl = class_info env sigma r in instances_of cl let is_class gr = GlobRef.Map.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index f8aedf88c2..e42b82c51f 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Constr open Evd open Environ @@ -54,19 +53,25 @@ type typeclass = { no backtracking and sharing of resolution. *) } -type instance +type instance = { + is_class: GlobRef.t; + is_info: hint_info; + (* Sections where the instance should be redeclared, + None for discard, Some 0 for none. *) + is_global: int option; + is_impl: GlobRef.t; +} -val instances : GlobRef.t -> instance list +val instances : env -> evar_map -> GlobRef.t -> instance list val typeclasses : unit -> typeclass list val all_instances : unit -> instance list -val add_class : typeclass -> unit +val load_class : typeclass -> unit -val new_instance : typeclass -> hint_info -> bool -> GlobRef.t -> instance -val add_instance : instance -> unit +val load_instance : instance -> unit val remove_instance : instance -> unit -val class_info : GlobRef.t -> typeclass (** raises a UserError if not a class *) +val class_info : env -> evar_map -> GlobRef.t -> typeclass (** raises a UserError if not a class *) (** These raise a UserError if not a class. @@ -78,7 +83,8 @@ val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.E val typeclass_univ_instance : typeclass Univ.puniverses -> typeclass (** Just return None if not a class *) -val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option +val class_of_constr : env -> evar_map -> EConstr.constr -> + (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option val instance_impl : instance -> GlobRef.t @@ -122,23 +128,9 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u val classes_transparent_state_hook : (unit -> TransparentState.t) Hook.t val classes_transparent_state : unit -> TransparentState.t -val add_instance_hint_hook : - (global_reference_or_constr -> GlobRef.t list -> - bool (* local? *) -> hint_info -> Decl_kinds.polymorphic -> unit) Hook.t -val remove_instance_hint_hook : (GlobRef.t -> unit) Hook.t -val add_instance_hint : global_reference_or_constr -> GlobRef.t list -> - bool -> hint_info -> Decl_kinds.polymorphic -> unit -val remove_instance_hint : GlobRef.t -> unit - val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t -(** Declares the given global reference as an instance of its type. - Does nothing — or emit a “not-a-class†warning if the [warn] argument is set — - when said type is not a registered type class. *) -val declare_instance : ?warn:bool -> hint_info option -> bool -> GlobRef.t -> unit - - (** Build the subinstances hints for a given typeclass object. check tells if we should check for existence of the subinstances and add only the missing ones. *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 89f72c874b..be71f44a5e 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -198,7 +198,7 @@ let check_type_fixpoint ?loc env sigma lna lar vdefj = (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = - let specif = Global.lookup_inductive (fst ind) in + let specif = lookup_mind_specif env (fst ind) in let sorts = elim_sorts specif in let pj = Retyping.get_judgment_of env sigma p in let _, s = splay_prod env sigma pj.uj_type in diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 229930142e..78733784a7 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -84,7 +84,8 @@ let tag_var = tag Tag.variable | Any -> true let prec_of_prim_token = function - | Numeral (_,b) -> if b then lposint else lnegint + | Numeral (SPlus,_) -> lposint + | Numeral (SMinus,_) -> lnegint | String _ -> latom let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps = @@ -234,7 +235,8 @@ let tag_var = tag Tag.variable | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t let pr_prim_token = function - | Numeral (n,s) -> str (if s then n else "-"^n) + | Numeral (SPlus,n) -> str (NumTok.to_string n) + | Numeral (SMinus,n) -> str ("-"^NumTok.to_string n) | String s -> qs s let pr_evar pr id l = @@ -397,12 +399,12 @@ let tag_var = tag Tag.variable pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c - let pr_guard_annot pr_aux bl (n,ro) = - match n with + let pr_guard_annot pr_aux bl ro = + match ro with | None -> mt () - | Some {loc; v = id} -> - match (ro : Constrexpr.recursion_order_expr) with - | CStructRec -> + | Some {loc; v = ro} -> + match ro with + | CStructRec { v = id } -> let names_of_binder = function | CLocalAssum (nal,_,_) -> nal | CLocalDef (_,_,_) -> [] @@ -411,10 +413,11 @@ let tag_var = tag Tag.variable if List.length ids > 1 then spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}" else mt() - | CWfRec c -> - spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_id id ++ str"}" - | CMeasureRec (m,r) -> - spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ spc() ++ pr_id id++ + | CWfRec (id,c) -> + spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_lident id ++ str"}" + | CMeasureRec (id,m,r) -> + spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ + match id with None -> mt() | Some id -> spc () ++ pr_lident id ++ (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}" let pr_fixdecl pr prd dangling_with_for ({v=id},ro,bl,t,c) = diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index db1687a49b..1332cd0168 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -35,10 +35,11 @@ val pr_patvar : Pattern.patvar -> Pp.t val pr_glob_level : Glob_term.glob_level -> Pp.t val pr_glob_sort : Glob_term.glob_sort -> Pp.t -val pr_guard_annot : (constr_expr -> Pp.t) -> - local_binder_expr list -> - lident option * recursion_order_expr -> - Pp.t +val pr_guard_annot + : (constr_expr -> Pp.t) + -> local_binder_expr list + -> recursion_order_expr option + -> Pp.t val pr_record_body : (qualid * constr_expr) list -> Pp.t val pr_binders : Environ.env -> Evd.evar_map -> local_binder_expr list -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 8bf86e9ef6..9541ea5882 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -952,5 +952,6 @@ let print_all_instances () = let print_instances r = let env = Global.env () in - let inst = instances r in + let sigma = Evd.from_env env in + let inst = instances env sigma r in prlist_with_sep fnl (pr_instance env) inst diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index d620e14a94..f378a5d2dd 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -102,8 +102,7 @@ let tokenize_string s = let st = CLexer.get_lexer_state () in try let istr = Stream.of_string s in - let lexer = CLexer.make_lexer ~diff_mode:true in - let lex = lexer.Gramlib.Plexing.tok_func istr in + let lex = CLexer.LexerDiff.tok_func istr in let toks = stream_tok [] (fst lex) in CLexer.set_lexer_state st; toks @@ -439,18 +438,18 @@ let match_goals ot nt = | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (2)") in let recursion_order_expr ogname exp exp2 = - match exp, exp2 with - | CStructRec, CStructRec -> () - | CWfRec c, CWfRec c2 -> + match exp.CAst.v, exp2.CAst.v with + | CStructRec _, CStructRec _ -> () + | CWfRec (_,c), CWfRec (_,c2) -> constr_expr ogname c c2 - | CMeasureRec (m,r), CMeasureRec (m2,r2) -> + | CMeasureRec (_,m,r), CMeasureRec (_,m2,r2) -> constr_expr ogname m m2; constr_expr_opt ogname r r2 | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (3)") in let fix_expr ogname exp exp2 = - let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in - recursion_order_expr ogname ro ro2; + let (l,ro,lb,ce1,ce2), (l2,ro2,lb2,ce12,ce22) = exp,exp2 in + Option.iter2 (recursion_order_expr ogname) ro ro2; iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 @@ -547,13 +546,16 @@ let match_goals ot nt = | None -> ()); !nevar_to_oevar +let get_proof_context (p : Proof.t) = + let Proof.{goals; sigma} = Proof.data p in + sigma, Refiner.pf_env { Evd.it = List.(hd goals); sigma } -let to_constr p = +let to_constr pf = let open CAst in - let pprf = Proof.partial_proof p in + let pprf = Proof.partial_proof pf in (* pprf generally has only one element, but it may have more in the derive plugin *) let t = List.hd pprf in - let sigma, env = Pfedit.get_current_context ~p () in + let sigma, env = get_proof_context pf in let x = Constrextern.extern_constr false env sigma t in (* todo: right options?? *) x.v diff --git a/proofs/dune b/proofs/dune index 679c45f6bf..36e9799998 100644 --- a/proofs/dune +++ b/proofs/dune @@ -3,4 +3,4 @@ (synopsis "Coq's Higher-level Refinement Proof Engine and Top-level Proof Structure") (public_name coq.proofs) (wrapped false) - (libraries interp)) + (libraries pretyping)) diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 0f97a942ed..1a34105ab6 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -55,6 +55,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } in try Pretyping.understand_ltac flags env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc diff --git a/proofs/goal.ml b/proofs/goal.ml index e5688fe730..94707accab 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -89,18 +89,9 @@ module V82 = struct | None -> sigma | Some id -> Evd.rename evk' id sigma - (* Parts of the progress tactical *) - let same_goal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - let c1 = EConstr.Unsafe.to_constr evi1.Evd.evar_concl in - let c2 = EConstr.Unsafe.to_constr evi2.Evd.evar_concl in - Constr.equal c1 c2 && - Environ.eq_named_context_val evi1.Evd.evar_hyps evi2.Evd.evar_hyps - let weak_progress glss gls = match glss.Evd.it with - | [ g ] -> not (same_goal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it) + | [ g ] -> not (Proofview.Progress.goal_equal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it) | _ -> true let progress glss gls = diff --git a/proofs/goal.mli b/proofs/goal.mli index af9fb662bf..665b0c9e59 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -57,9 +57,6 @@ module V82 : sig (* Principal part of the progress tactical *) val progress : goal list Evd.sigma -> goal Evd.sigma -> bool - (* Principal part of tclNOTSAMEGOAL *) - val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool - (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index 3581e90b79..a01ddf2388 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -63,7 +63,6 @@ let catchable_exception = function | CErrors.UserError _ | TypeError _ | Proof.OpenProof _ (* abstract will call close_proof inside a tactic *) - | Notation.PrimTokenNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 9509c36ec0..ef4a74b273 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -37,41 +37,35 @@ let get_nth_V82_goal p i = try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal -let get_goal_context_gen p i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal p i in +let get_goal_context_gen pf i = + let { it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) -let get_goal_context i = - try get_goal_context_gen (Proof_global.give_me_the_proof ()) i - with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") - | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") - -let get_current_goal_context () = - try get_goal_context_gen (Proof_global.give_me_the_proof ()) 1 - with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") - | NoSuchGoal -> - (* spiwack: returning empty evar_map, since if there is no goal, under focus, - there is no accessible evar either *) - let env = Global.env () in - (Evd.from_env env, env) +let get_goal_context pf i = + let p = Proof_global.give_me_the_proof pf in + get_goal_context_gen p i -let get_current_context ?p () = - let current_proof_by_default = function - | Some p -> p - | None -> Proof_global.give_me_the_proof () - in - try get_goal_context_gen (current_proof_by_default p) 1 - with Proof_global.NoCurrentProof -> +let get_current_goal_context pf = + let p = Proof_global.give_me_the_proof pf in + try get_goal_context_gen p 1 + with + | NoSuchGoal -> + (* spiwack: returning empty evar_map, since if there is no goal, + under focus, there is no accessible evar either. EJGA: this + seems strange, as we have pf *) let env = Global.env () in - (Evd.from_env env, env) - | NoSuchGoal -> - (* No more focused goals ? *) - let p = (current_proof_by_default p) in - let evd = Proof.in_proof p (fun x -> x) in - (evd, Global.env ()) + Evd.from_env env, env + +let get_current_context pf = + let p = Proof_global.give_me_the_proof pf in + try get_goal_context_gen p 1 + with + | NoSuchGoal -> + (* No more focused goals *) + let evd = Proof.in_proof p (fun x -> x) in + evd, Global.env () let solve ?with_end_tac gi info_lvl tac pr = - try let tac = match with_end_tac with | None -> tac | Some etac -> Proofview.tclTHEN tac etac in @@ -112,16 +106,9 @@ let solve ?with_end_tac gi info_lvl tac pr = | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) in (p,status) - with - Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof") let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) -let instantiate_nth_evar_com n com = - Proof_global.simple_with_current_proof (fun _ p -> - Proof.V82.instantiate_evar Global.(env ())n com p) - - (**********************************************************************) (* Shortcut to build a term using tactics *) @@ -133,21 +120,19 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in let goals = [ (Global.env_of_context sign , typ) ] in - Proof_global.start_proof evd id goal_kind goals terminator; + let pf = Proof_global.start_proof ~ontop:None evd id goal_kind goals terminator in try - let status = by tac in + let pf, status = by tac pf in let open Proof_global in - let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in + let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - discard_current (); let univs = UState.demote_seff_univs entry universes in entry, status, univs | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> let reraise = CErrors.push reraise in - Proof_global.discard_current (); iraise reraise let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 29ab00876a..77d701b41f 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -16,29 +16,29 @@ open Environ open Decl_kinds (** {6 ... } *) + +exception NoSuchGoal + (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) -val get_goal_context : int -> Evd.evar_map * env +val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env (** [get_current_goal_context ()] works as [get_goal_context 1] *) - -val get_current_goal_context : unit -> Evd.evar_map * env +val get_current_goal_context : Proof_global.t -> Evd.evar_map * env (** [get_current_context ()] returns the context of the current focused goal. If there is no focused goal but there is a proof in progress, it returns the corresponding evar_map. If there is no pending proof then it returns the current global environment and empty evar_map. *) - -val get_current_context : ?p:Proof.t -> unit -> Evd.evar_map * env +val get_current_context : Proof_global.t -> Evd.evar_map * env (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th - subgoal of the current focused proof or raises a [UserError] if no - proof is focused or if there is no [n]th subgoal. [solve SelectAll + subgoal of the current focused proof. [solve SelectAll tac] applies [tac] to all subgoals. *) val solve : ?with_end_tac:unit Proofview.tactic -> @@ -46,22 +46,14 @@ val solve : ?with_end_tac:unit Proofview.tactic -> Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current - focused proof or raises a UserError if there is no focused proof or - if there is no more subgoals. + focused proof. Returns [false] if an unsafe tactic has been used. *) -val by : unit Proofview.tactic -> bool +val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool (** Option telling if unification heuristics should be used. *) val use_unification_heuristics : unit -> bool -(** [instantiate_nth_evar_com n c] instantiate the [n]th undefined - existential variable of the current focused proof by [c] or raises a - UserError if no proof is focused or if there is no such [n]th - existential variable *) - -val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit - (** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac]. The return boolean, if [false] indicates the use of an unsafe tactic. *) diff --git a/proofs/proof.ml b/proofs/proof.ml index e40940f652..978b1f6f78 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -480,7 +480,7 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } (* Main component of vernac command Existential *) - let instantiate_evar env n com pr = + let instantiate_evar env n intern pr = let tac = Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> let (evk, evi) = @@ -494,7 +494,7 @@ module V82 = struct CList.nth evl (n-1) in let env = Evd.evar_filtered_env evi in - let rawc = Constrintern.intern_constr env sigma com in + let rawc = intern env sigma in let ltac_vars = Glob_ops.empty_lvar in let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma diff --git a/proofs/proof.mli b/proofs/proof.mli index 40e8ff7eef..defef57a8d 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -249,8 +249,11 @@ module V82 : sig val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : - Environ.env -> int -> Constrexpr.constr_expr -> t -> t + val instantiate_evar + : Environ.env + -> int + -> (Environ.env -> Evd.evar_map -> Glob_term.glob_constr) + -> t -> t end (* returns the set of all goals in the proof *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 6174b75a96..86d3d9601e 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -17,7 +17,6 @@ (***********************************************************************) open Util -open Pp open Names open Context @@ -55,108 +54,66 @@ type pstate = { strength : Decl_kinds.goal_kind; } -type t = pstate list +(* The head of [t] is the actual current proof, the other ones are + to be resumed when the current proof is closed or aborted. *) +type t = pstate * pstate list + +let pstate_map f (pf, pfl) = (f pf, List.map f pfl) let make_terminator f = f let apply_terminator f = f -(* The head of [!pstates] is the actual current proof, the other ones are - to be resumed when the current proof is closed or aborted. *) -let pstates = ref ([] : pstate list) - (* combinators for the current_proof lists *) -let push a l = l := a::!l - -exception NoCurrentProof -let () = CErrors.register_handler begin function - | NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") - | _ -> raise CErrors.Unhandled -end +let push ~ontop a = + match ontop with + | None -> a , [] + | Some (l,ls) -> a, (l :: ls) (*** Proof Global manipulation ***) -let get_all_proof_names () = - List.map Proof.(function pf -> (data pf.proof).name) !pstates - -let cur_pstate () = - match !pstates with - | np::_ -> np - | [] -> raise NoCurrentProof - -let give_me_the_proof () = (cur_pstate ()).proof -let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None -let get_current_proof_name () = (Proof.data (cur_pstate ()).proof).Proof.name -let get_current_persistence () = (cur_pstate ()).strength - -let with_current_proof f = - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> - let et = - match p.endline_tactic with - | None -> Proofview.tclUNIT () - | Some tac -> - let open Geninterp in - let ist = { lfun = Id.Map.empty; extra = TacStore.empty } in - let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in - let tac = Geninterp.interp tag ist tac in - Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) - in - let (newpr,ret) = f et p.proof in - let p = { p with proof = newpr } in - pstates := p :: rest; - ret - -let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ()) - -let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact) +let get_all_proof_names (pf : t) = + let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in + pn :: pns + +let give_me_the_proof (ps,_) = ps.proof +let get_current_proof_name (ps,_) = (Proof.data ps.proof).Proof.name +let get_current_persistence (ps,_) = ps.strength + +let with_current_proof f (ps, psl) = + let et = + match ps.endline_tactic with + | None -> Proofview.tclUNIT () + | Some tac -> + let open Geninterp in + let ist = { lfun = Id.Map.empty; poly = pi2 ps.strength; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in + let (newpr,ret) = f et ps.proof in + let ps = { ps with proof = newpr } in + (ps, psl), ret + +let simple_with_current_proof f pf = + let p, () = with_current_proof (fun t p -> f t p , ()) pf in p + +let compact_the_proof pf = simple_with_current_proof (fun _ -> Proof.compact) pf (* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac = - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> pstates := { p with endline_tactic = Some tac } :: rest - -(* spiwack: it might be considered to move error messages away. - Or else to remove special exceptions from Proof_global. - Arguments for the former: there is no reason Proof_global is only - accessed directly through vernacular commands. Error message should be - pushed to external layers, and so we should be able to have a finer - control on error message on complex actions. *) -let msg_proofs () = - match get_all_proof_names () with - | [] -> (spc () ++ str"(No proof-editing in progress).") - | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ - (pr_sequence Id.print l) ++ str".") - -let there_is_a_proof () = not (List.is_empty !pstates) -let there_are_pending_proofs () = there_is_a_proof () -let check_no_pending_proof () = - if not (there_are_pending_proofs ()) then - () - else begin - CErrors.user_err - (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ - str"Use \"Abort All\" first or complete proof(s).") - end +let set_endline_tactic tac (ps, psl) = + { ps with endline_tactic = Some tac }, psl let pf_name_eq id ps = let Proof.{ name } = Proof.data ps.proof in Id.equal name id -let discard_gen id = - pstates := List.filter (fun pf -> not (pf_name_eq id pf)) !pstates - -let discard {CAst.loc;v=id} = - let n = List.length !pstates in - discard_gen id; - if Int.equal (List.length !pstates) n then - CErrors.user_err ?loc - ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) +let discard {CAst.loc;v=id} (ps, psl) = + match List.filter (fun pf -> not (pf_name_eq id pf)) (ps :: psl) with + | [] -> None + | ps :: psl -> Some (ps, psl) -let discard_current () = - if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates -let discard_all () = pstates := [] +let discard_current (ps, psl) = + if List.is_empty psl then None else Some List.(hd psl, tl psl) (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -166,30 +123,30 @@ let discard_all () = pstates := [] end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = +let start_proof ~ontop sigma name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { terminator = CEphemeron.create terminator; proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - strength = kind; - universe_decl = pl } in - push initial_state pstates + universe_decl = pl; + strength = kind } in + push ~ontop initial_state -let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = +let start_dependent_proof ~ontop name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { terminator = CEphemeron.create terminator; proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - strength = kind; - universe_decl = pl } in - push initial_state pstates + universe_decl = pl; + strength = kind } in + push ~ontop initial_state -let get_used_variables () = (cur_pstate ()).section_vars -let get_universe_decl () = (cur_pstate ()).universe_decl +let get_used_variables (pf,_) = pf.section_vars +let get_universe_decl (pf,_) = pf.universe_decl -let set_used_variables l = +let set_used_variables (ps,psl) l = let open Context.Named.Declaration in let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in @@ -210,20 +167,17 @@ let set_used_variables l = else (ctx, all_safe) in let ctx, _ = Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> - if not (Option.is_empty p.section_vars) then - CErrors.user_err Pp.(str "Used section variables can be declared only once"); - pstates := { p with section_vars = Some ctx} :: rest; - ctx, [] - -let get_open_goals () = - let Proof.{ goals; stack; shelf } = Proof.data (cur_pstate ()).proof in + if not (Option.is_empty ps.section_vars) then + CErrors.user_err Pp.(str "Used section variables can be declared only once"); + (* EJGA: This is always empty thus we should modify the type *) + (ctx, []), ({ ps with section_vars = Some ctx}, psl) + +let get_open_goals (ps, _) = + let Proof.{ goals; stack; shelf } = Proof.data ps.proof in List.length goals + - List.fold_left (+) 0 + List.fold_left (+) 0 (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf + List.length shelf type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t @@ -240,8 +194,8 @@ let private_poly_univs = fun () -> !b let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now - (fpl : closed_proof_output Future.computation) = - let { section_vars; proof; terminator; universe_decl; strength } = cur_pstate () in + (fpl : closed_proof_output Future.computation) ps = + let { section_vars; proof; terminator; universe_decl; strength } = ps in let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in let constrain_variables ctx = @@ -339,8 +293,8 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now universes }, fun pr_ending -> CEphemeron.get terminator pr_ending -let return_proof ?(allow_partial=false) () = - let { proof } = cur_pstate () in +let return_proof ?(allow_partial=false) (ps,_) = + let { proof } = ps in if allow_partial then begin let proofs = Proof.partial_proof proof in let Proof.{sigma=evd} = Proof.data proof in @@ -368,43 +322,44 @@ let return_proof ?(allow_partial=false) () = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in proofs, Evd.evar_universe_context evd -let close_future_proof ~opaque ~feedback_id proof = - close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof -let close_proof ~opaque ~keep_body_ucst_separate fix_exn = +let close_future_proof ~opaque ~feedback_id (ps, psl) proof = + close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof ps + +let close_proof ~opaque ~keep_body_ucst_separate fix_exn (ps, psl) = close_proof ~opaque ~keep_body_ucst_separate ~now:true - (Future.from_val ~fix_exn (return_proof ())) + (Future.from_val ~fix_exn (return_proof (ps,psl))) ps (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator -let set_terminator hook = - match !pstates with - | [] -> raise NoCurrentProof - | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps - -let freeze ~marshallable = - if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") - else !pstates -let unfreeze s = pstates := s -let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof +let get_terminator (ps, _) = CEphemeron.get ps.terminator +let set_terminator hook (ps, psl) = + { ps with terminator = CEphemeron.create hook }, psl + let copy_terminators ~src ~tgt = - assert(List.length src = List.length tgt); - List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt + let (ps, psl), (ts,tsl) = src, tgt in + assert(List.length psl = List.length tsl); + {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl -let update_global_env pf_info = +let update_global_env (pf : t) = + let res, () = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> 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, ()))) - -(* XXX: Bullet hook, should be really moved elsewhere *) -let () = - let hook n = - try - let prf = give_me_the_proof () in - (Proof_bullet.suggest prf) - with NoCurrentProof -> mt () - in - Proofview.set_nosuchgoals_hook hook + (p, ()))) pf + in res + +(* XXX: This hook is used to provide a better error w.r.t. bullets, + however the proof engine [surprise!] knows nothing about bullets so + here we have a layering violation. The right fix is to modify the + entry point to handle this and reraise the exception with the + needed information. *) +(* let _ = + * let hook n = + * try + * let prf = give_me_the_proof pf in + * (Proof_bullet.suggest prf) + * with NoCurrentProof -> mt () + * in + * Proofview.set_nosuchgoals_hook hook *) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 38e234eaee..e2e457483b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,23 +13,15 @@ environment. *) type t -val there_are_pending_proofs : unit -> bool -val check_no_pending_proof : unit -> unit +val get_current_proof_name : t -> Names.Id.t +val get_current_persistence : t -> Decl_kinds.goal_kind +val get_all_proof_names : t -> Names.Id.t list -val get_current_proof_name : unit -> Names.Id.t -val get_current_persistence : unit -> Decl_kinds.goal_kind -val get_all_proof_names : unit -> Names.Id.t list +val discard : Names.lident -> t -> t option +val discard_current : t -> t option -val discard : Names.lident -> unit -val discard_current : unit -> unit -val discard_all : unit -> unit - -val give_me_the_proof_opt : unit -> Proof.t option -exception NoCurrentProof -val give_me_the_proof : unit -> Proof.t -(** @raise NoCurrentProof when outside proof mode. *) - -val compact_the_proof : unit -> unit +val give_me_the_proof : t -> Proof.t +val compact_the_proof : t -> t (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms @@ -60,7 +52,7 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str pl goals terminator] starts a proof of name +(** [start_proof ~ontop id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is; [terminator] is used at the end of the proof to close the proof @@ -68,25 +60,25 @@ val apply_terminator : proof_terminator -> proof_ending -> unit morphism). The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -val start_proof : +val start_proof : ontop:t option -> Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> unit + proof_terminator -> t (** Like [start_proof] except that there may be dependencies between initial goals. *) -val start_dependent_proof : +val start_dependent_proof : ontop:t option -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> unit + Proofview.telescope -> proof_terminator -> t (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes there_are_pending_proofs. *) -val update_global_env : unit -> unit +val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -96,39 +88,36 @@ type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * USt (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> unit -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> +val return_proof : ?allow_partial:bool -> t -> closed_proof_output +val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> closed_proof (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -val get_terminator : unit -> proof_terminator -val set_terminator : proof_terminator -> unit - -val get_open_goals : unit -> int +val get_terminator : t -> proof_terminator +val set_terminator : proof_terminator -> t -> t +val get_open_goals : t -> int (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> t -> t (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> unit +val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) -val set_used_variables : - Names.Id.t list -> Constr.named_context * Names.lident list -val get_used_variables : unit -> Constr.named_context option +val set_used_variables : t -> + Names.Id.t list -> (Constr.named_context * Names.lident list) * t + +val get_used_variables : t -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) -val get_universe_decl : unit -> UState.universe_decl +val get_universe_decl : t -> UState.universe_decl -val freeze : marshallable:bool -> t -val unfreeze : t -> unit -val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 8196f5e198..7b3d9e534b 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -65,14 +65,8 @@ let pf_ids_set_of_hyps gls = let pf_get_new_id id gls = next_ident_away id (pf_ids_set_of_hyps gls) -let pf_global gls id = - let env = pf_env gls in - let sigma = project gls in - Evd.fresh_global env sigma (Constrintern.construct_reference (pf_hyps gls) id) - let pf_apply f gls = f (pf_env gls) (project gls) -let pf_eapply f gls x = - on_sig gls (fun evm -> f (pf_env gls) evm x) +let pf_eapply f gls x = on_sig gls (fun evm -> f (pf_env gls) evm x) let pf_reduce = pf_apply let pf_e_reduce = pf_apply @@ -126,11 +120,6 @@ module New = struct let of_old f gl = f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; } - let pf_global id gl = - (* We only check for the existence of an [id] in [hyps] *) - let hyps = Proofview.Goal.hyps gl in - Constrintern.construct_reference hyps id - let pf_env = Proofview.Goal.env let pf_concl = Proofview.Goal.concl diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 1454140dd7..218011c316 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -33,7 +33,6 @@ val pf_hyps_types : Goal.goal sigma -> (Id.t Context.binder_annot * type val pf_nth_hyp_id : Goal.goal sigma -> int -> Id.t val pf_last_hyp : Goal.goal sigma -> named_declaration val pf_ids_of_hyps : Goal.goal sigma -> Id.t list -val pf_global : Goal.goal sigma -> Id.t -> evar_map * constr val pf_unsafe_type_of : Goal.goal sigma -> constr -> types val pf_type_of : Goal.goal sigma -> constr -> evar_map * types val pf_hnf_type_of : Goal.goal sigma -> constr -> types @@ -76,7 +75,6 @@ val pr_glls : Goal.goal list sigma -> Pp.t module New : sig val pf_apply : (env -> evar_map -> 'a) -> Proofview.Goal.t -> 'a - val pf_global : Id.t -> Proofview.Goal.t -> GlobRef.t (** FIXME: encapsulate the level in an existential type. *) val of_old : (Goal.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 73b9ef7da0..2493b1fac4 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -139,7 +139,7 @@ module Make(T : Task) () = struct (* We need to pass some options with one argument *) | ( "-I" | "-include" | "-top" | "-topfile" | "-coqlib" | "-exclude-dir" | "-compat" | "-load-ml-object" | "-load-ml-source" | "-require" | "-w" | "-color" | "-init-file" - | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" + | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" | "-set" | "-unset" | "-diffs" | "-mangle-name" | "-dump-glob" | "-bytecode-compiler" | "-native-compiler" as x) :: a :: tl -> x :: a :: set_slave_opt tl (* We need to pass some options with two arguments *) @@ -329,10 +329,12 @@ module Make(T : Task) () = struct let main_loop () = (* We pass feedback to master *) let slave_feeder oc fb = - Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in + Control.protect_sigalrm (fun () -> + Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc) () + in ignore (Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x)); (* We ask master to allocate universe identifiers *) - UnivGen.set_remote_new_univ_id (bufferize (fun () -> + UnivGen.set_remote_new_univ_id (bufferize @@ Control.protect_sigalrm (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with | MoreDataUnivLevel l -> l)); diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 230a3207a8..d13763cdec 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -49,12 +49,13 @@ let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.proof }) -> - let proof = Proof_global.proof_of_state proof in - let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in - let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in - if List.for_all (fun x -> simple_goal sigma x rest) focused - then `Simple focused - else `Not + Option.cata (fun proof -> + let proof = Proof_global.give_me_the_proof proof in + let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + if List.for_all (fun x -> simple_goal sigma x rest) focused + then `Simple focused + else `Not) `Not proof type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index 0c5d0c7b5d..e1ab45163a 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -139,8 +139,8 @@ let may_pierce_opaque = function | _ -> false let update_global_env () = - if Proof_global.there_are_pending_proofs () then - Proof_global.update_global_env () + if Vernacstate.Proof_global.there_are_pending_proofs () then + Vernacstate.Proof_global.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation @@ -872,7 +872,7 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy type proof_part = - Proof_global.t * + Proof_global.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) @@ -948,8 +948,8 @@ end = struct (* {{{ *) let prev = (VCS.visit id).next in if is_cached_and_valid prev then { s with proof = - Proof_global.copy_terminators - ~src:(get_cached prev).proof ~tgt:s.proof } + Vernacstate.Proof_global.copy_terminators + ~src:((get_cached prev).proof) ~tgt:s.proof } else s with VCS.Expired -> s in VCS.set_state id (FullState s) @@ -957,7 +957,7 @@ end = struct (* {{{ *) if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = - Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in + Vernacstate.Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system begin @@ -1009,8 +1009,8 @@ end = struct (* {{{ *) if feedback_processed then Hooks.(call state_computed ~doc id ~in_cache:false); VCS.reached id; - if Proof_global.there_are_pending_proofs () then - VCS.goals id (Proof_global.get_open_goals ()) + if Vernacstate.Proof_global.there_are_pending_proofs () then + VCS.goals id (Vernacstate.Proof_global.get_open_goals ()) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in @@ -1130,9 +1130,9 @@ let show_script ?proof () = try let prf = try match proof with - | None -> Some (Proof_global.get_current_proof_name ()) + | None -> Some (Vernacstate.Proof_global.get_current_proof_name ()) | Some (p,_) -> Some (p.Proof_global.id) - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None in let cmds = get_script prf in let _,_,_,indented_cmds = @@ -1255,9 +1255,8 @@ end = struct (* {{{ *) if Int.equal n 0 then `Stop id else `Cont (n-value) let get_proof ~doc id = - let open Vernacstate in match state_of_id ~doc id with - | `Valid (Some vstate) -> Some (Proof_global.proof_of_state vstate.proof) + | `Valid (Some vstate) -> Option.map Proof_global.give_me_the_proof vstate.Vernacstate.proof | _ -> None let undo_vernac_classifier v ~doc = @@ -1296,7 +1295,7 @@ end = struct (* {{{ *) | Some vcs, _ -> vcs in let cb, _ = try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) - with Failure _ -> raise Proof_global.NoCurrentProof in + with Failure _ -> raise Vernacstate.Proof_global.NoCurrentProof in let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in @@ -1334,7 +1333,7 @@ end = struct (* {{{ *) | None -> true done; !rv - with Not_found | Proof_global.NoCurrentProof -> None + with Not_found | Vernacstate.Proof_global.NoCurrentProof -> None end (* }}} *) @@ -1595,7 +1594,7 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - let p = Proof_global.return_proof ~allow_partial:drop_pt () in + let p = Vernacstate.Proof_global.return_proof ~allow_partial:drop_pt () in if drop_pt then feedback ~id Complete; p) @@ -1622,7 +1621,7 @@ end = struct (* {{{ *) to set the state manually here *) State.unfreeze st; let pobject, _ = - Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in + Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator []) in @@ -1759,15 +1758,15 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then - let _proof = Proof_global.return_proof ~allow_partial:true () in + let _proof = Vernacstate.Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED else begin (* The original terminator, a hook, has not been saved in the .vio*) - Proof_global.set_terminator (Lemmas.standard_proof_terminator []); + Vernacstate.Proof_global.set_terminator (Lemmas.standard_proof_terminator []); let opaque = Proof_global.Opaque in let proof = - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; @@ -2017,7 +2016,7 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; State.purify (fun () -> - let Proof.{sigma=sigma0} = Proof.data (Proof_global.give_me_the_proof ()) in + let Proof.{sigma=sigma0} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( @@ -2029,7 +2028,7 @@ end = struct (* {{{ *) "goals only")) else begin let (i, ast) = r_ast in - Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + Vernacstate.Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); (* STATE SPEC: * - start : id * - return: id @@ -2038,7 +2037,7 @@ end = struct (* {{{ *) *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp r_state_fb st ast); - let Proof.{sigma} = Proof.data (Proof_global.give_me_the_proof ()) in + let Proof.{sigma} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> @@ -2065,21 +2064,27 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () + let stm_fail ~st fail f = + if fail then + Vernacentries.with_fail ~st f + else + f () + let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id - { indentation; verbose; loc; expr = e; strlen } + { indentation; verbose; loc; expr = e; strlen } : unit = let e, time, batch, fail = let rec find ~time ~batch ~fail = function | VernacTime (batch,{CAst.v=e}) -> find ~time:true ~batch ~fail e | VernacRedirect (_,{CAst.v=e}) -> find ~time ~batch ~fail e - | VernacFail e -> find ~time ~batch ~fail:true e + | VernacFail {CAst.v=e} -> find ~time ~batch ~fail:true e | e -> e, time, batch, fail in find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in - Vernacentries.with_fail st fail (fun () -> + stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> - Proof_global.with_current_proof (fun _ p -> + Vernacstate.Proof_global.with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2112,7 +2117,7 @@ end = struct (* {{{ *) let open Notations in match Future.join f with | Some (pt, uc) -> - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Vernacstate.Proof_global.get_current_context () in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ @@ -2392,10 +2397,10 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () end in - match VCS.get_state base_state with + match (VCS.get_info base_state).state with | FullState { Vernacstate.proof } -> - Proof_global.unfreeze proof; - Proof_global.with_current_proof (fun _ p -> + Option.iter Vernacstate.Proof_global.unfreeze proof; + Vernacstate.Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: @@ -2565,7 +2570,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepDefined -> Proof_global.Transparent in let proof = - Proof_global.close_future_proof ~opaque ~feedback_id:id fp in + Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in @@ -2573,13 +2578,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), not redefine_qed, true | `Sync (name, `Immediate) -> (fun () -> reach eop; let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), true, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; @@ -2598,7 +2603,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in - Some(Proof_global.close_proof ~opaque + Some(Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in if keep <> VtKeep VtKeepAxiom then @@ -2609,7 +2614,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> reach ~cache:true start; @@ -2870,7 +2875,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) + Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Vernacstate.Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -2965,7 +2970,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise else @@ -3049,7 +3054,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise else let id = VCS.new_node ~id:newtip proof_mode () in @@ -3062,7 +3067,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) - if not in_proof && Proof_global.there_are_pending_proofs () then + if not in_proof && Vernacstate.Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in let opacity_of_produced_term = function diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index feb8e2a67f..243b5c333d 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -57,6 +57,7 @@ let options_affecting_stm_scheduling = stm_allow_nested_proofs_option_name; Vernacentries.proof_mode_opt_name; Attributes.program_mode_option_name; + Proof_using.proof_using_opt_name; ] let classify_vernac e = @@ -64,7 +65,7 @@ let classify_vernac e = (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) - | ( VernacSetOption (_, l,_) | VernacUnsetOption (_, l)) + | VernacSetOption (_, l,_) when CList.exists (CList.equal String.equal l) options_affecting_stm_scheduling -> VtSideff [], VtNow @@ -91,9 +92,6 @@ let classify_vernac e = VtProofStep { parallel = `No; proof_block_detection = Some "curly" }, VtLater - (* Options changing parser *) - | VernacUnsetOption (_, ["Default";"Proof";"Using"]) - | VernacSetOption (_, ["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ((Decl_kinds.DoDischarge,_),({v=i},_),ProveBody _) -> VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater @@ -156,7 +154,7 @@ let classify_vernac e = | VernacReserve _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ - | VernacUnsetOption _ | VernacSetOption _ + | VernacSetOption _ | VernacAddOption _ | VernacRemoveOption _ | VernacMemOption _ | VernacPrintOption _ | VernacGlobalCheck _ @@ -206,10 +204,10 @@ let classify_vernac e = | VernacExpr (f, e) -> let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in static_classifier ~poly e - | VernacTimeout (_,e) -> static_control_classifier e + | VernacTimeout (_,{v=e}) -> static_control_classifier e | VernacTime (_,{v=e}) | VernacRedirect (_, {v=e}) -> static_control_classifier e - | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + | VernacFail {v=e} -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ | VtMeta), _ as x -> x diff --git a/tactics/auto.ml b/tactics/auto.ml index 2619620eb8..4e0ec1f7e4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -143,7 +143,8 @@ let conclPattern concl pat tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - constr_bindings env sigma >>= fun constr_bindings -> + constr_bindings env sigma >>= fun constr_bindings -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Stdarg.wit_constr) with @@ -152,7 +153,9 @@ let conclPattern concl pat tac = in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in - let ist = { lfun; extra = TacStore.empty } in + let ist = { lfun + ; poly + ; extra = TacStore.empty } in match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index d9c0a26f91..51708670f5 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -99,11 +99,15 @@ let one_base general_rewrite_maybe_in tac_main bas = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_rewrite_maybe_in dir c' tc) end in - let lrul = List.map (fun h -> + let open Proofview.Notations in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> + let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly + ; extra = Geninterp.TacStore.empty } in Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a3620f4081..c1ac7d201a 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -33,7 +33,8 @@ open Hints module NamedDecl = Context.Named.Declaration -(** Hint database named "typeclass_instances", now created directly in Auto *) +(** Hint database named "typeclass_instances", created in prelude *) +let typeclasses_db = "typeclass_instances" (** Options handling *) @@ -361,7 +362,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm try match hdc with | Some (hd,_) when only_classes -> - let cl = Typeclasses.class_info hd in + let cl = Typeclasses.class_info env sigma hd in if cl.cl_strict then Evarutil.undefined_evars_of_term sigma concl else Evar.Set.empty @@ -933,11 +934,12 @@ module Search = struct try (* Instance may try to call this before a proof is set up! Thus, give_me_the_proof will fail. Beware! *) - let name, poly = try - let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in - name, poly - with | Proof_global.NoCurrentProof -> - Id.of_string "instance", false + let name, poly = + (* try + * let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in + * name, poly + * with | Proof_global.NoCurrentProof -> *) + Id.of_string "instance", false in let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply ~name ~poly env tac pv @@ -1050,7 +1052,7 @@ let error_unresolvable env comp evd = | Some s -> Evar.Set.mem ev s in let fold ev evi (found, accu) = - let ev_class = class_of_constr evd evi.evar_concl in + let ev_class = class_of_constr env evd evi.evar_concl in if not (Option.is_empty ev_class) && is_part ev then (* focus on one instance if only one was searched for *) if not found then (true, Some ev) diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index a6922213d0..c950e3de3d 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -13,6 +13,8 @@ open Names open EConstr +val typeclasses_db : string + val catchable : exn -> bool val set_typeclasses_debug : bool -> unit diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 3ff2e3852d..d9d3764b2a 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -67,17 +67,17 @@ let contradiction_context = let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma typ in - if is_empty_type sigma typ then + if is_empty_type env sigma typ then simplest_elim (mkVar id) else match EConstr.kind sigma typ with - | Prod (na,t,u) when is_empty_type sigma u -> - let is_unit_or_eq = match_with_unit_or_eq_type sigma t in + | Prod (na,t,u) when is_empty_type env sigma u -> + let is_unit_or_eq = match_with_unit_or_eq_type env sigma t in Tacticals.New.tclORELSE (match is_unit_or_eq with | Some _ -> let hd,args = decompose_app sigma t in let (ind,_ as indu) = destInd sigma hd in - let nparams = Inductiveops.inductive_nparams_env env ind in + let nparams = Inductiveops.inductive_nparams env ind in let params = Util.List.firstn nparams args in let p = applist ((mkConstructUi (indu,1)), params) in (* Checking on the fly that it type-checks *) @@ -103,7 +103,7 @@ let contradiction_context = let is_negation_of env sigma typ t = match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,t,u) -> - is_empty_type sigma u && is_conv_leq env sigma typ t + is_empty_type env sigma u && is_conv_leq env sigma typ t | _ -> false let contradiction_term (c,lbind as cl) = @@ -113,7 +113,7 @@ let contradiction_term (c,lbind as cl) = let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in let _, ccl = splay_prod env sigma typ in - if is_empty_type sigma ccl then + if is_empty_type env sigma ccl then Tacticals.New.tclTHEN (elim false None cl None) (Tacticals.New.tclTRY assumption) diff --git a/tactics/elim.ml b/tactics/elim.ml index 003b069b6e..71ea0098a3 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -81,12 +81,13 @@ let up_to_delta = ref false (* true *) let general_decompose recognizer c = Proofview.Goal.enter begin fun gl -> let type_of = pf_unsafe_type_of gl in + let env = pf_env gl in let sigma = project gl in let typc = type_of c in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId - (ifOnHyp (recognizer sigma) (general_decompose_aux (recognizer sigma)) + (ifOnHyp (recognizer env sigma) (general_decompose_aux (recognizer env sigma)) (fun id -> clear [id]))); exact_no_check c ] end @@ -105,17 +106,17 @@ let head_in indl t gl = let decompose_these c l = Proofview.Goal.enter begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in - general_decompose (fun sigma (_,t) -> head_in indl t gl) c + general_decompose (fun env sigma (_,t) -> head_in indl t gl) c end let decompose_and c = general_decompose - (fun sigma (_,t) -> is_record sigma t) + (fun env sigma (_,t) -> is_record env sigma t) c let decompose_or c = general_decompose - (fun sigma (_,t) -> is_disjunction sigma t) + (fun env sigma (_,t) -> is_disjunction env sigma t) c let h_decompose l c = decompose_these c l diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 073d66e4aa..3fdd97616f 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -686,11 +686,6 @@ let build_r2l_rew_scheme dep env ind k = let (sigma, c) = build_case_analysis_scheme env sigma indu dep k in c, Evd.evar_universe_context sigma -let build_l2r_rew_scheme = build_l2r_rew_scheme -let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme -let build_r2l_rew_scheme = build_r2l_rew_scheme -let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme - (**********************************************************************) (* Register the rewriting schemes *) (**********************************************************************) diff --git a/tactics/equality.ml b/tactics/equality.ml index 88ce9868af..3d760f1c3d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -257,7 +257,7 @@ let tclNOTSAMEGOAL tac = Proofview.Goal.goals >>= fun gls -> let check accu gl' = gl' >>= fun gl' -> - let accu = accu || Goal.V82.same_goal sigma ev (project gl') (goal gl') in + let accu = accu || Proofview.Progress.goal_equal sigma ev (project gl') (goal gl') in Proofview.tclUNIT accu in Proofview.Monad.List.fold_left check false gls >>= fun has_same -> @@ -356,7 +356,7 @@ let find_elim hdcncl lft2rgt dep cls ot = match EConstr.kind sigma hdcncl with | Ind (ind_sp,u) -> let pr1 = - lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) + lookup_eliminator env ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None @@ -446,7 +446,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in - match match_with_equality_type sigma t with + match match_with_equality_type env sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) @@ -462,7 +462,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) - match match_with_equality_type sigma t' with + match match_with_equality_type env sigma t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c @@ -743,7 +743,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let hd2,args2 = whd_all_stack env sigma t2 in match (EConstr.kind sigma hd1, EConstr.kind sigma hd2) with | Construct ((ind1,i1 as sp1),u1), Construct (sp2,_) - when Int.equal (List.length args1) (constructor_nallargs_env env sp1) + when Int.equal (List.length args1) (constructor_nallargs env sp1) -> let sorts' = Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) @@ -751,7 +751,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if eq_constructor sp1 sp2 then - let nparams = inductive_nparams_env env ind1 in + let nparams = inductive_nparams env ind1 in let params1,rargs1 = List.chop nparams args1 in let _,rargs2 = List.chop nparams args2 in let (mib,mip) = lookup_mind_specif env ind1 in @@ -966,9 +966,10 @@ let rec build_discriminator env sigma true_0 false_0 dirn c = function let gen_absurdity id = Proofview.Goal.enter begin fun gl -> + let env = pf_env gl in let sigma = project gl in let hyp_typ = pf_get_hyp_typ id gl in - if is_empty_type sigma hyp_typ + if is_empty_type env sigma hyp_typ then simplest_elim (mkVar id) else @@ -1066,7 +1067,7 @@ let onNegatedEquality with_evars tac = let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match EConstr.kind sigma (hnf_constr env sigma ccl) with - | Prod (_,t,u) when is_empty_type sigma u -> + | Prod (_,t,u) when is_empty_type env sigma u -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) diff --git a/tactics/hints.ml b/tactics/hints.ml index 85d75f1010..11a8816159 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -738,16 +738,7 @@ module Hintdbmap = String.Map type hint_db = Hint_db.t -(** Initially created hint databases, for typeclasses and rewrite *) -let typeclasses_db = "typeclass_instances" -let rewrite_db = "rewrite" - -let auto_init_db = - Hintdbmap.add typeclasses_db (Hint_db.empty TransparentState.full true) - (Hintdbmap.add rewrite_db (Hint_db.empty TransparentState.cst_full true) - Hintdbmap.empty) - -let searchtable = Summary.ref ~name:"searchtable" auto_init_db +let searchtable = Summary.ref ~name:"searchtable" Hintdbmap.empty let statustable = Summary.ref ~name:"statustable" KNmap.empty let searchtable_map name = @@ -1073,7 +1064,9 @@ let subst_autohint (subst, obj) = in let subst_hint (k,data as hint) = let k' = Option.Smart.map subst_key k in - let pat' = Option.Smart.map (subst_pattern subst) data.pat in + let env = Global.env () in + let sigma = Evd.from_env env in + let pat' = Option.Smart.map (subst_pattern env sigma subst) data.pat in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in let code' = match data.code.obj with | Res_pf (c,t,ctx) -> @@ -1362,7 +1355,7 @@ let interp_hints poly = let ind = global_inductive_with_alias qid in let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; - List.init (nconstructors ind) + List.init (nconstructors env ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in empty_hint_info, @@ -1398,7 +1391,7 @@ let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> match EConstr.kind sigma lem with | Ind (ind,u) -> - List.init (nconstructors ind) + List.init (nconstructors env ind) (fun i -> let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) (Evd.universe_context_set sigma) in @@ -1514,9 +1507,9 @@ let pr_hint_term env sigma cl = (str "No hint applicable for current goal") (* print all hints that apply to the concl of the current goal *) -let pr_applicable_hint () = +let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.give_me_the_proof () in + let pts = Proof_global.give_me_the_proof pf in let Proof.{goals;sigma} = Proof.data pts in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/hints.mli b/tactics/hints.mli index dd2c63d351..90a8b7fe52 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -277,11 +277,6 @@ val make_local_hint_db : env -> evar_map -> ?ts:TransparentState.t -> bool -> de val make_db_list : hint_db_name list -> hint_db list -(** Initially created hint databases, for typeclasses and rewrite *) - -val typeclasses_db : hint_db_name -val rewrite_db : hint_db_name - val wrap_hint_warning : 'a Proofview.tactic -> 'a Proofview.tactic (** Use around toplevel calls to hint-using tactics, to enable the tracking of non-imported hints. Any tactic calling [run_hint] must be wrapped this @@ -294,7 +289,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : unit -> Pp.t +val pr_applicable_hint : Proof_global.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 08131f6309..e1dad9ad20 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -34,44 +34,42 @@ module RelDecl = Context.Rel.Declaration -- Eduardo (6/8/97). *) -type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option +type 'a matching_function = Environ.env -> Evd.evar_map -> EConstr.constr -> 'a option -type testing_function = Evd.evar_map -> EConstr.constr -> bool +type testing_function = Environ.env -> Evd.evar_map -> EConstr.constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 let meta2 = mkmeta 2 -let op2bool = function Some _ -> true | None -> false - -let match_with_non_recursive_type sigma t = +let match_with_non_recursive_type env sigma t = match EConstr.kind sigma t with | App _ -> let (hdapp,args) = decompose_app sigma t in (match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if (Global.lookup_mind (fst ind)).mind_finite == CoFinite then + if (Environ.lookup_mind (fst ind) env).mind_finite == CoFinite then Some (hdapp,args) else None | _ -> None) | _ -> None -let is_non_recursive_type sigma t = op2bool (match_with_non_recursive_type sigma t) +let is_non_recursive_type env sigma t = Option.has_some (match_with_non_recursive_type env sigma t) (* Test dependencies *) (* NB: we consider also the let-in case in the following function, since they may appear in types of inductive constructors (see #2629) *) -let rec has_nodep_prod_after n sigma c = +let rec has_nodep_prod_after n env sigma c = match EConstr.kind sigma c with | Prod (_,_,b) | LetIn (_,_,_,b) -> ( n>0 || Vars.noccurn sigma 1 b) - && (has_nodep_prod_after (n-1) sigma b) + && (has_nodep_prod_after (n-1) env sigma b) | _ -> true -let has_nodep_prod sigma c = has_nodep_prod_after 0 sigma c +let has_nodep_prod env sigma c = has_nodep_prod_after 0 env sigma c (* A general conjunctive type is a non-recursive with-no-indices inductive type with only one constructor and no dependencies between argument; @@ -96,11 +94,11 @@ let rec whd_beta_prod sigma c = match EConstr.kind sigma c with | LetIn (n,d,t,c) -> mkLetIn (n,d,t,whd_beta_prod sigma c) | _ -> c -let match_with_one_constructor sigma style onlybinary allow_rec t = +let match_with_one_constructor env sigma style onlybinary allow_rec t = let (hdapp,args) = decompose_app sigma t in let res = match EConstr.kind sigma hdapp with | Ind ind -> - let (mib,mip) = Global.lookup_inductive (fst ind) in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) @@ -125,7 +123,7 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = let ctyp = whd_beta_prod sigma (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) cty args) in let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in - if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then + if not (is_lax_conjunction style) || has_nodep_prod env sigma ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) else @@ -138,20 +136,20 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = | Some (hdapp, [_; _]) -> res | _ -> None -let match_with_conjunction ?(strict=false) ?(onlybinary=false) sigma t = - match_with_one_constructor sigma (Some strict) onlybinary false t +let match_with_conjunction ?(strict=false) ?(onlybinary=false) env sigma t = + match_with_one_constructor env sigma (Some strict) onlybinary false t -let match_with_record sigma t = - match_with_one_constructor sigma None false false t +let match_with_record env sigma t = + match_with_one_constructor env sigma None false false t -let is_conjunction ?(strict=false) ?(onlybinary=false) sigma t = - op2bool (match_with_conjunction sigma ~strict ~onlybinary t) +let is_conjunction ?(strict=false) ?(onlybinary=false) env sigma t = + Option.has_some (match_with_conjunction env sigma ~strict ~onlybinary t) -let is_record sigma t = - op2bool (match_with_record sigma t) +let is_record env sigma t = + Option.has_some (match_with_record env sigma t) -let match_with_tuple sigma t = - let t = match_with_one_constructor sigma None false true t in +let match_with_tuple env sigma t = + let t = match_with_one_constructor env sigma None false true t in Option.map (fun (hd,l) -> let ind = destInd sigma hd in let ind = on_snd (fun u -> EInstance.kind sigma u) ind in @@ -159,8 +157,8 @@ let match_with_tuple sigma t = let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t -let is_tuple sigma t = - op2bool (match_with_tuple sigma t) +let is_tuple env sigma t = + Option.has_some (match_with_tuple env sigma t) (* A general disjunction type is a non-recursive with-no-indices inductive type with of which all constructors have a single argument; @@ -175,11 +173,11 @@ let test_strict_disjunction (mib, mip) = in Array.for_all_i check 0 mip.mind_nf_lc -let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = +let match_with_disjunction ?(strict=false) ?(onlybinary=false) env sigma t = let (hdapp,args) = decompose_app sigma t in let res = match EConstr.kind sigma hdapp with | Ind (ind,u) -> - let car = constructors_nrealargs ind in + let car = constructors_nrealargs env ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car && not (mis_is_recursive (ind,mib,mip)) @@ -205,31 +203,31 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = | Some (hdapp,[_; _]) -> res | _ -> None -let is_disjunction ?(strict=false) ?(onlybinary=false) sigma t = - op2bool (match_with_disjunction ~strict ~onlybinary sigma t) +let is_disjunction ?(strict=false) ?(onlybinary=false) env sigma t = + Option.has_some (match_with_disjunction ~strict ~onlybinary env sigma t) (* An empty type is an inductive type, possible with indices, that has no constructors *) -let match_with_empty_type sigma t = +let match_with_empty_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind, _) -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Inductive.lookup_mind_specif env ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None -let is_empty_type sigma t = op2bool (match_with_empty_type sigma t) +let is_empty_type env sigma t = Option.has_some (match_with_empty_type env sigma t) (* This filters inductive types with one constructor with no arguments; Parameters and indices are allowed *) -let match_with_unit_or_eq_type sigma t = +let match_with_unit_or_eq_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind , _) -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Inductive.lookup_mind_specif env ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 && Int.equal mip.mind_consnrealargs.(0) 0 then Some hdapp @@ -237,14 +235,14 @@ let match_with_unit_or_eq_type sigma t = None | _ -> None -let is_unit_or_eq_type sigma t = op2bool (match_with_unit_or_eq_type sigma t) +let is_unit_or_eq_type env sigma t = Option.has_some (match_with_unit_or_eq_type env sigma t) (* A unit type is an inductive type with no indices but possibly (useless) parameters, and that has no arguments in its unique constructor *) -let is_unit_type sigma t = - match match_with_conjunction sigma t with +let is_unit_type env sigma t = + match match_with_conjunction env sigma t with | Some (_,[]) -> true | _ -> false @@ -331,15 +329,16 @@ let match_with_equation env sigma t = let is_inductive_equality ind = let (mib,mip) = Global.lookup_inductive ind in let nconstr = Array.length mip.mind_consnames in - Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 + let env = Global.env () in + Int.equal nconstr 1 && Int.equal (constructor_nrealargs env (ind,1)) 0 -let match_with_equality_type sigma t = +let match_with_equality_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None -let is_equality_type sigma t = op2bool (match_with_equality_type sigma t) +let is_equality_type env sigma t = Option.has_some (match_with_equality_type env sigma t) (* Arrows/Implication/Negation *) @@ -353,39 +352,39 @@ let match_arrow_pattern env sigma t = assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) | _ -> anomaly (Pp.str "Incorrect pattern matching.") -let match_with_imp_term sigma c = +let match_with_imp_term env sigma c = match EConstr.kind sigma c with | Prod (_,a,b) when Vars.noccurn sigma 1 b -> Some (a,b) | _ -> None -let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) +let is_imp_term env sigma c = Option.has_some (match_with_imp_term env sigma c) let match_with_nottype env sigma t = try let (arg,mind) = match_arrow_pattern env sigma t in - if is_empty_type sigma mind then Some (mind,arg) else None + if is_empty_type env sigma mind then Some (mind,arg) else None with PatternMatchingFailure -> None -let is_nottype env sigma t = op2bool (match_with_nottype env sigma t) +let is_nottype env sigma t = Option.has_some (match_with_nottype env sigma t) (* Forall *) -let match_with_forall_term sigma c= +let match_with_forall_term env sigma c = match EConstr.kind sigma c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None -let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) +let is_forall_term env sigma c = Option.has_some (match_with_forall_term env sigma c) -let match_with_nodep_ind sigma t = +let match_with_nodep_ind env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind, _) -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Inductive.lookup_mind_specif env ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr (ctx, cty) = let c = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in - has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma c in + has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) env sigma c in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else @@ -395,9 +394,9 @@ let match_with_nodep_ind sigma t = None | _ -> None -let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) +let is_nodep_ind env sigma t = Option.has_some (match_with_nodep_ind env sigma t) -let match_with_sigma_type sigma t = +let match_with_sigma_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind, _) -> @@ -405,7 +404,7 @@ let match_with_sigma_type sigma t = if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) - && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) sigma + && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) env sigma (let (ctx, cty) = mip.mind_nf_lc.(0) in EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx)) then (*allowing only 1 existential*) @@ -414,7 +413,7 @@ let match_with_sigma_type sigma t = None | _ -> None -let is_sigma_type sigma t = op2bool (match_with_sigma_type sigma t) +let is_sigma_type env sigma t = Option.has_some (match_with_sigma_type env sigma t) (***** Destructing patterns bound to some theory *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 741f6713e3..b8c3ddb0f0 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -43,8 +43,8 @@ open Coqlib also work on ad-hoc disjunctions introduced by the user. (Eduardo, 6/8/97). *) -type 'a matching_function = evar_map -> constr -> 'a option -type testing_function = evar_map -> constr -> bool +type 'a matching_function = Environ.env -> evar_map -> constr -> 'a option +type testing_function = Environ.env -> evar_map -> constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function @@ -83,8 +83,8 @@ val is_inductive_equality : inductive -> bool val match_with_equality_type : (constr * constr list) matching_function val is_equality_type : testing_function -val match_with_nottype : Environ.env -> (constr * constr) matching_function -val is_nottype : Environ.env -> testing_function +val match_with_nottype : (constr * constr) matching_function +val is_nottype : testing_function val match_with_forall_term : (Name.t Context.binder_annot * constr * constr) matching_function val is_forall_term : testing_function diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index aabfae444e..447b908a1d 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -259,10 +259,12 @@ let subst_mps subst c = EConstr.of_constr (Mod_subst.subst_mps subst (EConstr.Unsafe.to_constr c)) let subst_red_expr subs = + let env = Global.env () in + let sigma = Evd.from_env env in Redops.map_red_expr_gen (subst_mps subs) (Mod_subst.subst_evaluable_reference subs) - (Patternops.subst_pattern subs) + (Patternops.subst_pattern env sigma subs) let inReduction : bool * string * red_expr -> obj = declare_object diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index ec8d4d0e14..dcd63fe760 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -704,7 +704,8 @@ module New = struct (* computing the case/elim combinators *) let gl_make_elim ind = begin fun gl -> - let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + let env = Proofview.Goal.env gl in + let gr = Indrec.lookup_eliminator env (fst ind) (elimination_sort_of_goal gl) in let (sigma, c) = pf_apply Evd.fresh_global gl gr in (sigma, c) end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b8308dc49b..066b9c7794 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1161,6 +1161,7 @@ let tactic_infer_flags with_evar = { Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } type evars_flag = bool (* true = pose evars false = fail on evars *) @@ -1431,7 +1432,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); - elimrename = Some (false, constructors_nrealdecls (fst mind))}) + elimrename = Some (false, constructors_nrealdecls env (fst mind))}) end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1454,7 +1455,8 @@ exception IsNonrec let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Declarations.BiFinite let find_ind_eliminator ind s gl = - let gr = lookup_eliminator ind s in + let env = Proofview.Goal.env gl in + let gr = lookup_eliminator env ind s in Tacmach.New.pf_apply Evd.fresh_global gl gr let find_eliminator c gl = @@ -1462,7 +1464,7 @@ let find_eliminator c gl = if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); - elimrename = Some (true, constructors_nrealdecls ind)} + elimrename = Some (true, constructors_nrealdecls (Global.env()) ind)} let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE @@ -1608,9 +1610,9 @@ let descend_in_conjunctions avoid tac (err, info) c = let t = Retyping.get_type_of env sigma c in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = EConstr.decompose_prod_assum sigma t in - match match_with_tuple sigma ccl with + match match_with_tuple env sigma ccl with | Some (_,_,isrec) -> - let n = (constructors_nrealargs ind).(0) in + let n = (constructors_nrealargs env ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in let IndType (indf,_) = find_rectype env sigma ccl in let (_,inst), params = dest_ind_family indf in @@ -2298,7 +2300,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (type_of (mkVar id)) in - let eqtac, thin = match match_with_equality_type sigma t with + let eqtac, thin = match match_with_equality_type env sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then let id' = destVar sigma lhs in @@ -4127,7 +4129,7 @@ let guess_elim isrec dep s hyp0 gl = let sigma, elimc = if isrec && not (is_nonrec mind) then - let gr = lookup_eliminator mind s in + let gr = lookup_eliminator env mind s in Evd.fresh_global env sigma gr else let u = EInstance.kind sigma u in @@ -4738,9 +4740,10 @@ let reflexivity_red allowred = (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match match_with_equality_type sigma concl with + match match_with_equality_type env sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings end diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b85258505b..e0324b0232 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index 35f8701b2f..135537f8ab 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -96,7 +96,7 @@ Admitted. Polymorphic Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x. Polymorphic Definition InitialObject obj {C : SpecializedCategory obj} (o : C) := - forall o', { m : C.(Morphism) o o' | is_unique m }. + forall o', { m : Morphism C o o' | is_unique m }. Polymorphic Definition SmallCat := ComputableCategory _ SUnderlyingCategory. @@ -136,7 +136,7 @@ Section GraphObj. Definition UnderlyingGraph_ObjectOf x := match x with - | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) } + | GraphIndexSource => { sd : objC * objC & Morphism C (fst sd) (snd sd) } | GraphIndexTarget => objC end. diff --git a/test-suite/bugs/closed/bug_4157.v b/test-suite/bugs/closed/bug_4157.v new file mode 100644 index 0000000000..a9e96fcdde --- /dev/null +++ b/test-suite/bugs/closed/bug_4157.v @@ -0,0 +1,272 @@ +(** The following proof is due to a bug in `vm_compute` and was found by + Maxime Dénès and Pierre-Marie Pédrot. *) +Inductive t := +| C_0 : nat -> t +| C_1 : nat -> t +| C_2 : nat -> t +| C_3 : nat -> t +| C_4 : nat -> t +| C_5 : nat -> t +| C_6 : nat -> t +| C_7 : nat -> t +| C_8 : nat -> t +| C_9 : nat -> t +| C_10 : nat -> t +| C_11 : nat -> t +| C_12 : nat -> t +| C_13 : nat -> t +| C_14 : nat -> t +| C_15 : nat -> t +| C_16 : nat -> t +| C_17 : nat -> t +| C_18 : nat -> t +| C_19 : nat -> t +| C_20 : nat -> t +| C_21 : nat -> t +| C_22 : nat -> t +| C_23 : nat -> t +| C_24 : nat -> t +| C_25 : nat -> t +| C_26 : nat -> t +| C_27 : nat -> t +| C_28 : nat -> t +| C_29 : nat -> t +| C_30 : nat -> t +| C_31 : nat -> t +| C_32 : nat -> t +| C_33 : nat -> t +| C_34 : nat -> t +| C_35 : nat -> t +| C_36 : nat -> t +| C_37 : nat -> t +| C_38 : nat -> t +| C_39 : nat -> t +| C_40 : nat -> t +| C_41 : nat -> t +| C_42 : nat -> t +| C_43 : nat -> t +| C_44 : nat -> t +| C_45 : nat -> t +| C_46 : nat -> t +| C_47 : nat -> t +| C_48 : nat -> t +| C_49 : nat -> t +| C_50 : nat -> t +| C_51 : nat -> t +| C_52 : nat -> t +| C_53 : nat -> t +| C_54 : nat -> t +| C_55 : nat -> t +| C_56 : nat -> t +| C_57 : nat -> t +| C_58 : nat -> t +| C_59 : nat -> t +| C_60 : nat -> t +| C_61 : nat -> t +| C_62 : nat -> t +| C_63 : nat -> t +| C_64 : nat -> t +| C_65 : nat -> t +| C_66 : nat -> t +| C_67 : nat -> t +| C_68 : nat -> t +| C_69 : nat -> t +| C_70 : nat -> t +| C_71 : nat -> t +| C_72 : nat -> t +| C_73 : nat -> t +| C_74 : nat -> t +| C_75 : nat -> t +| C_76 : nat -> t +| C_77 : nat -> t +| C_78 : nat -> t +| C_79 : nat -> t +| C_80 : nat -> t +| C_81 : nat -> t +| C_82 : nat -> t +| C_83 : nat -> t +| C_84 : nat -> t +| C_85 : nat -> t +| C_86 : nat -> t +| C_87 : nat -> t +| C_88 : nat -> t +| C_89 : nat -> t +| C_90 : nat -> t +| C_91 : nat -> t +| C_92 : nat -> t +| C_93 : nat -> t +| C_94 : nat -> t +| C_95 : nat -> t +| C_96 : nat -> t +| C_97 : nat -> t +| C_98 : nat -> t +| C_99 : nat -> t +| C_100 : nat -> t +| C_101 : nat -> t +| C_102 : nat -> t +| C_103 : nat -> t +| C_104 : nat -> t +| C_105 : nat -> t +| C_106 : nat -> t +| C_107 : nat -> t +| C_108 : nat -> t +| C_109 : nat -> t +| C_110 : nat -> t +| C_111 : nat -> t +| C_112 : nat -> t +| C_113 : nat -> t +| C_114 : nat -> t +| C_115 : nat -> t +| C_116 : nat -> t +| C_117 : nat -> t +| C_118 : nat -> t +| C_119 : nat -> t +| C_120 : nat -> t +| C_121 : nat -> t +| C_122 : nat -> t +| C_123 : nat -> t +| C_124 : nat -> t +| C_125 : nat -> t +| C_126 : nat -> t +| C_127 : nat -> t +| C_128 : nat -> t +| C_129 : nat -> t +| C_130 : nat -> t +| C_131 : nat -> t +| C_132 : nat -> t +| C_133 : nat -> t +| C_134 : nat -> t +| C_135 : nat -> t +| C_136 : nat -> t +| C_137 : nat -> t +| C_138 : nat -> t +| C_139 : nat -> t +| C_140 : nat -> t +| C_141 : nat -> t +| C_142 : nat -> t +| C_143 : nat -> t +| C_144 : nat -> t +| C_145 : nat -> t +| C_146 : nat -> t +| C_147 : nat -> t +| C_148 : nat -> t +| C_149 : nat -> t +| C_150 : nat -> t +| C_151 : nat -> t +| C_152 : nat -> t +| C_153 : nat -> t +| C_154 : nat -> t +| C_155 : nat -> t +| C_156 : nat -> t +| C_157 : nat -> t +| C_158 : nat -> t +| C_159 : nat -> t +| C_160 : nat -> t +| C_161 : nat -> t +| C_162 : nat -> t +| C_163 : nat -> t +| C_164 : nat -> t +| C_165 : nat -> t +| C_166 : nat -> t +| C_167 : nat -> t +| C_168 : nat -> t +| C_169 : nat -> t +| C_170 : nat -> t +| C_171 : nat -> t +| C_172 : nat -> t +| C_173 : nat -> t +| C_174 : nat -> t +| C_175 : nat -> t +| C_176 : nat -> t +| C_177 : nat -> t +| C_178 : nat -> t +| C_179 : nat -> t +| C_180 : nat -> t +| C_181 : nat -> t +| C_182 : nat -> t +| C_183 : nat -> t +| C_184 : nat -> t +| C_185 : nat -> t +| C_186 : nat -> t +| C_187 : nat -> t +| C_188 : nat -> t +| C_189 : nat -> t +| C_190 : nat -> t +| C_191 : nat -> t +| C_192 : nat -> t +| C_193 : nat -> t +| C_194 : nat -> t +| C_195 : nat -> t +| C_196 : nat -> t +| C_197 : nat -> t +| C_198 : nat -> t +| C_199 : nat -> t +| C_200 : nat -> t +| C_201 : nat -> t +| C_202 : nat -> t +| C_203 : nat -> t +| C_204 : nat -> t +| C_205 : nat -> t +| C_206 : nat -> t +| C_207 : nat -> t +| C_208 : nat -> t +| C_209 : nat -> t +| C_210 : nat -> t +| C_211 : nat -> t +| C_212 : nat -> t +| C_213 : nat -> t +| C_214 : nat -> t +| C_215 : nat -> t +| C_216 : nat -> t +| C_217 : nat -> t +| C_218 : nat -> t +| C_219 : nat -> t +| C_220 : nat -> t +| C_221 : nat -> t +| C_222 : nat -> t +| C_223 : nat -> t +| C_224 : nat -> t +| C_225 : nat -> t +| C_226 : nat -> t +| C_227 : nat -> t +| C_228 : nat -> t +| C_229 : nat -> t +| C_230 : nat -> t +| C_231 : nat -> t +| C_232 : nat -> t +| C_233 : nat -> t +| C_234 : nat -> t +| C_235 : nat -> t +| C_236 : nat -> t +| C_237 : nat -> t +| C_238 : nat -> t +| C_239 : nat -> t +| C_240 : nat -> t +| C_241 : nat -> t +| C_242 : nat -> t +| C_243 : nat -> t +| C_244 : nat -> t +| C_245 : nat -> t +| C_246 : nat -> t +| C_247 : nat -> t +| C_248 : nat -> t +| C_249 : nat -> t +| C_250 : nat -> t +| C_251 : nat -> t +| C_252 : nat -> t +| C_253 : nat -> t +| C_254 : nat -> t +| C_255 : nat -> t +| C_256 : nat -> t. + +Definition is_256 (x : t) : bool := + match x with + | C_256 _ => true + | _ => false + end. + +Lemma falso : False. + assert (is_256 (C_256 0) = true) by reflexivity. + (* The next line was successful in 8.2pl3 *) + Fail assert (is_256 (C_256 0) = false) by (vm_compute; reflexivity). +Abort. diff --git a/test-suite/bugs/closed/bug_4527.v b/test-suite/bugs/closed/bug_4527.v index 4f8a8dd272..dfb07520f1 100644 --- a/test-suite/bugs/closed/bug_4527.v +++ b/test-suite/bugs/closed/bug_4527.v @@ -10,6 +10,7 @@ Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. Require Coq.Init.Datatypes. +Require Import Coq.Init.Tactics. Import Coq.Init.Notations. diff --git a/test-suite/bugs/closed/bug_4798.v b/test-suite/bugs/closed/bug_4798.v index 696812dee1..f238086633 100644 --- a/test-suite/bugs/closed/bug_4798.v +++ b/test-suite/bugs/closed/bug_4798.v @@ -1,5 +1,5 @@ (* DO NOT MODIFY THIS FILE DIRECTLY *) (* It is autogenerated by dev/tools/update-compat.py. *) Check match 2 with 0 => 0 | S n => n end. -Notation "|" := 1 (compat "8.7"). +Notation "|" := 1 (compat "8.8"). Check match 2 with 0 => 0 | S n => n end. (* fails *) diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v index a89837dd12..21cd770cbb 100644 --- a/test-suite/bugs/closed/bug_9166.v +++ b/test-suite/bugs/closed/bug_9166.v @@ -2,7 +2,7 @@ (* It is autogenerated by dev/tools/update-compat.py. *) Set Warnings "+deprecated". -Notation bar := option (compat "8.7"). +Notation bar := option (compat "8.8"). Definition foo (x: nat) : nat := match x with diff --git a/test-suite/bugs/closed/bug_9652.v b/test-suite/bugs/closed/bug_9652.v new file mode 100644 index 0000000000..21ce1bea61 --- /dev/null +++ b/test-suite/bugs/closed/bug_9652.v @@ -0,0 +1,19 @@ +Set Universe Polymorphism. +Require Import Coq.ZArith.BinInt. +Class word_interface (width : Z) : Type := Build_word + { rep : Type; + unsigned : rep -> Z; + of_Z : Z -> rep; + sub : rep -> rep -> rep }. +Coercion rep : word_interface >-> Sortclass. +Axiom word : word_interface 64. Local Existing Instance word. +Goal + forall (x : list word) (x1 x2 : word), + (unsigned (sub x2 x1) / 2 ^ 4 * 2 ^ 3 < + unsigned (of_Z 8) * Z.of_nat (Datatypes.length x))%Z. +Proof. + intros. + assert (unsigned (sub x2 x1) = unsigned (sub x2 x1)) by exact eq_refl. + Fail progress rewrite H. + Fail rewrite H. +Abort. diff --git a/test-suite/bugs/closed/bug_9684.v b/test-suite/bugs/closed/bug_9684.v new file mode 100644 index 0000000000..436a00585b --- /dev/null +++ b/test-suite/bugs/closed/bug_9684.v @@ -0,0 +1,19 @@ +Set Primitive Projections. + +Record foo := mkFoo { proj1 : bool; proj2 : bool }. + +Definition x := mkFoo true false. +Definition proj x := proj2 x. + +Lemma oops : proj = fun x => proj1 x. +Proof. Fail native_compute; reflexivity. Abort. + +(* +Lemma bad : False. +assert (proj1 x = proj x). + rewrite oops; reflexivity. +discriminate. +Qed. + +Print Assumptions bad. +*) diff --git a/test-suite/coq-makefile/missing-install/run.sh b/test-suite/coq-makefile/missing-install/run.sh new file mode 100755 index 0000000000..4f36fdcb1c --- /dev/null +++ b/test-suite/coq-makefile/missing-install/run.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +. ../template/init.sh + +rm -rf _test; mkdir _test; cd _test + +cat > _CoqProject <<EOF +-R theories Test +theories/a.v +theories/b.v +EOF +mkdir theories +touch theories/a.v theories/b.v + +coq_makefile -f _CoqProject -o Makefile +make theories/b.vo +if make install; then exit 1; fi diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh new file mode 100755 index 0000000000..e1f17725dc --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" + +python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log2 || exit $? +python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log3 || exit $? + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? + +cat time-of-build.log.in | python2 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log2 || exit $? +cat time-of-build.log.in | python3 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log3 || exit $? + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? + +(python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log2 +(python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log3 + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected new file mode 100644 index 0000000000..05c1687002 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected @@ -0,0 +1,307 @@ +Time | File Name +----------------------------------------------------------------------- +39m02.51s | Total +----------------------------------------------------------------------- +3m26.96s | Kami/Ex/Multiplier64 +3m22.44s | bedrock2/compiler/src/FlatToRiscv +2m19.56s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI +2m11.59s | Kami/Ex/Divider64 +1m44.22s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR +1m44.11s | Kami/Ex/Multiplier32 +1m41.50s | bedrock2/bedrock2/src/Examples/bsearch +1m08.57s | Kami/Ex/ProcFDInl +1m07.92s | bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO +1m01.07s | Kami/Ex/FifoCorrect +1m00.73s | Kami/Ex/Divider32 +0m50.15s | bedrock2/deps/riscv-coq/src/Proofs/EncodeBound +0m40.64s | bedrock2/bedrock2/src/Examples/FE310CompilerDemo +0m40.29s | Kami/InlineFacts +0m39.12s | Kami/Renaming +0m37.44s | Kami/Ex/SimpleFifoCorrect +0m37.08s | Kami/SemFacts +0m36.08s | ─preprbedrock2/deps/coqutil/src/Map/TestGoals +0m32.76s | Kami/ModularFacts +0m28.68s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA +0m26.60s | Kami/Lib/Word +0m26.55s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB +0m26.45s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64 +0m25.80s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64 +0m25.47s | bedrock2/processor/src/KamiRiscv +0m23.66s | bedrock2/compiler/src/EmitsValid +0m22.68s | Kami/Ex/InDepthTutorial +0m22.60s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM +0m21.68s | Kami/Specialize +0m21.59s | bedrock2/bedrock2/src/Examples/lightbulb +0m19.20s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66 +0m19.19s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ +0m17.33s | Kami/Ex/ProcDecInl +0m15.63s | bedrock2/compiler/src/examples/MMIO +0m14.78s | Kami/ParametricSyntax +0m12.11s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S +0m11.74s | bedrock2/deps/riscv-coq/src/Platform/MetricMinimal +0m09.95s | bedrock2/deps/coqutil/src/Word/Properties +0m09.77s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64 +0m09.56s | Kami/Lib/FMap +0m09.35s | bedrock2/bedrock2/src/Examples/ipow +0m09.26s | Kami/StepDet +0m09.19s | bedrock2/bedrock2/src/WeakestPreconditionProperties +0m09.16s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence +0m08.98s | Kami/RefinementFacts +0m08.68s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic +0m08.26s | bedrock2/compiler/src/FlatToRiscv32 +0m07.55s | Kami/Ex/Fifo +0m07.54s | ─ensbedrock2/deps/coqutil/src/Map/SlowGoals +0m06.99s | bedrock2/deps/riscv-coq/src/Platform/Minimal +0m06.89s | bedrock2/compiler/src/GoFlatToRiscv +0m06.82s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I +0m06.72s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI +0m06.50s | Kami/Semantics +0m06.36s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57 +0m06.32s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R +0m06.24s | Kami/PartialInlineFacts +0m06.02s | bedrock2/deps/coqutil/src/Map/Properties +0m05.62s | Kami/Ex/ProcThreeStage +0m05.56s | Kami/Decomposition +0m05.12s | Kami/Amortization +0m05.07s | Kami/Ex/SCMMInl +0m04.71s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system +0m04.46s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U +0m04.19s | Kami/ParametricInline +0m04.13s | Kami/Ex/ProcDec +0m03.88s | bedrock2/bedrock2/src/Examples/swap +0m03.81s | Kami/Ex/SC +0m03.64s | bedrock2/bedrock2/src/FE310CSemantics +0m03.39s | Kami/Tutorial +0m03.30s | bedrock2/compiler/src/examples/Fibonacci +0m03.17s | Kami/Label +0m03.17s | Kami/ModuleBoundEx +0m03.10s | Kami/ParametricEquiv +0m03.06s | Kami/Wf +0m02.50s | bedrock2/compiler/src/Pipeline +0m02.42s | Kami/Ex/ProcFDInv +0m02.42s | Kami/ParamDup +0m02.39s | Kami/Duplicate +0m02.19s | Kami/ParametricWf +0m02.11s | Kami/Ex/ProcFetchDecode +0m02.06s | bedrock2/bedrock2/src/Examples/ARPResponder +0m01.94s | Kami/MapReifyEx +0m01.89s | Kami/Syntax +0m01.88s | Kami/Ex/IsaRv32/PgmGcd +0m01.87s | Kami/Ex/IsaRv32/PgmBankerWorker1 +0m01.87s | Kami/Ex/IsaRv32/PgmMatMulReport +0m01.85s | Kami/Ex/IsaRv32/PgmBankerWorker3 +0m01.83s | Kami/Ex/IsaRv32/PgmDekker2 +0m01.83s | Kami/Ex/IsaRv32/PgmFact +0m01.83s | Kami/Ex/IsaRv32/PgmMatMulNormal1 +0m01.81s | Kami/Ex/IsaRv32/PgmBankerInit +0m01.81s | Kami/Ex/IsaRv32/PgmMatMulInit +0m01.81s | Kami/Ex/IsaRv32/PgmMatMulNormal2 +0m01.81s | Kami/Ex/RegFile +0m01.80s | Kami/Ex/IsaRv32/PgmBankerWorker2 +0m01.80s | Kami/Ex/IsaRv32/PgmPeterson1 +0m01.80s | Kami/Ex/IsaRv32/PgmPeterson2 +0m01.80s | bedrock2/bedrock2/src/ptsto_bytes +0m01.78s | Kami/Ex/IsaRv32/PgmDekker1 +0m01.78s | Kami/Ex/ProcDecInv +0m01.76s | bedrock2/bedrock2/src/Map/SeparationLogic +0m01.75s | Kami/Ex/IsaRv32/PgmBsort +0m01.74s | Kami/Ex/IsaRv32/PgmHanoi +0m01.70s | Kami/Ex/NativeFifo +0m01.52s | Kami/Lib/NatLib +0m01.51s | bedrock2/processor/src/Test +0m01.48s | Kami/SymEval +0m01.47s | Kami/Ex/MemAtomic +0m01.44s | Kami/Ex/ProcThreeStInv +0m01.35s | bedrock2/bedrock2/src/Array +0m01.34s | bedrock2/bedrock2/src/TailRecursion +0m01.30s | Kami/Ex/IsaRv32 +0m01.29s | Kami/ModuleBound +0m01.29s | bedrock2/bedrock2/src/Byte +0m01.25s | bedrock2/bedrock2/src/Examples/chacha20 +0m01.19s | Kami/Ex/ProcThreeStDec +0m01.18s | bedrock2/bedrock2/src/Scalars +0m01.17s | bedrock2/deps/riscv-coq/src/Utility/ListLib +0m01.15s | Kami/Ex/OneEltFifo +0m01.14s | bedrock2/bedrock2/src/Examples/Trace +0m01.13s | bedrock2/bedrock2/src/TODO_absint +0m01.10s | bedrock2/compiler/lib/LibTactics +0m01.08s | Kami/Lib/StringAsList +0m01.00s | bedrock2/deps/coqutil/src/Z/ZLib +0m00.99s | Kami/Lib/Struct +0m00.98s | bedrock2/compiler/src/examples/toposort +0m00.95s | bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise +0m00.94s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver +0m00.94s | bedrock2/deps/riscv-coq/src/Spec/ExecuteI +0m00.93s | Kami/Ex/ProcDecSC +0m00.92s | Kami/Ex/IsaRv32PgmExt +0m00.90s | Kami/Lib/Indexer +0m00.89s | Kami/Tactics +0m00.88s | bedrock2/compiler/src/util/ListLib +0m00.87s | Kami/Notations +0m00.84s | bedrock2/bedrock2/src/Memory +0m00.83s | Kami/Ex/ProcFDCorrect +0m00.83s | bedrock2/deps/riscv-coq/src/Utility/ZBitOps +0m00.82s | Kami/Ex/IsaRv32Pgm +0m00.82s | Kami/Lib/ilist +0m00.81s | Kami/Ex/ProcDecSCN +0m00.81s | bedrock2/deps/coqutil/src/Z/BitOps +0m00.80s | Kami/Ex/ProcFourStDec +0m00.80s | bedrock2/compiler/src/examples/EditDistExample +0m00.79s | Kami/Ext/BSyntax +0m00.79s | Kami/Ext/Extraction +0m00.77s | Kami/ParametricInlineLtac +0m00.76s | bedrock2/deps/riscv-coq/src/Platform/Example64Literal +0m00.76s | bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives +0m00.75s | Kami/Ex/ProcThreeStInl +0m00.74s | Kami/Kami +0m00.74s | bedrock2/compiler/src/examples/CompileExamples +0m00.74s | bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump +0m00.74s | bedrock2/deps/riscv-coq/src/Platform/MinimalLogging +0m00.72s | Kami/Substitute +0m00.72s | bedrock2/compiler/src/examples/TestExprImp +0m00.72s | bedrock2/deps/riscv-coq/src/Spec/Primitives +0m00.71s | Kami/Ex/MemTypes +0m00.71s | bedrock2/compiler/src/examples/InlineAssemblyMacro +0m00.71s | bedrock2/compiler/src/examples/TestFlatImp +0m00.71s | bedrock2/deps/riscv-coq/src/Platform/Memory +0m00.71s | bedrock2/deps/riscv-coq/src/Spec/Decode +0m00.70s | Kami/Inline +0m00.70s | Kami/Lib/StringAsOT +0m00.69s | bedrock2/compiler/src/FlatToRiscvDef +0m00.68s | bedrock2/compiler/src/Rem4 +0m00.67s | Kami/SymEvalTac +0m00.67s | bedrock2/compiler/src/SimplWordExpr +0m00.67s | bedrock2/deps/riscv-coq/src/Utility/Encode +0m00.66s | bedrock2/bedrock2/src/Semantics +0m00.63s | Kami/Lib/StringStringAsOT +0m00.63s | bedrock2/deps/coqutil/src/Datatypes/PropSet +0m00.61s | bedrock2/compiler/src/UnmappedMemForExtSpec +0m00.61s | bedrock2/deps/riscv-coq/src/Utility/Monads +0m00.60s | bedrock2/deps/coqutil/src/Map/SortedList +0m00.59s | Kami/Synthesize +0m00.59s | bedrock2/compiler/src/util/Common +0m00.59s | bedrock2/deps/coqutil/src/Map/SortedListWord +0m00.58s | bedrock2/deps/coqutil/src/Word/Naive +0m00.58s | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run +0m00.57s | bedrock2/bedrock2/src/BasicC64Semantics +0m00.57s | bedrock2/deps/riscv-coq/src/Utility/Utility +0m00.56s | Kami/Lib/WordSupport +0m00.56s | bedrock2/bedrock2/src/WeakestPrecondition +0m00.55s | Kami/Lib/StringEq +0m00.55s | bedrock2/bedrock2/src/BasicC32Semantics +0m00.55s | bedrock2/compiler/src/examples/highlevel/FuncMut +0m00.55s | bedrock2/deps/riscv-coq/src/Spec/ExecuteI64 +0m00.55s | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32 +0m00.54s | bedrock2/bedrock2/src/Examples/MultipleReturnValues +0m00.53s | bedrock2/compiler/src/RegAlloc2 +0m00.53s | bedrock2/deps/riscv-coq/src/Spec/ExecuteM +0m00.52s | bedrock2/bedrock2/src/ProgramLogic +0m00.52s | bedrock2/deps/riscv-coq/src/Platform/Run +0m00.52s | bedrock2/deps/riscv-coq/src/Spec/ExecuteM64 +0m00.52s | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64 +0m00.52s | bedrock2/deps/riscv-coq/src/Utility/Words32Naive +0m00.50s | bedrock2/bedrock2/src/BasicCSyntax +0m00.50s | bedrock2/compiler/src/Basic32Semantics +0m00.50s | bedrock2/compiler/src/RegAlloc3 +0m00.49s | bedrock2/bedrock2/src/BytedumpTest +0m00.49s | bedrock2/bedrock2/src/BytedumpTestα +0m00.49s | bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap +0m00.49s | bedrock2/deps/riscv-coq/src/Spec/Machine +0m00.49s | bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth +0m00.49s | bedrock2/deps/riscv-coq/src/Utility/Words64Naive +0m00.48s | bedrock2/bedrock2/src/ToCString +0m00.48s | bedrock2/compiler/src/SeparationLogic +0m00.48s | bedrock2/deps/coqutil/src/Decidable +0m00.48s | bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine +0m00.48s | bedrock2/deps/riscv-coq/src/Platform/RiscvMachine +0m00.47s | bedrock2/bedrock2/src/BasicC64Syntax +0m00.47s | bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions +0m00.46s | bedrock2/compiler/src/ZNameGen +0m00.46s | bedrock2/deps/riscv-coq/src/Platform/MetricLogging +0m00.45s | bedrock2/compiler/src/RegAllocAnnotatedNotations +0m00.45s | bedrock2/processor/src/KamiWord +0m00.44s | bedrock2/deps/coqutil/src/Map/SortedListString_test +0m00.44s | bedrock2/deps/coqutil/src/Tactics/Tactics +0m00.44s | bedrock2/deps/riscv-coq/src/Spec/Execute +0m00.44s | bedrock2/deps/riscv-coq/src/Utility/InstructionNotations +0m00.43s | bedrock2/bedrock2/src/Map/Separation +0m00.43s | bedrock2/compiler/src/RiscvWordProperties +0m00.43s | bedrock2/deps/riscv-coq/src/Spec/VirtualMemory +0m00.43s | bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions +0m00.42s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode +0m00.40s | bedrock2/compiler/src/util/Tactics +0m00.40s | bedrock2/deps/coqutil/src/Map/Interface +0m00.39s | bedrock2/deps/coqutil/src/Z/HexNotation +0m00.38s | Kami/Lib/CommonTactics +0m00.38s | Kami/Lib/Nomega +0m00.38s | bedrock2/bedrock2/src/ZNamesSyntax +0m00.37s | bedrock2/deps/coqutil/src/Map/Funext +0m00.37s | bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem +0m00.36s | Kami/Ex/Names +0m00.36s | Kami/Lib/Concat +0m00.36s | bedrock2/bedrock2/src/string2ident +0m00.36s | bedrock2/compiler/src/Simp +0m00.36s | bedrock2/deps/coqutil/src/Map/Solver +0m00.36s | bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem +0m00.35s | Kami/Lib/Misc +0m00.35s | bedrock2/bedrock2/src/Examples/StructAccess +0m00.35s | bedrock2/bedrock2/src/StructNotations +0m00.35s | bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map +0m00.35s | bedrock2/deps/coqutil/src/Map/SortedListString +0m00.34s | Kami/Lib/Reflection +0m00.34s | bedrock2/bedrock2/src/Bytedump +0m00.34s | bedrock2/deps/riscv-coq/src/Utility/Tactics +0m00.33s | bedrock2/bedrock2/src/NotationsCustomEntry +0m00.33s | bedrock2/compiler/src/util/MyOmega +0m00.32s | bedrock2/bedrock2/src/Hexdump +0m00.32s | bedrock2/compiler/src/NameGen +0m00.31s | bedrock2/compiler/lib/LibTacticsMin +0m00.30s | bedrock2/bedrock2/src/StringNamesSyntax +0m00.30s | bedrock2/compiler/src/util/Set +0m00.30s | bedrock2/compiler/src/util/SetSolverTests +0m00.29s | bedrock2/deps/coqutil/src/Datatypes/String +0m00.27s | bedrock2/deps/coqutil/src/Word/LittleEndian +0m00.27s | bedrock2/deps/riscv-coq/src/Utility/MonadTests +0m00.26s | bedrock2/deps/coqutil/src/Z/div_mod_to_equations +0m00.23s | bedrock2/deps/riscv-coq/src/Utility/MonadT +0m00.19s | bedrock2/bedrock2/src/NotationsInConstr +0m00.19s | bedrock2/deps/coqutil/src/Datatypes/HList +0m00.17s | Kami/Lib/VectorFacts +0m00.17s | bedrock2/deps/riscv-coq/src/Utility/JMonad +0m00.14s | Kami/Lib/DepEq +0m00.13s | Kami/Lib/FinNotations +0m00.13s | bedrock2/bedrock2/src/ListPred +0m00.13s | bedrock2/bedrock2/src/Variables +0m00.13s | bedrock2/deps/coqutil/src/Datatypes/List +0m00.12s | bedrock2/deps/riscv-coq/src/Utility/MonadNotations +0m00.09s | bedrock2/bedrock2/src/Lift1Prop +0m00.09s | bedrock2/deps/coqutil/src/Datatypes/Option +0m00.09s | bedrock2/deps/coqutil/src/Datatypes/Prod +0m00.07s | Kami/Lib/BasicLogic +0m00.07s | bedrock2/bedrock2/src/Syntax +0m00.06s | Kami/Lib/DepEqNat +0m00.06s | bedrock2/deps/coqutil/src/Macros/symmetry +0m00.05s | bedrock2/compiler/lib/fiat_crypto_tactics/Not +0m00.05s | bedrock2/compiler/src/util/Misc +0m00.05s | bedrock2/deps/riscv-coq/src/Utility/PowerFunc +0m00.05s | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet +0m00.04s | bedrock2/bedrock2/src/Markers +0m00.04s | bedrock2/bedrock2/src/Notations +0m00.04s | bedrock2/compiler/lib/fiat_crypto_tactics/Test +0m00.04s | bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose +0m00.04s | bedrock2/compiler/src/NoActionSyntaxParams +0m00.04s | bedrock2/compiler/src/eqexact +0m00.04s | bedrock2/compiler/src/examples/highlevel/For +0m00.04s | bedrock2/compiler/src/on_hyp_containing +0m00.04s | bedrock2/compiler/src/util/Learning +0m00.04s | bedrock2/deps/coqutil/src/Datatypes/PrimitivePair +0m00.04s | bedrock2/deps/coqutil/src/Macros/subst +0m00.04s | bedrock2/deps/coqutil/src/Macros/unique +0m00.04s | bedrock2/deps/coqutil/src/Tactics/eabstract +0m00.04s | bedrock2/deps/coqutil/src/Tactics/letexists +0m00.04s | bedrock2/deps/coqutil/src/Tactics/rdelta +0m00.04s | bedrock2/deps/coqutil/src/Tactics/syntactic_unify +0m00.04s | bedrock2/deps/coqutil/src/dlet +0m00.04s | bedrock2/deps/coqutil/src/sanity +0m00.04s | bedrock2/deps/riscv-coq/src/Utility/MMIOTrace +0m00.03s | bedrock2/compiler/src/util/LogGoal
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build.log.in new file mode 100644 index 0000000000..a306586175 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build.log.in @@ -0,0 +1,3856 @@ +bedrock2/deps/coqutil/src/Tactics/eabstract (real: 0.17, user: 0.04, sys: 0.03, mem: 55016 ko) +bedrock2/deps/coqutil/src/sanity (real: 0.18, user: 0.04, sys: 0.03, mem: 54804 ko) +bedrock2/deps/coqutil/src/Tactics/letexists (real: 0.17, user: 0.04, sys: 0.03, mem: 55296 ko) +bedrock2/deps/coqutil/src/Tactics/rdelta (real: 0.17, user: 0.04, sys: 0.04, mem: 54916 ko) +bedrock2/deps/coqutil/src/Macros/subst (real: 0.16, user: 0.04, sys: 0.03, mem: 54100 ko) +bedrock2/deps/coqutil/src/dlet (real: 0.17, user: 0.04, sys: 0.03, mem: 54440 ko) +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 9, characters 2-67: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 11, characters 2-63: +Warning: Notation "{ _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 14, characters 2-67: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/deps/coqutil/src/Macros/unique (real: 0.16, user: 0.04, sys: 0.03, mem: 54384 ko) +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 15, characters 2-73: +Warning: Notation "{ ' _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 17, characters 2-70: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +bedrock2/deps/coqutil/src/Datatypes/PrimitivePair (real: 0.17, user: 0.04, sys: 0.03, mem: 56232 ko) +bedrock2/deps/coqutil/src/Datatypes/List (real: 0.58, user: 0.13, sys: 0.09, mem: 142420 ko) +bedrock2/deps/coqutil/src/Datatypes/String (real: 0.85, user: 0.29, sys: 0.16, mem: 252176 ko) +bedrock2/deps/coqutil/src/Datatypes/Option (real: 0.37, user: 0.09, sys: 0.06, mem: 108600 ko) +make[1]: Entering directory 'bedrock2' +make -C bedrock2/deps/coqutil +make[2]: Entering directory 'bedrock2/deps/coqutil' +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = coqutil -arg "-async-proofs-tac-j 1" bedrock2/deps/coqutil/src/Tactics/Tactics.v bedrock2/deps/coqutil/src/Tactics/eabstract.v bedrock2/deps/coqutil/src/Tactics/letexists.v bedrock2/deps/coqutil/src/Tactics/rdelta.v bedrock2/deps/coqutil/src/Tactics/syntactic_unify.v bedrock2/deps/coqutil/src/dlet.v bedrock2/deps/coqutil/src/Map/Funext.v bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map.v bedrock2/deps/coqutil/src/Map/SortedListString.v bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap.v bedrock2/deps/coqutil/src/Map/SortedListWord.v bedrock2/deps/coqutil/src/Map/Properties.v bedrock2/deps/coqutil/src/Map/TestLemmas.v bedrock2/deps/coqutil/src/Map/Interface.v bedrock2/deps/coqutil/src/Map/TestGoals.v bedrock2/deps/coqutil/src/Map/SlowGoals.v bedrock2/deps/coqutil/src/Map/SortedListString_test.v bedrock2/deps/coqutil/src/Map/Solver.v bedrock2/deps/coqutil/src/Map/SortedList.v bedrock2/deps/coqutil/src/Z/div_mod_to_equations.v bedrock2/deps/coqutil/src/Z/ZLib.v bedrock2/deps/coqutil/src/Z/HexNotation.v bedrock2/deps/coqutil/src/Z/BitOps.v bedrock2/deps/coqutil/src/Datatypes/String.v bedrock2/deps/coqutil/src/Datatypes/List.v bedrock2/deps/coqutil/src/Datatypes/PropSet.v bedrock2/deps/coqutil/src/Datatypes/Option.v bedrock2/deps/coqutil/src/Datatypes/Prod.v bedrock2/deps/coqutil/src/Datatypes/HList.v bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v bedrock2/deps/coqutil/src/Word/Naive.v bedrock2/deps/coqutil/src/Word/Properties.v bedrock2/deps/coqutil/src/Word/Interface.v bedrock2/deps/coqutil/src/Word/LittleEndian.v bedrock2/deps/coqutil/src/sanity.v bedrock2/deps/coqutil/src/Decidable.v bedrock2/deps/coqutil/src/Macros/subst.v bedrock2/deps/coqutil/src/Macros/symmetry.v bedrock2/deps/coqutil/src/Macros/unique.v -o Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/deps/coqutil' +COQDEP VFILES +COQC bedrock2/deps/coqutil/src/Tactics/eabstract.v +COQC bedrock2/deps/coqutil/src/sanity.v +COQC bedrock2/deps/coqutil/src/Tactics/letexists.v +COQC bedrock2/deps/coqutil/src/Tactics/rdelta.v +COQC bedrock2/deps/coqutil/src/dlet.v +COQC bedrock2/deps/coqutil/src/Macros/subst.v +COQC bedrock2/deps/coqutil/src/Macros/unique.v +COQC bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v +COQC bedrock2/deps/coqutil/src/Datatypes/List.v +COQC bedrock2/deps/coqutil/src/Datatypes/String.v +COQC bedrock2/deps/coqutil/src/Word/Interface.v +COQC bedrock2/deps/coqutil/src/Datatypes/Option.v +COQC bedbedrock2/deps/coqutil/src/Word/Interface (real: 1.40, user: 0.31, sys: 0.22, mem: 293000 ko) +bedrock2/deps/coqutil/src/Z/div_mod_to_equations (real: 0.92, user: 0.26, sys: 0.17, mem: 238732 ko) +bedrock2/deps/coqutil/src/Z/HexNotation (real: 1.24, user: 0.39, sys: 0.18, mem: 303504 ko) +bedrock2/deps/coqutil/src/Z/ZLib (real: 2.83, user: 1.00, sys: 0.28, mem: 442912 ko) +bedrock2/deps/coqutil/src/Datatypes/Prod (real: 0.32, user: 0.09, sys: 0.06, mem: 93184 ko) +bedrock2/deps/coqutil/src/Z/BitOps (real: 2.25, user: 0.81, sys: 0.26, mem: 439216 ko) +bedrock2/deps/coqutil/src/Word/Naive (real: 1.75, user: 0.58, sys: 0.27, mem: 415316 ko) +bedrock2/deps/coqutil/src/Macros/symmetry (real: 0.23, user: 0.06, sys: 0.04, mem: 67708 ko) +bedrock2/deps/coqutil/src/Decidable (real: 1.50, user: 0.48, sys: 0.23, mem: 375156 ko) +bedrock2/deps/coqutil/src/Tactics/syntactic_unify (real: 0.18, user: 0.04, sys: 0.04, mem: 56184 ko) +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "{ _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "{ ' _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 90, characters 2-19: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 90, characters 2-19: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +bedrock2/deps/coqutil/src/Datatypes/HList (real: 0.63, user: 0.19, sys: 0.12, mem: 180476 ko) +bedrock2/deps/coqutil/src/Tactics/Tactics (real: 1.35, user: 0.44, sys: 0.19, mem: 321736 ko) +bedrock2/deps/coqutil/src/Word/LittleEndian (real: 0.89, user: 0.27, sys: 0.16, mem: 227732 ko) +bedrock2/deps/coqutil/src/Datatypes/PropSet (real: 1.93, user: 0.63, sys: 0.29, mem: 426168 ko) +bedrock2/deps/coqutil/src/Map/Interface (real: 1.32, user: 0.40, sys: 0.23, mem: 323944 ko) +bedrock2/deps/coqutil/src/Map/Funext (real: 1.24, user: 0.37, sys: 0.23, mem: 316400 ko) +bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map (real: 1.17, user: 0.35, sys: 0.21, mem: 295952 ko) +File "bedrock2/deps/coqutil/src/Map/SortedList.v", line 110, characters 2-28: +Warning: Use of “Require†inside a section is deprecated. +[require-in-section,deprecated] +bedrock2/deps/coqutil/src/Map/SortedList (real: 1.86, user: 0.60, sys: 0.29, mem: 426440 ko) +bedrock2/deps/coqutil/src/Word/Properties (real: 21.22, user: 9.95, sys: 0.38, mem: 568468 ko) +bedrock2/deps/coqutil/src/Map/SortedListString (real: 1.20, user: 0.35, sys: 0.22, mem: 289456 ko) +bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap (real: 1.56, user: 0.49, sys: 0.26, mem: 365272 ko) +bedrock2/deps/coqutil/src/Map/SortedListWord (real: 1.88, user: 0.59, sys: 0.30, mem: 440596 ko) +bedrock2/deps/coqutil/src/Map/Properties (real: 13.04, user: 6.02, sys: 0.32, mem: 486764 ko) +bedrock2/deps/coqutil/src/Map/SortedListString_test (real: 1.34, user: 0.44, sys: 0.21, mem: 305528 ko) +bedrock2/deps/coqutil/src/Map/Solver (real: 0.80, user: 0.36, sys: 0.21, mem: 312496 ko) +rock2/deps/coqutil/src/Z/div_mod_to_equations.v +COQC bedrock2/deps/coqutil/src/Z/ZLib.v +COQC bedrock2/deps/coqutil/src/Z/HexNotation.v +COQC bedrock2/deps/coqutil/src/Z/BitOps.v +COQC bedrock2/deps/coqutil/src/Datatypes/Prod.v +COQC bedrock2/deps/coqutil/src/Word/Naive.v +COQC bedrock2/deps/coqutil/src/Word/Properties.v +COQC bedrock2/deps/coqutil/src/Macros/symmetry.v +COQC bedrock2/deps/coqutil/src/Decidable.v +COQC bedrock2/deps/coqutil/src/Tactics/syntactic_unify.v +COQC bedrock2/deps/coqutil/src/Datatypes/HList.v +COQC bedrock2/deps/coqutil/src/Tactics/Tactics.v +COQC bedrock2/deps/coqutil/src/Word/LittleEndian.v +COQC bedrock2/deps/coqutil/src/Datatypes/PropSet.v +COQC bedrock2/deps/coqutil/src/Map/Interface.v +COQC bedrock2/deps/coqutil/src/Map/Funext.v +COQC bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map.v +COQC bedrock2/deps/coqutil/src/Map/SortedList.v +COQC bedrock2/deps/coqutil/src/Map/Properties.v +COQC bedrock2/deps/coqutil/src/Map/SortedListString.v +COQC bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap.v +COQC bedrock2/deps/coqutil/src/Map/SortedListWord.v +COQC bedrock2/deps/coqutil/src/Map/SortedListString_test.v +COQC bedrock2/deps/coqutil/src/Map/Solver.v +COQC bedrock2/deps/coqutil/src/Map/TestGoals.v +COQC bedrock2/deps/coqutil/src/Map/TestLemmas.v +Finished transaction in 0.297 secs (0.095u,0.05s) (successful) +Part 1a: Small goals (originally took <5s each) +Finished transaction in 0.35 secs (0.143u,0.032s) (successful) +Finished transaction in 0.438 secs (0.204u,0.008s) (successful) +End of TestLemmas.v +total time: 1.147s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.1% 99.9% 15 0.252s +─map_solver_core ----------------------- 1.0% 69.6% 15 0.209s +─map_solver_core_impl ------------------ 0.9% 68.2% 0 0.207s +─map_specialize ------------------------ 0.2% 54.9% 15 0.199s +─map_specialize_step ------------------- 24.9% 54.7% 42 0.146s +─preprocess_impl ----------------------- 1.8% 30.1% 15 0.043s +─abstract_unrecogs --------------------- 3.2% 19.8% 15 0.030s +─unrecogs_in_prop ---------------------- 15.2% 15.2% 0 0.017s +─specialize (constr_with_bindings) ----- 12.3% 12.3% 769 0.081s +─canonicalize_map_hyp ------------------ 2.3% 8.9% 316 0.011s +─unrecogs_in_option_value -------------- 3.6% 8.3% 0 0.013s +─maps_propositional -------------------- 0.3% 6.5% 15 0.009s +─ensure_no_body ------------------------ 2.1% 5.3% 602 0.006s +─assert_fails -------------------------- 1.9% 4.4% 756 0.006s +─rew_map_specs_in ---------------------- 1.3% 4.4% 316 0.010s +─canonicalize_all ---------------------- 0.6% 4.2% 15 0.006s +─maps_leaf_tac ------------------------- 0.3% 3.8% 32 0.003s +─one_rew_map_specs --------------------- 2.6% 3.5% 0 0.010s +─unrecogs_in_key ----------------------- 1.6% 2.9% 0 0.001s +─pose proof H as H' -------------------- 2.8% 2.8% 448 0.000s +─tac ----------------------------------- 1.8% 2.5% 756 0.000s +─revert_all_Props bedrock2/deps/coqutil/src/Map/TestLemmas (real: 3.68, user: 1.47, sys: 0.32, mem: 435336 ko) +---------------------- 2.1% 2.2% 15 0.003s +─autounfold (hintbases) (clause_dft_conc 2.2% 2.2% 62 0.001s +─unrecogs_in_map ----------------------- 1.4% 2.0% 0 0.002s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.1% 99.9% 15 0.252s + ├─map_solver_core --------------------- 1.0% 69.6% 15 0.209s + │└map_solver_core_impl ---------------- 0.9% 68.2% 0 0.207s + │ ├─map_specialize -------------------- 0.2% 54.9% 15 0.199s + │ │└map_specialize_step --------------- 24.9% 54.7% 42 0.146s + │ │ ├─specialize (constr_with_bindings) 10.7% 10.7% 448 0.081s + │ │ ├─canonicalize_map_hyp ------------ 1.2% 5.9% 154 0.011s + │ │ │└rew_map_specs_in ---------------- 0.8% 3.3% 154 0.010s + │ │ │└one_rew_map_specs --------------- 1.9% 2.5% 0 0.010s + │ │ ├─ensure_no_body ------------------ 2.1% 5.3% 602 0.006s + │ │ │└assert_fails -------------------- 1.6% 3.1% 602 0.006s + │ │ └─pose proof H as H' -------------- 2.8% 2.8% 448 0.000s + │ ├─maps_propositional ---------------- 0.3% 6.5% 15 0.009s + │ │└maps_leaf_tac --------------------- 0.3% 3.8% 32 0.003s + │ └─canonicalize_all ------------------ 0.6% 4.2% 15 0.006s + │ └canonicalize_map_hyp -------------- 1.1% 3.0% 162 0.001s + └─preprocess_impl --------------------- 1.8% 30.1% 15 0.043s + ├─abstract_unrecogs ----------------- 3.2% 19.8% 15 0.030s + │└unrecogs_in_prop ------------------ 15.2% 15.2% 0 0.017s + │└unrecogs_in_option_value ---------- 3.6% 8.3% 0 0.013s + │ ├─unrecogs_in_key ----------------- 1.1% 2.0% 0 0.001s + │ └─unrecogs_in_map ----------------- 1.4% 2.0% 0 0.002s + └─revert_all_Props ------------------ 2.1% 2.2% 15 0.003s + +COQC bedrock2/deps/coqutil/src/Map/SlowGoals.v +Finished transaction in 3.949 secs (1.835u,0.093s) (successful) +Finished transaction in 6.898 secs (3.179u,0.177s) (successful) +Finished transaction in 6.138 secs (2.811u,0.154s) (successful) +Finished transaction in 15.112 secs (7.09u,0.222s) (successful) +Finished transaction in 0.047 secs (0.024u,0.s) (successful) +End of SlowGoals.v +total time: 7.313s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver_core ----------------------- 0.0% 100.0% 1 7.312s +─map_solver_core_impl ------------------ 0.0% 100.0% 0 7.310s +─maps_propositional -------------------- 0.6% 61.3% 33 4.485s +─map_specialize ------------------------ 0.0% 38.0% 1 2.779s +─map_specialize_step ------------------- 15.8% 38.0% 37 1.817s +─maps_leaf_tac ------------------------- 0.7% 32.8% 228 0.018s +─propositional_cheap_step -------------- 25.2% 25.6% 427 0.013s +─congruence ---------------------------- 16.9% 16.9% 228 0.010s +─maps_choice_step ---------------------- 0.1% 15.7% 0 0.040s +─next ---------------------------------- 15.7% 15.7% 32 0.040s +─auto (int_or_var_opt) (auto_using) (hin 14.8% 14.8% 358 0.008s +─unify (constr) (constr) --------------- 5.5% 5.5% 4416 0.006s +─canonicalize_map_hyp ------------------ 1.0% 4.4% 822 0.008s +─specialize (constr_with_bindings) ----- 4.2% 4.2% 3293 0.008s +─ensbedrock2/deps/coqutil/src/Map/SlowGoals (real: 16.46, user: 7.54, sys: 0.41, mem: 454624 ko) +ure_no_body ------------------------ 1.5% 3.6% 3220 0.008s +─assert_fails -------------------------- 0.9% 3.2% 4005 0.008s +─pose proof H as H' -------------------- 3.0% 3.0% 2405 0.009s +─tac ----------------------------------- 1.4% 2.3% 4005 0.008s +─maps_split_step ----------------------- 0.3% 2.2% 260 0.006s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver_core ----------------------- 0.0% 100.0% 1 7.312s +└map_solver_core_impl ------------------ 0.0% 100.0% 0 7.310s + ├─maps_propositional ------------------ 0.6% 61.3% 33 4.485s + │ ├─maps_leaf_tac --------------------- 0.7% 32.8% 228 0.018s + │ │ ├─congruence ---------------------- 16.9% 16.9% 228 0.010s + │ │ └─auto (int_or_var_opt) (auto_using 14.8% 14.8% 358 0.008s + │ ├─propositional_cheap_step ---------- 25.0% 25.4% 424 0.013s + │ ├─maps_choice_step ------------------ 0.1% 15.7% 0 0.040s + │ │└next ------------------------------ 15.7% 15.7% 32 0.040s + │ └─maps_split_step ------------------- 0.3% 2.2% 260 0.006s + └─map_specialize ---------------------- 0.0% 38.0% 1 2.779s + └map_specialize_step ----------------- 15.8% 38.0% 37 1.817s + ├─unify (constr) (constr) ----------- 5.5% 5.5% 4413 0.006s + ├─canonicalize_map_hyp -------------- 0.9% 4.2% 785 0.008s + ├─ensure_no_body -------------------- 1.5% 3.6% 3220 0.008s + │└assert_fails ---------------------- 0.7% 2.1% 3220 0.008s + ├─pose proof H as H' ---------------- 3.0% 3.0% 2405 0.009s + └─specialize (constr_with_bindings) - 2.5% 2.5% 2405 0.007s + +Finished transaction in 2.274 secs (1.721u,0.068s) (successful) +Finished transaction in 1.891 secs (1.771u,0.084s) (successful) +Finished transaction in 1.713 secs (1.599u,0.076s) (successful) +Finished transaction in 0.196 secs (0.185u,0.008s) (successful) +Part 1b: Medium goals (originally took >5s each) +Finished transaction in 1.398 secs (1.318u,0.055s) (successful) +Finished transaction in 3.691 secs (3.403u,0.173s) (successful) +Finished transaction in 3.279 secs (3.017u,0.167s) (successful) +Finished transaction in 1.982 secs (1.851u,0.083s) (successful) +Finished transaction in 1.932 secs (1.8u,0.097s) (successful) +Finished transaction in 3.391 secs (3.136u,0.144s) (successful) +Finished transaction in 3.23 secs (3.024u,0.138s) (successful) +Part 1c: Large goals (originally took >50s each) +Finished transaction in 4.687 secs (4.34u,0.215s) (successful) +End of TestGoals.v +total time: 37.262s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 100.0% 18 4.555s +─map_solver_core ----------------------- 0.0% 96.9% 18 4.483s +─map_solver_core_impl ------------------ 0.0% 96.8% 0 4.482s +─map_specialize ------------------------ 0.0% 93.4% 18 4.351s +─map_specialize_step ------------------- 43.0% 93.3% 428 1.253s +─ensure_no_body ------------------------ 5.8% 13.2% 62635 0.014s +─specialize (constr_with_bindings) ----- 12.8% 12.8% 63060 0.013s +─pose proof H as H' -------------------- 11.4% 11.4% 55172 0.009s +─assert_fails -------------------------- 3.3% 9.5% 69963 0.014s +─canonicalize_map_hyp ------------------ 1.8% 7.6% 7811 0.014s +─tac ----------------------------------- 4.2% 6.2% 69963 0.014s +─preprbedrock2/deps/coqutil/src/Map/TestGoals (real: 49.22, user: 36.08, sys: 2.04, mem: 562540 ko) +ocess_impl ----------------------- 0.1% 3.1% 18 0.116s +─Tactics.ensure_new -------------------- 1.1% 3.1% 7328 0.014s +─rew_map_specs_in ---------------------- 1.0% 3.0% 7812 0.014s +─maps_propositional -------------------- 0.0% 2.8% 22 0.231s +─abstract_unrecogs --------------------- 0.4% 2.4% 18 0.107s +─unify (constr) (constr) --------------- 2.2% 2.2% 75932 0.009s +─one_rew_map_specs --------------------- 1.4% 2.1% 0 0.014s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 100.0% 18 4.555s + ├─map_solver_core --------------------- 0.0% 96.9% 18 4.483s + │└map_solver_core_impl ---------------- 0.0% 96.8% 0 4.482s + │ ├─map_specialize -------------------- 0.0% 93.4% 18 4.351s + │ │└map_specialize_step --------------- 43.0% 93.3% 428 1.253s + │ │ ├─ensure_no_body ------------------ 5.8% 13.2% 62635 0.014s + │ │ │└assert_fails -------------------- 2.9% 7.5% 62635 0.014s + │ │ │└tac ----------------------------- 3.3% 4.6% 62635 0.011s + │ │ ├─pose proof H as H' -------------- 11.4% 11.4% 55172 0.009s + │ │ ├─specialize (constr_with_bindings) 10.5% 10.5% 55172 0.010s + │ │ ├─canonicalize_map_hyp ------------ 1.7% 7.3% 7328 0.014s + │ │ │ ├─rew_map_specs_in -------------- 0.9% 2.9% 7328 0.014s + │ │ │ └─specialize (constr_with_binding 2.2% 2.2% 7328 0.013s + │ │ ├─Tactics.ensure_new -------------- 1.1% 3.1% 7328 0.014s + │ │ │└assert_fails -------------------- 0.4% 2.0% 7328 0.014s + │ │ └─unify (constr) (constr) --------- 2.2% 2.2% 75866 0.009s + │ └─maps_propositional ---------------- 0.0% 2.8% 22 0.231s + └─preprocess_impl --------------------- 0.1% 3.1% 18 0.116s + └abstract_unrecogs ------------------- 0.4% 2.4% 18 0.107s + +make[3]: Leaving directory 'bedrock2/deps/coqutil' +make[2]: Leaving directory 'bedrock2/deps/coqutil' +make -C bedrock2/deps/riscv-coq all +make -C bedrock2/bedrock2 +make[2]: Entering directory 'bedrock2/deps/riscv-coq' +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = riscv -arg "-async-proofs-tac-j 1" bedrock2/deps/riscv-coq/src/Spec/Primitives.v bedrock2/deps/riscv-coq/src/Spec/ExecuteI.v bedrock2/deps/riscv-coq/src/Spec/ExecuteI64.v bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives.v bedrock2/deps/riscv-coq/src/Spec/Machine.v bedrock2/deps/riscv-coq/src/Spec/ExecuteM.v bedrock2/deps/riscv-coq/src/Spec/ExecuteM64.v bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions.v bedrock2/deps/riscv-coq/src/Spec/Execute.v bedrock2/deps/riscv-coq/src/Spec/Decode.v bedrock2/deps/riscv-coq/src/Spec/VirtualMemory.v bedrock2/deps/riscv-coq/src/Utility/MMIOTrace.v bedrock2/deps/riscv-coq/src/Utility/InstructionNotations.v bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem.v bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise.v bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions.v bedrock2/deps/riscv-coq/src/Utility/Words32Naive.v bedrock2/deps/riscv-coq/src/Utility/JMonad.v bedrock2/deps/riscv-coq/src/Utility/Utility.v bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64.v bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run.v bedrock2/deps/riscv-coq/src/Utility/ZBitOps.v bedrock2/deps/riscv-coq/src/Utility/MonadNotations.v bedrock2/deps/riscv-coq/src/Utility/Tactics.v bedrock2/deps/riscv-coq/src/Utility/MonadTests.v bedrock2/deps/riscv-coq/src/Utility/Words64Naive.v bedrock2/deps/riscv-coq/src/Utility/Encode.v bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth.v bedrock2/deps/riscv-coq/src/Utility/MonadT.v bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem.v bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32.v bedrock2/deps/riscv-coq/src/Utility/PowerFunc.v bedrock2/deps/riscv-coq/src/Utility/ListLib.v bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v bedrock2/deps/riscv-coq/src/Utility/Monads.v bedrock2/deps/riscv-coq/src/Platform/MetricLogging.v bedrock2/deps/riscv-coq/src/Platform/Example64Literal.v bedrock2/deps/riscv-coq/src/Platform/RiscvMachine.v bedrock2/deps/riscv-coq/src/Platform/MetricMinimal.v bedrock2/deps/riscv-coq/src/Platform/Example.v bedrock2/deps/riscv-coq/src/Platform/Memory.v bedrock2/deps/riscv-coq/src/Platform/MinimalLogging.v bedrock2/deps/riscv-coq/src/Platform/Run.v bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine.v bedrock2/deps/riscv-coq/src/Platform/Minimal.v bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64.v bedrock2/deps/riscv-coq/src/Proofs/EncodeBound.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66.v -o Makefile.coq.all +make[2]: Entering directory 'bedrock2/bedrock2' +printf -- '-Q src bedrock2\n-Q /builds/coq/coWarning: ../coqutil/src (used in -R or -Q) is not a subdirectory of the current directory + +bedrock2/bedrock2/src/Syntax (real: 0.28, user: 0.07, sys: 0.04, mem: 93508 ko) +bedrock2/deps/riscv-coq/src/Utility/Monads (real: 1.74, user: 0.61, sys: 0.22, mem: 357880 ko) +bedrock2/deps/riscv-coq/src/Utility/Tactics (real: 1.14, user: 0.34, sys: 0.21, mem: 294376 ko) +bedrock2/bedrock2/src/Byte (real: 3.14, user: 1.29, sys: 0.27, mem: 418180 ko) +bedrock2/bedrock2/src/Notations (real: 0.16, user: 0.04, sys: 0.03, mem: 56396 ko) +bedrock2/deps/riscv-coq/src/Platform/MetricLogging (real: 1.44, user: 0.46, sys: 0.23, mem: 344552 ko) +bedrock2/deps/riscv-coq/src/Utility/MMIOTrace (real: 0.17, user: 0.04, sys: 0.03, mem: 56096 ko) +q/_build_ci/bedrock2/deps/coqutil/src coqutil\n' > _CoqProject +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = bedrock2 -arg "-async-proofs-tac-j 1" bedrock2/bedrock2/src/BasicCSyntax.v bedrock2/bedrock2/src/ToCString.v bedrock2/bedrock2/src/BytedumpTest.v bedrock2/bedrock2/src/BasicC32Semantics.v bedrock2/bedrock2/src/Byte.v bedrock2/bedrock2/src/Variables.v bedrock2/bedrock2/src/Semantics.v bedrock2/bedrock2/src/div10.v bedrock2/bedrock2/src/NotationsCustomEntry.v bedrock2/bedrock2/src/ListPred.v bedrock2/bedrock2/src/BasicC64Semantics.v bedrock2/bedrock2/src/Map/SeparationLogic.v bedrock2/bedrock2/src/Map/Separation.v bedrock2/bedrock2/src/Syntax.v bedrock2/bedrock2/src/WeakestPreconditionProperties.v bedrock2/bedrock2/src/NotationsInConstr.v bedrock2/bedrock2/src/WeakestPrecondition.v bedrock2/bedrock2/src/TODO_absint.v bedrock2/bedrock2/src/Bytedump.v bedrock2/bedrock2/src/FE310CSemantics.v bedrock2/bedrock2/src/StructNotations.v bedrock2/bedrock2/src/Examples/lightbulb.v bedrock2/bedrock2/src/Examples/MultipleReturnValues.v bedrock2/bedrock2/src/Examples/ARPResponder.v bedrock2/bedrock2/src/Examples/swap.v bedrock2/bedrock2/src/Examples/chacha20.v bedrock2/bedrock2/src/Examples/Demos.v bedrock2/bedrock2/src/Examples/bsearch.v bedrock2/bedrock2/src/Examples/Trace.v bedrock2/bedrock2/src/Examples/StructAccess.v bedrock2/bedrock2/src/Examples/FE310CompilerDemo.v bedrock2/bedrock2/src/Examples/ipow.v bedrock2/bedrock2/src/Markers.v bedrock2/bedrock2/src/Memory.v bedrock2/bedrock2/src/Structs.v bedrock2/bedrock2/src/Notations.v bedrock2/bedrock2/src/ProgramLogic.v bedrock2/bedrock2/src/Hexdump.v bedrock2/bedrock2/src/BasicC64Syntax.v bedrock2/bedrock2/src/Scalars.v bedrock2/bedrock2/src/string2ident.v bedrock2/bedrock2/src/ptsto_bytes.v bedrock2/bedrock2/src/StringNamesSyntax.v bedrock2/bedrock2/src/Lift1Prop.v bedrock2/bedrock2/src/ZNamesSyntax.v bedrock2/bedrock2/src/TailRecursion.v bedrock2/bedrock2/src/Array.v -o Makefile.coq.all +make -f Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/deps/riscv-coq' +make[3]: Entering directory 'bedrock2/bedrock2' +COQDEP VFILES +COQDEP VFILES +COQC bedrock2/bedrock2/src/Syntax.v +COQC bedrock2/deps/riscv-coq/src/Utility/Monads.v +COQC bedrock2/bedrock2/src/Byte.v +COQC bedrock2/deps/riscv-coq/src/Utility/Tactics.v +COQC bedrock2/deps/riscv-coq/src/Platform/MetricLogging.v +COQC bedrock2/bedrock2/src/Notations.v +COQC bedrock2/bedrock2/src/div10.v +COQC bedrock2/deps/riscv-coq/src/Utility/MMIOTrace.v +COQC bedrock2/deps/riscv-coq/src/Utility/nat_div_mbedrock2/bedrock2/src/div10 (real: 1.82, user: 0.61, sys: 0.29, mem: 437628 ko) +bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem (real: 1.14, user: 0.36, sys: 0.19, mem: 298516 ko) +File "bedrock2/bedrock2/src/NotationsCustomEntry.v", line 50, characters 0-51: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_nontail.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsCustomEntry.v", line 142, characters 0-45: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_tail.". [undeclared-scope,deprecated] +File "bedrock2/deps/riscv-coq/src/Utility/JMonad.v", line 13, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/NotationsCustomEntry (real: 1.07, user: 0.33, sys: 0.18, mem: 301112 ko) +bedrock2/deps/riscv-coq/src/Utility/JMonad (real: 0.64, user: 0.17, sys: 0.13, mem: 184664 ko) +bedrock2/bedrock2/src/ListPred (real: 0.47, user: 0.13, sys: 0.09, mem: 144616 ko) +File "bedrock2/deps/riscv-coq/src/Utility/MonadNotations.v", line 3, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +bedrock2/deps/riscv-coq/src/Utility/MonadNotations (real: 0.48, user: 0.12, sys: 0.11, mem: 146976 ko) +bedrock2/deps/riscv-coq/src/Utility/PowerFunc (real: 0.20, user: 0.05, sys: 0.04, mem: 65768 ko) +bedrock2/bedrock2/src/Lift1Prop (real: 0.32, user: 0.09, sys: 0.06, mem: 116312 ko) +File "bedrock2/deps/riscv-coq/src/Utility/MonadTests.v", line 10, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 5, characters 0-43: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_var.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 7, characters 0-45: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_expr.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 21, characters 0-43: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_cmd.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 46, characters 0-55: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_func_body.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/NotationsInConstr (real: 0.66, user: 0.19, sys: 0.10, mem: 172428 ko) +bedrock2/deps/riscv-coq/src/Utility/MonadTests (real: 0.93, user: 0.27, sys: 0.16, mem: 255852 ko) +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 17, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 265, characters 2-23: +Warning: State is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 266, characters 2-37: +Warning: step is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 280, characters 2-23: +Warning: State is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 281, characters 2-37: +Warning: step is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 311, characters 2-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/deps/riscv-coq/src/Utility/MonadT (real: 0.78, user: 0.23, sys: 0.15, mem: 212520 ko) +od_to_quot_rem.v +COQC bedrock2/bedrock2/src/NotationsCustomEntry.v +COQC bedrock2/deps/riscv-coq/src/Utility/JMonad.v +COQC bedrock2/bedrock2/src/ListPred.v +COQC bedrock2/deps/riscv-coq/src/Utility/MonadNotations.v +COQC bedrock2/bedrock2/src/Lift1Prop.v +COQC bedrock2/deps/riscv-coq/src/Utility/PowerFunc.v +COQC bedrock2/deps/riscv-coq/src/Utility/MonadTests.v +COQC bedrock2/bedrock2/src/NotationsInConstr.v + = [(3, true); (3, false); (4, true); (4, false)] + : Id (list (nat * bool)) + = None + : Id (option (list nat)) + = [Some 3; Some 4; None] + : Id (list (option nat)) + = (tt, 5) + : Id (unit * nat) + = [(tt, 6); (tt, 7)] + : Id (list (unit * nat)) + = [0; 1; 2; 3] + : list nat + = [(tt, 0); (tt, 1); (tt, 2); (tt, 3)] + : Id (list (unit * nat)) +COQC bedrock2/bedrock2/src/Structs.v + = ([(0, 1); (0, 0)], (0, 0)) + : Id (list (nat * nat) * (nat * nat)) + = [(0, 1, (0, 1)); (1, 0, (1, 0))] + : Id (list (nat * nat * (nat * nat))) + = ([0; 1; 2; 3], 3) + : Id (list nat * nat) + = ([0; 5; 6; 15], 15) + : Id (list nat * nat) + = (tt, <<20,10,10>>) + : Id (unit * Regs) + = ([<<0,20,30>>; <<1,20,30>>; <<2,20,30>>], <<2,20,30>>) + : Id (list Regs * Regs) + = ([<<0,11,11>>; <<1,11,11>>; <<2,11,11>>; <<3,11,11>>], <<3,11,11>>) + : Id (list Regs * Regs) +COQC bedrock2/deps/riscv-coq/src/Utility/MonadT.v + = list (option nat) + : Type + = fun (A : Type) (aset : (A -> Prop) -> Prop) + (f : (A -> Prop) -> A) (b : A) => + exists a : A -> Prop, aset a /\ f a = b + : forall A : Type, + ((A -> Prop) -> Prop) -> ((A -> Prop) -> A) -> A -> Prop +runsTo_ind + : forall (initial : State) (P : State -> Prop) (P0 : Prop), + (P initial -> P0) -> + ((forall omid : option State, + step initial omid -> + exists mid : State, omid = Some mid /\ runsTo mid P) -> P0) -> + runsTo initial P -> P0 +runsTo_ind = +fun (initial : State) (P : State -> Prop) (P0 : Prop) + (f : P initial -> P0) + (f0 : (forall omid : option (option unit * State), + step initial omid -> + exists mid : State, omid = Some (Some tt, mid) /\ runsTo mid P) -> + P0) (r : runsTo initial P) => +match r with +| runsToDone _ _ x => f x +| runsToStep _ _ x => f0 x +end + : forall (initial : State) (P : State -> Prop) (P0 : Prop), + (P initial -> P0) -> + ((forall omid : option (option unit * State), + step initial omid -> + exists mid : State, omid = Some (Some tt, mid) /\ runsTo mid P) -> + P0) -> runsTo initial P -> P0 + +Argument scopes are [_ function_scope type_scope function_scope + function_scope _] +Closed under the global context +COQC bedrock2/deps/riscv-coq/src/Utility/ListLib.v + = 4%Z + : Z + = 20%Z + : Z + = 30%Z + : Z + = 90%Z + : Z + = inr + (Struct + (("first", Array 15 (Bytes 1)) + :: ("last", Array 15 (Bytes 1)) :: nil), 30%Z) + : PathError Z + type * Z + = inr (Array 15 (Bytes 1), 45%Z) + : PathError Z + type * Z + = inr (Bytes 1, 47%Z) + : PathError Z + type * Z + = fun (p : parameters) (add mul : bopname) (base : expr) => + inr + (Struct + (("first", Array 15 (Bytes 1)) + :: ("last", Array 15 (Bytes 1)) :: nil), + expr.op add base (expr.op mul (expr.literal 1) (expr.literal 30))) + : forall p : parameters, + bopname -> bopname -> expr -> PathError expr + type * expr + = fun (p : parameters) (add mul : bopname) (base : expr) => + inr + (Array 15 (Bytes 1), + expr.op add + (expr.op add base (expr.op mul (expr.literal 1) (expr.literal 30))) + (expr.literal 15)) + : forall p : parameters, + bopname -> bopname -> expr -> PathError expr + type * bedrock2/bedrock2/src/Structs (real: 1.31, user: 0.44, sys: 0.20, mem: 308516 ko) +File "bedrock2/bedrock2/src/Markers.v", line 19, characters 2-71: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope hide_markers.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/Markers (real: 0.18, user: 0.04, sys: 0.04, mem: 57444 ko) +bedrock2/bedrock2/src/string2ident (real: 1.15, user: 0.36, sys: 0.20, mem: 272052 ko) +File "bedrock2/bedrock2/src/Hexdump.v", line 16, characters 0-41: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope hexdump_scope.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/Hexdump (real: 1.06, user: 0.32, sys: 0.19, mem: 274924 ko) +bedrock2/deps/riscv-coq/src/Utility/ListLib (real: 2.96, user: 1.17, sys: 0.28, mem: 444076 ko) +bedrock2/bedrock2/src/ZNamesSyntax (real: 1.16, user: 0.38, sys: 0.18, mem: 294268 ko) +bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem (real: 1.14, user: 0.37, sys: 0.18, mem: 295668 ko) +File "bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v", line 20, characters 2-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v", line 30, characters 2-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/deps/riscv-coq/src/Utility/runsToNonDet (real: 0.20, user: 0.05, sys: 0.03, mem: 65120 ko) +bedrock2/bedrock2/src/Variables (real: 0.46, user: 0.13, sys: 0.09, mem: 149744 ko) +bedrock2/bedrock2/src/StringNamesSyntax (real: 1.02, user: 0.30, sys: 0.18, mem: 252388 ko) +File "bedrock2/bedrock2/src/Bytedump.v", line 2, characters 0-43: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bytedump_scope.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/Bytedump (real: 1.08, user: 0.34, sys: 0.18, mem: 272812 ko) +bedrock2/deps/riscv-coq/src/Utility/ZBitOps (real: 2.28, user: 0.83, sys: 0.28, mem: 439724 ko) +File "bedrock2/deps/riscv-coq/src/Utility/Utility.v", line 120, characters 0-78: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope alu_scope.". [undeclared-scope,deprecated] +bedrock2/deps/riscv-coq/src/Utility/Utility (real: 1.69, user: 0.57, sys: 0.25, mem: 358716 ko) +bedrock2/bedrock2/src/Memory (real: 2.40, user: 0.84, sys: 0.30, mem: 443020 ko) +bedrock2/bedrock2/src/Map/Separation (real: 1.31, user: 0.43, sys: 0.20, mem: 289244 ko) +bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise (real: 2.66, user: 0.95, sys: 0.32, mem: 441452 ko) +bedrock2/bedrock2/src/StructNotations (real: 1.10, user: 0.35, sys: 0.18, mem: 267768 ko) +bedrock2/deps/riscv-coq/src/Utility/Words32Naive (real: 1.51, user: 0.52, sys: 0.21, mem: 346660 ko) +bedrock2/bedrock2/src/ToCString (real: 1.34, user: 0.48, sys: 0.17, mem: 276676 ko) +bedrock2/deps/riscv-coq/src/Utility/Words64Naive (real: 1.41, user: 0.49, sys: 0.19, mem: 346980 ko) +bedrock2/bedrock2/src/BytedumpTest (real: 1.52, user: 0.49, sys: 0.25, mem: 411496 ko) +bedrock2/bedrock2/src/BytedumpTestα (real: 1.52, user: 0.49, sys: 0.25, mem: 411496 ko) +bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32 (real: 1.64, user: 0.55, sys: 0.23, mem: 376020 ko) +bedrock2/bedrock2/src/Semantics (real: 1.81, user: 0.66, sys: 0.26, mem: 441912 ko) +bedrock2/deps/riscv-coq/src/Spec/Decode (real: 2.09, user: 0.71, sys: 0.28, mem: 446048 ko) +bedrock2/deps/riscv-coq/src/Platform/Memory (real: 2.06, user: 0.71, sys: 0.27, mem: 449484 ko) +bedrock2/bedrock2/src/Map/SeparationLogic (real: 4.20, user: 1.76, sys: 0.27, mem: 433996 ko) +bedrock2/deps/riscv-coq/src/Spec/Machine (real: 1.50, user: 0.49, sys: 0.24, mem: 375808 ko) +bedrock2/bedrock2/src/WeakestPrecondition (real: 1.67, user: 0.56, sys: 0.24, mem: 410516 ko) +bedrock2/deps/riscv-coq/src/Platform/RiscvMachine (real: 1.48, user: 0.48, sys: 0.24, mem: 370692 ko) +bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth (real: 1.44, user: 0.49, sys: 0.21, mem: 360632 ko) +bedrock2/bedrock2/src/Array (real: 3.30, user: 1.35, sys: 0.27, mem: 457132 ko) +bedrock2/deps/riscv-coq/src/Spec/VirtualMemory (real: 1.33, user: 0.43, sys: 0.22, mem: 321032 ko) +bedrock2/bedrock2/src/BasicC64Syntax (real: 1.40, user: 0.47, sys: 0.21, mem: 321560 ko) +bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine (real: 1.49, user: 0.48, sys: 0.24, mem: 362608 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteM (real: 1.62, user: 0.53, sys: 0.26, mem: 387416 ko) +bedrock2/bedrock2/src/Examples/Trace (real: 2.96, user: 1.14, sys: 0.29, mem: 449412 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteM64 (real: 1.64, user: 0.52, sys: 0.25, mem: 375816 ko) +bedrock2/bedrock2/src/Examples/StructAccess (real: 1.12, user: 0.35, sys: 0.19, mem: 272888 ko) +bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions (real: 1.40, user: 0.47, sys: 0.21, mem: 338992 ko) +bedrock2/bedrock2/src/BasicCSyntax (real: 1.40, user: 0.50, sys: 0.18, mem: 322924 ko) +expr + = fun (p : parameters) (add mul : bopname) (base : expr) => + inr + (Bytes 1, + expr.op add + (expr.op add + (expr.op add base + (expr.op mul (expr.literal 1) (expr.literal 30))) + (expr.literal 15)) + (expr.op mul (expr.literal 2) (expr.literal 1))) + : forall p : parameters, + bopname -> bopname -> expr -> PathError expr + type * expr +COQC bedrock2/bedrock2/src/Markers.v +COQC bedrock2/bedrock2/src/string2ident.v +COQC bedrock2/bedrock2/src/Hexdump.v +COQC bedrock2/bedrock2/src/ZNamesSyntax.v +COQC bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem.v +COQC bedrock2/bedrock2/src/Variables.v +COQC bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v +COQC bedrock2/deps/riscv-coq/src/Utility/ZBitOps.v +COQC bedrock2/bedrock2/src/StringNamesSyntax.v +COQC bedrock2/bedrock2/src/Bytedump.v +COQC bedrock2/bedrock2/src/Memory.v +COQC bedrock2/deps/riscv-coq/src/Utility/Utility.v +COQC bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise.v +COQC bedrock2/bedrock2/src/Map/Separation.v +COQC bedrock2/bedrock2/src/StructNotations.v +COQC bedrock2/deps/riscv-coq/src/Utility/Words32Naive.v +COQC bedrock2/bedrock2/src/ToCString.v +COQC bedrock2/deps/riscv-coq/src/Utility/Words64Naive.v +COQC bedrock2/bedrock2/src/BytedumpTest.v +COQC bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32.v + +
!"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ +COQC bedrock2/bedrock2/src/Semantics.v +COQC bedrock2/deps/riscv-coq/src/Spec/Decode.v +COQC bedrock2/bedrock2/src/Map/SeparationLogic.v +COQC bedrock2/deps/riscv-coq/src/Platform/Memory.v +COQC bedrock2/deps/riscv-coq/src/Spec/Machine.v +COQC bedrock2/bedrock2/src/WeakestPrecondition.v +COQC bedrock2/deps/riscv-coq/src/Platform/RiscvMachine.v +COQC bedrock2/bedrock2/src/Array.v +COQC bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth.v +COQC bedrock2/deps/riscv-coq/src/Spec/VirtualMemory.v +COQC bedrock2/bedrock2/src/BasicC64Syntax.v +COQC bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine.v +COQC bedrock2/bedrock2/src/Examples/Trace.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteM.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteM64.v +squarer_correct + : forall (m : Semantics.mem) (l : Semantics.locals), + exec map.empty squarer [] m l + (fun (t' : trace) (_ : Semantics.mem) (_ : Semantics.locals) => + squarer_trace t') +squarer_correct + : forall (m : Semantics.mem) (l : Semantics.locals), + exec map.empty squarer [] m l + (fun (t' : trace) (_ : Semantics.mem) (_ : Semantics.locals) => + squarer_trace t') +COQC bedrock2/bedrock2/src/Examples/StructAccess.v +COQC bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions.v +COQC bedrock2/bedrock2/src/BasicCSyntax.v +COQC bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions.v +COQC bedrock2/bedrock2/src/WeakestPreconditionFile "bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions.v", line 10, characters 0-70: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope ilist_scope.". [undeclared-scope,deprecated] +bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions (real: 1.33, user: 0.43, sys: 0.21, mem: 313976 ko) +bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64 (real: 1.59, user: 0.52, sys: 0.25, mem: 375840 ko) +bedrock2/deps/riscv-coq/src/Utility/Encode (real: 2.03, user: 0.67, sys: 0.31, mem: 446648 ko) +bedrock2/deps/riscv-coq/src/Spec/Primitives (real: 2.21, user: 0.72, sys: 0.34, mem: 457772 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteI (real: 2.60, user: 0.94, sys: 0.32, mem: 454504 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteI64 (real: 1.85, user: 0.55, sys: 0.28, mem: 401008 ko) +bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives (real: 2.20, user: 0.76, sys: 0.30, mem: 459200 ko) +bedrock2/deps/riscv-coq/src/Spec/Execute (real: 1.43, user: 0.44, sys: 0.24, mem: 336624 ko) +bedrock2/deps/riscv-coq/src/Utility/InstructionNotations (real: 1.41, user: 0.44, sys: 0.24, mem: 340268 ko) +bedrock2/deps/riscv-coq/src/Platform/Run (real: 1.69, user: 0.52, sys: 0.27, mem: 374676 ko) +File "bedrock2/bedrock2/src/WeakestPreconditionProperties.v", line 193, characters 2-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/bedrock2/src/WeakestPreconditionProperties (real: 19.56, user: 9.19, sys: 0.41, mem: 663884 ko) +bedrock2/bedrock2/src/FE310CSemantics (real: 8.23, user: 3.64, sys: 0.34, mem: 472892 ko) +File "bedrock2/bedrock2/src/TailRecursion.v", line 16, characters 2-67: +Warning: Notation "_ /\ _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "{ _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "{ ' _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 138, characters 2-49: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/bedrock2/src/TailRecursion (real: 3.43, user: 1.34, sys: 0.32, mem: 461368 ko) +bedrock2/deps/riscv-coq/src/Platform/Minimal (real: 14.97, user: 6.99, sys: 0.33, mem: 482444 ko) +File "bedrock2/bedrock2/src/ptsto_bytes.v", line 151, characters 6-173: +Warning: Unused introduction patterns: R IH [unused-intro-pattern,tactics] +File "bedrock2/bedrock2/src/ptsto_bytes.v", line 163, characters 6-132: +Warning: Unused introduction patterns: R IH [unused-intro-pattern,tactics] +bedrock2/bedrock2/src/ptsto_bytes (real: 4.33, user: 1.80, sys: 0.31, mem: 461200 ko) +bedrock2/bedrock2/src/Examples/MultipleReturnValues (real: 1.64, user: 0.54, sys: 0.23, mem: 310296 ko) +bedrock2/bedrock2/src/Examples/ARPResponder (real: 4.88, user: 2.06, sys: 0.33, mem: 465924 ko) +bedrock2/bedrock2/src/Examples/chacha20 (real: 3.11, user: 1.25, sys: 0.26, mem: 435736 ko) +Properties.v +COQC bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64.v +COQC bedrock2/deps/riscv-coq/src/Utility/Encode.v +COQC bedrock2/deps/riscv-coq/src/Spec/Primitives.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteI.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteI64.v +COQC bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives.v +COQC bedrock2/deps/riscv-coq/src/Spec/Execute.v +COQC bedrock2/deps/riscv-coq/src/Utility/InstructionNotations.v +COQC bedrock2/deps/riscv-coq/src/Platform/Run.v +COQC bedrock2/deps/riscv-coq/src/Platform/Minimal.v +COQC bedrock2/bedrock2/src/FE310CSemantics.v +COQC bedrock2/bedrock2/src/TailRecursion.v +COQC bedrock2/bedrock2/src/ptsto_bytes.v +COQC bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO.v +COQC bedrock2/bedrock2/src/Examples/MultipleReturnValues.v +COQC bedrock2/bedrock2/src/Examples/ARPResponder.v +COQC bedrock2/bedrock2/src/Examples/chacha20.v +COQC bedrock2/bedrock2/src/Examples/Demos.v +allProgs@{bedrock2.Examples.Demos.686 bedrock2.Examples.Demos.687} = +[("bsearch", + ([left; right; target], [left], + (while (right - left) {{ + mid = left + (right - left) >> 4 << 3;; + (if (*(uintptr_t*) mid < target) {{ + left = mid + 8 + }} else {{ + right = mid + }});; + cmd.unset mid + }})%bedrock_cmd)); +("listsum", +([], [sumreg], +(sumreg = 0;; + n = *(uint32_t*) 1024;; + ListSum.i = 0;; + while (ListSum.i < n) {{ + ListSum.a = *(uint32_t*) (1024 + 4 + 4 * ListSum.i);; + sumreg = sumreg + ListSum.a;; + ListSum.i = ListSum.i + 1 + }})%bedrock_cmd)); +("fibonacci", +([], [b], +(a = 0;; + b = 1;; + i = 0;; + while (i < 6) {{ + c = a + b;; + a = b;; + b = c;; + i = i + 1 + }})%bedrock_cmd))] + : list Prog +allProgs@{bedrock2.Examples.Demos.135 bedrock2.Examples.Demos.136 +bedrock2.Examples.Demos.137 bedrock2.Examples.Demos.146 +bedrock2.Examples.Demos.171 bedrock2.Examples.Demos.345 +bedrock2.Examples.Demos.515 bedrock2.Examples.Demos.686 +bedrock2.Examples.Demos.687} = +fun (p : Syntax.parameters) (bsearchNames : BinarySearch.Names) + (listsumNames : ListSum.Names) (fibonacciNames : Fibonacci.Names) => +[("bsearch", + ([BinarySearch.left; BinarySearch.right; BinarySearch.target], + [BinarySearch.left], + cmd.while + (expr.op bopname.sub (var BinarySearch.right) (var BinarySearch.left)) + (cmd.seq + (cmd.set BinarySearch.mid + (expr.op bopname.add (var BinarySearch.left) + (expr.op bopname.slu + (expr.op bopname.sru + (expr.op bopname.sub (var BinarySearch.right) + (var BinarySearch.left)) (literal 4)) + (literal 3)))) + (cmd.seq + (cmd.cond + (expr.op bopname.ltu + (expr.load access_size.word (var BinarySearch.mid)) + (var BinarySearch.target)) + (cmd.set BinarySearch.left + (expr.op bopname.add (var BinarySearch.mid) (literal 8))) + (cmd.set BinarySearch.right (var BinarySearch.mid))) + (cmd.unset BinarySearch.mid))))); +("listsum", +([], [ListSum.sumreg], +cmd.seq (cmd.set ListSum.sumreg (literal 0)) + (cmd.seq (cmd.set ListSum.n (expr.load access_size.four (literal 1024))) + (cmd.seq (cmd.set ListSum.i (literal 0)) + (cmd.while (expr.op bopname.ltu (var ListSum.i) (var ListSum.n)) + (cmd.seq + (cmd.set ListSum.a + (expr.load access_size.four + (expr.op bopname.add (literal (1024 + 4)) + (expr.op bopname.mul (literal 4) (var ListSum.i))))) + (cmd.seq + (cmd.set ListSum.sumreg + (expr.op bopname.add (var ListSum.sumreg) (var ListSum.a))) + bedrock2/bedrock2/src/Examples/Demos (real: 1.93, user: 0.69, sys: 0.23, mem: 353168 ko) +bedrock2/bedrock2/src/BasicC32Semantics (real: 1.66, user: 0.55, sys: 0.25, mem: 387552 ko) +bedrock2/bedrock2/src/BasicC64Semantics (real: 1.74, user: 0.57, sys: 0.27, mem: 403188 ko) +bedrock2/bedrock2/src/Scalars (real: 3.04, user: 1.18, sys: 0.30, mem: 457564 ko) +bedrock2/bedrock2/src/TODO_absint (real: 2.93, user: 1.13, sys: 0.30, mem: 457912 ko) + (cmd.set ListSum.i + (expr.op bopname.add (var ListSum.i) (literal 1)))))))))); +("fibonacci", +([], [Fibonacci.b], +cmd.seq (cmd.set Fibonacci.a (literal 0)) + (cmd.seq (cmd.set Fibonacci.b (literal 1)) + (cmd.seq (cmd.set Fibonacci.i (literal 0)) + (cmd.while (expr.op bopname.ltu (var Fibonacci.i) (literal 6)) + (cmd.seq + (cmd.set Fibonacci.c + (expr.op bopname.add (var Fibonacci.a) (var Fibonacci.b))) + (cmd.seq (cmd.set Fibonacci.a (var Fibonacci.b)) + (cmd.seq (cmd.set Fibonacci.b (var Fibonacci.c)) + (cmd.set Fibonacci.i + (expr.op bopname.add (var Fibonacci.i) (literal 1)))))))))))] + : forall p : Syntax.parameters, + BinarySearch.Names -> ListSum.Names -> Fibonacci.Names -> list Prog + +Arguments p, bsearchNames, listsumNames, fibonacciNames are implicit and +maximally inserted +allProgsAsCStrings@{} = +["uintptr_t bsearch(uintptr_t left, uintptr_t right, uintptr_t target) { + uintptr_t mid; + while ((right)-(left)) { + mid = (left)+((((right)-(left))>>((uintptr_t)4ULL))<<((uintptr_t)3ULL)); + if ((*(uintptr_t*)(mid))<(target)) { + left = (mid)+((uintptr_t)8ULL); + } else { + right = mid; + } + // unset mid + } + return left; +} +"; +"uintptr_t listsum() { + uintptr_t n, sumreg, a, i; + sumreg = (uintptr_t)0ULL; + n = *(uint32_t*)((uintptr_t)1024ULL); + i = (uintptr_t)0ULL; + while ((i)<(n)) { + a = *(uint32_t*)(((uintptr_t)1028ULL)+(((uintptr_t)4ULL)*(i))); + sumreg = (sumreg)+(a); + i = (i)+((uintptr_t)1ULL); + } + return sumreg; +} +"; +"uintptr_t fibonacci() { + uintptr_t a, b, c, i; + a = (uintptr_t)0ULL; + b = (uintptr_t)1ULL; + i = (uintptr_t)0ULL; + while ((i)<((uintptr_t)6ULL)) { + c = (a)+(b); + a = b; + b = c; + i = (i)+((uintptr_t)1ULL); + } + return b; +} +"] + : list string +allProgsWithZNames@{bedrock2.Examples.Demos.721} = +[("bsearch", + ([1; 2; 3], [1], + cmd.while (expr.op bopname.sub (expr.var 2) (expr.var 1)) + (cmd.seq + (cmd.set 4 + (expr.op bopname.add (expr.var 1) + (expr.op bopname.slu + (expr.op bopname.sru + (expr.op bopname.sub (expr.var 2) (expr.var 1)) + (expr.literal 4)) (expr.literal 3)))) + (cmd.seq + (cmd.cond + (expr.op bopname.ltu (expr.load access_size.word (expr.var 4)) + (expr.var 3)) + (cmd.set 1 (expr.op bopname.add (expr.var 4) (expr.literal 8))) + (cmd.set 2 (expr.var 4))) (cmd.unset 4))))); +("listsum", +([], [3], +cmd.seq (cmd.set 3 (expr.literal 0)) + (cmd.seq (cmd.set 1 (expr.load access_size.four (expr.literal 1024))) + (cmd.seq (cmd.set 2 (expr.literal 0)) + (cmd.while (expr.op bopname.ltu (expr.var 2) (expr.var 1)) + (cmd.seq + (cmd.set 4 + (expr.load access_size.four + (expr.op bopname.add (expr.literal 1028) + (expr.op bopname.mul (expr.literal 4) (expr.var 2))))) + (cmd.seq + (cmd.set 3 (expr.op bopname.add (expr.var 3) (expr.var 4))) + (cmd.set 2 + (expr.op bopname.add (expr.var 2) (expr.literal 1)))))))))); +("fibonacci", +([], [2], +cmd.seq (cmd.set 1 (expr.literal 0)) + (cmd.seq (cmd.set 2 (expr.literal 1)) + (cmd.seq (cmd.set 4 (expr.literal 0)) + (cmd.while (expr.op bopname.ltu (expr.var 4) (expr.literal 6)) + (cmd.seq + (cmd.set 3 (expr.op bopname.add (expr.var 1) (expr.var 2))) + (cmd.seq (cmd.set 1 (expr.var 2)) + (cmd.seq (cmd.set 2 (expr.var 3)) + (cmd.set 4 + (expr.op bopname.add (expr.var 4) (expr.literal 1)))))))))))] + : list (string * (list Z * list Z * cmd)) +COQC bedrock2/bedrock2/src/BasicC32Semantics.v +COQC bedrock2/bedrock2/src/BasicC64Semantics.v +COQC bedrock2/bedrock2/src/Scalars.v +COQC bedrock2/bedrock2/src/TODO_absint.v +bedrock2/bedrock2/src/ProgramLogic (real: 1.65, user: 0.52, sys: 0.25, mem: 371960 ko) +File "bedrock2/bedrock2/src/Examples/lightbulb.v", line 48, characters 0-36: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/bedrock2/src/Examples/lightbulb (real: 44.98, user: 21.59, sys: 0.37, mem: 525428 ko) +File "bedrock2/bedrock2/src/Examples/swap.v", line 31, characters 24-60: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/bedrock2/src/Examples/swap (real: 8.68, user: 3.88, sys: 0.33, mem: 478956 ko) +bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO (real: 140.04, user: 67.92, sys: 0.50, mem: 590104 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence (real: 19.81, user: 9.16, sys: 0.36, mem: 495544 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R (real: 13.71, user: 6.32, sys: 0.36, mem: 478812 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic (real: 18.82, user: 8.68, sys: 0.36, mem: 494004 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I (real: 14.67, user: 6.82, sys: 0.30, mem: 485168 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57 (real: 13.83, user: 6.36, sys: 0.32, mem: 478692 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66 (real: 40.12, user: 19.20, sys: 0.36, mem: 526372 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system (real: 10.48, user: 4.71, sys: 0.33, mem: 470712 ko) +bedrock2/bedrock2/src/Examples/bsearch (real: 208.32, user: 101.50, sys: 0.51, mem: 564436 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S (real: 25.56, user: 12.11, sys: 0.34, mem: 518652 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB (real: 55.25, user: 26.55, sys: 0.40, mem: 632108 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U (real: 9.99, user: 4.46, sys: 0.31, mem: 468412 ko) +bedrock2/bedrock2/src/Examples/FE310CompilerDemo (real: 83.94, user: 40.64, sys: 0.41, mem: 588832 ko) +bedrock2/bedrock2/src/Examples/ipow (real: 19.97, user: 9.35, sys: 0.30, mem: 496100 ko) +/bin/sh: 1: hexdump: not found +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ (real: 39.56, user: 19.19, sys: 0.35, mem: 580040 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI (real: 14.48, user: 6.72, sys: 0.31, mem: 485544 ko) +bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run (real: 1.66, user: 0.58, sys: 0.23, mem: 408744 ko) +bedrock2/deps/riscv-coq/src/Platform/MinimalLogging (real: 2.10, user: 0.74, sys: 0.27, mem: 460380 ko) +bedrock2/deps/riscv-coq/src/Platform/MetricMinimal (real: 24.74, user: 11.74, sys: 0.31, mem: 501100 ko) +COQC bedrock2/bedrock2/src/ProgramLogic.v +COQC bedrock2/bedrock2/src/Examples/lightbulb.v + = "uintptr_t lightbulb(uintptr_t packet, uintptr_t len) { + uintptr_t ethertype, protocol, mmio_val, command, r; + ethertype = ((*(uint8_t*)((packet)+((uintptr_t)12ULL)))<<((uintptr_t)8ULL))|(*(uint8_t*)((packet)+((uintptr_t)13ULL))); + if (((uintptr_t)1535ULL)<(ethertype)) { + protocol = *(uint8_t*)((packet)+((uintptr_t)23ULL)); + if ((protocol)==((uintptr_t)17ULL)) { + command = *(uint8_t*)((packet)+((uintptr_t)42ULL)); + mmio_val = MMIOREAD((uintptr_t)268509192ULL); + MMIOWRITE((uintptr_t)268509192ULL, (mmio_val)|(((uintptr_t)1ULL)<<((uintptr_t)23ULL))); + mmio_val = MMIOREAD((uintptr_t)268509196ULL); + MMIOWRITE((uintptr_t)268509196ULL, (mmio_val)|((command)<<((uintptr_t)23ULL))); + r = (uintptr_t)0ULL; + } else { + r = (uintptr_t)-1ULL; + } + } else { + r = (uintptr_t)-1ULL; + } + return r; +} +" + : string +COQC bedrock2/bedrock2/src/Examples/swap.v +static void swap(uintptr_t a, uintptr_t b); + +void swap_swap(uintptr_t a, uintptr_t b) { + swap(a, b); + swap(a, b); + return; +} + +static void swap(uintptr_t a, uintptr_t b) { + uintptr_t t; + t = *(uintptr_t*)(b); + *(uintptr_t*)(b) = *(uintptr_t*)(a); + *(uintptr_t*)(a) = t; + return; +} + +COQC bedrock2/bedrock2/src/Examples/bsearch.v +H19 +H13 +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S.v +COQC bedrock2/bedrock2/src/Examples/FE310CompilerDemo.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ.v +COQC bedrock2/bedrock2/src/Examples/ipow.v +make[3]: Leaving directory 'bedrock2/bedrock2' +make src/BytedumpTest.out +make[3]: Entering directory 'bedrock2/bedrock2' +coqc -q -Q src bedrock2 -Q bedrock2/deps/coqutil/src coqutil src/BytedumpTest.v | head --bytes -1 > src/BytedumpTest.out.tmp +hexdump < /dev/null && \ + hexdump -C src/BytedumpTest.golden.bin > src/BytedumpTest.golden.hex && \ + hexdump -C src/BytedumpTest.out.tmp > src/BytedumpTest.out.hex && \ + diff -u src/BytedumpTest.golden.hex src/BytedumpTest.out.hex && \ + rm src/BytedumpTest.golden.hex src/BytedumpTest.out.hex || true +diff -u src/BytedumpTest.golden.bin src/BytedumpTest.out.tmp +mv src/BytedumpTest.out.tmp src/BytedumpTest.out +make[3]: Leaving directory 'bedrock2/bedrock2' +make[2]: Leaving directory 'bedrock2/bedrock2' +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI.v +COQC bedrock2/deps/riscv-coq/src/Proofs/EncodeBound.v +COQC bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run.v +COQC bedrock2/deps/riscv-coq/src/Platform/MinimalLogging.v +COQC bedrock2/deps/riscv-coq/src/Platform/MetricMinimal.v +COQC bedrock2/deps/riscv-coq/src/Platform/Example.v + = [({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; Sbedrock2/deps/riscv-coq/src/Platform/Example (real: 4.13, user: 1.62, sys: 0.27, mem: 468188 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver (real: 2.54, user: 0.94, sys: 0.29, mem: 450352 ko) +bedrock2/deps/riscv-coq/src/Platform/Example64Literal (real: 2.12, user: 0.76, sys: 0.28, mem: 409784 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64 (real: 55.42, user: 26.45, sys: 0.45, mem: 605916 ko) +bedrock2/deps/riscv-coq/src/Proofs/EncodeBound (real: 103.45, user: 50.15, sys: 0.41, mem: 573560 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64 (real: 53.82, user: 25.80, sys: 0.43, mem: 650288 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA (real: 60.04, user: 28.68, sys: 0.44, mem: 639092 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR (real: 215.18, user: 104.22, sys: 0.79, mem: 997556 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64 (real: 21.95, user: 9.77, sys: 0.34, mem: 523092 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM (real: 47.35, user: 22.60, sys: 0.37, mem: 589708 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI (real: 226.75, user: 139.56, sys: 1.26, mem: 1730872 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode (real: 0.81, user: 0.42, sys: 0.18, mem: 374624 ko) +ortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 16 (IInstruction (Jal 0 20)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 12 (IInstruction (Addi 9 0 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 8 (IInstruction (Addi 18 0 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 4 (IInstruction (Addi 20 0 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 0 (IInstruction (Addi 19 0 6)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, []))] + : list (LogItem LogEvent) +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver.v +COQC bedrock2/deps/riscv-coq/src/Platform/Example64Literal.v + = {| unsigned := 1073745919; _unsigned_in_range := eq_refl |} + : word64 +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode.v +make[3]: Leaving directory 'bedrock2/deps/riscv-coq' +make[2]: Leaving directory 'bedrock2/deps/riscv-coq' +make -C bedrock2/compiler +make -C bedrock2/deps/kami +make[2]: Entering directory 'bedrock2/compiler' +printf -- '-Q ../bedrock2/src bedrock2\n-Q bedrock2/deps/coqutil/src coqutil\n-Q bedrock2/deps/riscv-coq/src riscv\n-Q ./lib lib\n-Q ./src compiler\n' > _CoqProject +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = bedrock2 -arg "-async-proofs-tac-j 1" bedrock2/compiler/src/EmitsValid.v bedrock2/compiler/src/util/Misc.v bedrock2/compiler/src/util/Learning.v bedrock2/compiler/src/util/Tactics.v bedrock2/compiler/src/util/MyOmega.v bedrock2/compiler/src/util/ListLib.v bedrock2/compiler/src/util/Set.v bedrock2/compiler/src/util/SetSolverTests.v bedrock2/compiler/src/util/Common.v bedrock2/compiler/src/util/LogGoal.v bedrock2/compiler/src/SeparationLogic.v bedrock2/compiler/src/ExprImp.v bedrock2/compiler/src/FlatToRiscv32.v bedrock2/compiler/src/FlatToRiscv.v bedrock2/compiler/src/on_hyp_containing.v bedrock2/compiler/src/Basic32Semantics.v bedrock2/compiler/src/Simp.v bedrock2/compiler/src/FlatToRiscvDef.v bedrock2/compiler/src/RegAlloc3.v bedrock2/compiler/src/RegAllocAnnotatedNotations.v bedrock2/compiler/src/UnmappedMemForExtSpec.v bedrock2/compiler/src/RegAlloc2.v bedrock2/compiler/src/NoActionSyntaxParams.v bedrock2/compiler/src/Pipeline.v bedrock2/compiler/src/RiscvWordProperties.v bedrock2/compiler/src/GoFlatToRiscv.v bedrock2/compiler/src/Rem4.v bedrock2/compiler/src/SimplWordExpr.v bedrock2/compiler/src/ZNameGen.v bedrock2/compiler/src/NameGen.v bedrock2/compiler/src/FlatImp.v bedrock2/compiler/src/FlattenExpr.v bedrock2/compiler/src/eqexact.v bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump.v bedrock2/compiler/src/examples/TestExprImp.v bedrock2/compiler/src/examples/highlevel/FuncMut.v bedrock2/compiler/src/examples/highlevel/For.v bedrock2/compiler/src/examples/InlineAssemblyMacro.v bedrock2/compiler/src/examples/CompileExamples.v bedrock2/compiler/src/examples/toposort.v bedrock2/compiler/src/examples/FE310Compiler.v bedrock2/compiler/src/examples/EditDistExample.v bedrock2/compiler/src/examples/Fibonacci.v bedrock2/compiler/src/examples/TestFlatImp.v bedrock2/compiler/src/examples/MMIO.v bedrock2/compiler/lib/LibTacticsMin.v bedrock2/compiler/lib/fiat_crypto_tactics/Not.v bedrock2/compiler/lib/fiat_crypto_tactics/Test.v bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose.v bedrock2/compiler/lib/LibTactics.v -o Makefile.coq.all +make[2]: Entering directory 'bedrock2/deps/kami' +printf -- '-R Kami Kami\n-Q bedrock2/deps/Warning: ../bedrock2/src (used in -R or -Q) is not a subdirectory of the current directory + +Warning: bedrock2/deps/riscv-coq/src (used in -R or -Q) is not a subdirectory of the current directory + +Warning: no common logical root +Warning: in such case INSTALLDEFAULTROOT must be defined +Warning: the install-doc target is going to install files +Warning: in orphan_riscv_coqutil_Kami +bedrock2/compiler/lib/fiat_crypto_tactics/Test (real: 0.17, user: 0.04, sys: 0.04, mem: 55660 ko) +File "bedrock2/compiler/lib/LibTacticsMin.v", line 76, characters 0-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/lib/LibTacticsMin.v", line 121, characters 0-42: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope ltac_scope.". [undeclared-scope,deprecated] +File "bedrock2/compiler/lib/LibTacticsMin.v", line 463, characters 0-16: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/compiler/lib/LibTacticsMin (real: 0.92, user: 0.31, sys: 0.14, mem: 301996 ko) +bedrock2/compiler/src/NoActionSyntaxParams (real: 0.17, user: 0.04, sys: 0.03, mem: 57364 ko) +bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose (real: 0.16, user: 0.04, sys: 0.03, mem: 57340 ko) +File "./Kami/Lib/StringAsOT.v", line 86, characters 2-38: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/StringAsOT (real: 1.80, user: 0.70, sys: 0.19, mem: 423260 ko) +bedrock2/compiler/src/Simp (real: 1.02, user: 0.36, sys: 0.13, mem: 298624 ko) +bedrock2/compiler/src/util/Misc (real: 0.19, user: 0.05, sys: 0.04, mem: 70976 ko) +bedrock2/compiler/src/util/Learning (real: 0.16, user: 0.04, sys: 0.03, mem: 58420 ko) +File "./Kami/Lib/CommonTactics.v", line 276, characters 0-39: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/CommonTactics.v", line 277, characters 0-92: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/CommonTactics (real: 1.03, user: 0.38, sys: 0.13, mem: 319992 ko) +bedrock2/compiler/src/util/MyOmega (real: 0.97, user: 0.33, sys: 0.14, mem: 289700 ko) +bedrock2/compiler/src/util/LogGoal (real: 0.15, user: 0.03, sys: 0.03, mem: 54716 ko) +Kami/Lib/StringEq (real: 1.50, user: 0.55, sys: 0.18, mem: 413664 ko) +File "bedrock2/compiler/src/SeparationLogic.v", line 10, characters 0-29: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope sep_scope.". [undeclared-scope,deprecated] +bedrock2/compiler/src/SeparationLogic (real: 1.37, user: 0.48, sys: 0.16, mem: 352200 ko) +Kami/Lib/Nomega (real: 1.17, user: 0.38, sys: 0.19, mem: 363832 ko) +Kami/Lib/DepEq (real: 0.46, user: 0.14, sys: 0.08, mem: 160816 ko) +Kami/Lib/VectorFacts (real: 0.56, user: 0.17, sys: 0.09, mem: 180940 ko) +bedrock2/compiler/src/Rem4 (real: 1.86, user: 0.68, sys: 0.21, mem: 447424 ko) +bedrock2/compiler/src/SimplWordExpr (real: 1.85, user: 0.67, sys: 0.22, mem: 446424 ko) +Kami/Lib/StringAsList (real: 2.62, user: 1.08, sys: 0.20, mem: 421756 ko) +Kami/Lib/FinNotations (real: 0.43, user: 0.13, sys: 0.07, mem: 142092 ko) +bedrock2/compiler/src/RiscvWordProperties (real: 1.24, user: 0.43, sys: 0.18, mem: 362292 ko) +bedrock2/compiler/src/eqexact (real: 0.15, user: 0.04, sys: 0.03, mem: 56364 ko) +bedrock2/compiler/src/on_hyp_containing (real: 0.15, user: 0.04, sys: 0.03, mem: 56680 ko) +Kami/Lib/Reflection (real: 1.00, user: 0.34, sys: 0.15, mem: 328692 ko) +Kami/Lib/Concat (real: 1.06, user: 0.36, sys: 0.16, mem: 338456 ko) +bedrock2/compiler/src/Basic32Semantics (real: 1.46, user: 0.50, sys: 0.20, mem: 385968 ko) +riscv-coq/src riscv\n-Q bedrock2/deps/coqutil/src coqutil\n' > _CoqProject +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/compiler' +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject Kami/Lib/StringStringAsOT.v Kami/Lib/FMap.v Kami/Lib/ilist.v Kami/Lib/Indexer.v Kami/Lib/DepEq.v Kami/Lib/Nomega.v Kami/Lib/StringEq.v Kami/Lib/Misc.v Kami/Lib/Word.v Kami/Lib/FinNotations.v Kami/Lib/Reflection.v Kami/Lib/NatLib.v Kami/Lib/StringAsList.v Kami/Lib/Concat.v Kami/Lib/ListSupport.v Kami/Lib/VectorFacts.v Kami/Lib/StringAsOT.v Kami/Lib/CommonTactics.v Kami/Lib/WordSupport.v Kami/Lib/BasicLogic.v Kami/Lib/DepEqNat.v Kami/Lib/Struct.v Kami/SemFacts.v Kami/ParametricInlineLtac.v Kami/PartialInlineFacts.v Kami/Wf.v Kami/Semantics.v Kami/ParametricSyntax.v Kami/Inline.v Kami/StepDet.v Kami/InlineFacts.v Kami/Amortization.v Kami/Tutorial.v Kami/Label.v Kami/MapReifyEx.v Kami/ParametricEquiv.v Kami/ParametricInline.v Kami/Notations.v Kami/Substitute.v Kami/ParametricWf.v Kami/ParamDup.v Kami/SymEval.v Kami/Syntax.v Kami/ModuleBoundEx.v Kami/Tactics.v Kami/SymEvalTac.v Kami/ModularFacts.v Kami/Synthesize.v Kami/RefinementFacts.v Kami/Decomposition.v Kami/Renaming.v Kami/Kami.v Kami/Duplicate.v Kami/ModuleBound.v Kami/Specialize.v Kami/Ex/ProcThreeStage.v Kami/Ex/SimpleFifoCorrect.v Kami/Ex/IsaRv32PgmExt.v Kami/Ex/ProcThreeStInv.v Kami/Ex/Divider32.v Kami/Ex/SC.v Kami/Ex/Names.v Kami/Ex/OneEltFifo.v Kami/Ex/Multiplier64.v Kami/Ex/Multiplier32.v Kami/Ex/ProcFDInv.v Kami/Ex/ProcDec.v Kami/Ex/ProcFourStDec.v Kami/Ex/IsaRv32.v Kami/Ex/MemAtomic.v Kami/Ex/ProcFDInl.v Kami/Ex/IsaRv32Pgm.v Kami/Ex/Divider64.v Kami/Ex/Fifo.v Kami/Ex/ProcThreeStInl.v Kami/Ex/ProcDecSC.v Kami/Ex/ProcDecSCN.v Kami/Ex/NativeFifo.v Kami/Ex/FifoCorrect.v Kami/Ex/ProcThreeStDec.v Kami/Ex/RegFile.v Kami/Ex/InDepthTutorial.v Kami/Ex/ProcDecInv.v Kami/Ex/ProcFetchDecode.v Kami/Ex/SCMMInl.v Kami/Ex/ProcFDCorrect.v Kami/Ex/MemTypes.v Kami/Ex/ProcDecInl.v Kami/Ex/IsaRv32/PgmFact.v Kami/Ex/IsaRv32/PgmMatMulReport.v Kami/Ex/IsaRv32/PgmBankerWorker3.v Kami/Ex/IsaRv32/PgmGcd.v Kami/Ex/IsaRv32/PgmMatMulInit.v Kami/Ex/IsaRv32/PgmPeterson2.v Kami/Ex/IsaRv32/PgmHanoi.v Kami/Ex/IsaRv32/PgmBankerWorker1.v Kami/Ex/IsaRv32/PgmPeterson1.v Kami/Ex/IsaRv32/PgmBankerInit.v Kami/Ex/IsaRv32/PgmMatMulNormal1.v Kami/Ex/IsaRv32/PgmDekker1.v Kami/Ex/IsaRv32/PgmBankerWorker2.v Kami/Ex/IsaRv32/PgmBsort.v Kami/Ex/IsaRv32/PgmMatMulNormal2.v Kami/Ex/IsaRv32/PgmDekker2.v Kami/Ext/Extraction.v Kami/Ext/BSyntax.v -o Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/deps/kami' +COQDEP VFILES +COQDEP VFILES +COQC bedrock2/compiler/lib/fiat_crypto_tactics/Test.v +COQC bedrock2/compiler/lib/LibTacticsMin.v +COQC Kami/Lib/StringAsOT.v +COQC bedrock2/compiler/src/NoActionSyntaxParams.v +COQC bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose.v +COQC bedrock2/compiler/src/Simp.v +COQC Kami/Lib/CommonTactics.v +COQC bedrock2/compiler/src/util/Misc.v +COQC bedrock2/compiler/src/util/Learning.v +COQC bedrock2/compiler/src/util/MyOmega.v +COQC Kami/Lib/StringEq.v +COQC bedrock2/compiler/src/util/LogGoal.v +COQC bedrock2/compiler/src/SeparationLogic.v +COQC Kami/Lib/Nomega.v +COQC bedrock2/compiler/src/Rem4.v +COQC Kami/Lib/DepEq.v +COQC Kami/Lib/VectorFacts.v +COQC Kami/Lib/StringAsList.v +COQC bedrock2/compiler/src/SimplWordExpr.v +COQC bedrock2/compiler/src/RiscvWordProperties.v +COQC Kami/Lib/FinNotations.v +COQC Kami/Lib/Reflection.v +COQC bedrock2/compiler/src/eqexact.v +COQC bedrock2/compiler/src/on_hyp_containing.v +COQC bedrock2/compiler/src/Basic32Semantics.v +COQC Kami/Lib/Concat.v +COQC Kami/LKami/Lib/ListSupport (real: 1.09, user: 0.37, sys: 0.15, mem: 353524 ko) +File "bedrock2/compiler/src/UnmappedMemForExtSpec.v", line 45, characters 2-49: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/src/UnmappedMemForExtSpec.v", line 47, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/BasicLogic (real: 0.24, user: 0.07, sys: 0.03, mem: 87856 ko) +Kami/Lib/DepEqNat (real: 0.22, user: 0.06, sys: 0.03, mem: 76484 ko) +bedrock2/compiler/src/UnmappedMemForExtSpec (real: 1.68, user: 0.61, sys: 0.21, mem: 446012 ko) +Kami/Ex/Names (real: 1.02, user: 0.36, sys: 0.13, mem: 271052 ko) +bedrock2/compiler/src/NameGen (real: 0.95, user: 0.32, sys: 0.15, mem: 286108 ko) +bedrock2/compiler/src/examples/highlevel/For (real: 0.15, user: 0.04, sys: 0.02, mem: 55764 ko) +Kami/Lib/StringStringAsOT (real: 1.73, user: 0.63, sys: 0.19, mem: 420276 ko) +bedrock2/compiler/src/examples/toposort (real: 2.47, user: 0.98, sys: 0.21, mem: 426872 ko) +File "bedrock2/compiler/lib/LibTactics.v", line 55, characters 0-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/lib/LibTactics.v", line 100, characters 0-42: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope ltac_scope.". [undeclared-scope,deprecated] +File "bedrock2/compiler/lib/LibTactics.v", line 581, characters 0-16: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/lib/LibTactics.v", line 4771, characters 0-28: +Warning: skip_axiom is declared as a local axiom [local-declaration,scope] +File "bedrock2/compiler/lib/LibTactics.v", line 4998, characters 0-196: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope let_scope.". [undeclared-scope,deprecated] +Kami/Lib/NatLib (real: 3.58, user: 1.52, sys: 0.22, mem: 429812 ko) +bedrock2/compiler/lib/LibTactics (real: 2.73, user: 1.10, sys: 0.23, mem: 419492 ko) +bedrock2/compiler/lib/fiat_crypto_tactics/Not (real: 0.17, user: 0.05, sys: 0.03, mem: 56680 ko) +bedrock2/compiler/src/util/Tactics (real: 1.16, user: 0.40, sys: 0.17, mem: 282384 ko) +Kami/Lib/ilist (real: 2.17, user: 0.82, sys: 0.23, mem: 422368 ko) +bedrock2/compiler/src/util/Common (real: 1.69, user: 0.59, sys: 0.22, mem: 371952 ko) +Kami/Lib/Indexer (real: 2.29, user: 0.90, sys: 0.21, mem: 421100 ko) +bedrock2/compiler/src/util/ListLib (real: 2.24, user: 0.88, sys: 0.22, mem: 427540 ko) +Kami/Lib/Misc (real: 1.05, user: 0.35, sys: 0.16, mem: 299684 ko) +bedrock2/compiler/src/util/Set (real: 0.96, user: 0.30, sys: 0.14, mem: 282580 ko) +File "./Kami/Lib/Word.v", line 19, characters 0-35: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope word_scope.". [undeclared-scope,deprecated] +File "./Kami/Lib/Word.v", line 147, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/Word.v", line 400, characters 0-45: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/Word.v", line 1090, characters 0-43: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/Word.v", line 1217, characters 0-42: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 464, characters 4-57: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 464, characters 4-57: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 491, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 491, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 491, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 533, characters 4-108: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 533, characters 4-108: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 533, characters 4-108: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +ib/ListSupport.v +COQC bedrock2/compiler/src/UnmappedMemForExtSpec.v +COQC Kami/Lib/BasicLogic.v +COQC Kami/Lib/DepEqNat.v +COQC Kami/Ex/Names.v +COQC bedrock2/compiler/src/NameGen.v +COQC Kami/Lib/StringStringAsOT.v +COQC bedrock2/compiler/src/examples/highlevel/For.v +COQC bedrock2/compiler/src/examples/toposort.v +COQC Kami/Lib/NatLib.v +COQC bedrock2/compiler/lib/LibTactics.v +COQC Kami/Lib/ilist.v +COQC bedrock2/compiler/lib/fiat_crypto_tactics/Not.v +COQC bedrock2/compiler/src/util/Tactics.v +COQC bedrock2/compiler/src/util/Common.v +COQC Kami/Lib/Indexer.v +COQC bedrock2/compiler/src/util/ListLib.v +COQC Kami/Lib/Misc.v +COQC bedrock2/compiler/src/util/Set.v +COQC Kami/Lib/Word.v +COQC bedrock2/compiler/src/ExprImp.v +End of ExprImp.v +total time: 8.389s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 49.5% 44 0.222s +─preprocess_impl ----------------------- 0.7% 39.2% 44 0.177s +─abstract_unrecogs --------------------- 16.3% 34.8% 44 0.161s +─set_solver_generic -------------------- 0.2% 15.1% 30 0.405s +─<Coq.Init.Tauto.with_uniform_flags> --- 0.0% 14.9% 34 0.400s +─t_tauto_intuit ------------------------ 3.0% 14.9% 93 0.400s +─remember_unrecogs --------------------- 3.1% 12.3% 548 0.016s +─<Coq.Init.Tauto.simplif> -------------- 9.4% 12.1% 93 0.334s +─map_solver_core ----------------------- 0.5% 10.2% 29 0.085s +─map_solver_core_impl ------------------ 0.3% 9.6% 2 0.084s +─inversion H --------------------------- 9.4% 9.4% 74 0.061s +─inversion_lemma ----------------------- 0.1% 6.2% 9 0.217s +─inversionss --------------------------- 0.1% 6.0% 10 0.226s +─inverts (var) ------------------------- 0.1% 5.9% 63 0.030s +─inverts_tactic ------------------------ 0.2% 5.8% 63 0.030s +─unrecogs_in_prop ---------------------- 5.7% 5.7% 0 0.027s +─map_specialize ------------------------ 0.0% 5.1% 29 0.041s +─map_specialize_step ------------------- 3.7% 5.1% 35 0.036s +─congruence ---------------------------- 4.5% 4.5% 117 0.027s +─invert keep (var) --------------------- 0.1% 4.5% 63 0.028s +─remember P as name eqn:a -------------- 4.5% 4.5% 197 0.012s +─eauto (int_or_var_opt) (int_or_var_opt) 4.3% 4.5% 53 0.055s +─apply mk_Abstracted in a -------------- 3.8% 3.8% 264 0.002s +─replace (uconstr) with (constr) (clause 0.8% 3.6% 21 0.032s +─econstructor -------------------------- 2.8% 2.8% 49 0.010s +─maps_propositional -------------------- 0.1% 2.8% 45 0.043s +─pose proof IH as IH' ------------------ 2.6% 2.6% 3724 0.006s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 49.5% 44 0.222s + ├─preprocess_impl --------------------- 0.7% 39.2% 44 0.177s + │└abstract_unrecogs ------------------- 16.3% 34.8% 44 0.161s + │ ├─remember_unrecogs ----------------- 3.1% 12.3% 548 0.016s + │ │ ├─remember P as name eqn:a -------- 4.5% 4.5% 197 0.012s + │ │ └─apply mk_Abstracted in a -------- bedrock2/compiler/src/ExprImp (real: 23.40, user: 10.90, sys: 0.52, mem: 540624 ko) +bedrock2/compiler/src/ZNameGen (real: 1.33, user: 0.46, sys: 0.18, mem: 351756 ko) +bedrock2/compiler/src/examples/TestExprImp (real: 2.02, user: 0.72, sys: 0.26, mem: 458732 ko) +bedrock2/compiler/src/examples/highlevel/FuncMut (real: 1.61, user: 0.55, sys: 0.23, mem: 420416 ko) +File "bedrock2/compiler/src/FlatImp.v", line 418, characters 6-59: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "./Kami/Lib/Word.v", line 2154, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/Word (real: 55.47, user: 26.60, sys: 0.45, mem: 741048 ko) +File "./Kami/Lib/Struct.v", line 151, characters 0-57: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/Struct (real: 2.57, user: 0.99, sys: 0.21, mem: 435576 ko) +File "bedrock2/compiler/src/FlatImp.v", line 474, characters 6-210: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/FlatImp.v", line 474, characters 6-210: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/FlatImp.v", line 474, characters 6-210: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +Kami/Lib/WordSupport (real: 1.56, user: 0.56, sys: 0.20, mem: 432120 ko) +File "./Kami/Lib/FMap.v", line 563, characters 2-19: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 567, characters 2-51: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 595, characters 2-43: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 618, characters 2-44: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 626, characters 2-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 876, characters 2-45: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 913, characters 2-46: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 1328, characters 2-43: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 1475, characters 2-45: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 2482, characters 0-44: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope fmap_scope.". [undeclared-scope,deprecated] +File "./Kami/Lib/FMap.v", line 2681, characters 0-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 2682, characters 0-48: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/FMap (real: 20.44, user: 9.56, sys: 0.30, mem: 537308 ko) +File "bedrock2/compiler/src/FlatImp.v", line 624, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/FlatImp.v", line 624, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "./Kami/Syntax.v", line 1139, characters 2-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Syntax.v", line 1309, characters 0-121: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Syntax.v", line 1315, characters 0-84: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_struct_scope.". [undeclared-scope,deprecated] +File "./Kami/Syntax.v", line 1317, characters 0-54: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_scope.". [undeclared-scope,deprecated] +Kami/Syntax (real: 4.38, user: 1.89, sys: 0.23, mem: 479116 ko) +3.8% 3.8% 264 0.002s + │ └─unrecogs_in_prop ------------------ 5.7% 5.7% 0 0.027s + └─map_solver_core --------------------- 0.5% 10.2% 29 0.085s + â””map_solver_core_impl ---------------- 0.3% 9.6% 2 0.084s + ├─map_specialize -------------------- 0.0% 5.1% 29 0.041s + │└map_specialize_step --------------- 3.7% 5.1% 35 0.036s + └─maps_propositional ---------------- 0.1% 2.8% 45 0.043s +─set_solver_generic -------------------- 0.2% 15.1% 30 0.405s +â””<Coq.Init.Tauto.with_uniform_flags> --- 0.0% 14.0% 30 0.400s +â””t_tauto_intuit ------------------------ 3.0% 14.0% 89 0.400s +â””<Coq.Init.Tauto.simplif> -------------- 8.8% 11.3% 89 0.334s +─inversion_lemma ----------------------- 0.1% 6.2% 9 0.217s +â””inversionss --------------------------- 0.0% 3.3% 9 0.084s +â””inverts (var) ------------------------- 0.0% 3.2% 32 0.020s +â””inverts_tactic ------------------------ 0.1% 3.2% 32 0.020s +â””invert keep (var) --------------------- 0.0% 2.5% 32 0.018s +─inversion H --------------------------- 6.0% 6.0% 11 0.061s +─replace (uconstr) with (constr) (clause 0.8% 3.6% 21 0.032s +â””congruence ---------------------------- 2.8% 2.8% 21 0.027s +─eauto (int_or_var_opt) (int_or_var_opt) 3.2% 3.3% 44 0.023s +─econstructor -------------------------- 2.8% 2.8% 49 0.010s +─inversionss --------------------------- 0.1% 2.7% 1 0.226s +â””inverts (var) ------------------------- 0.0% 2.6% 31 0.030s +â””inverts_tactic ------------------------ 0.1% 2.6% 31 0.030s +â””invert keep (var) --------------------- 0.0% 2.0% 31 0.028s +─pose proof IH as IH' ------------------ 2.6% 2.6% 3724 0.006s + +COQC bedrock2/compiler/src/ZNameGen.v +COQC bedrock2/compiler/src/examples/TestExprImp.v +COQC bedrock2/compiler/src/examples/highlevel/FuncMut.v +COQC bedrock2/compiler/src/FlatImp.v +COQC Kami/Lib/Struct.v +COQC Kami/Lib/WordSupport.v +COQC Kami/Lib/FMap.v +COQC Kami/Syntax.v +COQC Kami/Semantics.v +End of FlatImp.v +total time: 26.926s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─simp ---------------------------------- 0.0% 71.8% 97 2.046s +─simp_step ----------------------------- 0.1% 71.8% 209 0.530s +─unique_inversion ---------------------- 71.4% 71.4% 3388 0.529s +─inversion H --------------------------- 66.5% 66.5% 686 0.199s +─equalities ---------------------------- 0.3% 57.3% 3 10.539s +─map_solver ---------------------------- 0.0% 11.2% 30 0.277s +─preprocess_impl ----------------------- 0.2% 8.1% 30 0.215s +─abstract_unrecogs --------------------- 2.9% 7.0% 30 0.198s +─protect_equalities -------------------- 2.0% 3.8% 593 0.011s +─congruence ---------------------------- 3.6% 3.6% 187 0.043s +─map_solver_core ----------------------- 0.1% 3.1% 25 0.077s +─map_solver_core_impl ------------------ 0.1% 3.0% 2 0.076s +─pose proof IH as IH' ------------------ 2.5% 2.5% 11247 0.004s +─remember_unrecogs --------------------- 0.6% 2.5% 303 0.016s +─inversion_lemma ----------------------- 0.0% 2.3% 11 0.208s +─inversionss --------------------------- 0.0% 2.2% 12 0.246s +─inverts (var) ------------------------- 0.0% 2.2% 81 0.023s +─inverts_tactic ------------------------ 0.1% 2.1% 81 0.023s +─assert (H : e1 = e2) by congruence ---- 0.1% 2.1% 80 0.026s + + tactic bedrock2/compiler/src/FlatImp (real: 62.83, user: 30.21, sys: 0.60, mem: 608088 ko) +bedrock2/compiler/src/util/SetSolverTests (real: 1.00, user: 0.30, sys: 0.15, mem: 290132 ko) +bedrock2/compiler/src/RegAlloc2 (real: 1.61, user: 0.53, sys: 0.21, mem: 386872 ko) +File "./Kami/Semantics.v", line 947, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Semantics (real: 13.71, user: 6.50, sys: 0.26, mem: 501300 ko) +Kami/Inline (real: 1.93, user: 0.70, sys: 0.23, mem: 469696 ko) +Kami/SymEval (real: 3.58, user: 1.48, sys: 0.24, mem: 476176 ko) +File "./Kami/Wf.v", line 16, characters 2-22: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Wf (real: 6.87, user: 3.06, sys: 0.29, mem: 499932 ko) +File "./Kami/SemFacts.v", line 1666, characters 0-20: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/SemFacts (real: 76.97, user: 37.08, sys: 0.39, mem: 601836 ko) +File "./Kami/ModularFacts.v", line 42, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/ModularFacts (real: 68.49, user: 32.76, sys: 0.55, mem: 885880 ko) +Kami/StepDet (real: 19.67, user: 9.26, sys: 0.28, mem: 504428 ko) +Kami/Label (real: 7.13, user: 3.17, sys: 0.27, mem: 486656 ko) +Kami/RefinementFacts (real: 18.99, user: 8.98, sys: 0.27, mem: 511956 ko) +Kami/InlineFacts (real: 83.55, user: 40.29, sys: 0.46, mem: 668564 ko) +File "./Kami/Renaming.v", line 16, characters 0-25: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Renaming.v", line 185, characters 2-44: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Renaming.v", line 203, characters 2-58: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Renaming (real: 81.06, user: 39.12, sys: 0.38, mem: 563328 ko) +Kami/Substitute (real: 2.10, user: 0.72, sys: 0.26, mem: 473852 ko) +Kami/Decomposition (real: 11.95, user: 5.56, sys: 0.26, mem: 507520 ko) +Kami/Amortization (real: 11.22, user: 5.12, sys: 0.29, mem: 505436 ko) +Kami/SymEvalTac (real: 1.93, user: 0.67, sys: 0.23, mem: 474056 ko) +Kami/PartialInlineFacts (real: 13.41, user: 6.24, sys: 0.29, mem: 509232 ko) +Kami/ParametricSyntax (real: 31.00, user: 14.78, sys: 0.34, mem: 561068 ko) +File "./Kami/Specialize.v", line 858, characters 2-44: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Specialize.v", line 1194, characters 0-130: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Specialize (real: 45.09, user: 21.68, sys: 0.30, mem: 506640 ko) +Kami/ParametricWf (real: 5.32, user: 2.19, sys: 0.29, mem: 489072 ko) +File "./Kami/ParametricEquiv.v", line 10, characters 2-22: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/ParametricEquiv (real: 6.90, user: 3.10, sys: 0.28, mem: 492424 ko) +File "./Kami/Notations.v", line 28, characters 0-81: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_expr_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 89, characters 0-169: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope init_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 110, characters 0-190: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_action_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 263, characters 0-212: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_sin_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 404, characters 0-247: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_gen_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 663, characters 0-260: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_meta_scope.". [undeclared-scope,deprecated] +Kami/Notations (real: 2.42, user: 0.87, sys: 0.28, mem: 460284 ko) +Kami/Duplicate (real: 5.46, user: 2.39, sys: 0.28, mem: 487424 ko) +Kami/Synthesize (real: 1.72, user: 0.59, sys: 0.24, mem: 442252 ko) +Kami/Ex/MemTypes (real: 1.99, user: 0.71, sys: 0.23, mem: 452980 ko) +Kami/Ext/BSyntax (real: 2.19, user: 0.79, sys: 0.27, mem: 477872 ko) +Kami/ParametricInline (real: 9.22, user: 4.19, sys: 0.30, mem: 509168 ko) +Kami/ModuleBound (real: 3.21, user: 1.29, sys: 0.27, mem: 485936 ko) +File "./Kami/ModuleBoundEx.v", line 25, characters 2-71: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope namebound_scope.". [undeclared-scope,deprecated] +File "./Kami/ModuleBoundEx.v", line 332, characters 2-71: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope namebound_scope.". [undeclared-scope,deprecated] +Kami/ModuleBoundEx (real: 7.16, user: 3.17, sys: 0.30, mem: 492768 ko) +Kami/ParamDup (real: 5.47, user: 2.42, sys: 0.25, mem: 489812 ko) +File "./Kami/Tactics.v", line 923, characters 0-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Tactics.v", line 924, characters 0-77: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Tactics.v", line 984, characters 0-543: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope mapping_scope.". [undeclared-scope,deprecated] +Kami/Tactics (real: 2.58, user: 0.89, sys: 0.26, mem: 484828 ko) +Kami/ParametricInlineLtac (real: 2.11, user: 0.77, sys: 0.26, mem: 486708 ko) +Kami/MapReifyEx (real: 4.56, user: 1.94, sys: 0.29, mem: 494008 ko) +File "./Kami/Ex/SC.v", line 432, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/SC.v", line 441, characters 2-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/SC.v", line 460, characters 0-72: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/SC (real: 8.37, user: 3.81, sys: 0.27, mem: 510132 ko) +File "./Kami/Ex/OneEltFifo.v", line 85, characters 0-50: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/OneEltFifo.v", line 86, characters 0-56: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/OneEltFifo.v", line 87, characters 0-56: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/OneEltFifo (real: 2.92, user: 1.15, sys: 0.26, mem: 487776 ko) +File "./Kami/Ex/Fifo.v", line 197, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 202, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 207, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 212, characters 2-36: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 266, characters 0-167: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 270, characters 0-175: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/Fifo (real: 16.06, user: 7.55, sys: 0.28, mem: 534616 ko) +File "./Kami/Ex/NativeFifo.v", line 174, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 181, characters 2-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 188, characters 2-36: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 195, characters 2-42: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 273, characters 0-215: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 277, characters 0-223: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/NativeFifo (real: 4.03, user: 1.70, sys: 0.27, mem: 490720 ko) +File "./Kami/Ex/IsaRv32.v", line 88, characters 0-79: +Warning: Notation "$ _" was already used in scope kami_expr_scope. +[notation-overridden,parsing] +Kami/Ex/IsaRv32 (real: 3.31, user: 1.30, sys: 0.26, mem: 509008 ko) +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiXq cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiXq cannot be defined because the projection ndiXq was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiX cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: HndiX cannot be defined because the projection ndiX was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiD cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: HndiD cannot be defined because the projection ndiD was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiDp cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDp cannot be defined because the projection ndiDp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiDn cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDn cannot be defined because the projection ndiDn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiCnt cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiCnt cannot be defined because the projection ndiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDdp cannot be defined because the projections ndiDp, ndiD were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDdn cannot be defined because the projections ndiDn, ndiDp were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiInv cannot be defined because the projections ndiD, ndiCnt, ndiXq, ndiX, +ndiD were not defined. [cannot-define-projection,records] +Kami/Ex/Divider32 (real: 125.49, user: 60.73, sys: 0.58, mem: 847228 ko) +File "./Kami/Ex/Multiplier64.v", line 399, characters 2-24: +Warning: Use of “Require†inside a section is deprecated. +[require-in-section,deprecated] +File "./Kami/Ex/Multiplier64.v", line 431, characters 4-143: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bword_scope.". [undeclared-scope,deprecated] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiM cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HbsiM cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiR cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HbsiR cannot be defined because the projection bsiR was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiMp cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMp cannot be defined because the projection bsiMp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiMn cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMn cannot be defined because the projection bsiMn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiP cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HbsiP cannot be defined because the projection bsiP was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiCnt cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiCnt cannot be defined because the projection bsiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMmp cannot be defined because the projections bsiMp, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMmn cannot be defined because the projections bsiMn, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HmInv cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiInv cannot be defined because the projections bsiCnt, bsiP, bsiM, bsiR +were not defined. [cannot-define-projection,records] +Kami/Ex/Multiplier64 (real: 430.88, user: 206.96, sys: 1.70, mem: 1980772 ko) +File "./Kami/Ex/Multiplier32.v", line 399, characters 2-24: +Warning: Use of “Require†inside a section is deprecated. +[require-in-section,deprecated] +File "./Kami/Ex/Multiplier32.v", line 431, characters 4-143: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bword_scope.". [undeclared-scope,deprecated] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiM cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HbsiM cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiR cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HbsiR cannot be defined because the projection bsiR was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiMp cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMp cannot be defined because the projection bsiMp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiMn cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMn cannot be defined because the projection bsiMn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiP cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HbsiP cannot be defined because the projection bsiP was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiCnt cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiCnt cannot be defined because the projection bsiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMmp cannot be defined because the projections bsiMp, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMmn cannot be defined because the projections bsiMn, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HmInv cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiInv cannot be defined because the projections bsiCnt, bsiP, bsiM, bsiR +were not defined. [cannot-define-projection,records] + local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─equalities ---------------------------- 0.3% 57.3% 3 10.539s + ├─simp -------------------------------- 0.0% 54.9% 77 2.046s + │└simp_step --------------------------- 0.0% 54.9% 160 0.530s + │└unique_inversion -------------------- 54.6% 54.6% 2632 0.529s + │ ├─inversion H ----------------------- 47.8% 47.8% 454 0.170s + │ └─protect_equalities ---------------- 1.7% 3.3% 454 0.010s + └─assert (H : e1 = e2) by congruence -- 0.1% 2.1% 80 0.026s + â””congruence -------------------------- 2.0% 2.0% 80 0.025s +─simp ---------------------------------- 0.0% 17.0% 20 0.417s +â””simp_step ----------------------------- 0.0% 17.0% 49 0.396s +â””unique_inversion ---------------------- 16.8% 16.8% 756 0.395s +â””inversion H --------------------------- 15.4% 15.4% 139 0.199s +─map_solver ---------------------------- 0.0% 11.2% 30 0.277s + ├─preprocess_impl --------------------- 0.2% 8.1% 30 0.215s + │└abstract_unrecogs ------------------- 2.9% 7.0% 30 0.198s + │└remember_unrecogs ------------------- 0.6% 2.5% 303 0.016s + └─map_solver_core --------------------- 0.1% 3.1% 25 0.077s + â””map_solver_core_impl ---------------- 0.1% 3.0% 2 0.076s +─pose proof IH as IH' ------------------ 2.5% 2.5% 11247 0.004s +─inversion_lemma ----------------------- 0.0% 2.3% 11 0.208s + +COQC bedrock2/compiler/src/util/SetSolverTests.v +COQC bedrock2/compiler/src/RegAlloc2.v +COQC bedrock2/compiler/src/FlattenExpr.v +COQC Kami/Inline.v +COQC Kami/SymEval.v +COQC Kami/Wf.v +COQC Kami/SemFacts.v +COQC Kami/ModularFacts.v +COQC Kami/StepDet.v +COQC Kami/Label.v +COQC Kami/RefinementFacts.v +COQC Kami/InlineFacts.v +COQC Kami/Renaming.v +COQC Kami/Substitute.v +COQC Kami/Decomposition.v +COQC Kami/Amortization.v +COQC Kami/SymEvalTac.v +COQC Kami/PartialInlineFacts.v +COQC Kami/ParametricSyntax.v +COQC Kami/Specialize.v +COQC Kami/ParametricWf.v +COQC Kami/ParametricEquiv.v +COQC Kami/Notations.v +COQC Kami/Duplicate.v +COQC Kami/Synthesize.v +COQC Kami/Ex/MemTypes.v +COQC Kami/Ext/BSyntax.v +COQC Kami/ParametricInline.v +COQC Kami/ModuleBound.v +COQC Kami/ModuleBoundEx.v +COQC Kami/ParamDup.v +COQC Kami/Tactics.v +COQC Kami/ParametricInlineLtac.v +COQC Kami/MapReifyEx.v +COQC Kami/Ex/SC.v +COQC Kami/Ex/OneEltFifo.v +COQC Kami/Ex/Fifo.v +COQC Kami/Ex/NativeFifo.v +COQC Kami/Ex/IsaRv32.v +COQC Kami/Ex/Divider32.v +COQC Kami/Ex/Multiplier64.v +COQC Kami/Ex/Multiplier32.v +End of FlattenExpr.v +total time: 587.422s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─maps ---------------------------------- 0.0% 88.3% 84 17.968s +─map_solver ---------------------------- 0.0% 54.8% 95 9.899s +─map_solver_core ----------------------- 0.1% 42.7% 92 9.552s +─map_solver_core_impl ------------------ 0.0% 42.6% 13 9.549s +─default_flattenBooleanExpr ------------ 0.0% 37.3% 21 36.430s +─map_specialize ------------------------ 0.0% 36.3% 92 7.801s +─map_specialize_step ------------------- 24.9% 36.3% 1911 5.056s +─pose_flatten_var_ineqs ---------------- 4.0% 34.0% 86 10.352s +─unique eapply (constr) in copy of (iden 1.0% 30.1% 59814 0.049s +─unshelve (tactic1) -------------------- 0.7% 26.8% 59814 0.048s +─eapply p in H' ------------------------ 26.2% 26.2% 59814 0.048s +─preprocess_impl ----------------------- 0.0% 12.1% 95 2.152s +─abstract_unrecogs --------------------- 7.0% 11.1% 95 2.057s +─simp ---------------------------------- 0.0% 6.3% 78 3.196s +─simp_step ----------------------------- 0.0% 6.3% 644 1.145s +─maps_propositional -------------------- 0.0% 6.0% 480 7.295s +─unique_inversion ---------------------- 3.9% 3.9% 5338 1.144s +─maps_leaf_tac ------------------------- 0.1% 3.5% 2100 0.035s +─inversion H --------------------------- 3.4% 3.4% 1097 1.070s +─congruence ---------------------------- 3.2% 3.2% 2495 0.085s +─pose proof H as H' -------------------- 3.1% 3.1% 185783 0.026s +─canonicalize_map_hyp ------------------ 0.6% 2.9% 37401 0.022s +─specialize (constr_with_bindings) ----- 2.5% 2.5% 166250 0.022s +─destruct_unique_match ----------------- 2.4% 2.4% 821 0.389s +─remember_unrecogs --------------------- 0.9% 2.4% 2727 0.644s +─ensure_no_body ------------------------ 1.0% 2.3% 161949 0.015s +─propositional_cheap_step -------------- 2.2% 2.3% 3800 0.016s +─auto (int_or_var_opt) (auto_using) (hin 1.8% 2.1% 3290 0.023s +─assert_fails -------------------------- 0.6% 2.0% 196767 0.023s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─maps ---------------------------------- 0.0% 52.5% 53 17.968s + ├─map_solver -------------------------- 0.0% 30.3% 64 9.899s + │ ├─map_solver_core ------------------- 0.0% 22.4% 64 9.552s + │ │└map_solver_core_impl -------------- 0.0% 22.4% 1 9.549s + │ │ ├─map_specialize ------------------ 0.0% 17.8% 64 5.088s + │ │ │└map_specialize_step ------------- 12.7% 17.8% 1057 4.472s + │ │ └─maps_propositional -------------- 0.0% 4.4% 350 7.295s + │ │ â””maps_leaf_tac ------------------- 0.0% 2.5% 1634 0.025s + │ └─preprocess_impl ------------------- 0.0% 7.9% 64 2.152s + │ â””abstract_unrecogs ----------------- 4.6% 7.3% 64 2.057s + └─pose_flatten_var_ineqs -------------- 2.5% 22.1% 53 10.352s + â””unique eapply (constr) in copy of (id 0.6% 19.7% 36953 0.049s + â””unshelve (tactic1) ------------------ 0.4% 17.8% 36953 0.048s + â””eapply p in H' ---------------------- 17.4% 17.4% 36953 0.048s +─default_flattenBooleanExpr ------------ 0.0% 37.3% 21 36.430s + ├─maps -------------------------------- 0.0% 35.0% 30 12.207s + │ ├─map_solver ------------------------ 0.0% 24.0% 30 9.184s + │ │ ├─map_solver_core ----------------- 0.0% 20.1% 27 7.870s + │ │ │└map_solver_core_impl ------------ 0.0% 20.1% 12 7.859s + │ │ │└map_specialize ------------------ 0.0% 18.3% 27 7.801s + │ │ │└map_specialize_step ------------- 12.1% 18.3% 845 5.056s + │ │ └─preprocess_impl ----------------- 0.0% 3.9% 30 1.349s + │ │ â””abstract_unrecogs --------------- 2.3% 3.6% 30 1.238s + │ └─pose_flatten_var_ineqs ------------ 1.4% 11.0% 30 3.250s + │ â””unique eapply (constr) in copy of ( 0.4% 9.6% 21011 0.027s + │ â””unshelve (tactic1) ---------------- 0.2% 8.3% 21011 0.027s + │ â””eapply p in H' -------------------- 8.1% 8.1% 21011 0.027s + └─simp -------------------------------- 0.0% 2.2% 21 1.839s + â””simp_step --------------------------- 0.0% 2.1% 243 0.174s +─simp ---------------------------------- 0.0% 4.2% 57 3.196s +â””simp_step ----------------------------- 0.0% 4.2% 401 1.145s +â””unique_inversion --------bedrock2/compiler/src/FlattenExpr (real: 1225.77, user: 593.01, sys: 9.58, mem: 1060368 ko) +bedrock2/compiler/src/examples/TestFlatImp (real: 4.39, user: 0.71, sys: 0.28, mem: 459820 ko) +bedrock2/compiler/src/FlatToRiscvDef (real: 2.44, user: 0.69, sys: 0.24, mem: 466532 ko) +bedrock2/compiler/src/RegAlloc3 (real: 1.44, user: 0.50, sys: 0.18, mem: 389304 ko) +bedrock2/compiler/src/EmitsValid (real: 49.36, user: 23.66, sys: 0.35, mem: 610544 ko) +bedrock2/compiler/src/RegAllocAnnotatedNotations (real: 1.73, user: 0.45, sys: 0.18, mem: 350576 ko) +bedrock2/compiler/src/GoFlatToRiscv (real: 15.43, user: 6.89, sys: 0.27, mem: 480324 ko) +bedrock2/compiler/src/FlatToRiscv32 (real: 17.62, user: 8.26, sys: 0.29, mem: 505664 ko) +Kami/Ex/Multiplier32 (real: 214.00, user: 104.11, sys: 0.86, mem: 1131272 ko) +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiXq cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiXq cannot be defined because the projection ndiXq was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiX cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: HndiX cannot be defined because the projection ndiX was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiD cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: HndiD cannot be defined because the projection ndiD was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiDp cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDp cannot be defined because the projection ndiDp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiDn cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDn cannot be defined because the projection ndiDn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiCnt cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiCnt cannot be defined because the projection ndiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDdp cannot be defined because the projections ndiDp, ndiD were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDdn cannot be defined because the projections ndiDn, ndiDp were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiInv cannot be defined because the projections ndiD, ndiCnt, ndiXq, ndiX, +ndiD were not defined. [cannot-define-projection,records] +Kami/Ex/Divider64 (real: 271.33, user: 131.59, sys: 1.01, mem: 1411224 ko) +bedrock2/compiler/src/FlatToRiscv (real: 415.73, user: 202.44, sys: 0.75, mem: 899104 ko) +bedrock2/compiler/src/Pipeline (real: 5.85, user: 2.50, sys: 0.27, mem: 505076 ko) +Kami/Ex/FifoCorrect (real: 125.57, user: 61.07, sys: 0.56, mem: 798376 ko) +File "./Kami/Ex/RegFile.v", line 132, characters 0-66: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/RegFile.v", line 133, characters 0-69: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/RegFile (real: 4.25, user: 1.81, sys: 0.24, mem: 495792 ko) +Kami/Ex/SCMMInl (real: 11.10, user: 5.07, sys: 0.30, mem: 561800 ko) +Kami/Kami (real: 2.25, user: 0.74, sys: 0.24, mem: 485920 ko) +File "./Kami/Ex/MemAtomic.v", line 121, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/compiler/src/examples/MMIO (real: 32.79, user: 15.63, sys: 0.31, mem: 555732 ko) +File "./Kami/Ex/MemAtomic.v", line 128, characters 2-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/MemAtomic.v", line 137, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/MemAtomic.v", line 144, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/MemAtomic.v", line 166, characters 0-146: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/MemAtomic (real: 3.50, user: 1.47, sys: 0.24, mem: 497260 ko) +bedrock2/compiler/src/examples/InlineAssemblyMacro (real: 1.97, user: 0.71, sys: 0.26, mem: 483356 ko) +bedrock2/compiler/src/examples/CompileExamples (real: 2.52, user: 0.74, sys: 0.21, mem: 501084 ko) +bedrock2/compiler/src/examples/Fibonacci (real: 7.21, user: 3.30, sys: 0.23, mem: 510956 ko) +-------------- 3.2% 3.2% 3570 1.144s +â””inversion H --------------------------- 2.7% 2.7% 626 1.070s + +COQC bedrock2/compiler/src/examples/TestFlatImp.v +COQC bedrock2/compiler/src/FlatToRiscvDef.v +COQC bedrock2/compiler/src/RegAlloc3.v +COQC bedrock2/compiler/src/EmitsValid.v +COQC bedrock2/compiler/src/RegAllocAnnotatedNotations.v +COQC bedrock2/compiler/src/GoFlatToRiscv.v +COQC bedrock2/compiler/src/FlatToRiscv32.v +COQC bedrock2/compiler/src/FlatToRiscv.v +COQC Kami/Ex/Divider64.v +COQC Kami/Ex/FifoCorrect.v +COQC bedrock2/compiler/src/Pipeline.v +COQC bedrock2/compiler/src/examples/MMIO.v +compiled@{} = +[[Lui addr 268582912; Addi addr addr 0; Lw i addr 0; +Beq i 0 16; Mul s i i; Sw addr s 0; Jal 0 (-16)]] + : list Instruction +COQC Kami/Ex/RegFile.v +COQC Kami/Ex/SCMMInl.v +COQC Kami/Kami.v +COQC Kami/Ex/MemAtomic.v +COQC bedrock2/compiler/src/examples/InlineAssemblyMacro.v +COQC Kami/Ex/SimpleFifoCorrect.v +compiled@{} = +[[Lw 9 1 0; Mul 4 2 3; Add 5 2 3; Sub 6 2 3; Auipc 31 0; +Add 31 31 9; Jalr 0 31 8; Addi 7 4 0; Jal 0 20; Addi 7 5 0; +Jal 0 12; Addi 7 6 0; Jal 0 4]] + : list Instruction +COQC bedrock2/compiler/src/examples/CompileExamples.v +COQC bedrock2/compiler/src/examples/Fibonacci.v +fib_ExprImp@{compiler.examples.Fibonacci.17} = +fun n : Z => +cmd.seq (cmd.set 1 (expr.literal 0)) + (cmd.seq (cmd.set 2 (expr.literal 1)) + (cmd.seq (cmd.set 4 (expr.literal 0)) + (cmd.while (expr.op ltu (expr.var 4) (expr.literal n)) + (cmd.seq (cmd.set 3 (expr.op add (expr.var 1) (expr.var 2))) + (cmd.seq (cmd.set 1 (expr.var 2)) + (cmd.seq (cmd.set 2 (expr.var 3)) + (cmd.set 4 (expr.op add (expr.var 4) (expr.literal 1))))))))) + : Z -> cmd + +Argument scope is [Z_scope] + = SSeq (SLit 1 0) + (SSeq (SLit 2 1) + (SSeq (SLit 4 0) + (SLoop (SSeq SSkip (SLit 5 6)) (CondBinary BLtu 4 5) + (SSeq (SSeq SSkip (SSeq SSkip (SOp 3 add 1 2))) + (SSeq (SSet 1 2) + (SSeq (SSet 2 3) + (SSeq SSkip (SSeq (SLit 6 1) (SOp 4 add 4 6))))))))) + : stmt +Finished transaction in 0.012 secs (0.007u,0.s) (successful) +fib6_riscv@{} = +[Addi 1 0 0; Addi 2 0 1; Addi 4 0 0; Addi 5 0 6; Bgeu 4 5 28; +Add 3 1 2; Add 1 0 2; Add 2 0 3; Addi 6 0 1; Add 4 4 6; +Jal 0 (-28)] + : list Instruction +fib6_riscv@{} = +RISCV: + addi x1, x0, 0 + addi x2, x0, 1 + addi x4, x0, 0 + addi x5, x0, 6 + bgeu x4, x5, 28 + add x3, x1, x2 + add x1, x0, x2 + add x2, x0, x3 + addi x6, x0, 1 + add x4, x4, x6 + jal x0, -28 + : list Instruction +93000000 13011000 13020000 93026000 637e5200 b3812000 b3002000 33013000 +13031000 33026200 6ff05ffe + = {| Naive.unsigned := 13; Naive._unsigned_in_range := eq_refl |} + : word +COQC bedrock2/compiler/src/examples/FE310Compiler.v +Finished transaction in 0.063 secs (0.028u,0.001s) (successful) +Axioms: +AdmitAxiom.proof_admitted : False + used in map_ok_subproof5 to prove: forall (m1 m2 : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get m2 k = Some v -> + map.get (map.putmany m1 m2) k = Some v + used in map_ok_subproof4 to prove: forall (m1 m2 : map p ok) + (k : parameters.key), + map.get m2 k = None -> + map.get (map.putmany m1 m2) k = + map.get m1 k + used in map_ok_subproof3 to prove: forall (m : map p ok) + (k k' : parameters.key), + k <> k' -> + map.get (map.remove m k') k = map.get m k + used in map_ok_subproof2 to prove: forall (m : map p ok) + (k : parameters.key), + map.get (map.remove m k) k = None + used in map_ok_subproof1 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value) + (k' : parameters.key), + k <> k' -> + map.get (map.put m k' v) k = map.get m k + used in map_ok_subproof0 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get (map.put m k v) k = Some v + used in map_ok_subproof to prove: forall m1 m2 : map p ok, + (forall k : parameters.key, + map.get m1 k = map.get m2 k) -> + m1 = m2 +ext_spec_Proper : forall + (trace : list + (mem * actname * list Semantics.word * + (mem * list Semantics.word))) + (m : mem) (act : actname) (args : list Semantics.word), + Morphisms.Proper + (Morphisms.respectful + (Morphisms.pointwise_relation mem + (Morphisms.pointwise_relation + (list Semantics.word) Basics.impl)) Basics.impl) + (ext_spec trace m act args) +Axioms: +FlatToRiscv.word_eq_dec : forall p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + DecidableEq word +undef_on_unchecked_store_byte_tuple_list : forall + (n : nat) + (l : list (HList.tuple word8 n)) + (start : word32), + map.undef_on + (unchecked_store_byte_tuple_list + start l map.empty) + (fun x : word32 => + ~ + word.unsigned start <= + word.unsigned x < + word.unsigned start + + Z.of_nat n * Zlength l) +store_program_empty : forall (prog : list Instruction) (addr : word), + GoFlatToRiscv.program addr prog + (unchecked_store_program addr prog map.empty) +FlatToRiscv.reduce_eq_to_sub_and_lt : forall + p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + forall (y z : word) + (T : Type) + (thenVal elseVal : T), + (if word.eqb y z + then thenVal + else elseVal) = + (if + word.ltu (word.sub y z) (word.of_Z 1) + then thenVal + else elseVal) +real_ext_spec_implies_simple_ext_spec : forall (p : MMIO.parameters) + (t : trace) + (m : MMIO.mem) + (a : MMIOAction) + (args : list MMIO.word) + (post : + MMIO.mem -> + list MMIO.word -> Prop), + real_ext_spec t m a args post -> + simple_ext_spec t m a args post +FlatToRiscv.put_put_same : forall (K V : Type) (M : map.map K V) + (k : K) (v1 v2 : V) (m : M), + map.put (map.put m k v1) k v2 = map.put m k v2 +PropExtensionality.propositional_extensionality : +forall P Q : Prop, P <-> Q -> P = Q +AdmitAxiom.proof_admitted : False + used in map_ok_subproof5 to prove: forall (m1 m2 : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get m2 k = Some v -> + map.get (map.putmany m1 m2) k = Some v + used in map_ok_subproof4 to prove: forall (m1 m2 : map p ok) + (k : parameters.key), + map.get m2 k = None -> + map.get (map.putmany m1 m2) k = + map.get m1 k + used in map_ok_subproof3 to prove: forall (m : map p ok) + (k k' : parameters.key), + k <> k' -> + map.get (map.remove m k') k = map.get m k + used in map_ok_subproof2 to prove: forall (m : map p ok) + (k : parameters.key), + map.get (map.remove m k) k = None + used in map_ok_subproof1 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value) + (k' : parameters.key), + k <> k' -> + map.get (map.put m k' v) k = map.get m k + used in map_ok_subproof0 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get (map.put m k v) k = Some v + used in map_ok_subproof to prove: forall m1 m2 : map p ok, + (forall k : parameters.key, + map.get m1 k = map.get m2 k) -> + m1 = m2 +max_ext_call_code_size_bound : forall (p : FlattenExpr.parameters) + (f : FlattenExpr.actname), + 0 <= FlattenExpr.max_ext_call_code_size f <= 7 +map_undef_on_weaken : forall (P Q : PropSet.set word32) (m : Mem), + map.undef_on m Q -> + PropSet.subset P Q -> map.undef_on m P +FlatImp.exec.map_split_diff : forall pp : Semantics.parameters, + FlatImp.env -> + forall m m1 m2 m3 : mem, + map.split m m2 m1 -> + map.split m m3 m1 -> m2 = m3 +load4bytes_in_MMIO_is_None : forall (p : MMIO.parameters) + (m : MMIO.mem) (addr : MMIO.word), + map.undef_on m isMMIOAddr -> + isMMIOAddr addr -> load_bytes 4 m addr = None +FunctionalExtensionality.functional_extensionality_dep : +forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), +(forall x : A, f x = g x) -> f = g +FlatImp.exec.ext_spec_intersect : forall (pp : Semantics.parameters) + (t : list + (mem * actname * + list Semantics.word * + (mem * list Semantics.word))) + (mGive1 mGive2 : mem) + (a : actname) + (args : list Semantics.word) + (post1 + post2 : mem -> + list Semantics.word -> Prop), + ext_spec t mGive1 a args post1 -> + ext_spec t mGive2 a args post2 -> + mGive1 = mGive2 /\ + ext_spec t mGive1 a args + (fun (mReceive : mem) + (resvals : list Semantics.word) => + post1 mReceive resvals /\ + post2 mReceive resvals) +ext_spec_Proper : forall + (trace : list + (mem * actname * list Semantics.word * + (mem * list Semantics.word))) + (m : mem) (act : actname) (args : list Semantics.word), + Morphisms.Proper + (Morphisms.respectful + (Morphisms.pointwise_relation mem + (Morphisms.pointwise_relation + (list Semantics.word) Basics.impl)) Basics.impl) + (ext_spec trace m act args) +FlatToRiscv.divisibleBy4_admit : forall + p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + forall x y : word, + FlatToRiscv.divisibleBy4 x -> + FlatToRiscv.divisibleBy4 y +compile_lit_new_size : forall iset : InstructionSet, + FlatToRiscvDef.FlatToRiscvDef.parameters -> + forall (x : Register) (v : Z), + 0 <= + Zlength (FlatToRiscvDef.compile_lit_new iset x v) <= + 15 +FlatToRiscv.compile_lit_correct_full : forall + p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + forall + (initialL : + RiscvMachine.RiscvMachine + Syntax.varname + FlatToRiscvDef.FlatToRiscvDef.actname) + (post : RiscvMachine.RiscvMachine + Register + FlatToRiscvDef.FlatToRiscvDef.actname -> + Prop) + (x : Syntax.varname) + (v : Z) + (R : FlatToRiscv.FlatToRiscv.mem -> + Prop), + getNextPc initialL = + add (getPc initialL) (ZToReg 4) -> + let insts := + FlatToRiscvDef.compile_stmt + FlatToRiscv.FlatToRiscv.iset + (FlatImp.SLit x v) in + let d := + mul (ZToReg 4) + (ZToReg (Zlength insts)) in + Separation.sep + (GoFlatToRiscv.program + (getPc initialL) insts) R + (getMem initialL) -> + FlatToRiscvDef.valid_registers + (FlatImp.SLit x v) -> + FlatToRiscv.runsTo + (withRegs + (map.put + (getRegs inibedrock2/compiler/src/examples/FE310Compiler (real: 42.80, user: 20.27, sys: 0.35, mem: 610324 ko) +bedrock2/compiler/src/examples/EditDistExample (real: 2.19, user: 0.80, sys: 0.26, mem: 499980 ko) +bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump (real: 2.04, user: 0.74, sys: 0.23, mem: 505316 ko) +Kami/Ex/IsaRv32Pgm (real: 2.28, user: 0.82, sys: 0.26, mem: 507796 ko) +File "./Kami/Ex/ProcDec.v", line 279, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDec.v", line 289, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDec.v", line 301, characters 2-31: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDec.v", line 314, characters 0-76: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcDec (real: 9.01, user: 4.13, sys: 0.26, mem: 512264 ko) +Kami/Ext/Extraction (real: 2.36, user: 0.79, sys: 0.24, mem: 488532 ko) +Kami/Ex/SimpleFifoCorrect (real: 74.95, user: 37.44, sys: 0.37, mem: 672092 ko) +File "./Kami/Tutorial.v", line 72, characters 0-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 801, characters 2-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Tutorial (real: 7.47, user: 3.39, sys: 0.25, mem: 517872 ko) +File "./Kami/Ex/ProcThreeStage.v", line 806, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 811, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 816, characters 2-38: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 821, characters 2-38: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 831, characters 2-36: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 839, characters 2-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 844, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/IsaRv32/PgmGcd (real: 4.45, user: 1.88, sys: 0.27, mem: 521816 ko) +File "./Kami/Ex/ProcThreeStage.v", line 855, characters 2-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 871, characters 0-251: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcThreeStage (real: 12.09, user: 5.62, sys: 0.28, mem: 535096 ko) +Kami/Ex/IsaRv32/PgmFact (real: 4.26, user: 1.83, sys: 0.25, mem: 522312 ko) +Kami/Ex/IsaRv32/PgmBsort (real: 4.09, user: 1.75, sys: 0.23, mem: 521896 ko) +Kami/Ex/IsaRv32/PgmHanoi (real: 4.05, user: 1.74, sys: 0.23, mem: 522080 ko) +Kami/Ex/IsaRv32/PgmDekker1 (real: 4.24, user: 1.78, sys: 0.27, mem: 520604 ko) +Kami/Ex/IsaRv32/PgmDekker2 (real: 4.29, user: 1.83, sys: 0.25, mem: 524584 ko) +Kami/Ex/IsaRv32/PgmPeterson1 (real: 4.23, user: 1.80, sys: 0.27, mem: 519680 ko) +Kami/Ex/IsaRv32/PgmPeterson2 (real: 4.14, user: 1.80, sys: 0.24, mem: 519696 ko) +Kami/Ex/IsaRv32/PgmMatMulInit (real: 4.29, user: 1.81, sys: 0.25, mem: 521416 ko) +Kami/Ex/IsaRv32/PgmMatMulNormal1 (real: 4.30, user: 1.83, sys: 0.26, mem: 519240 ko) +Kami/Ex/IsaRv32/PgmMatMulNormal2 (real: 4.21, user: 1.81, sys: 0.24, mem: 519724 ko) +Kami/Ex/IsaRv32/PgmMatMulReport (real: 4.32, user: 1.87, sys: 0.25, mem: 519908 ko) +Kami/Ex/IsaRv32/PgmBankerInit (real: 4.21, user: 1.81, sys: 0.24, mem: 522124 ko) +Kami/Ex/IsaRv32/PgmBankerWorker1 (real: 4.43, user: 1.87, sys: 0.27, mem: 522776 ko) +Kami/Ex/IsaRv32/PgmBankerWorker2 (real: 4.24, user: 1.80, sys: 0.25, mem: 520460 ko) +Kami/Ex/ProcThreeStInl (real: 2.03, user: 0.75, sys: 0.23, mem: 490144 ko) +Kami/Ex/IsaRv32/PgmBankerWorker3 (real: 4.25, user: 1.85, sys: 0.24, mem: 520188 ko) +File "./Kami/Ex/ProcFetchDecode.v", line 333, characters 2-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcFetchDecode.v", line 342, characters 2-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcFetchDecode.v", line 356, characters 0-68: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcFetchDecode (real: 4.85, user: 2.11, sys: 0.24, mem: 508168 ko) +tialL) x + (ZToReg v)) + (withPc + (add (getPc initialL) d) + (withNextPc + (add (getNextPc initialL) d) + initialL))) post -> + FlatToRiscv.runsTo initialL post +assume_riscv_word_properties : forall p : MMIO.parameters, + RiscvWordProperties.word.riscv_ok MMIO.word +COQC bedrock2/compiler/src/examples/EditDistExample.v +COQC bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump.v +37250200 1305c5fe 03210500 b7850010 93850500 37060040 13060600 9306f001 +3377d100 93070001 3318f700 b3680601 23a01501 13031000 37390110 13098901 +93090027 23203901 373a0110 130a8a00 23206a00 b73a0110 938aca00 23a06a00 +372b0110 130b8b03 b70b0300 938b0b00 23207b01 9303e002 b3007000 33027340 +630c0206 b7020080 93820200 33015000 b3047340 33fc2400 b37c5c00 638c0c00 +373d0110 130d4d00 03210d00 b3846440 6ff05ffe 37340110 13040400 b3015000 +b3047340 b3fd3400 33fe5d00 63080e00 83210400 b3846440 6ff0dffe 23201400 +b3002000 33026240 63967000 33424200 6f004000 6ff0dff8 +make[3]: Leaving directory 'bedrock2/compiler' +make[2]: Leaving directory 'bedrock2/compiler' +COQC Kami/Ex/IsaRv32Pgm.v +COQC Kami/Ex/ProcDec.v +COQC Kami/Ext/Extraction.v +COQC Kami/Tutorial.v +COQC Kami/Ex/ProcThreeStage.v +COQC Kami/Ex/IsaRv32/PgmGcd.v +COQC Kami/Ex/IsaRv32/PgmFact.v +COQC Kami/Ex/IsaRv32/PgmBsort.v +COQC Kami/Ex/IsaRv32/PgmHanoi.v +COQC Kami/Ex/IsaRv32/PgmDekker1.v +COQC Kami/Ex/IsaRv32/PgmDekker2.v +COQC Kami/Ex/IsaRv32/PgmPeterson1.v +COQC Kami/Ex/IsaRv32/PgmPeterson2.v +COQC Kami/Ex/IsaRv32/PgmMatMulInit.v +COQC Kami/Ex/IsaRv32/PgmMatMulNormal1.v +COQC Kami/Ex/IsaRv32/PgmMatMulNormal2.v +COQC Kami/Ex/IsaRv32/PgmMatMulReport.v +COQC Kami/Ex/IsaRv32/PgmBankerInit.v +COQC Kami/Ex/IsaRv32/PgmBankerWorker1.v +COQC Kami/Ex/IsaRv32/PgmBankerWorker2.v +COQC Kami/Ex/IsaRv32/PgmBankerWorker3.v +COQC Kami/Ex/ProcThreeStInl.v +COQC Kami/Ex/ProcFetchDecode.v +COQC Kami/Ex/ProcDecInl.v +COQC Kami/Ex/InDepthTutorial.v +Inductive Modules : Type := + RegFile : string -> + list string -> + string -> + forall (IdxBits : nat) (Data : Kind), + ConstT (Vector Data IdxBits) -> Modules + | Mod : list RegInitT -> + list (Struct.Attribute (Action Void)) -> list DefMethT -> Modules + | ConcatMod : Modules -> Modules -> Modules + +For RegFile: Arguments IdxBits, Data are implicit +For RegFile: Argument scopes are [string_scope list_scope string_scope + nat_scope _ _] +For Mod: Argument scopes are [list_scope list_scope list_scope] +Inductive ActionT (ty : Kind -> Type) (lretT : Kind) : Type := + MCall : string -> + forall s : SignatureT, + (arg s) @ (ty) -> + (ty (ret s) -> ActionT ty lretT) -> ActionT ty lretT + | Let_ : forall lretT' : FullKind, + Expr ty lretT' -> + (fullType ty lretT' -> ActionT ty lretT) -> ActionT ty lretT + | ReadNondet : forall k : FullKind, + (fullType ty k -> ActionT ty lretT) -> ActionT ty lretT + | ReadReg : string -> + forall k : FullKind, + (fullType ty k -> ActionT ty lretT) -> ActionT ty lretT + | WriteReg : string -> + forall k : FullKind, + Expr ty k -> ActionT ty lretT -> ActionT ty lretT + | IfElse : (Bool) @ (ty) -> + forall k : Kind, + ActionT ty k -> + ActionT ty k -> (ty k -> ActionT ty lretT) -> ActionT ty lretT + | Assert_ : (Bool) @ (ty) -> ActionT ty lretT -> ActionT ty lretT + | Displ : list (Disp ty) -> ActionT ty lretT -> ActionT ty lretT + | Return : (lretT) @ (ty) -> ActionT ty lretT + +For MCall: Arguments ty, lretT are implicit +For Let_: Arguments ty, lretT, lretT' are implicit +For ReadNondet: Arguments ty, lretT are implicit +For ReadReg: Arguments ty, lretT are implicit +For WriteReg: Arguments ty, lretT, k are implicit +For IfElse: Arguments ty, lretT, k are implicit +For Assert_: Arguments ty, lretT are implicit +For Displ: Arguments ty, lretT are implicit +For Return: Arguments ty, lretT are implicit +For ActionT: Argument scopes are [function_scope _] +For MCall: Argument scopes are [function_scope _ string_scope _ _ + function_scope] +For Let_: Argument scopes are [function_scope _ _ _ function_scope] +For ReadNondet: Argument scopes are [function_scope _ _ function_scope] +For ReadReg: Argument scopes are [function_scope _ string_scope _ + function_scope] +For WriteReg: Argument scopes are [function_scope _ string_scope _ _ _] +For IfElse: Argument scopes are [function_scope _ _ _ _ _ function_scope] +For Assert_: Argument scopes are [function_scope _ _ _] +For Displ: Argument scopes are [function_scope _ list_scope _] +For Return: Argument scopes are [function_scope _ _] +Inductive Expr (ty : Kind -> Type) : FullKind -> Type := + Var : forall k : FullKind, fullType ty k -> Expr ty k + | Const : forall k : Kind, ConstT k -> (k) @ (ty) + | UniBool : UniBoolOp -> (Bool) @ (ty) -> (Bool) @ (ty) + | BinBool : BinBoolOp -> (Bool) @ (ty) -> (Bool) @ (ty) -> (Bool) @ (ty) + | UniBit : forall n1 n2 : nat, + UniBitOp n1 n2 -> (Bit n1) @ (ty) -> (Bit n2) @ (ty) + | BinBit : forall n1 n2 n3 : nat, + BinBitOp n1 n2 n3 -> + (Bit n1) @ (ty) -> (Bit n2) @ (ty) -> (Bit n3) @ (ty) + | BinBitBool : forall n1 n2 : nat, + BinBitBoolOp n1 n2 -> + (Bit n1) @ (ty) -> (Bit n2) @ (ty) -> (Bool) @ (ty) + | ITE : forall k : FullKind, + (Bool) @ (ty) -> Expr ty k -> Expr ty k -> Expr ty k + | Eq : forall k : Kind, (k) @ (ty) -> (k) @ (ty) -> (Bool) @ (ty) + | ReadIndex : forall (i : nat) (k : Kind), + (Bit i) @ (ty) -> (Vector k i) @ (ty) -> (k) @ (ty) + | ReadField : forall (n : nat) (ls : Vector.t (Struct.Attribute Kind) n) + (i : Fin.t n), + (Struct ls) @ (ty) -> + (Vector.nth (Vector.map (Struct.attrType (A:=Kind)) ls) i) @ + (ty) + | BuildVector : forall (n : Kind) (k : nat), + Vec (n) @ (ty) k -> (Vector n k) @ (ty) + | BuildStruct : forall (n : nat) + (attrs : Vector.t (Struct.Attribute Kind) n), + ilist.ilist + (fun a : Struct.Attribute Kind => + (Struct.attrType a) @ (ty)) attrs -> + (Struct attrs) @ (ty) + | UpdateVector : forall (i : nat) (k : Kind), + (Vector k i) @ (ty) -> + (Bit i) @ (ty) -> (k) @ (ty) -> (Vector k i) @ (ty) + | ReadArrayIndex : forall (i : nat) (k : Kind), + (Bit (Nat.log2 (2 * i))) @ (ty) -> + (Array k i) @ (ty) -> (k) @ (ty) + | BuildArray : forall (n : Kind) (k : nat), + Vector.t (n) @ (ty) (S k) -> (Array n k) @ (ty) + | UpdateArray : forall (i : nat) (k : Kind), + (Array k i) @ (ty) -> + (Bit (Nat.log2 (2 * i))) @ (ty) -> + (k) @ (ty) -> (Array k i) @ (ty) + +For Const: Argument k is implicit +For UniBool: Argument ty is implicit +For BinBool: Argument ty is implicit +For UniBit: Arguments ty, n1, n2 are implicit +For BinBit: Arguments ty, n1, n2, n3 are implicit +For BinBitBool: Arguments ty, n1, n2 are implicit +For ITE: Arguments ty, k are implicit +For Eq: Arguments ty, k are implicit +For ReadIndex: Arguments ty, i, k are implicit +For ReadField: Arguments ty, n, ls are implicit +For BuildVector: Arguments ty, n, k are implicit +For BuildStruct: Arguments ty, n, attrs are implicit +For UpdateVector: Arguments ty, i, k are implicit +For ReadArrayIndex: Arguments ty, i, k are implicit +For BuildArray: Arguments ty, n, k are implicit +For UpdateArray: Arguments ty, i, k are implicit +For Expr: Argument scopes are [function_scope _] +For Var: Argument scopes are [function_scope _ _] +For Const: Argument scopes are [function_scope _ _] +For UniBool: Argument scopes are [function_scope _ _] +For BinBool: Argument scopes are [function_scope _ _ _] +For UniBit: Argument scopes are [function_scope nat_scope nat_scope _ _] +For BinBit: Argument scopes are [function_scope nat_scope nat_scope nat_scope + _ _ _] +For BinBitBool: Argument scopes are [function_scope nat_scope nat_scope _ _ + _] +For ITE: Argument scopes are [function_scope _ _ _ _] +For Eq: Argument scopes are [function_scope _ _ _] +For ReadIndex: Argument scopes are [function_scope nat_scope _ _ _] +For ReadField: Argument scopes are [function_scope nat_scope _ _ _] +For BuildVector: Argument scopes are [function_scope _ nat_scope _] +For BuildStruct: Argument scopes are [function_scope nat_scope _ _] +For UpdateVector: Argument scopes are [function_scope nat_scope _ _ _ _] +For ReadArrayIndex: Argument scopes are [function_scope nat_scope _ _ _] +For BuildArray: Argument scopes are [function_scope _ nat_scope _] +For UpdateArray: Argument scopes are [function_scope nat_scope _ _ _ _] +evalExpr = +fix evalExpr (exprT : FullKind) (e : Expr type exprT) {struct e} : + fullType type exprT := + match e in (Expr _ exprT0) return (fullType type exprT0) with + | @Var _ _ v => v + | @Const _ k v => evalConstT v + | UniBool op e1 => evalUniBool op (evalExpr (SyntaxKind Bool) e1) + | BinBool op e1 e2 => + evalBinBool op (evalExpr (SyntaxKind Bool) e1) + (evalExpr (SyntaxKind Bool) e2) + | @UniBit _ n1 n2 op e1 => + evalUniBit op (evalExpr (SyntaxKind (Bit n1)) e1) + | @BinBit _ n1 n2 n3 op e1 e2 => + evalBinBit op (evalExpr (SyntaxKind (Bit n1)) e1) + (evalExpr (SyntaxKind (Bit n2)) e2) + | @BinBitBool _ n1 n2 op e1 e2 => + evalBinBitBool op (evalExpr (SyntaxKind (Bit n1)) e1) + (evalExpr (SyntaxKind (Bit n2)) e2) + | @ITE _ k p e1 e2 => + if evalExpr (SyntaxKind Bool) p then evalExpr k e1 else evalExpr k e2 + | @Eq _ k e1 e2 => + if isEq k (evalExpr (SyntaxKind k) e1) (evalExpr (SyntaxKind k) e2) + then true + else false + | @ReadIndex _ i0 k i f => + evalExpr (SyntaxKind (Vector k i0)) f + (evalExpr (SyntaxKind (Bit i0)) i) + | @ReadField _ n ls i e0 => + VectorFacts.Vector_nth_map (Struct.attrType (A:=Kind)) type ls + (evalExpr (SyntaxKind (Struct ls)) e0) i + | @BuildVector _ n k vec => evalVec (mapVec (evalExpr (SyntaxKind n)) vec) + | @BuildStruct _ n attrs ils => + ilist.ilist_to_fun_m (Expr type) (fullType type) + (fun sk : Struct.Attribute Kind => SyntaxKind (Struct.attrType sk)) + evalExpr ils + | @UpdateVector _ i0 k fn i v => + fun w : word i0 => + if weq w (evalExpr (SyntaxKind (Bit i0)) i) + then evalExpr (SyntaxKind k) v + else evalExpr (SyntaxKind (Vector k i0)) fn w + | @ReadArrayIndex _ i k idx vec => + evalExpr (SyntaxKind (Array k i)) vec + (natToFin i # (evalExpr (SyntaxKind (Bit (Nat.log2 (2 * i)))) idx)) + | @BuildArray _ i k vecVal => + evalArray (Vector.map (evalExpr (SyntaxKind i)) vecVal) + | @UpdateArray _ i k arr idx val => + fun fini : Fin.t (S i) => + if + Fin.eq_dec fini + (natToFin i # (evalExpr (SyntaxKind (Bit (Nat.log2 (2 * i)))) idx)) + then evalExpr (SyntaxKind k) val + else evalExpr (SyntaxKind (Array k i)) arr fini + end + : forall exprT : FullKind, Expr type exprT -> fullType type exprT + +Argument exprT is implicit +Inductive +SemAction (oldRegs : RegsT) + : forall k : Kind, ActionT type k -> UpdatesT -> MethsT -> type k -> Prop := + SemMCall : forall (meth : M.key) (s : SignatureT) + (marg : (arg s) @ (type)) (mret : type (ret s)) + (retK : Kind) (fret : type retK) + (cont : type (ret s) -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT) + (acalls : M.t {x : SignatureT & SignT x}), + (calls) @[ meth]%fmap = None -> + acalls = (calls) #[ meth |-> (evalExpr marg, mret)]%fmap -> + SemAction oldRegs (cont mret) newRegs calls fret -> + SemAction oldRegs (MCall meth s marg cont) newRegs acalls fret + | SemLet : forall (k : FullKind) (e : Expr type k) + (retK : Kind) (fret : type retK) + (cont : fullType type k -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT), + SemAction oldRegs (cont (evalExpr e)) newRegs calls fret -> + SemAction oldRegs (LET name <- e; cont name)%kami_action newRegs + calls fret + | SemReadNondet : forall (valueT : FullKind) + (valueV : fullType type valueT) + (retK : Kind) (fret : type retK) + (cont : fullType type valueT -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT), + SemAction oldRegs (cont valueV) newRegs calls fret -> + SemAction oldRegs + (Nondet name : valueT; cont name)%kami_action newRegs + calls fret + | SemReadReg : forall (r : string) (regT : FullKind) + (regV : fullType type regT) (retK : Kind) + (fret : type retK) + (cont : fullType type regT -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT), + (oldRegs) @[ r]%fmap = + Some (existT (fullType type) regT regV) -> + SemAction oldRegs (cont regV) newRegs calls fret -> + SemAction oldRegs (Read name <- r; cont name)%kami_action + newRegs calls fret + | SemWriteReg : forall (r : string) (k : FullKind) + (e : Expr type k) (retK : Kind) + (fret : type retK) (cont : ActionT type retK) + (newRegs : M.t {x : FullKind & fullType type x}) + (calls : MethsT) + (anewRegs : M.t {x : FullKind & fullType type x}), + (newRegs) @[ r]%fmap = None -> + anewRegs = (newRegs) #[ r |-> evalExpr e]%fmap -> + SemAction oldRegs cont newRegs calls fret -> + SemAction oldRegs (Write r <- e; cont)%kami_action anewRegs + calls fret + | SemIfElseTrue : forall (p : (Bool) @ (type)) (k1 : Kind) + (a a' : ActionT type k1) (r1 : type k1) + (k2 : Kind) (cont : type k1 -> ActionT type k2) + (newRegs1 + newRegs2 : M.Map.t {x : FullKind & fullType type x}) + (calls1 calls2 : M.Map.t {x : SignatureT & SignT x}) + (r2 : type k2), + M.Disj newRegs1 newRegs2 -> + M.Disj calls1 calls2 -> + evalExpr p = true -> + SemAction oldRegs a newRegs1 calls1 r1 -> + SemAction oldRegs (cont r1) newRegs2 calls2 r2 -> + forall + (unewRegs : M.Map.t {x : FullKind & fullType type x}) + (ucalls : M.Map.t {x : SignatureT & SignT x}), + unewRegs = M.union newRegs1 newRegs2 -> + ucalls = M.union calls1 calls2 -> + SemAction oldRegs + (If p then a else a' as name; cont name)%kami_action + unewRegs ucalls r2 + | SemIfElseFalse : forall (p : (Bool) @ (type)) + (k1 : Kind) (a a' : ActionT type k1) + (r1 : type k1) (k2 : Kind) + (cont : type k1 -> ActionT type k2) + (newRegs1 + newRegs2 : M.Map.t {x : FullKind & fullType type x}) + (calls1 calls2 : M.Map.t {x : SignatureT & SignT x}) + (r2 : type k2), + M.Disj newRegs1 newRegs2 -> + M.Disj calls1 calls2 -> + evalExpr p = false -> + SemAction oldRegs a' newRegs1 calls1 r1 -> + SemAction oldRegs (cont r1) newRegs2 calls2 r2 -> + forall + (unewRegs : M.Map.t {x : FullKind & fullType type x}) + (ucalls : M.Map.t {x : SignatureT & SignT x}), + unewRegs = M.union newRegs1 newRegs2 -> + ucalls = M.union calls1 calls2 -> + SemAction oldRegs + (If p then a else a' as name; cont name)%kami_action + unewRegs ucalls r2 + | SemAssertTrue : forall (p : (Bool) @ (type)) (k2 : Kind) + (cont : ActionT type k2) (newRegs2 : UpdatesT) + (calls2 : MethsT) (r2 : type k2), + evalExpr p = true -> + SemAction oldRegs cont newRegs2 calls2 r2 -> + SemAction oldRegs (Assert p; cont)%kami_action newRegs2 + calls2 r2 + | SemDispl : forall (ls : list (Disp type)) (k2 : Kind) + (cont : ActionT type k2) (newRegs2 : UpdatesT) + (calls2 : MethsT) (r2 : type k2), + SemAction oldRegs cont newRegs2 calls2 r2 -> + SemAction oldRegs (Displ ls cont) newRegs2 calls2 r2 + | SemReturn : forall (k : Kind) (e : (k) @ (type)) + (evale : fullType type (SyntaxKind k)), + evale = evalExpr e -> + SemAction oldRegs (Ret e)%kami_action []%fmap []%fmap evale + +For SemAction: Argument k is implicit +For SemMCall: Arguments oldRegs, meth, s, mret, retK, fret, newRegs, calls, + acalls are implicit +For SemLet: Arguments oldRegs, k, retK, fret, newRegs, calls are implicit +For SemReadNondet: Arguments oldRegs, retK, fret, newRegs, calls are implicit +For SemReadReg: Arguments oldRegs, regT, regV, retK, fret, newRegs, calls + are implicit +For SemWriteReg: Arguments oldRegs, r, k, retK, fret, cont, newRegs, calls, + anewRegs are implicit +For SemIfElseTrue: Arguments oldRegs, k1, a, r1, k2, newRegs1, newRegs2, + calls1, calls2, r2, unewRegs, ucalls are implicit +For SemIfElseFalse: Arguments oldRegs, k1, a', r1, k2, newRegs1, newRegs2, + calls1, calls2, r2, unewRegs, ucalls are implicit +For SemAssertTrue: Arguments oldRegs, k2, cont, newRegs2, calls2, r2 + are implicit +For SemDispl: Arguments oldRegs, k2, cont, newRegs2, calls2, r2 are implicit +For SemReturn: Arguments k, evale are implicit +For SemMCall: Argument scopes are [_ _ _ _ _ _ _ function_scope _ _ _ _ _ _] +For SemLet: Argument scopes are [_ _ _ _ _ function_scope _ _ _] +For SemReadNondet: Argument scopes are [_ _ _ _ _ function_scope _ _ _] +For SemReadReg: Argument scopes are [_ string_scope _ _ _ _ function_scope _ + _ _ _] +For SemWriteReg: Argument scopes are [_ string_scope _ _ _ _ _ _ _ _ _ _ _] +For SemIfElseTrue: Argument scopes are [_ _ _ _ _ _ _ function_scope _ _ _ _ + _ _ _ _ _ _ _ _ _ _] +For SemIfElseFalse: Argument scopes are [_ _ _ _ _ _ _ function_scope _ _ _ _ + _ _ _ _ _ _ _ _ _ _] +For SemDispl: Argument scopes are [_ list_scope _ _ _ _ _ _] +Record LabelT : Type := Build_LabelT + { annot : option (option string); defs : MethsT; calls : MethsT } +Inductive +Substep (m : Modules) (o : RegsT) + : UpdatesT -> UnitLabel -> MethsT -> Prop := + EmptyRule : Substep m o []%fmap (Rle None) []%fmap + | EmptyMeth : Substep m o []%fmap (Meth None) []%fmap + | SingleRule : forall (k : string) (a : Action Void), + In (k :: a)%struct (getRules m) -> + forall (u : UpdatesT) (cs : MethsT), + SemAction o (a type) u cs WO -> + Substep m o u (Rle (Some k)) cs + | SingleMeth : forall f : DefMethT, + In f (getDefsBodies m) -> + forall (u : UpdatesT) (cs : MethsT) + (argV : type (arg (projT1 (Struct.attrType f)))) + (retV : type (ret (projT1 (Struct.attrType f)))), + SemAction o (projT2 (Struct.attrType f) type argV) u cs retV -> + forall sig : Struct.Attribute {x : SignatureT & SignT x}, + sig = + (Struct.attrName f + :: existT SignT (projT1 (Struct.attrType f)) (argV, retV))%struct -> + Substep m o u (Meth (Some sig)) cs + +For SingleRule: Arguments o, u, cs are implicit +For SingleMeth: Arguments o, u, cs, argV, retV, sig are implicit +For SingleRule: Argument scopes are [_ _ string_scope _ _ _ _ _] +Inductive +SubstepsInd (m : Modules) (o : RegsT) : UpdatesT -> LabelT -> Prop := + SubstepsNil : SubstepsInd m o []%fmap + {| annot := None; defs := []%fmap; calls := []%fmap |} + | SubstepsCons : forall (u : UpdatesT) (l : LabelT), + SubstepsInd m o u l -> + forall (su : UpdatesT) (scs : MethsT) (sul : UnitLabel), + Substep m o su sul scs -> + CanCombineUUL u l su scs sul -> + forall (uu : M.Map.t {x : FullKind & fullType type x}) + (ll : LabelT), + uu = M.union u su -> + ll = mergeLabel (getLabel sul scs) l -> + SubstepsInd m o uu ll + +For SubstepsCons: Arguments m, o, u, l, su, scs, sul, uu, ll are implicit +Inductive StepInd (m : Modules) (o : RegsT) : UpdatesT -> LabelT -> Prop := + StepIndIntro : forall (u : UpdatesT) (l : LabelT), + SubstepsInd m o u l -> + wellHidden m (hide l) -> StepInd m o u (hide l) + +For StepIndIntro: Arguments m, o, u, l are implicit +Inductive Multistep (m : Modules) : RegsT -> RegsT -> list LabelT -> Prop := + NilMultistep : forall o1 o2 : RegsT, o1 = o2 -> Multistep m o1 o2 nil + | Multi : forall (o : RegsT) (a : list LabelT) (n : RegsT), + Multistep m o n a -> + forall (u : UpdatesT) (l : LabelT), + Step m n u l -> Multistep m o (M.union u n) (l :: a) + +For NilMultistep: Arguments o1, o2 are implicit +For Multi: Arguments m, o, a, n, u, l are implicit +For Multistep: Argument scopes are [_ _ _ list_scope] +For Multi: Argument scopes are [_ _ list_scope _ _ _ _ _] +Inductive Behavior (m : Modules) : RegsT -> LabelSeqT -> Prop := + BehaviorIntro : forall (a : list LabelT) (n : RegsT), + Multistep m (initRegs (getRegInits m)) n a -> + Behavior m n a + +For BehaviorIntro: Arguments m, a, n are implicit +For BehaviorIntro: Argument scopes are [_ list_scope _ _] +traceRefines = +fun (p : MethsT -> MethsT) (m1 m2 : Modules) => +forall (s1 : RegsT) (sig1 : LabelSeqT), +Behavior m1 s1 sig1 -> +exists (s2 : RegsT) (sig2 : LabelSeqT), + Behavior m2 s2 sig2 /\ equivalentLabelSeq p sig1 sig2 + : (MethsT -> MethsT) -> Modules -> Modules -> Prop + +Argument scopes are [function_scope _ _] +traceRefines_refl + : forall m : Modules, traceRefines id m m +traceRefines_trans + : forall (ma mb mc : Modules) (p q : MethsT -> MethsT), + traceRefines p ma mb -> + traceRefines q mb mc -> traceRefines (fun f : MethsT => q (p f)) ma mc +traceRefines_comm + : forall ma mb : Modules, + NoDup (Struct.namesOf (getRegInits (ma ++ mb)%kami)) -> + traceRefines id (ma ++ mb)%kami (mb ++ ma)%kami +traceRefines_assoc_1 + : forall ma mb mc : Modules, + traceRefines id ((ma ++ mb) ++ mc)%kami (ma ++ mb ++ mc)%kami +traceRefines_assoc_2 + : forall ma mb mc : Modules, + traceRefines id (ma ++ mb ++ mc)%kami ((ma ++ mb) ++ mc)%kami +traceRefines_modular_noninteracting + : forall ma mb mc md : Modules, + ModEquiv type typeUT ma -> + ModEquiv type typeUT mb -> + ModEquiv type typeUT mc -> + ModEquiv type typeUT md -> + DisjList (Struct.namesOf (getRegInits ma)) + (Struct.namesOf (getRegInits mc)) -> + DisjList (Struct.namesOf (getRegInits mb)) + (Struct.namesOf (getRegInits md)) -> + ValidRegsModules type (ma ++ mc)%kami -> + ValidRegsModules type (mb ++ md)%kami -> + DisjList (getDefs ma) (getDefs mc) -> + DisjList (getCalls ma) (getCalls mc) -> + DisjList (getDefs mb) (getDefs md) -> + DisjList (getCalls mb) (getCalls md) -> + forall + vp : M.key -> + {x : SignatureT & SignT x} -> option {x : SignatureT & SignT x}, + NonInteracting ma mc -> + NonInteracting mb md -> + (ma <<=[ vp ] mb) -> + (mc <<=[File "./Kami/Ex/InDepthTutorial.v", line 229, characters 0-58: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 232, characters 0-26: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 241, characters 0-55: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 245, characters 0-25: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 274, characters 0-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 277, characters 0-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 357, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 360, characters 0-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 379, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 382, characters 0-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +datav cannot be defined because it is informative and impl12_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +Hdatav cannot be defined because the projection datav was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +eltv cannot be defined because it is informative and impl12_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: Heltv cannot be defined because the projection eltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +Hinv cannot be defined because the projections eltv, datav were not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 527, characters 0-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 530, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 554, characters 0-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +datav cannot be defined because it is informative and impl123_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +Hdatav cannot be defined because the projection datav was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +eltv cannot be defined because it is informative and impl123_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: Heltv cannot be defined because the projection eltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +Hinv cannot be defined because the projections eltv, datav were not defined. +[cannot-define-projection,records] +Kami/Ex/ProcDecInl (real: 36.23, user: 17.33, sys: 0.37, mem: 724164 ko) +Kami/Ex/IsaRv32PgmExt (real: 2.54, user: 0.92, sys: 0.31, mem: 550756 ko) +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +sbv0 cannot be defined because it is informative and p3st_scoreboard_waw_inv +is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: Hsbv0 cannot be defined because the projection sbv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +d2eeltv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hd2eeltv0 cannot be defined because the projection d2eeltv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +d2efullv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hd2efullv0 cannot be defined because the projection d2efullv0 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +e2weltv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +He2weltv0 cannot be defined because the projection e2weltv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +e2wfullv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +He2wfullv0 cannot be defined because the projection e2wfullv0 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +stallv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hstallv0 cannot be defined because the projection stallv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +stalledv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hstalledv0 cannot be defined because the projection stalledv0 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hinv0 cannot be defined because the projections d2efullv0, d2eeltv0, +e2wfullv0, e2weltv0, stallv0, stalledv0, sbv0 were not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +d2eeltv1 cannot be defined because it is informative and p3st_raw_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2eeltv1 cannot be defined because the projection d2eeltv1 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +d2efullv1 cannot be defined because it is informative and p3st_raw_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2efullv1 cannot be defined because the projection d2efullv1 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +e2weltv1 cannot be defined because it is informative and p3st_raw_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +He2weltv1 cannot be defined because the projection e2weltv1 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +e2wfullv1 cannot be defined because it is informative and p3st_raw_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +He2wfullv1 cannot be defined because the projection e2wfullv1 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +stallv1 cannot be defined because it is informative and p3st_raw_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hstallv1 cannot be defined because the projection stallv1 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +stalledv1 cannot be defined because it is informative and p3st_raw_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hstalledv1 cannot be defined because the projection stalledv1 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2einv1 cannot be defined because the projections d2efullv1, stallv1, +d2eeltv1, stalledv1 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +He2winv1 cannot be defined because the projections e2wfullv1, stallv1, +e2weltv1, stalledv1 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2winv1 cannot be defined because the projections d2efullv1, e2wfullv1, +d2eeltv1, e2weltv1 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +pgmv2 cannot be defined because it is informative and p3st_decode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hpgmv2 cannot be defined because the projection pgmv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +rfv2 cannot be defined because it is informative and p3st_decode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: Hrfv2 cannot be defined because the projection rfv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +d2eeltv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hd2eeltv2 cannot be defined because the projection d2eeltv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +d2efullv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hd2efullv2 cannot be defined because the projection d2efullv2 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +e2weltv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +He2weltv2 cannot be defined because the projection e2weltv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +e2wfullv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +He2wfullv2 cannot be defined because the projection e2wfullv2 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hd2einv2 cannot be defined because the projections pgmv2, rfv2, d2eeltv2, +d2efullv2 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +He2winv2 cannot be defined because the projections pgmv2, rfv2, e2weltv2, +e2wfullv2 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +pgmv3 cannot be defined because it is informative and p3st_stalled_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hpgmv3 cannot be defined because the projection pgmv3 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +rfv3 cannot be defined because it is informative and p3st_stalled_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: Hrfv3 cannot be defined because the projection rfv3 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +stallv3 cannot be defined because it is informative and p3st_stalled_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hstallv3 cannot be defined because the projection stallv3 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +stalledv3 cannot be defined because it is informative and p3st_stalled_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hstalledv3 cannot be defined because the projection stalledv3 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hinv3 cannot be defined because the projections pgmv3, rfv3, stallv3, +stalledv3 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +pcv4 cannot be defined because it is informative and p3st_exec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: Hpcv4 cannot be defined because the projection pcv4 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +rfv4 cannot be defined because it is informative and p3st_exec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: Hrfv4 cannot be defined because the projection rfv4 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +e2weltv4 cannot be defined because it is informative and p3st_exec_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +He2weltv4 cannot be defined because the projection e2weltv4 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +e2wfullv4 cannot be defined because it is informative and p3st_exec_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +He2wfullv4 cannot be defined because the projection e2wfullv4 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +Hinv4 cannot be defined because the projections pcv4, rfv4, e2wfullv4, +e2weltv4 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +pcv5 cannot be defined because it is informative and p3st_epochs_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: Hpcv5 cannot be defined because the projection pcv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +fepochv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hfepochv5 cannot be defined because the projection fepochv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +d2eeltv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hd2eeltv5 cannot be defined because the projection d2eeltv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +d2efullv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hd2efullv5 cannot be defined because the projection d2efullv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +w2deltv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hw2deltv5 cannot be defined because the projection w2deltv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +w2dfullv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hw2dfullv5 cannot be defined because the projection w2dfullv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +e2weltv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +He2weltv5 cannot be defined because the projection e2weltv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +e2wfullv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +He2wfullv5 cannot be defined because the projection e2wfullv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +stallv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hstallv5 cannot be defined because the projection stallv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +stalledv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hstalledv5 cannot be defined because the projection stalledv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +eepochv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Heepochv5 cannot be defined because the projection eepochv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hinv5 cannot be defined because the projections fepochv5, eepochv5, +d2efullv5, e2wfullv5, w2dfullv5, stallv5, pcv5, d2eeltv5, e2weltv5, stalledv5 +were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +pcv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: Hpcv6 cannot be defined because the projection pcv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +fepochv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hfepochv6 cannot be defined because the projection fepochv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +d2eeltv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hd2eeltv6 cannot be defined because the projection d2eeltv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +d2efullv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hd2efullv6 cannot be defined because the projection d2efullv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +w2dfullv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hw2dfullv6 cannot be defined because the projection w2dfullv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +e2weltv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +He2weltv6 cannot be defined because the projection e2weltv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +e2wfullv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +He2wfullv6 cannot be defined because the projection e2wfullv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +stallv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hstallv6 cannot be defined because the projection stallv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +stalledv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hstalledv6 cannot be defined because the projection stalledv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +eepochv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Heepochv6 cannot be defined because the projection eepochv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hinv6 cannot be defined because the projections fepochv6, eepochv6, +d2efullv6, e2wfullv6, w2dfullv6, stallv6, pcv6, d2eeltv6, e2weltv6, stalledv6 +were not defined. [cannot-define-projection,records] +Kami/Ex/ProcThreeStInv (real: 3.48, user: 1.44, sys: 0.25, mem: 498104 ko) +File "./Kami/Ex/InDepthTutorial.v", line 680, characters 0-16: +Warning: The spelling "OCaml" should be used instead of "Ocaml". +[deprecated-ocaml-spelling,deprecated] +Kami/Ex/InDepthTutorial (real: 47.16, user: 22.68, sys: 0.34, mem: 653084 ko) +File "./Kami/Ex/ProcThreeStDec.v", line 120, characters 2-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStDec.v", line 121, characters 2-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcThreeStDec (real: 2.97, user: 1.19, sys: 0.25, mem: 495240 ko) +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +pcv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hpcv cannot be defined because the projection pcv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +rfv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hrfv cannot be defined because the projection rfv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +pgmv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hpgmv cannot be defined because the projection pgmv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +stallv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hstallv cannot be defined because the projection stallv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +iev cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hiev cannot be defined because the projection iev was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ifv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hifv cannot be defined because the projection ifv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ienqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hienqpv cannot be defined because the projection ienqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ideqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hideqpv cannot be defined because the projection ideqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ieltv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hieltv cannot be defined because the projection ieltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +oev cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hoev cannot be defined because the projection oev was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ofv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hofv cannot be defined because the projection ofv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +oenqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hoenqpv cannot be defined because the projection oenqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +odeqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hodeqpv cannot be defined because the projection odeqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +oeltv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hoeltv cannot be defined because the projection oeltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hinv cannot be defined because the projections stallv, iev, ienqpv, ideqpv, +oev, oenqpv, odeqpv, stallv, iev, ienqpv, ideqpv, oev, oenqpv, odeqpv, pgmv, +pcv, rfv, iev, ieltv, ideqpv, stallv, iev, ienqpv, ideqpv, oev, oenqpv, +odeqpv were not defined. [cannot-define-projection,records] +Kami/Ex/ProcDecInv (real: 4.24, user: 1.78, sys: 0.26, mem: 495196 ko) +File "./Kami/Ex/ProcDecSC.v", line 46, characters 2-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDecSC.v", line 47, characters 2-61: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcDecSC (real: 4.07, user: 0.93, sys: 0.30, mem: 493232 ko) +Kami/Ex/ProcDecSCN (real: 2.30, user: 0.81, sys: 0.29, mem: 488468 ko) +Kami/Ex/ProcFDInl (real: 81.62, user: 68.57, sys: 0.68, mem: 1312068 ko) +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +pcv cannot be defined because it is informative and fetchDecode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: Hpcv cannot be defined because the projection pcv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +pgmv cannot be defined because it is informative and fetchDecode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: Hpgmv cannot be defined because the projection pgmv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +fepochv cannot be defined because it is informative and fetchDecode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hfepochv cannot be defined because the projection fepochv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +f2dfullv cannot be defined because it is informative and fetchDecode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hf2dfullv cannot be defined because the projection f2dfullv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +f2deltv cannot be defined because it is informative and fetchDecode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hf2deltv cannot be defined because the projection f2deltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hinv cannot be defined because the projections pcv, pgmv, fepochv, f2dfullv, +f2deltv were not defined. [cannot-define-projection,records] +Kami/Ex/ProcFDInv (real: 2.76, user: 2.42, sys: 0.23, mem: 526316 ko) +File "./Kami/Ex/ProcFDCorrect.v", line 96, characters 2-73: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcFDCorrect.v", line 97, characters 2-75: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcFDCorrect (real: 1.11, user: 0.83, sys: 0.23, mem: 526908 ko) +Kami/Ex/ProcFourStDec (real: 1.06, user: 0.80, sys: 0.23, mem: 527136 ko) +Warning: bedrock2/deps/coqutil/src (used in -R or -Q) is not a subdirectory of the current directory + +bedrock2/processor/src/KamiWord (real: 1.30, user: 0.45, sys: 0.16, mem: 358800 ko) +bedrock2/processor/src/Test (real: 3.56, user: 1.51, sys: 0.22, mem: 473632 ko) +bedrock2/processor/src/KamiRiscv (real: 27.54, user: 25.47, sys: 0.35, mem: 729768 ko) + vp ] md) -> (ma ++ mc)%kami <<=[ vp ] (mb ++ md)%kami +simpleFifo + : string -> nat -> Kind -> Modules + = Mod + [("data" :: RegInitDefault (SyntaxKind (Bit dataSize)))%struct; + ("elt.fifo1" + :: RegInitCustom + (existT ConstFullT (list (word dataSize)) #< (nil)%kami_expr + (NativeConst nil nil)))%struct] + [("produce" + :: (fun type : Kind -> Type => + (Read a : Bit dataSize <- "data"; + LET a0 : Bit dataSize <- # (a); + Read a1 <- "elt.fifo1"; + Write "elt.fifo1" <- + Var type (list (type (Bit dataSize))) #< (nil) + ((fix app (l m : list (type (Bit dataSize))) {struct l} : + list (type (Bit dataSize)) := + match l with + | nil => m + | a2 :: l1 => a2 :: app l1 m + end) a1 [a0]); + LET _ : Void <- $$ (WO); + Write "data" : Bit dataSize <- # (a) + $$ ($ (1)); + Ret $$ (WO))%kami_action))%struct; + ("doDouble" + :: (fun type : Kind -> Type => + (LET _ : Void <- $$ (WO); + Read a0 <- "elt.fifo1"; + Assert ! + $$ + (match a0 with + | nil => true + | _ :: _ => false + end); + Write "elt.fifo1" <- + Var type (list (type (Bit dataSize))) #< (nil) + match a0 with + | nil => nil + | _ :: t => t + end; + LET ak : Bit dataSize <- + match a0 with + | nil => $$ (getDefaultConstBit dataSize) + | h :: _ => # (h) + end; + LET a1 : Bit dataSize <- $$ ($ (2)) * # (ak); + CallM _ : Void <- "enq.fifo2" (# (a1) : + Bit dataSize); Ret $$ (WO))%kami_action))%struct] nil + : Modules +COQC Kami/Ex/IsaRv32PgmExt.v +COQC Kami/Ex/ProcThreeStInv.v +COQC Kami/Ex/ProcFDInl.v +impl = +fun dataSize : nat => +(stage1 dataSize ++ + fifo1 dataSize ++ stage2 dataSize ++ fifo2 dataSize ++ stage3 dataSize)%kami + : nat -> Modules + +Argument scope is [nat_scope] +COQC Kami/Ex/ProcThreeStDec.v +COQC Kami/Ex/ProcDecInv.v +COQC Kami/Ex/ProcDecSC.v +COQC Kami/Ex/ProcDecSCN.v +COQC Kami/Ex/ProcFDInv.v +COQC Kami/Ex/ProcFDCorrect.v +COQC Kami/Ex/ProcFourStDec.v +make[3]: Leaving directory 'bedrock2/deps/kami' +make[2]: Leaving directory 'bedrock2/deps/kami' +make -C bedrock2/processor +make[2]: Entering directory 'bedrock2/processor' +printf -- '-Q bedrock2/deps/coqutil/src coqutil\n-Q bedrock2/deps/riscv-coq/src riscv\n-R bedrock2/deps/kami/Kami/ Kami\n-Q ./src processor\n' > _CoqProject +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = bedrock2 -arg "-async-proofs-tac-j 1" bedrock2/processor/src/Test.v bedrock2/processor/src/KamiWord.v bedrock2/processor/src/KamiRiscv.v -o Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/processor' +COQDEP VFILES +COQC bedrock2/processor/src/Test.v +COQC bedrock2/processor/src/KamiWord.v +COQC bedrock2/processor/src/KamiRiscv.v +make[3]: Leaving directory 'bedrock2/processor' +make[2]: Leaving directory 'bedrock2/processor' +make[1]: Leaving directory 'bedrock2' diff --git a/test-suite/micromega/example_nia.v b/test-suite/micromega/example_nia.v index 8de631aa6a..485c24f0c9 100644 --- a/test-suite/micromega/example_nia.v +++ b/test-suite/micromega/example_nia.v @@ -435,6 +435,12 @@ Goal forall (R : sz + d * sz - sz * x >= 1), False. Proof. + (* Manual proof. + assert (H : sz >= 2) by GE + R. + assert (GEd : x - d >= 1 by GE / H + assert (Rd : 1 + d - x >= 1 by R / H) + 1 >= 2 by GEd + Rd + *) intros. assert (x - d >= 1) by nia. nia. diff --git a/test-suite/micromega/rsyntax.v b/test-suite/micromega/rsyntax.v new file mode 100644 index 0000000000..02b98b562f --- /dev/null +++ b/test-suite/micromega/rsyntax.v @@ -0,0 +1,75 @@ +Require Import ZArith. +Require Import Lra. +Require Import Reals. + +Goal (1 / (1 - 1) = 0)%R. + Fail lra. (* division by zero *) +Abort. + +Goal (0 / (1 - 1) = 0)%R. + lra. (* 0 * x = 0 *) +Qed. + +Goal (10 ^ 2 = 100)%R. + lra. (* pow is reified as a constant *) +Qed. + +Goal (2 / (1/2) ^ 2 = 8)%R. + lra. (* pow is reified as a constant *) +Qed. + + +Goal ( IZR (Z.sqrt 4) = 2)%R. +Proof. + Fail lra. +Abort. + +Require Import DeclConstant. + +Instance Dsqrt : DeclaredConstant Z.sqrt := {}. + +Goal ( IZR (Z.sqrt 4) = 2)%R. +Proof. + lra. +Qed. + +Require Import QArith. +Require Import Qreals. + +Goal (Q2R (1 # 2) = 1/2)%R. +Proof. + lra. +Qed. + +Goal ( 1 ^ (2 + 2) = 1)%R. +Proof. + Fail lra. +Abort. + +Instance Dplus : DeclaredConstant Init.Nat.add := {}. + +Goal ( 1 ^ (2 + 2) = 1)%R. +Proof. + lra. +Qed. + +Require Import Lia. + +Goal ( 1 ^ (2 + 2) = 1)%Z. +Proof. + Fail lia. + reflexivity. +Qed. + +Instance DZplus : DeclaredConstant Z.add := {}. + +Goal ( 1 ^ (2 + 2) = 1)%Z. +Proof. + lia. +Qed. + + +Goal (1 / IZR (Z.pow_pos 10 25) = 1 / 10 ^ 25)%R. +Proof. + lra. +Qed. diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index 7266b662fa..9efb81a901 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -54,7 +54,7 @@ Qed. Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. Proof. unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq. - assert (Heq : (Qnum x ^ 2 = 2 * Zpos (Qden x) ^ 2%Q)%Z) by + assert (Heq : (Qnum x ^ 2 = 2 * Zpos (Qden x) ^ 2)%Z) by (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). assert (Hnx : (Qnum x <> 0)%Z) by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq). diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 239bc69360..55691f553c 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -82,11 +82,48 @@ Proof. lia. Qed. +Section S. + Variables x y: Z. + Variables XGe : x >= 0. + Variables YGt : y > 0. + Variables YLt : y < 0. + + Goal False. + Proof using - XGe. + lia. + Qed. + + Goal False. + Proof using YGt YLt x y. + lia. + Qed. + + End S. + (* Bug 5073 *) Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. Proof. lia. Qed. +Lemma ex_pos : forall x, exists z t, x = z - t /\ z >= 0 /\ t >= 0. +Proof. + intros. + destruct (dec_Zge x 0). + exists x, 0. + lia. + exists 0, (-x). + lia. +Qed. - +Goal forall + (b q r : Z) + (H : b * q + r <= 0) + (H5 : - b < r) + (H6 : r <= 0) + (H2 : 0 <= b), + b = 0 -> False. +Proof. + intros b q r. + lia. +Qed. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index 36992e4dda..7429a521b3 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -7,6 +7,8 @@ Require Import QMicromega. Require Import RMicromega. Recursive Extraction - List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + List.map simpl_cone (*map_cone indexes*) + denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/test-suite/output/NumeralNotations.out b/test-suite/output/NumeralNotations.out new file mode 100644 index 0000000000..460c77879c --- /dev/null +++ b/test-suite/output/NumeralNotations.out @@ -0,0 +1,182 @@ +The command has indeed failed with message: +Unexpected term (nat -> nat) while parsing a numeral notation. +The command has indeed failed with message: +Unexpected non-option term opaque4 while parsing a numeral notation. +The command has indeed failed with message: +Unexpected term (fun (A : Type) (x : A) => x) while parsing a numeral +notation. +let v := 0%ppp in v : punit + : punit +let v := 0%ppp in v : punit + : punit +let v := 0%ppp in v : punit + : punit +let v := 0%ppp in v : punit + : punit +let v := 0%uto in v : unit + : unit +The command has indeed failed with message: +Cannot interpret this number as a value of type unit +The command has indeed failed with message: +Cannot interpret this number as a value of type unit +let v := 0%upp in v : unit + : unit +let v := 0%upp in v : unit + : unit +let v := 0%upp in v : unit + : unit +let v := 0%ppps in v : punit + : punit +File "stdin", line 91, characters 2-46: +Warning: To avoid stack overflow, large numbers in punit are interpreted as +applications of pto_punits. [abstract-large-number,numbers] +The command has indeed failed with message: +In environment +v := pto_punits (Decimal.D1 Decimal.Nil) : punit +The term "v" has type "punit@{Set}" while it is expected to have type + "punit@{u}". +S + : nat -> nat +S (ack 4 4) + : nat +let v := 0%wnat in v : wnat + : wnat +0%wnat + : wnat +{| unwrap := ack 4 4 |} + : wnat +{| Test6.unwrap := 0 |} + : Test6.wnat +let v := 0%wnat in v : Test6.wnat + : Test6.wnat +let v := 0%wuint in v : wuint + : wuint +let v := 1%wuint in v : wuint + : wuint +let v := 0%wuint8 in v : wuint + : wuint +let v := 0 in v : nat + : nat +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "wuint". + = {| unwrap := Decimal.D0 Decimal.Nil |} + : wuint +let v := 0%wuint8' in v : wuint + : wuint +let v := 0%wuint9 in v : wuint + : wuint +let v := 0%wuint9' in v : wuint + : wuint +let v := 0 in v : nat + : nat +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "wuint". +File "stdin", line 202, characters 2-72: +Warning: The 'abstract after' directive has no effect when the parsing +function (of_uint) targets an option type. +[abstract-large-number-no-op,numbers] +The command has indeed failed with message: +The 'abstract after' directive has no effect when the parsing function +(of_uint) targets an option type. [abstract-large-number-no-op,numbers] +let v := of_uint (Decimal.D1 Decimal.Nil) in v : unit + : unit +let v := 0%test13 in v : unit + : unit +The command has indeed failed with message: +to_uint' is bound to a notation that does not denote a reference. +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +to_uint'' is bound to a notation that does not denote a reference. +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +let v := 0%test14' in v : unit + : unit +let v := 0%test14' in v : unit + : unit +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +let v := 0%test14' in v : unit + : unit +The command has indeed failed with message: +This command does not support the Global option in sections. +let v := 0%test14'' in v : unit + : unit +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +let v := 0%test15 in v : unit + : unit +let v := 0%test15 in v : unit + : unit +let v := 0%test15 in v : unit + : unit +let v := foo a.t in v : Foo + : Foo +The command has indeed failed with message: +Cannot interpret in test16_scope because NumeralNotations.Test16.F.Foo could not be found in the current environment. +let v := 0%test17 in v : myint63 + : myint63 +let v := 0%Q in v : Q + : Q +let v := 1%Q in v : Q + : Q +let v := 2%Q in v : Q + : Q +let v := 3%Q in v : Q + : Q +let v := 4%Q in v : Q + : Q + = (0, 1) + : nat * nat + = (1, 1) + : nat * nat + = (2, 1) + : nat * nat + = (3, 1) + : nat * nat + = (4, 1) + : nat * nat +let v := (-1)%Zlike in v : Zlike + : Zlike +let v := 0%Zlike in v : Zlike + : Zlike +let v := 1%Zlike in v : Zlike + : Zlike +let v := 2%Zlike in v : Zlike + : Zlike +let v := 3%Zlike in v : Zlike + : Zlike +let v := 4%Zlike in v : Zlike + : Zlike +2%Zlike + : Zlike +0%Zlike + : Zlike diff --git a/test-suite/success/NumeralNotations.v b/test-suite/output/NumeralNotations.v index 7b857c70c5..44805ad09d 100644 --- a/test-suite/success/NumeralNotations.v +++ b/test-suite/output/NumeralNotations.v @@ -1,5 +1,7 @@ (* Test that we fail, rather than raising anomalies, on opaque terms during interpretation *) +Declare Scope opaque_scope. + (* https://github.com/coq/coq/pull/8064#discussion_r202497516 *) Module Test1. Axiom hold : forall {A B C}, A -> B -> C. @@ -19,6 +21,8 @@ Module Test2. Fail Check 1%opaque. End Test2. +Declare Scope silly_scope. + Module Test3. Inductive silly := SILLY (v : Decimal.uint) (f : forall A, A -> A). Definition to_silly (v : Decimal.uint) := SILLY v (fun _ x => x). @@ -28,8 +32,18 @@ Module Test3. Fail Check 1%silly. End Test3. - Module Test4. + Declare Scope opaque_scope. + Declare Scope silly_scope. + Declare Scope pto. + Declare Scope ppo. + Declare Scope ptp. + Declare Scope ppp. + Declare Scope uto. + Declare Scope upo. + Declare Scope utp. + Declare Scope upp. + Declare Scope ppps. Polymorphic NonCumulative Inductive punit := ptt. Polymorphic Definition pto_punit (v : Decimal.uint) : option punit := match Nat.of_uint v with O => Some ptt | _ => None end. Polymorphic Definition pto_punit_all (v : Decimal.uint) : punit := ptt. @@ -102,6 +116,7 @@ Module Test6. Definition to_uint (x : wnat) : Decimal.uint := Nat.to_uint x. Definition of_uint (x : Decimal.uint) : wnat := Nat.of_uint x. Module Export Scopes. + Declare Scope wnat_scope. Delimit Scope wnat_scope with wnat. End Scopes. Module Export Notations. @@ -123,6 +138,7 @@ End Test6_2. Module Test7. Local Set Primitive Projections. Record wuint := wrap { unwrap : Decimal.uint }. + Declare Scope wuint_scope. Delimit Scope wuint_scope with wuint. Numeral Notation wuint wrap unwrap : wuint_scope. Check let v := 0%wuint in v : wuint. @@ -132,6 +148,8 @@ End Test7. Module Test8. Local Set Primitive Projections. Record wuint := wrap { unwrap : Decimal.uint }. + Declare Scope wuint8_scope. + Declare Scope wuint8'_scope. Delimit Scope wuint8_scope with wuint8. Delimit Scope wuint8'_scope with wuint8'. Section with_var. @@ -152,6 +170,8 @@ Module Test8. End Test8. Module Test9. + Declare Scope wuint9_scope. + Declare Scope wuint9'_scope. Delimit Scope wuint9_scope with wuint9. Delimit Scope wuint9'_scope with wuint9'. Section with_let. @@ -175,6 +195,8 @@ Module Test10. Definition to_uint (v : unit) := Nat.to_uint 0. Definition of_uint (v : Decimal.uint) := match Nat.of_uint v with O => Some tt | _ => None end. Definition of_any_uint (v : Decimal.uint) := tt. + Declare Scope unit_scope. + Declare Scope unit2_scope. Delimit Scope unit_scope with unit. Delimit Scope unit2_scope with unit2. Numeral Notation unit of_uint to_uint : unit_scope (abstract after 1). @@ -185,22 +207,9 @@ Module Test10. Numeral Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). End Test10. -Module Test11. - (* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) - Inductive unit11 := tt11. - Delimit Scope unit11_scope with unit11. - Goal True. - evar (to_uint : unit11 -> Decimal.uint). - evar (of_uint : Decimal.uint -> unit11). - Fail Numeral Notation unit11 of_uint to_uint : uint11_scope. - exact I. - Unshelve. - all: solve [ constructor ]. - Qed. -End Test11. - Module Test12. (* Test for numeral notations on context variables *) + Declare Scope test12_scope. Delimit Scope test12_scope with test12. Section test12. Context (to_uint : unit -> Decimal.uint) (of_uint : Decimal.uint -> unit). @@ -212,6 +221,9 @@ End Test12. Module Test13. (* Test for numeral notations on notations which do not denote references *) + Declare Scope test13_scope. + Declare Scope test13'_scope. + Declare Scope test13''_scope. Delimit Scope test13_scope with test13. Delimit Scope test13'_scope with test13'. Delimit Scope test13''_scope with test13''. @@ -232,6 +244,10 @@ Module Test14. (* Test that numeral notations follow [Import], not [Require], and also test that [Local Numeral Notation]s do not escape modules nor sections. *) + Declare Scope test14_scope. + Declare Scope test14'_scope. + Declare Scope test14''_scope. + Declare Scope test14'''_scope. Delimit Scope test14_scope with test14. Delimit Scope test14'_scope with test14'. Delimit Scope test14''_scope with test14''. @@ -263,6 +279,7 @@ End Test14. Module Test15. (** Test module include *) + Declare Scope test15_scope. Delimit Scope test15_scope with test15. Module Inner. Definition to_uint (x : unit) : Decimal.uint := Nat.to_uint O. @@ -280,6 +297,7 @@ End Test15. Module Test16. (** Test functors *) + Declare Scope test16_scope. Delimit Scope test16_scope with test16. Module Type A. Axiom T : Set. @@ -305,9 +323,71 @@ Require Import Coq.Numbers.Cyclic.Int63.Int63. Module Test17. (** Test int63 *) Declare Scope test17_scope. + Declare Scope test17_scope. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. Numeral Notation myint63 of_int to_int : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. + +Module Test18. + (** Test https://github.com/coq/coq/issues/9840 *) + Record Q := { num : nat ; den : nat ; reduced : Nat.gcd num den = 1 }. + Declare Scope Q_scope. + Delimit Scope Q_scope with Q. + + Definition nat_eq_dec (x y : nat) : {x = y} + {x <> y}. + Proof. decide equality. Defined. + + Definition transparentify {A} (D : {A} + {not A}) (H : A) : A := + match D with + | left pf => pf + | right npf => match npf H with end + end. + + Axiom gcd_good : forall x, Nat.gcd x 1 = 1. + + Definition Q_of_nat (x : nat) : Q := {| num := x ; den := 1 ; reduced := transparentify (nat_eq_dec _ _) (gcd_good _) |}. + Definition nat_of_Q (x : Q) : option nat + := if Nat.eqb x.(den) 1 then Some (x.(num)) else None. + Definition Q_of_uint (x : Decimal.uint) : Q := Q_of_nat (Nat.of_uint x). + Definition uint_of_Q (x : Q) : option Decimal.uint + := option_map Nat.to_uint (nat_of_Q x). + + Numeral Notation Q Q_of_uint uint_of_Q : Q_scope. + + Check let v := 0%Q in v : Q. + Check let v := 1%Q in v : Q. + Check let v := 2%Q in v : Q. + Check let v := 3%Q in v : Q. + Check let v := 4%Q in v : Q. + Compute let v := 0%Q in (num v, den v). + Compute let v := 1%Q in (num v, den v). + Compute let v := 2%Q in (num v, den v). + Compute let v := 3%Q in (num v, den v). + Compute let v := 4%Q in (num v, den v). +End Test18. + +Require Import Coq.Lists.List. +Require Import Coq.ZArith.ZArith. +Module Test19. + (** Test another thing related to https://github.com/coq/coq/issues/9840 *) + Record Zlike := { summands : list Z }. + Declare Scope Zlike_scope. + Delimit Scope Zlike_scope with Zlike. + + Definition Z_of_Zlike (x : Zlike) := List.fold_right Z.add 0%Z (summands x). + Definition Zlike_of_Z (x : Z) := {| summands := cons x nil |}. + + Numeral Notation Zlike Zlike_of_Z Z_of_Zlike : Zlike_scope. + + Check let v := (-1)%Zlike in v : Zlike. + Check let v := 0%Zlike in v : Zlike. + Check let v := 1%Zlike in v : Zlike. + Check let v := 2%Zlike in v : Zlike. + Check let v := 3%Zlike in v : Zlike. + Check let v := 4%Zlike in v : Zlike. + Check {| summands := (cons 1 (cons 2 (cons (-1) nil)))%Z |}. + Check {| summands := nil |}. +End Test19. diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 2713e6a188..35f36e87d7 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -1,5 +1,6 @@ Set Printing Projections. +Set Primitive Projections. Class HostFunction := host_func : Type. diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index b0ac9ea29f..4cd0ffb1dc 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -19,30 +19,31 @@ Nat.div2: nat -> nat Nat.log2: nat -> nat Nat.succ: nat -> nat Nat.sqrt: nat -> nat +S: nat -> nat Nat.pred: nat -> nat Nat.double: nat -> nat Nat.square: nat -> nat -S: nat -> nat -Nat.ldiff: nat -> nat -> nat -Nat.tail_add: nat -> nat -> nat Nat.land: nat -> nat -> nat +Nat.lor: nat -> nat -> nat +Nat.mul: nat -> nat -> nat Nat.tail_mul: nat -> nat -> nat Nat.div: nat -> nat -> nat -Nat.lor: nat -> nat -> nat +Nat.tail_add: nat -> nat -> nat Nat.gcd: nat -> nat -> nat Nat.modulo: nat -> nat -> nat Nat.max: nat -> nat -> nat Nat.sub: nat -> nat -> nat -Nat.mul: nat -> nat -> nat +Nat.pow: nat -> nat -> nat Nat.lxor: nat -> nat -> nat -Nat.add: nat -> nat -> nat +Nat.ldiff: nat -> nat -> nat Nat.min: nat -> nat -> nat -Nat.pow: nat -> nat -> nat +Nat.add: nat -> nat -> nat Nat.of_uint: Decimal.uint -> nat +Decimal.nb_digits: Decimal.uint -> nat Nat.tail_addmul: nat -> nat -> nat -> nat Nat.of_uint_acc: Decimal.uint -> nat -> nat -Nat.log2_iter: nat -> nat -> nat -> nat -> nat Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat +Nat.log2_iter: nat -> nat -> nat -> nat -> nat length: forall A : Type, list A -> nat Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat Nat.div2: nat -> nat diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out new file mode 100644 index 0000000000..2a7ce806d7 --- /dev/null +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -0,0 +1,33 @@ +File "stdin", line 10, characters 0-28: +Warning: Ambiguous paths: [ac; cd] : A >-> D [ambiguous-paths,typechecker] +[ab] : A >-> B +[ab; bd] : A >-> D +[ac] : A >-> C +[bd] : B >-> D +[cd] : C >-> D +[B_A] : B >-> A +[C_A] : C >-> A +[D_B] : D >-> B +[D_A] : D >-> A +[D_C] : D >-> C +[A'_A] : A' >-> A +[B_A'] : B >-> A' +[B_A'; A'_A] : B >-> A +[C_A'] : C >-> A' +[C_A'; A'_A] : C >-> A +[D_B; B_A'] : D >-> A' +[D_A] : D >-> A +[D_B] : D >-> B +[D_C] : D >-> C +File "stdin", line 103, characters 0-86: +Warning: Ambiguous paths: [D_C; C_A'] : D >-> A' +[ambiguous-paths,typechecker] +[A'_A] : A' >-> A +[B_A'] : B >-> A' +[B_A'; A'_A] : B >-> A +[C_A'] : C >-> A' +[C_A'; A'_A] : C >-> A +[D_B; B_A'] : D >-> A' +[D_A] : D >-> A +[D_B] : D >-> B +[D_C] : D >-> C diff --git a/test-suite/output/relaxed_ambiguous_paths.v b/test-suite/output/relaxed_ambiguous_paths.v new file mode 100644 index 0000000000..a4af27539c --- /dev/null +++ b/test-suite/output/relaxed_ambiguous_paths.v @@ -0,0 +1,109 @@ +Module test1. +Section test1. + +Variable (A B C D : Type). +Variable (ab : A -> B) (bd : B -> D) (ac : A -> C) (cd : C -> D). + +Local Coercion ab : A >-> B. +Local Coercion bd : B >-> D. +Local Coercion ac : A >-> C. +Local Coercion cd : C >-> D. + +Print Graph. + +End test1. +End test1. + +Module test2. +Section test2. +Variable (A : Type) (P Q : A -> Prop). + +Record B := { + B_A : A; + B_P : P B_A }. + +Record C := { + C_A : A; + C_Q : Q C_A }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion B_A : B >-> A. +Local Coercion C_A : C >-> A. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B := Build_B (D_A d) (D_P d). +Local Coercion D_C (d : D) : C := Build_C (D_A d) (D_Q d). + +Print Graph. + +End test2. +End test2. + +Module test3. +Section test3. + +Variable (A : Type) (P Q : A -> Prop). + +Definition A' (x : bool) := A. + +Record B (x : bool) := { + B_A' : A' x; + B_P : P B_A' }. + +Record C (x : bool) := { + C_A' : A' x; + C_Q : Q C_A' }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion A'_A (x : bool) (a : A' x) : A := a. +Local Coercion B_A' : B >-> A'. +Local Coercion C_A' : C >-> A'. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B false := Build_B false (D_A d) (D_P d). +Local Coercion D_C (d : D) : C true := Build_C true (D_A d) (D_Q d). + +Print Graph. + +End test3. +End test3. + +Module test4. +Section test4. + +Variable (A : Type) (P Q : A -> Prop). + +Record A' (x : bool) := { A'_A : A }. + +Record B (x : bool) := { + B_A' : A' x; + B_P : P (A'_A x B_A') }. + +Record C (x : bool) := { + C_A' : A' x; + C_Q : Q (A'_A x C_A') }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion A'_A : A' >-> A. +Local Coercion B_A' : B >-> A'. +Local Coercion C_A' : C >-> A'. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B false := + Build_B false (Build_A' false (D_A d)) (D_P d). +Local Coercion D_C (d : D) : C true := + Build_C true (Build_A' true (D_A d)) (D_Q d). + +Print Graph. + +End test4. +End test4. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v deleted file mode 100644 index 1f62635f50..0000000000 --- a/test-suite/success/CompatOldOldFlag.v +++ /dev/null @@ -1,6 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.7") -*- *) -(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq810. -Import Coq.Compat.Coq89. -Import Coq.Compat.Coq88. -Import Coq.Compat.Coq87. diff --git a/test-suite/success/NumeralNotationsNoLocal.v b/test-suite/success/NumeralNotationsNoLocal.v new file mode 100644 index 0000000000..ea3907ef8a --- /dev/null +++ b/test-suite/success/NumeralNotationsNoLocal.v @@ -0,0 +1,12 @@ +(* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) +Inductive unit11 := tt11. +Declare Scope unit11_scope. +Delimit Scope unit11_scope with unit11. +Goal True. + evar (to_uint : unit11 -> Decimal.uint). + evar (of_uint : Decimal.uint -> unit11). + Fail Numeral Notation unit11 of_uint to_uint : uint11_scope. + exact I. + Unshelve. + all: solve [ constructor ]. +Qed. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 85d7a770fc..02adb012d9 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -13,7 +13,7 @@ Print sigT_rect. Obligation Tactic := program_simplify ; auto with *. About MR. -Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat := +Program Fixpoint merge (n m : nat) {measure (n + m) lt} : nat := match n with | 0 => 0 | S n' => merge n' m @@ -101,5 +101,5 @@ Next Obligation. simpl in *; intros. Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) - {measure (p - n) p} : nat := + {measure (p - n)} : nat := _. diff --git a/test-suite/success/QArithSyntax.v b/test-suite/success/QArithSyntax.v new file mode 100644 index 0000000000..2f2ee0134a --- /dev/null +++ b/test-suite/success/QArithSyntax.v @@ -0,0 +1,9 @@ +Require Import QArith. +Open Scope Q_scope. +Check (eq_refl : 1.02 = 102 # 100). +Check (eq_refl : 1.02e1 = 102 # 10). +Check (eq_refl : 1.02e+03 = 1020). +Check (eq_refl : 1.02e+02 = 102 # 1). +Check (eq_refl : 10.2e-1 = 1.02). +Check (eq_refl : -0.0001 = -1 # 10000). +Check (eq_refl : -0.50 = - 50 # 100). diff --git a/test-suite/success/RealSyntax.v b/test-suite/success/RealSyntax.v new file mode 100644 index 0000000000..2765200991 --- /dev/null +++ b/test-suite/success/RealSyntax.v @@ -0,0 +1,19 @@ +Require Import Reals. +Open Scope R_scope. +Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). +Check (eq_refl : 1.02e1 = IZR 102 / IZR (Z.pow_pos 10 1)). +Check (eq_refl : 1.02e+03 = IZR 102 * IZR (Z.pow_pos 10 1)). +Check (eq_refl : 1.02e+02 = IZR 102). +Check (eq_refl : 10.2e-1 = 1.02). +Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). +Check (eq_refl : -0.5 = IZR (-5) / IZR (Z.pow_pos 10 1)). + +Goal 254e3 = 2540 * 10 ^ 2. +ring. +Qed. + +Require Import Psatz. + +Goal 254e3 = 2540 * 10 ^ 2. +lra. +Qed. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 61273c4f37..7ff5571ffb 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --master || exit $? +dev/tools/update-compat.py --assert-unchanged --release || exit $? diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 0c68b75124..e91f589d67 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -147,10 +147,6 @@ Register not_gt as num.nat.not_gt. See now [Nat.compare] and its properties. In scope [nat_scope], the notation for [Nat.compare] is "?=" *) -Notation nat_compare := Nat.compare (compat "8.7"). - -Notation nat_compare_spec := Nat.compare_spec (compat "8.7"). -Notation nat_compare_eq_iff := Nat.compare_eq_iff (compat "8.7"). Notation nat_compare_S := Nat.compare_succ (only parsing). Lemma nat_compare_lt n m : n<m <-> (n ?= m) = Lt. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index bc58995fd6..c46c23ad60 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -52,7 +52,7 @@ Proof. intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS. Qed. -(** Recursion fonction *) +(** Recursion function *) Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := nat_rect (fun _ => A). diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 9a815d2a7e..63f907e567 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1835,36 +1835,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Implicit Types e : elt. Definition empty : t elt := Bst (empty_bst elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). - Definition mem x m : bool := Raw.mem x m.(this). - Definition find x m : option elt := Raw.find x m.(this). - Definition map f m : t elt' := Bst (map_bst f m.(is_bst)). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Bst (add_bst x e (is_bst m)). + Definition remove x m : t elt := Bst (remove_bst x (is_bst m)). + Definition mem x m : bool := Raw.mem x (this m). + Definition find x m : option elt := Raw.find x (this m). + Definition map f m : t elt' := Bst (map_bst f (is_bst m)). Definition mapi (f:key->elt->elt') m : t elt' := - Bst (mapi_bst f m.(is_bst)). + Bst (mapi_bst f (is_bst m)). Definition map2 f m (m':t elt') : t elt'' := - Bst (map2_bst f m.(is_bst) m'.(is_bst)). - Definition elements m : list (key*elt) := Raw.elements m.(this). - Definition cardinal m := Raw.cardinal m.(this). - Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). + Bst (map2_bst f (is_bst m) (is_bst m')). + Definition elements m : list (key*elt) := Raw.elements (this m). + Definition cardinal m := Raw.cardinal (this m). + Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f (this m) i. + Definition equal cmp m m' : bool := Raw.equal cmp (this m) (this m'). - Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). - Definition In x m : Prop := Raw.In0 x m.(this). - Definition Empty m : Prop := Empty m.(this). + Definition MapsTo x e m : Prop := Raw.MapsTo x e (this m). + Definition In x m : Prop := Raw.In0 x (this m). + Definition Empty m : Prop := Empty (this m). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. + Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. @@ -1876,9 +1876,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_1 _ (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_2 _ (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. @@ -1890,22 +1890,22 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. + Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@find_2 elt m.(this)). Qed. + Proof. intros m; exact (@find_2 elt (this m)). Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). @@ -1920,13 +1920,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. + Proof. intro m; exact (@elements_cardinal elt (this m)). Qed. Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := @@ -1962,7 +1962,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed. Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. @@ -1973,7 +1973,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. @@ -1987,8 +1987,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') @@ -1997,8 +1997,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. End IntMake. @@ -2124,7 +2124,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (* Proofs about [eq] and [lt] *) Definition selements (m1 : t) := - LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). + LO.MapS.Build_slist (P.elements_sort (is_bst m1)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index d19c5558d8..e68bc5930d 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -26,8 +26,6 @@ Hint Extern 1 (Equivalence _) => constructor; congruence : core. Module WFacts_fun (E:DecidableType)(Import M:WSfun E). -Notation option_map := option_map (compat "8.7"). - Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. @@ -676,7 +674,7 @@ Qed. Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. Proof. -unfold Empty; intros m m' Hm. split; intros; intro. +unfold Empty; intros m m' Hm. split; intros; intro. rewrite <-Hm in H0; eapply H, H0. rewrite Hm in H0; eapply H, H0. Qed. @@ -758,7 +756,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Instance eqk_equiv : Equivalence eqk. Proof. unfold eq_key; split; eauto. Qed. - + Instance eqke_equiv : Equivalence eqke. Proof. unfold eq_key_elt; split; repeat red; firstorder. @@ -2198,4 +2196,3 @@ Module OrdProperties (M:S). End Elt. End OrdProperties. - diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 7bc9edff8d..b23885154b 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -466,39 +466,39 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Implicit Types e : elt. Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). - Definition is_empty m : bool := is_empty m.(this). + Definition is_empty m : bool := is_empty (this m). Definition add x e m : t elt := - Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). + Bbst (add_bst x e (is_bst m)) (add_avl x e (is_avl m)). Definition remove x m : t elt := - Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). - Definition mem x m : bool := mem x m.(this). - Definition find x m : option elt := find x m.(this). + Bbst (remove_bst x (is_bst m)) (remove_avl x (is_avl m)). + Definition mem x m : bool := mem x (this m). + Definition find x m : option elt := find x (this m). Definition map f m : t elt' := - Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). + Bbst (map_bst f (is_bst m)) (map_avl f (is_avl m)). Definition mapi (f:key->elt->elt') m : t elt' := - Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). + Bbst (mapi_bst f (is_bst m)) (mapi_avl f (is_avl m)). Definition map2 f m (m':t elt') : t elt'' := - Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). - Definition elements m : list (key*elt) := elements m.(this). - Definition cardinal m := cardinal m.(this). - Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this). + Bbst (map2_bst f (is_bst m) (is_bst m')) (map2_avl f (is_avl m) (is_avl m')). + Definition elements m : list (key*elt) := elements (this m). + Definition cardinal m := cardinal (this m). + Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f (this m) i. + Definition equal cmp m m' : bool := equal cmp (this m) (this m'). - Definition MapsTo x e m : Prop := MapsTo x e m.(this). - Definition In x m : Prop := In0 x m.(this). - Definition Empty m : Prop := Empty m.(this). + Definition MapsTo x e m : Prop := MapsTo x e (this m). + Definition In x m : Prop := In0 x (this m). + Definition Empty m : Prop := Empty (this m). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. + Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. @@ -510,9 +510,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_1 _ (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_2 _ (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. @@ -524,22 +524,22 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. + Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@find_2 elt m.(this)). Qed. + Proof. intros m; exact (@find_2 elt (this m)). Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). @@ -554,13 +554,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. + Proof. intro m; exact (@elements_cardinal elt (this m)). Qed. Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := @@ -596,7 +596,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed. Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. @@ -607,7 +607,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. @@ -621,8 +621,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') @@ -631,8 +631,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. End IntMake. @@ -655,7 +655,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: match D.compare e e' with EQ _ => true | _ => false end. Definition elements (m:t) := - LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). + LO.MapS.Build_slist (Raw.Proofs.elements_sort (is_bst m)). (** * As comparison function, we propose here a non-structural version faithful to the code of Ocaml's Map library, instead of @@ -750,7 +750,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (* Proofs about [eq] and [lt] *) Definition selements (m1 : t) := - LO.MapS.Build_slist (elements_sort m1.(is_bst)). + LO.MapS.Build_slist (elements_sort (is_bst m1)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 4febd64842..335fdc3232 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1037,106 +1037,106 @@ Section Elt. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_sorted elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e). + Definition find x m : option elt := Raw.find x (this m). + Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x). + Definition mem x m : bool := Raw.mem x (this m). + Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f). + Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f). Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). - Definition elements m : list (key*elt) := @Raw.elements elt m.(this). - Definition cardinal m := length m.(this). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). + Build_slist (Raw.map2_sorted f (sorted m) (sorted m')). + Definition elements m : list (key*elt) := @Raw.elements elt (this m). + Definition cardinal m := length (this m). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. + Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - Definition Empty m : Prop := Raw.Empty m.(this). + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). + Definition In x m : Prop := Raw.PX.In x (this m). + Definition Empty m : Prop := Raw.Empty (this m). Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed. + Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed. Lemma empty_1 : Empty empty. Proof. exact (@Raw.empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. + Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. + Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), @@ -1144,14 +1144,14 @@ Section Elt. find x (map2 f m m') = f (find x m) (find x m'). Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). + exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). + exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). Qed. End Make. @@ -1182,7 +1182,7 @@ Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := | _, _ => False end. -Definition eq m m' := eq_list m.(this) m'.(this). +Definition eq m m' := eq_list (this m) (this m'). Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := match m, m' with @@ -1197,7 +1197,7 @@ Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := end end. -Definition lt m m' := lt_list m.(this) m'.(this). +Definition lt m m' := lt_list (this m) (this m'). Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. Proof. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index a923f4e6f9..12550ddf9a 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -882,102 +882,102 @@ Section Elt. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Build_slist (Raw.add_NoDup (NoDup m) x e). + Definition find x m : option elt := Raw.find x (this m). + Definition remove x m : t elt := Build_slist (Raw.remove_NoDup (NoDup m) x). + Definition mem x m : bool := Raw.mem x (this m). + Definition map f m : t elt' := Build_slist (Raw.map_NoDup (NoDup m) f). + Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup (NoDup m) f). Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). - Definition elements m : list (key*elt) := @Raw.elements elt m.(this). - Definition cardinal m := length m.(this). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - Definition Empty m : Prop := Raw.Empty m.(this). + Build_slist (Raw.map2_NoDup f (NoDup m) (NoDup m')). + Definition elements m : list (key*elt) := @Raw.elements elt (this m). + Definition cardinal m := length (this m). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. + Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). + Definition In x m : Prop := Raw.PX.In x (this m). + Definition Empty m : Prop := Raw.Empty (this m). Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed. + Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.mem_1 elt (this m) (NoDup m)). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.mem_2 elt (this m) (NoDup m)). Qed. Lemma empty_1 : Empty empty. Proof. exact (@Raw.empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.remove_1 elt (this m) (NoDup m)). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.remove_2 elt (this m) (NoDup m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.remove_3 elt (this m) (NoDup m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.find_1 elt (this m) (NoDup m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.elements_3w elt (this m) (NoDup m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. + Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. + Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), @@ -985,14 +985,14 @@ Section Elt. find x (map2 f m m') = f (find x m) (find x m'). Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). + exact (@Raw.map2_1 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). + exact (@Raw.map2_2 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). Qed. End Make. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 59b2f789ab..3f8840529e 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -170,7 +170,7 @@ Qed. Lemma equal_cardinal: equal s s'=true -> cardinal s=cardinal s'. Proof. -auto with set. +auto with set fset. Qed. (* Properties of [subset] *) @@ -268,7 +268,7 @@ Proof. intros; apply bool_1; split; intros. rewrite MP.cardinal_1; simpl; auto with set. assert (cardinal s = 0) by (apply zerob_true_elim; auto). -auto with set. +auto with set fset. Qed. (** Properties of [singleton] *) @@ -551,7 +551,7 @@ End Fold. Lemma add_cardinal_1: forall s x, mem x s=true -> cardinal (add x s)=cardinal s. Proof. -auto with set. +auto with set fset. Qed. Lemma add_cardinal_2: @@ -846,9 +846,9 @@ Lemma sum_plus : Proof. unfold sum. intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto. +assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto with fset. assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. -assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto. +assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto with fset. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 17f0e25e7a..6b6546f82d 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -21,8 +21,8 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op Proper respectful : core. -Hint Extern 1 (Equivalence _) => constructor; congruence : core. +Hint Unfold transpose compat_op Proper respectful : fset. +Hint Extern 1 (Equivalence _) => constructor; congruence : fset. (** First, a functor for Weak Sets in functorial version. *) @@ -708,7 +708,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. Proof. - intros; rewrite cardinal_fold; apply fold_1; auto. + intros; rewrite cardinal_fold; apply fold_1; auto with fset. Qed. Lemma cardinal_2 : @@ -716,7 +716,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ => S) x). - apply fold_2; auto. + apply fold_2; auto with fset. Qed. (** ** Cardinal and (non-)emptiness *) @@ -732,7 +732,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. - Hint Resolve cardinal_inv_1 : core. + Hint Resolve cardinal_inv_1 : fset. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. @@ -757,7 +757,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry. remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. induction n; intros. - apply cardinal_1; rewrite <- H; auto. + apply cardinal_1; rewrite <- H; auto with fset. destruct (cardinal_inv_2 Heqn) as (x,H2). revert Heqn. rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. @@ -769,13 +769,13 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). exact Equal_cardinal. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : fset. (** ** Cardinal and set operators *) Lemma empty_cardinal : cardinal empty = 0. Proof. - rewrite cardinal_fold; apply fold_1; auto with set. + rewrite cardinal_fold; apply fold_1; auto with set fset. Qed. Hint Immediate empty_cardinal cardinal_1 : set. @@ -795,7 +795,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma union_cardinal: @@ -804,7 +804,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. - apply fold_union; auto. + apply fold_union; auto with fset. Qed. Lemma subset_cardinal : @@ -838,7 +838,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. do 4 rewrite cardinal_fold. do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@Logic.eq nat); auto. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma union_cardinal_inter : @@ -860,7 +860,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. - auto with set. + auto with set fset. Qed. Lemma add_cardinal_2 : @@ -869,7 +869,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. do 2 rewrite cardinal_fold. change S with ((fun _ => S) x); - apply fold_add with (eqA:=@Logic.eq nat); auto. + apply fold_add with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma remove_cardinal_1 : @@ -878,16 +878,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. do 2 rewrite cardinal_fold. change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. Proof. - auto with set. + auto with set fset. Qed. - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : fset. End WProperties_fun. @@ -952,7 +952,7 @@ Module OrdProperties (M:S). red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. - Hint Resolve gtb_compat leb_compat : core. + Hint Resolve gtb_compat leb_compat : fset. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. @@ -1047,7 +1047,7 @@ Module OrdProperties (M:S). (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. case_eq (max_elt s); intros. apply X0 with (remove e s) e; auto with set. apply IHn. @@ -1068,7 +1068,7 @@ Module OrdProperties (M:S). (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. case_eq (min_elt s); intros. apply X0 with (remove e s) e; auto with set. apply IHn. diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 3d4b3d0568..1a7dadb2c3 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -16,6 +16,8 @@ We represent numbers in base 10 as lists of decimal digits, in big-endian order (most significant digit comes first). *) +Require Import Datatypes. + (** Unsigned integers are just lists of digits. For instance, ten is (D1 (D0 Nil)) *) @@ -42,6 +44,15 @@ Notation zero := (D0 Nil). Variant int := Pos (d:uint) | Neg (d:uint). +(** For decimal numbers, we use two constructors [Decimal] and + [DecimalExp], depending on whether or not they are given with an + exponent (e.g., 1.02e+01). [i] is the integral part while [f] is + the fractional part (beware that leading zeroes do matter). *) + +Variant decimal := + | Decimal (i:int) (f:uint) + | DecimalExp (i:int) (f:uint) (e:int). + Declare Scope dec_uint_scope. Delimit Scope dec_uint_scope with uint. Bind Scope dec_uint_scope with uint. @@ -52,6 +63,14 @@ Bind Scope dec_int_scope with int. Register uint as num.uint.type. Register int as num.int.type. +Register decimal as num.decimal.type. + +Fixpoint nb_digits d := + match d with + | Nil => O + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => + S (nb_digits d) + end. (** This representation favors simplicity over canonicity. For normalizing numbers, we need to remove head zero digits, @@ -115,6 +134,28 @@ Fixpoint revapp (d d' : uint) := Definition rev d := revapp d Nil. +Definition app d d' := revapp (rev d) d'. + +Definition app_int d1 d2 := + match d1 with Pos d1 => Pos (app d1 d2) | Neg d1 => Neg (app d1 d2) end. + +(** [nztail] removes all trailing zero digits and return both the + result and the number of removed digits. *) + +Definition nztail d := + let fix aux d_rev := + match d_rev with + | D0 d_rev => let (r, n) := aux d_rev in pair r (S n) + | _ => pair d_rev O + end in + let (r, n) := aux (rev d) in pair (rev r) n. + +Definition nztail_int d := + match d with + | Pos d => let (r, n) := nztail d in pair (Pos r) n + | Neg d => let (r, n) := nztail d in pair (Neg r) n + end. + Module Little. (** Successor of little-endian numbers *) diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index e5d63c547d..fcec2f2fd6 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -801,19 +801,3 @@ Defined. Hint Resolve left right inleft inright: core. Hint Resolve exist exist2 existT existT2: core. - -(* Compatibility *) - -Notation sigS := sigT (compat "8.7"). -Notation existS := existT (compat "8.7"). -Notation sigS_rect := sigT_rect (compat "8.7"). -Notation sigS_rec := sigT_rec (compat "8.7"). -Notation sigS_ind := sigT_ind (compat "8.7"). -Notation projS1 := projT1 (compat "8.7"). -Notation projS2 := projT2 (compat "8.7"). - -Notation sigS2 := sigT2 (compat "8.7"). -Notation existS2 := existT2 (compat "8.7"). -Notation sigS2_rect := sigT2_rect (compat "8.7"). -Notation sigS2_rec := sigT2_rec (compat "8.7"). -Notation sigS2_ind := sigT2_ind (compat "8.7"). diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index af4632161e..497cf2550b 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -332,3 +332,7 @@ Tactic Notation "assert_succeeds" tactic3(tac) := assert_succeeds tac. Tactic Notation "assert_fails" tactic3(tac) := assert_fails tac. + +Create HintDb rewrite discriminated. +Hint Variables Opaque : rewrite. +Create HintDb typeclass_instances discriminated. diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 86894cd1f2..4576ff4cbe 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -74,8 +74,8 @@ Record retract_cond : Prop := (** The dependent elimination above implies the axiom of choice: *) -Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a. -Proof. intros r. exact r.(inv2). Qed. +Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. +Proof. intros r. exact (inv2 r). Qed. End Retracts. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index b930388d13..e2ec41ca94 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -125,8 +125,6 @@ Proof. apply eq_dep_intro. Qed. -Notation eq_sigS_eq_dep := eq_sigT_eq_dep (compat "8.7"). (* Compatibility *) - Lemma eq_dep_eq_sigT : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), eq_dep p x q y -> existT P p x = existT P q y. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 0ba2799bfb..6a18f59fc4 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -445,7 +445,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Arguments Mkt this {is_ok}. Hint Resolve is_ok : typeclass_instances. - Definition In (x : elt)(s : t) := M.In x s.(this). + Definition In (x : elt)(s : t) := M.In x (this s). Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'. Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'. Definition Empty (s : t) := forall a : elt, ~ In a s. diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index d319ed1029..b8da5a2ed1 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -985,33 +985,13 @@ Notation N_ind := N_ind (only parsing). Notation N0 := N0 (only parsing). Notation Npos := N.pos (only parsing). -Notation Ndiscr := N.discr (compat "8.7"). Notation Ndouble_plus_one := N.succ_double (only parsing). -Notation Ndouble := N.double (compat "8.7"). -Notation Nsucc := N.succ (compat "8.7"). -Notation Npred := N.pred (compat "8.7"). -Notation Nsucc_pos := N.succ_pos (compat "8.7"). -Notation Ppred_N := Pos.pred_N (compat "8.7"). Notation Nplus := N.add (only parsing). Notation Nminus := N.sub (only parsing). Notation Nmult := N.mul (only parsing). -Notation Neqb := N.eqb (compat "8.7"). -Notation Ncompare := N.compare (compat "8.7"). -Notation Nlt := N.lt (compat "8.7"). -Notation Ngt := N.gt (compat "8.7"). -Notation Nle := N.le (compat "8.7"). -Notation Nge := N.ge (compat "8.7"). -Notation Nmin := N.min (compat "8.7"). -Notation Nmax := N.max (compat "8.7"). -Notation Ndiv2 := N.div2 (compat "8.7"). -Notation Neven := N.even (compat "8.7"). -Notation Nodd := N.odd (compat "8.7"). -Notation Npow := N.pow (compat "8.7"). -Notation Nlog2 := N.log2 (compat "8.7"). Notation nat_of_N := N.to_nat (only parsing). Notation N_of_nat := N.of_nat (only parsing). -Notation N_eq_dec := N.eq_dec (compat "8.7"). Notation Nrect := N.peano_rect (only parsing). Notation Nrect_base := N.peano_rect_base (only parsing). Notation Nrect_step := N.peano_rect_succ (only parsing). @@ -1020,11 +1000,8 @@ Notation Nrec := N.peano_rec (only parsing). Notation Nrec_base := N.peano_rec_base (only parsing). Notation Nrec_succ := N.peano_rec_succ (only parsing). -Notation Npred_succ := N.pred_succ (compat "8.7"). Notation Npred_minus := N.pred_sub (only parsing). -Notation Nsucc_pred := N.succ_pred (compat "8.7"). Notation Ppred_N_spec := N.pos_pred_spec (only parsing). -Notation Nsucc_pos_spec := N.succ_pos_spec (compat "8.7"). Notation Ppred_Nsucc := N.pos_pred_succ (only parsing). Notation Nplus_0_l := N.add_0_l (only parsing). Notation Nplus_0_r := N.add_0_r (only parsing). @@ -1032,7 +1009,6 @@ Notation Nplus_comm := N.add_comm (only parsing). Notation Nplus_assoc := N.add_assoc (only parsing). Notation Nplus_succ := N.add_succ_l (only parsing). Notation Nsucc_0 := N.succ_0_discr (only parsing). -Notation Nsucc_inj := N.succ_inj (compat "8.7"). Notation Nminus_N0_Nle := N.sub_0_le (only parsing). Notation Nminus_0_r := N.sub_0_r (only parsing). Notation Nminus_succ_r:= N.sub_succ_r (only parsing). @@ -1042,29 +1018,14 @@ Notation Nmult_1_r := N.mul_1_r (only parsing). Notation Nmult_comm := N.mul_comm (only parsing). Notation Nmult_assoc := N.mul_assoc (only parsing). Notation Nmult_plus_distr_r := N.mul_add_distr_r (only parsing). -Notation Neqb_eq := N.eqb_eq (compat "8.7"). Notation Nle_0 := N.le_0_l (only parsing). -Notation Ncompare_refl := N.compare_refl (compat "8.7"). Notation Ncompare_Eq_eq := N.compare_eq (only parsing). Notation Ncompare_eq_correct := N.compare_eq_iff (only parsing). -Notation Nlt_irrefl := N.lt_irrefl (compat "8.7"). -Notation Nlt_trans := N.lt_trans (compat "8.7"). Notation Nle_lteq := N.lt_eq_cases (only parsing). -Notation Nlt_succ_r := N.lt_succ_r (compat "8.7"). -Notation Nle_trans := N.le_trans (compat "8.7"). -Notation Nle_succ_l := N.le_succ_l (compat "8.7"). -Notation Ncompare_spec := N.compare_spec (compat "8.7"). Notation Ncompare_0 := N.compare_0_r (only parsing). Notation Ndouble_div2 := N.div2_double (only parsing). Notation Ndouble_plus_one_div2 := N.div2_succ_double (only parsing). -Notation Ndouble_inj := N.double_inj (compat "8.7"). Notation Ndouble_plus_one_inj := N.succ_double_inj (only parsing). -Notation Npow_0_r := N.pow_0_r (compat "8.7"). -Notation Npow_succ_r := N.pow_succ_r (compat "8.7"). -Notation Nlog2_spec := N.log2_spec (compat "8.7"). -Notation Nlog2_nonpos := N.log2_nonpos (compat "8.7"). -Notation Neven_spec := N.even_spec (compat "8.7"). -Notation Nodd_spec := N.odd_spec (compat "8.7"). Notation Nlt_not_eq := N.lt_neq (only parsing). Notation Ngt_Nlt := N.gt_lt (only parsing). diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index e2b2b4904e..302ec434d0 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -22,8 +22,6 @@ Local Open Scope N_scope. (** Obsolete results about boolean comparisons over [N], kept for compatibility with IntMap and SMC. *) -Notation Peqb := Pos.eqb (compat "8.7"). -Notation Neqb := N.eqb (compat "8.7"). Notation Peqb_correct := Pos.eqb_refl (only parsing). Notation Neqb_correct := N.eqb_refl (only parsing). Notation Neqb_comm := N.eqb_sym (only parsing). diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v index 885c0d48b1..9d8745fff7 100644 --- a/theories/NArith/Ndiv_def.v +++ b/theories/NArith/Ndiv_def.v @@ -24,10 +24,7 @@ Lemma Pdiv_eucl_remainder a b : snd (Pdiv_eucl a b) < Npos b. Proof. now apply (N.pos_div_eucl_remainder a (Npos b)). Qed. -Notation Ndiv_eucl := N.div_eucl (compat "8.7"). -Notation Ndiv := N.div (compat "8.7"). Notation Nmod := N.modulo (only parsing). Notation Ndiv_eucl_correct := N.div_eucl_spec (only parsing). Notation Ndiv_mod_eq := N.div_mod' (only parsing). -Notation Nmod_lt := N.mod_lt (compat "8.7"). diff --git a/theories/NArith/Nsqrt_def.v b/theories/NArith/Nsqrt_def.v index f043328375..3a37c94fd8 100644 --- a/theories/NArith/Nsqrt_def.v +++ b/theories/NArith/Nsqrt_def.v @@ -13,8 +13,4 @@ Require Import BinNat. (** Obsolete file, see [BinNat] now, only compatibility notations remain here. *) -Notation Nsqrtrem := N.sqrtrem (compat "8.7"). -Notation Nsqrt := N.sqrt (compat "8.7"). -Notation Nsqrtrem_spec := N.sqrtrem_spec (compat "8.7"). Notation Nsqrt_spec := (fun n => N.sqrt_spec n (N.le_0_l n)) (only parsing). -Notation Nsqrtrem_sqrt := N.sqrtrem_sqrt (compat "8.7"). diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 01ecdd710c..c85252d6f8 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1907,12 +1907,8 @@ Notation IsNul := Pos.IsNul (only parsing). Notation IsPos := Pos.IsPos (only parsing). Notation IsNeg := Pos.IsNeg (only parsing). -Notation Psucc := Pos.succ (compat "8.7"). Notation Pplus := Pos.add (only parsing). Notation Pplus_carry := Pos.add_carry (only parsing). -Notation Ppred := Pos.pred (compat "8.7"). -Notation Piter_op := Pos.iter_op (compat "8.7"). -Notation Piter_op_succ := Pos.iter_op_succ (compat "8.7"). Notation Pmult_nat := (Pos.iter_op plus) (only parsing). Notation nat_of_P := Pos.to_nat (only parsing). Notation P_of_succ_nat := Pos.of_succ_nat (only parsing). @@ -1922,29 +1918,17 @@ Notation positive_mask_rect := Pos.mask_rect (only parsing). Notation positive_mask_ind := Pos.mask_ind (only parsing). Notation positive_mask_rec := Pos.mask_rec (only parsing). Notation Pdouble_plus_one_mask := Pos.succ_double_mask (only parsing). -Notation Pdouble_mask := Pos.double_mask (compat "8.7"). Notation Pdouble_minus_two := Pos.double_pred_mask (only parsing). Notation Pminus_mask := Pos.sub_mask (only parsing). Notation Pminus_mask_carry := Pos.sub_mask_carry (only parsing). Notation Pminus := Pos.sub (only parsing). Notation Pmult := Pos.mul (only parsing). Notation iter_pos := @Pos.iter (only parsing). -Notation Ppow := Pos.pow (compat "8.7"). -Notation Pdiv2 := Pos.div2 (compat "8.7"). -Notation Pdiv2_up := Pos.div2_up (compat "8.7"). Notation Psize := Pos.size_nat (only parsing). Notation Psize_pos := Pos.size (only parsing). Notation Pcompare x y m := (Pos.compare_cont m x y) (only parsing). -Notation Plt := Pos.lt (compat "8.7"). -Notation Pgt := Pos.gt (compat "8.7"). -Notation Ple := Pos.le (compat "8.7"). -Notation Pge := Pos.ge (compat "8.7"). -Notation Pmin := Pos.min (compat "8.7"). -Notation Pmax := Pos.max (compat "8.7"). -Notation Peqb := Pos.eqb (compat "8.7"). Notation positive_eq_dec := Pos.eq_dec (only parsing). Notation xI_succ_xO := Pos.xI_succ_xO (only parsing). -Notation Psucc_discr := Pos.succ_discr (compat "8.7"). Notation Psucc_o_double_minus_one_eq_xO := Pos.succ_pred_double (only parsing). Notation Pdouble_minus_one_o_succ_eq_xI := @@ -1953,9 +1937,7 @@ Notation xO_succ_permute := Pos.double_succ (only parsing). Notation double_moins_un_xO_discr := Pos.pred_double_xO_discr (only parsing). Notation Psucc_not_one := Pos.succ_not_1 (only parsing). -Notation Ppred_succ := Pos.pred_succ (compat "8.7"). Notation Psucc_pred := Pos.succ_pred_or (only parsing). -Notation Psucc_inj := Pos.succ_inj (compat "8.7"). Notation Pplus_carry_spec := Pos.add_carry_spec (only parsing). Notation Pplus_comm := Pos.add_comm (only parsing). Notation Pplus_succ_permute_r := Pos.add_succ_r (only parsing). @@ -2002,17 +1984,11 @@ Notation Pmult_xO_discr := Pos.mul_xO_discr (only parsing). Notation Pmult_reg_r := Pos.mul_reg_r (only parsing). Notation Pmult_reg_l := Pos.mul_reg_l (only parsing). Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (only parsing). -Notation Psquare_xO := Pos.square_xO (compat "8.7"). -Notation Psquare_xI := Pos.square_xI (compat "8.7"). Notation iter_pos_swap_gen := Pos.iter_swap_gen (only parsing). Notation iter_pos_swap := Pos.iter_swap (only parsing). Notation iter_pos_succ := Pos.iter_succ (only parsing). Notation iter_pos_plus := Pos.iter_add (only parsing). Notation iter_pos_invariant := Pos.iter_invariant (only parsing). -Notation Ppow_1_r := Pos.pow_1_r (compat "8.7"). -Notation Ppow_succ_r := Pos.pow_succ_r (compat "8.7"). -Notation Peqb_refl := Pos.eqb_refl (compat "8.7"). -Notation Peqb_eq := Pos.eqb_eq (compat "8.7"). Notation Pcompare_refl_id := Pos.compare_cont_refl (only parsing). Notation Pcompare_eq_iff := Pos.compare_eq_iff (only parsing). Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (only parsing). @@ -2022,23 +1998,9 @@ Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (only parsing). Notation Pcompare_antisym := Pos.compare_cont_antisym (only parsing). Notation ZC1 := Pos.gt_lt (only parsing). Notation ZC2 := Pos.lt_gt (only parsing). -Notation Pcompare_spec := Pos.compare_spec (compat "8.7"). Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (only parsing). -Notation Pcompare_succ_succ := Pos.compare_succ_succ (compat "8.7"). Notation Pcompare_1 := Pos.nlt_1_r (only parsing). Notation Plt_1 := Pos.nlt_1_r (only parsing). -Notation Plt_1_succ := Pos.lt_1_succ (compat "8.7"). -Notation Plt_lt_succ := Pos.lt_lt_succ (compat "8.7"). -Notation Plt_irrefl := Pos.lt_irrefl (compat "8.7"). -Notation Plt_trans := Pos.lt_trans (compat "8.7"). -Notation Plt_ind := Pos.lt_ind (compat "8.7"). -Notation Ple_lteq := Pos.le_lteq (compat "8.7"). -Notation Ple_refl := Pos.le_refl (compat "8.7"). -Notation Ple_lt_trans := Pos.le_lt_trans (compat "8.7"). -Notation Plt_le_trans := Pos.lt_le_trans (compat "8.7"). -Notation Ple_trans := Pos.le_trans (compat "8.7"). -Notation Plt_succ_r := Pos.lt_succ_r (compat "8.7"). -Notation Ple_succ_l := Pos.le_succ_l (compat "8.7"). Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (only parsing). Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (only parsing). Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (only parsing). @@ -2057,8 +2019,6 @@ Notation Pmult_le_mono_r := Pos.mul_le_mono_r (only parsing). Notation Pmult_le_mono := Pos.mul_le_mono (only parsing). Notation Plt_plus_r := Pos.lt_add_r (only parsing). Notation Plt_not_plus_l := Pos.lt_not_add_l (only parsing). -Notation Ppow_gt_1 := Pos.pow_gt_1 (compat "8.7"). -Notation Ppred_mask := Pos.pred_mask (compat "8.7"). Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (only parsing). Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (only parsing). Notation Pminus_succ_r := Pos.sub_succ_r (only parsing). diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 139c4bf432..790bdf9ed6 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -29,12 +29,38 @@ Ltac simpl_mult := rewrite ?Pos2Z.inj_mul. Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope. +Definition of_decimal (d:Decimal.decimal) : Q := + let '(i, f, e) := + match d with + | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Decimal.DecimalExp i f e => (i, f, e) + end in + let num := Z.of_int (Decimal.app_int i f) in + let e := Z.sub (Z.of_int e) (Z.of_nat (Decimal.nb_digits f)) in + match e with + | Z0 => Qmake num 1 + | Zpos e => Qmake (Pos.iter (Z.mul 10) num e) 1 + | Zneg e => Qmake num (Pos.iter (Pos.mul 10) 1%positive e) + end. + +Definition to_decimal (q:Q) : option Decimal.decimal := + let num := Z.to_int (Qnum q) in + let (den, e_den) := Decimal.nztail (Pos.to_uint (Qden q)) in + match den with + | Decimal.D1 Decimal.Nil => + match Z.of_nat e_den with + | Z0 => Some (Decimal.Decimal num Decimal.Nil) + | e => Some (Decimal.DecimalExp num Decimal.Nil (Z.to_int (Z.opp e))) + end + | _ => None + end. + +Numeral Notation Q of_decimal to_decimal : Q_scope. + Definition inject_Z (x : Z) := Qmake x 1. Arguments inject_Z x%Z. Notation QDen p := (Zpos (Qden p)). -Notation " 0 " := (0#1) : Q_scope. -Notation " 1 " := (1#1) : Q_scope. Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z. Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z. diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index e66130b347..d16b5a3020 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -82,7 +82,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs elim (Hyp eps eps_pos) ; intros delta Hyp2. assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0). clear-a lb ub a_encad delta. - apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. + apply Rmin_pos ; [exact ((cond_pos delta)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond). intros h h_neq h_encad. replace (g (a + h) - g a) with (f (a + h) - f a). @@ -120,7 +120,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs elim (Hyp eps eps_pos) ; intros delta Hyp2. assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0). clear-a lb ub a_encad delta. - apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. + apply Rmin_pos ; [exact ((cond_pos delta)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond). intros h h_neq h_encad. replace (f (a + h) - f a) with (g (a + h) - g a). @@ -696,7 +696,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. intros deltatemp' Htemp'. exists deltatemp'. split. - exact deltatemp'.(cond_pos). + exact (cond_pos deltatemp'). intros htemp cond. apply (Htemp' htemp). exact (proj1 cond). @@ -721,7 +721,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. assert (mydelta_pos : mydelta > 0). unfold mydelta, Rmin. case (Rle_dec delta alpha). - intro ; exact (delta.(cond_pos)). + intro ; exact ((cond_pos delta)). intro ; exact alpha_pos. elim (g_cont mydelta mydelta_pos). intros delta' new_g_cont. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 59e0148625..e17f02bb6e 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -15,7 +15,6 @@ Require Import Rbase. Require Import R_Ifp. -Require Import Lra. Local Open Scope R_scope. Implicit Type r : R. @@ -357,7 +356,9 @@ Qed. Lemma Rle_abs : forall x:R, x <= Rabs x. Proof. - intro; unfold Rabs; case (Rcase_abs x); intros; lra. + intro; unfold Rabs; case (Rcase_abs x); intros;auto with real. + apply Rminus_le; rewrite <- Rplus_0_r; + unfold Rminus; rewrite Ropp_involutive; auto with real. Qed. Definition RRle_abs := Rle_abs. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index b6b72de889..2bfd99ebc7 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -136,7 +136,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') eps > 0 -> exists alp : R, alp > 0 /\ - (forall x:Base X, D x /\ X.(dist) x x0 < alp -> X'.(dist) (f x) l < eps). + (forall x:Base X, D x /\ (dist X) x x0 < alp -> (dist X') (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -165,9 +165,9 @@ Lemma tech_limit : Proof. intros f D l x0 H H0. case (Rabs_pos (f x0 - l)); intros H1. - absurd (R_met.(@dist) (f x0) l < R_met.(@dist) (f x0) l). + absurd ((@dist R_met) (f x0) l < (@dist R_met) (f x0) l). apply Rlt_irrefl. - case (H0 (R_met.(@dist) (f x0) l)); auto. + case (H0 ((@dist R_met) (f x0) l)); auto. intros alpha1 [H2 H3]; apply H3; auto; split; auto. case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto. case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 346c300ee5..4591c7ed94 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -128,9 +128,9 @@ Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. [EqualityType] and [DecidableType] *) Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. - Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _). - Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _). - Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _). + Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. + Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. + Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. End BackportEq. Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 542d169e66..a346ab8ccb 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1612,40 +1612,18 @@ End Z2Pos. Notation Zdouble_plus_one := Z.succ_double (only parsing). Notation Zdouble_minus_one := Z.pred_double (only parsing). -Notation Zdouble := Z.double (compat "8.7"). Notation ZPminus := Z.pos_sub (only parsing). -Notation Zsucc' := Z.succ (compat "8.7"). -Notation Zpred' := Z.pred (compat "8.7"). -Notation Zplus' := Z.add (compat "8.7"). Notation Zplus := Z.add (only parsing). (* Slightly incompatible *) -Notation Zopp := Z.opp (compat "8.7"). -Notation Zsucc := Z.succ (compat "8.7"). -Notation Zpred := Z.pred (compat "8.7"). Notation Zminus := Z.sub (only parsing). Notation Zmult := Z.mul (only parsing). -Notation Zcompare := Z.compare (compat "8.7"). -Notation Zsgn := Z.sgn (compat "8.7"). -Notation Zle := Z.le (compat "8.7"). -Notation Zge := Z.ge (compat "8.7"). -Notation Zlt := Z.lt (compat "8.7"). -Notation Zgt := Z.gt (compat "8.7"). -Notation Zmax := Z.max (compat "8.7"). -Notation Zmin := Z.min (compat "8.7"). -Notation Zabs := Z.abs (compat "8.7"). -Notation Zabs_nat := Z.abs_nat (compat "8.7"). -Notation Zabs_N := Z.abs_N (compat "8.7"). Notation Z_of_nat := Z.of_nat (only parsing). Notation Z_of_N := Z.of_N (only parsing). Notation Zind := Z.peano_ind (only parsing). -Notation Zopp_0 := Z.opp_0 (compat "8.7"). -Notation Zopp_involutive := Z.opp_involutive (compat "8.7"). -Notation Zopp_inj := Z.opp_inj (compat "8.7"). Notation Zplus_0_l := Z.add_0_l (only parsing). Notation Zplus_0_r := Z.add_0_r (only parsing). Notation Zplus_comm := Z.add_comm (only parsing). Notation Zopp_plus_distr := Z.opp_add_distr (only parsing). -Notation Zopp_succ := Z.opp_succ (compat "8.7"). Notation Zplus_opp_r := Z.add_opp_diag_r (only parsing). Notation Zplus_opp_l := Z.add_opp_diag_l (only parsing). Notation Zplus_assoc := Z.add_assoc (only parsing). @@ -1654,11 +1632,6 @@ Notation Zplus_reg_l := Z.add_reg_l (only parsing). Notation Zplus_succ_l := Z.add_succ_l (only parsing). Notation Zplus_succ_comm := Z.add_succ_comm (only parsing). Notation Zsucc_discr := Z.neq_succ_diag_r (only parsing). -Notation Zsucc_inj := Z.succ_inj (compat "8.7"). -Notation Zsucc'_inj := Z.succ_inj (compat "8.7"). -Notation Zsucc'_pred' := Z.succ_pred (compat "8.7"). -Notation Zpred'_succ' := Z.pred_succ (compat "8.7"). -Notation Zpred'_inj := Z.pred_inj (compat "8.7"). Notation Zsucc'_discr := Z.neq_succ_diag_r (only parsing). Notation Zminus_0_r := Z.sub_0_r (only parsing). Notation Zminus_diag := Z.sub_diag (only parsing). diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index 6cadf30f85..88288d3964 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -34,8 +34,6 @@ Lemma Zcompare_rec (P:Set) (n m:Z) : ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P. Proof. apply Zcompare_rect. Defined. -Notation Z_eq_dec := Z.eq_dec (compat "8.7"). - Section decidability. Variables x y : Z. diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index 057eb49965..d926198a9c 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -29,17 +29,13 @@ Local Open Scope Z_scope. (**********************************************************************) (** * Properties of absolute value *) -Notation Zabs_eq := Z.abs_eq (compat "8.7"). Notation Zabs_non_eq := Z.abs_neq (only parsing). Notation Zabs_Zopp := Z.abs_opp (only parsing). Notation Zabs_pos := Z.abs_nonneg (only parsing). -Notation Zabs_involutive := Z.abs_involutive (compat "8.7"). Notation Zabs_eq_case := Z.abs_eq_cases (only parsing). -Notation Zabs_triangle := Z.abs_triangle (compat "8.7"). Notation Zsgn_Zabs := Z.sgn_abs (only parsing). Notation Zabs_Zsgn := Z.abs_sgn (only parsing). Notation Zabs_Zmult := Z.abs_mul (only parsing). -Notation Zabs_square := Z.abs_square (compat "8.7"). (** * Proving a property of the absolute value by cases *) diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v index 6ccb0153de..eec3878898 100644 --- a/theories/ZArith/Zcompare.v +++ b/theories/ZArith/Zcompare.v @@ -183,15 +183,8 @@ Qed. (** Compatibility notations *) -Notation Zcompare_refl := Z.compare_refl (compat "8.7"). Notation Zcompare_Eq_eq := Z.compare_eq (only parsing). Notation Zcompare_Eq_iff_eq := Z.compare_eq_iff (only parsing). -Notation Zcompare_spec := Z.compare_spec (compat "8.7"). -Notation Zmin_l := Z.min_l (compat "8.7"). -Notation Zmin_r := Z.min_r (compat "8.7"). -Notation Zmax_l := Z.max_l (compat "8.7"). -Notation Zmax_r := Z.max_r (compat "8.7"). -Notation Zabs_eq := Z.abs_eq (compat "8.7"). Notation Zabs_non_eq := Z.abs_neq (only parsing). Notation Zsgn_0 := Z.sgn_null (only parsing). Notation Zsgn_1 := Z.sgn_pos (only parsing). diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index c278cada61..8b69fb04f4 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -21,11 +21,8 @@ Local Open Scope Z_scope. specifications and properties are in [BinInt]. *) Notation Zdiv_eucl_POS := Z.pos_div_eucl (only parsing). -Notation Zdiv_eucl := Z.div_eucl (compat "8.7"). -Notation Zdiv := Z.div (compat "8.7"). Notation Zmod := Z.modulo (only parsing). -Notation Zdiv_eucl_eq := Z.div_eucl_eq (compat "8.7"). Notation Z_div_mod_eq_full := Z.div_mod (only parsing). Notation Zmod_POS_bound := Z.pos_div_eucl_bound (only parsing). Notation Zmod_pos_bound := Z.mod_pos_bound (only parsing). diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 9e83bfc136..45d0f58524 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -141,9 +141,6 @@ Notation Zodd_bool_pred := Z.odd_pred (only parsing). (** * Definition of [Z.quot2], [Z.div2] and properties wrt [Zeven] and [Zodd] *) -Notation Zdiv2 := Z.div2 (compat "8.7"). -Notation Zquot2 := Z.quot2 (compat "8.7"). - (** Properties of [Z.div2] *) Lemma Zdiv2_odd_eqn n : n = 2*(Z.div2 n) + if Z.odd n then 1 else 0. diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index 26bd9e8171..08d4de0d1e 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -18,22 +18,13 @@ Local Open Scope Z_scope. (** Exact compatibility *) -Notation Zmax_case := Z.max_case (compat "8.7"). -Notation Zmax_case_strong := Z.max_case_strong (compat "8.7"). Notation Zmax_right := Z.max_r (only parsing). -Notation Zle_max_l := Z.le_max_l (compat "8.7"). -Notation Zle_max_r := Z.le_max_r (compat "8.7"). -Notation Zmax_lub := Z.max_lub (compat "8.7"). -Notation Zmax_lub_lt := Z.max_lub_lt (compat "8.7"). Notation Zle_max_compat_r := Z.max_le_compat_r (only parsing). Notation Zle_max_compat_l := Z.max_le_compat_l (only parsing). Notation Zmax_idempotent := Z.max_id (only parsing). Notation Zmax_n_n := Z.max_id (only parsing). -Notation Zmax_comm := Z.max_comm (compat "8.7"). -Notation Zmax_assoc := Z.max_assoc (compat "8.7"). Notation Zmax_irreducible_dec := Z.max_dec (only parsing). Notation Zmax_le_prime := Z.max_le (only parsing). -Notation Zsucc_max_distr := Z.succ_max_distr (compat "8.7"). Notation Zmax_SS := Z.succ_max_distr (only parsing). Notation Zplus_max_distr_l := Z.add_max_distr_l (only parsing). Notation Zplus_max_distr_r := Z.add_max_distr_r (only parsing). diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index 5509ee7865..b56f563e0e 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -18,20 +18,11 @@ Local Open Scope Z_scope. (** Exact compatibility *) -Notation Zmin_case := Z.min_case (compat "8.7"). -Notation Zmin_case_strong := Z.min_case_strong (compat "8.7"). -Notation Zle_min_l := Z.le_min_l (compat "8.7"). -Notation Zle_min_r := Z.le_min_r (compat "8.7"). -Notation Zmin_glb := Z.min_glb (compat "8.7"). -Notation Zmin_glb_lt := Z.min_glb_lt (compat "8.7"). Notation Zle_min_compat_r := Z.min_le_compat_r (only parsing). Notation Zle_min_compat_l := Z.min_le_compat_l (only parsing). Notation Zmin_idempotent := Z.min_id (only parsing). Notation Zmin_n_n := Z.min_id (only parsing). -Notation Zmin_comm := Z.min_comm (compat "8.7"). -Notation Zmin_assoc := Z.min_assoc (compat "8.7"). Notation Zmin_irreducible_inf := Z.min_dec (only parsing). -Notation Zsucc_min_distr := Z.succ_min_distr (compat "8.7"). Notation Zmin_SS := Z.succ_min_distr (only parsing). Notation Zplus_min_distr_r := Z.add_min_distr_r (only parsing). Notation Zmin_plus := Z.add_min_distr_r (only parsing). diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index e6066d53f9..7191825af0 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -27,28 +27,15 @@ Open Scope Z_scope. - properties of the efficient [Z.gcd] function *) -Notation Zgcd := Z.gcd (compat "8.7"). -Notation Zggcd := Z.ggcd (compat "8.7"). -Notation Zggcd_gcd := Z.ggcd_gcd (compat "8.7"). -Notation Zggcd_correct_divisors := Z.ggcd_correct_divisors (compat "8.7"). -Notation Zgcd_divide_l := Z.gcd_divide_l (compat "8.7"). -Notation Zgcd_divide_r := Z.gcd_divide_r (compat "8.7"). -Notation Zgcd_greatest := Z.gcd_greatest (compat "8.7"). -Notation Zgcd_nonneg := Z.gcd_nonneg (compat "8.7"). -Notation Zggcd_opp := Z.ggcd_opp (compat "8.7"). - (** The former specialized inductive predicate [Z.divide] is now a generic existential predicate. *) -Notation Zdivide := Z.divide (compat "8.7"). - (** Its former constructor is now a pseudo-constructor. *) Definition Zdivide_intro a b q (H:b=q*a) : Z.divide a b := ex_intro _ q H. (** Results concerning divisibility*) -Notation Zdivide_refl := Z.divide_refl (compat "8.7"). Notation Zone_divide := Z.divide_1_l (only parsing). Notation Zdivide_0 := Z.divide_0_r (only parsing). Notation Zmult_divide_compat_l := Z.mul_divide_mono_l (only parsing). @@ -95,11 +82,6 @@ Qed. Notation Zdivide_1 := Z.divide_1_r (only parsing). -(** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *) - -Notation Zdivide_antisym := Z.divide_antisym (compat "8.7"). -Notation Zdivide_trans := Z.divide_trans (compat "8.7"). - (** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *) Lemma Zdivide_bounds a b : (a | b) -> b <> 0 -> Z.abs a <= Z.abs b. @@ -800,8 +782,6 @@ Proof. rewrite <- Zdivide_Zdiv_eq; auto. Qed. -Notation Zgcd_comm := Z.gcd_comm (compat "8.7"). - Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd b c). Proof. symmetry. apply Z.gcd_assoc. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index bd460f77f0..9911a568cc 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -71,10 +71,6 @@ Register not_Zeq as plugins.omega.not_Zeq. (** * Relating strict and large orders *) -Notation Zgt_lt := Z.gt_lt (compat "8.7"). -Notation Zlt_gt := Z.lt_gt (compat "8.7"). -Notation Zge_le := Z.ge_le (compat "8.7"). -Notation Zle_ge := Z.le_ge (compat "8.7"). Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing). Notation Zge_iff_le := Z.ge_le_iff (only parsing). @@ -134,7 +130,6 @@ Register not_Zne as plugins.omega.not_Zne. (** Reflexivity *) -Notation Zle_refl := Z.le_refl (compat "8.7"). Notation Zeq_le := Z.eq_le_incl (only parsing). Hint Resolve Z.le_refl: zarith. @@ -154,7 +149,6 @@ Qed. (** Irreflexivity *) -Notation Zlt_irrefl := Z.lt_irrefl (compat "8.7"). Notation Zlt_not_eq := Z.lt_neq (only parsing). Lemma Zgt_irrefl n : ~ n > n. @@ -178,8 +172,6 @@ Notation Zle_or_lt := Z.le_gt_cases (only parsing). (** Transitivity of strict orders *) -Notation Zlt_trans := Z.lt_trans (compat "8.7"). - Lemma Zgt_trans n m p : n > m -> m > p -> n > p. Proof. Z.swap_greater. intros; now transitivity m. @@ -187,9 +179,6 @@ Qed. (** Mixed transitivity *) -Notation Zlt_le_trans := Z.lt_le_trans (compat "8.7"). -Notation Zle_lt_trans := Z.le_lt_trans (compat "8.7"). - Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p. Proof. Z.swap_greater. Z.order. @@ -202,8 +191,6 @@ Qed. (** Transitivity of large orders *) -Notation Zle_trans := Z.le_trans (compat "8.7"). - Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p. Proof. Z.swap_greater. Z.order. @@ -268,9 +255,6 @@ Qed. (** Relating strict and large order using successor or predecessor *) -Notation Zlt_succ_r := Z.lt_succ_r (compat "8.7"). -Notation Zle_succ_l := Z.le_succ_l (compat "8.7"). - Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m. Proof. Z.swap_greater. apply Z.le_succ_l. @@ -347,9 +331,6 @@ Qed. (** Special cases of ordered integers *) -Notation Zlt_0_1 := Z.lt_0_1 (compat "8.7"). -Notation Zle_0_1 := Z.le_0_1 (compat "8.7"). - Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. Proof. exact Pos2Z.neg_le_pos. diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index 881ead1c4b..6e4850338a 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -233,7 +233,5 @@ Qed. (** * Z.square: a direct definition of [z^2] *) -Notation Psquare := Pos.square (compat "8.7"). -Notation Zsquare := Z.square (compat "8.7"). Notation Psquare_correct := Pos.square_spec (only parsing). Notation Zsquare_correct := Z.square_spec (only parsing). diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index 264109dc6f..a619eb90ef 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -37,17 +37,7 @@ Notation Ndiv_Zquot := N2Z.inj_quot (only parsing). Notation Nmod_Zrem := N2Z.inj_rem (only parsing). Notation Z_quot_rem_eq := Z.quot_rem' (only parsing). Notation Zrem_lt := Z.rem_bound_abs (only parsing). -Notation Zquot_unique := Z.quot_unique (compat "8.7"). -Notation Zrem_unique := Z.rem_unique (compat "8.7"). -Notation Zrem_1_r := Z.rem_1_r (compat "8.7"). -Notation Zquot_1_r := Z.quot_1_r (compat "8.7"). -Notation Zrem_1_l := Z.rem_1_l (compat "8.7"). -Notation Zquot_1_l := Z.quot_1_l (compat "8.7"). -Notation Z_quot_same := Z.quot_same (compat "8.7"). Notation Z_quot_mult := Z.quot_mul (only parsing). -Notation Zquot_small := Z.quot_small (compat "8.7"). -Notation Zrem_small := Z.rem_small (compat "8.7"). -Notation Zquot2_quot := Zquot2_quot (compat "8.7"). (** Particular values taken for [a÷0] and [(Z.rem a 0)]. We avise to not rely on these arbitrary values. *) diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index bd9d8c9221..0236c549d5 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -468,6 +468,9 @@ beautify: $(BEAUTYFILES) # Extensions can't assume when they run. install: + $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ + if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ + done; exit $$code $(HIDE)for f in $(FILESTOINSTALL); do\ df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ if [ "$$?" != "0" -o -z "$$df" ]; then\ diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 854dd25b75..3d07661d56 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -34,6 +34,24 @@ def reformat_time_string(time): minutes, seconds = divmod(seconds, 60) return '%dm%02d.%ss' % (minutes, seconds, milliseconds) +def get_file_lines(file_name): + if file_name == '-': + if hasattr(sys.stdin, 'buffer'): + lines = sys.stdin.buffer.readlines() + else: + lines = sys.stdin.readlines() + else: + with open(file_name, 'rb') as f: + lines = f.readlines() + for line in lines: + try: + yield line.decode('utf-8') + except UnicodeDecodeError: # invalid utf-8 + pass + +def get_file(file_name): + return ''.join(get_file_lines(file_name)) + def get_times(file_name): ''' Reads the contents of file_name, which should be the output of @@ -41,11 +59,7 @@ def get_times(file_name): names to compile durations, as strings. Removes common prefixes using STRIP_REG and STRIP_REP. ''' - if file_name == '-': - lines = sys.stdin.read() - else: - with open(file_name, 'r', encoding="utf-8") as f: - lines = f.read() + lines = get_file(file_name) reg = re.compile(r'^([^\s]+) \([^\)]*?user: ([0-9\.]+)[^\)]*?\)\s*$', re.MULTILINE) times = reg.findall(lines) if all(time in ('0.00', '0.01') for name, time in times): @@ -61,11 +75,7 @@ def get_single_file_times(file_name): 'coqc -time', and parses it to construct a dict mapping lines to to compile durations, as strings. ''' - if file_name == '-': - lines = sys.stdin.read() - else: - with open(file_name, 'r', encoding="utf-8") as f: - lines = f.read() + lines = get_file(file_name) reg = re.compile(r'^Chars ([0-9]+) - ([0-9]+) ([^ ]+) ([0-9\.]+) secs (.*)$', re.MULTILINE) times = reg.findall(lines) if len(times) == 0: return dict() @@ -209,11 +219,10 @@ def make_table_string(times_dict, def print_or_write_table(table, files): if len(files) == 0 or '-' in files: - try: - binary_stdout = sys.stdout.buffer - except AttributeError: - binary_stdout = sys.stdout - print(table.encode("utf-8"), file=binary_stdout) + if hasattr(sys.stdout, 'buffer'): + sys.stdout.buffer.write(table.encode("utf-8")) + else: + sys.stdout.write(table.encode("utf-8")) for file_name in files: if file_name != '-': with open(file_name, 'w', encoding="utf-8") as f: diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 66f1f257b8..7114965a11 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -563,4 +563,5 @@ let _ = try coqdep () with CoqlibError msg -> - eprintf "*** Error: %s@\n%!" msg + eprintf "*** Error: %s@\n%!" msg; + exit 1 diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 3fe6ad0718..416ea88c1b 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -85,7 +85,7 @@ let ensure_exists f = let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Proof_global.get_all_proof_names () in + let pfs = Vernacstate.Proof_global.get_all_proof_names () in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index d682d3641f..319f5c8ad6 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -38,6 +38,8 @@ type color = [`ON | `AUTO | `OFF] type native_compiler = NativeOff | NativeOn of { ondemand : bool } +type option_command = OptionSet of string option | OptionUnset + type t = { load_init : bool; @@ -63,6 +65,8 @@ type t = { allow_sprop : bool; cumulative_sprop : bool; + set_options : (Goptions.option_name * option_command) list; + stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; @@ -115,6 +119,8 @@ let default = { allow_sprop = false; cumulative_sprop = false; + set_options = []; + stm_flags = Stm.AsyncOpts.default_opts; debug = false; diffs_set = false; @@ -155,7 +161,6 @@ let add_vo_require opts d p export = let add_compat_require opts v = match v with - | Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false) | Flags.V8_8 -> add_vo_require opts "Coq.Compat.Coq88" None (Some false) | Flags.V8_9 -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) | Flags.Current -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) @@ -246,6 +251,16 @@ let get_native_name s = Nativelib.output_dir; Library.native_name_from_filename s] with _ -> "" +let to_opt_key = Str.(split (regexp " +")) + +let parse_option_set opt = + match String.index_opt opt '=' with + | None -> to_opt_key opt, None + | Some eqi -> + let len = String.length opt in + let v = String.sub opt (eqi+1) (len - eqi - 1) in + to_opt_key (String.sub opt 0 eqi), Some v + (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] between coqtop and coqc. *) @@ -451,6 +466,16 @@ let parse_args ~help ~init arglist : t * string list = in { oval with native_compiler } + | "-set" -> + let opt = next() in + let opt, v = parse_option_set opt in + { oval with set_options = (opt, OptionSet v) :: oval.set_options } + + | "-unset" -> + let opt = next() in + let opt = to_opt_key opt in + { oval with set_options = (opt, OptionUnset) :: oval.set_options } + (* Options with zero arg *) |"-async-queries-always-delegate" |"-async-proofs-always-delegate" diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 97a62e97e4..9bcfdca332 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -14,6 +14,8 @@ val default_toplevel : Names.DirPath.t type native_compiler = NativeOff | NativeOn of { ondemand : bool } +type option_command = OptionSet of string option | OptionUnset + type t = { load_init : bool; @@ -38,6 +40,8 @@ type t = { allow_sprop : bool; cumulative_sprop : bool; + set_options : (Goptions.option_name * option_command) list; + stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index d4107177a7..fd4c515209 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -46,8 +46,9 @@ let coqc_main () = outputstate copts; flush_all(); + if opts.Coqargs.output_context then begin - let sigma, env = Pfedit.get_current_context () in + let sigma, env = let e = Global.env () in Evd.from_env e, e in Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 1094fc86b4..4129562065 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -191,8 +191,8 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Proof_global.get_current_proof_name ())) ^ " < " - with Proof_global.NoCurrentProof -> + (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " + with Vernacstate.Proof_global.NoCurrentProof -> "Coq < " (* the coq prompt added to the default one when in emacs mode @@ -340,9 +340,7 @@ let print_anyway_opts = [ let print_anyway c = let open Vernacexpr in match c with - | VernacExpr (_, VernacSetOption (_, opt, _)) - | VernacExpr (_, VernacUnsetOption (_, opt)) -> - List.mem opt print_anyway_opts + | VernacExpr (_, VernacSetOption (_, opt, _)) -> List.mem opt print_anyway_opts | _ -> false (* We try to behave better when goal printing raises an exception @@ -353,7 +351,7 @@ let print_anyway c = let top_goal_print ~doc c oldp newp = try let proof_changed = not (Option.equal cproof oldp newp) in - let print_goals = proof_changed && Proof_global.there_are_pending_proofs () || + let print_goals = proof_changed && Vernacstate.Proof_global.there_are_pending_proofs () || print_anyway c in if not !Flags.quiet && print_goals then begin let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 626023737b..8fae561be8 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -50,6 +50,41 @@ let print_memory_stat () = let _ = at_exit print_memory_stat +let interp_set_option opt v old = + let open Goptions in + let err expect = + let opt = String.concat " " opt in + let got = v in (* avoid colliding with Pp.v *) + CErrors.user_err + Pp.(str "-set: " ++ str opt ++ + str" expects " ++ str expect ++ + str" but got " ++ str got) + in + match old with + | BoolValue _ -> + let v = match String.trim v with + | "true" -> true + | "false" | "" -> false + | _ -> err "a boolean" + in + BoolValue v + | IntValue _ -> + let v = String.trim v in + let v = match int_of_string_opt v with + | Some _ as v -> v + | None -> if v = "" then None else err "an int" + in + IntValue v + | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) + +let set_option = let open Goptions in function + | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt + | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true + | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v + +let set_options = List.iter set_option + (******************************************************************************) (* Input/Output State *) (******************************************************************************) @@ -195,6 +230,8 @@ let init_toplevel ~help ~init custom_init arglist = Global.set_allow_sprop opts.allow_sprop; if opts.cumulative_sprop then Global.make_sprop_cumulative (); + set_options opts.set_options; + (* Allow the user to load an arbitrary state here *) inputstate opts; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 513374c2af..7074215afe 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -74,6 +74,9 @@ let print_usage_common co command = \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ +\n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ +\n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ +\n -unset \"Foo Bar\" disable Foo Bar (as Unset Foo Bar. in a file)\ \n -time display the time taken by each command\ \n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index ef1dc6993b..038ff54bf6 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -70,7 +70,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Proof_global.give_me_the_proof_opt () in + let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird @@ -91,7 +91,8 @@ let load_vernac_core ~echo ~check ~interactive ~state file = let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in let in_pa = - Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile file)) + (Stream.of_channel in_chan) in let open State in (* ids = For beautify, list of parsed sids *) diff --git a/vernac/canonical.ml b/vernac/canonical.ml new file mode 100644 index 0000000000..92d5731f92 --- /dev/null +++ b/vernac/canonical.ml @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Names +open Libobject +open Recordops + +let open_canonical_structure i (_, o) = + let env = Global.env () in + let sigma = Evd.from_env env in + if Int.equal i 1 then register_canonical_structure env sigma ~warn:false o + +let cache_canonical_structure (_, o) = + let env = Global.env () in + let sigma = Evd.from_env env in + register_canonical_structure ~warn:true env sigma o + +let discharge_canonical_structure (_,x) = Some x + +let inCanonStruc : Constant.t * inductive -> obj = + declare_object {(default_object "CANONICAL-STRUCTURE") with + open_function = open_canonical_structure; + cache_function = cache_canonical_structure; + subst_function = (fun (subst,c) -> subst_canonical_structure subst c); + classify_function = (fun x -> Substitute x); + discharge_function = discharge_canonical_structure } + +let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) + +let declare_canonical_structure ref = + let env = Global.env () in + let sigma = Evd.from_env env in + add_canonical_structure (check_and_decompose_canonical_structure env sigma ref) diff --git a/theories/Compat/Coq87.v b/vernac/canonical.mli index 5e031efa85..5b223a0615 100644 --- a/theories/Compat/Coq87.v +++ b/vernac/canonical.mli @@ -7,19 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names -(** Compatibility file for making Coq act similar to Coq v8.7 *) -Local Set Warnings "-deprecated". - -Require Export Coq.Compat.Coq88. - -(* In 8.7, omega wasn't taking advantage of local abbreviations, - see bug 148 and PR#768. For adjusting this flag, we're forced to - first dynlink the omega plugin, but we should avoid doing a full - "Require Omega", since it has some undesired effects (at least on hints) - and breaks at least fiat-crypto. *) -Declare ML Module "omega_plugin". -Unset Omega UseLocalDefs. - - -Set Typeclasses Axioms Are Instances. +val declare_canonical_structure : GlobRef.t -> unit diff --git a/vernac/class.ml b/vernac/class.ml index 0837beccee..f3a279eab1 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -23,6 +23,7 @@ open Classops open Declare open Globnames open Decl_kinds +open Libobject let strength_min l = if List.mem `LOCAL l then `LOCAL else `GLOBAL @@ -230,6 +231,58 @@ let check_source = function | Some (CL_FUN as s) -> raise (CoercionError (ForbiddenSourceClass s)) | _ -> () +let cache_coercion (_,c) = + let env = Global.env () in + let sigma = Evd.from_env env in + Classops.declare_coercion env sigma c + +let open_coercion i o = + if Int.equal i 1 then + cache_coercion o + +let discharge_coercion (_, c) = + if c.coercion_local then None + else + let n = + try + let ins = Lib.section_instance c.coercion_type in + Array.length (snd ins) + with Not_found -> 0 + in + let nc = { c with + coercion_params = n + c.coercion_params; + coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; + } in + Some nc + +let classify_coercion obj = + if obj.coercion_local then Dispose else Substitute obj + +let inCoercion : coercion -> obj = + declare_object {(default_object "COERCION") with + open_function = open_coercion; + cache_function = cache_coercion; + subst_function = (fun (subst,c) -> subst_coercion subst c); + classify_function = classify_coercion; + discharge_function = discharge_coercion } + +let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = + let isproj = + match coef with + | ConstRef c -> Recordops.find_primitive_projection c + | _ -> None + in + let c = { + coercion_type = coef; + coercion_local = local; + coercion_is_id = isid; + coercion_is_proj = isproj; + coercion_source = cls; + coercion_target = clt; + coercion_params = ps; + } in + Lib.add_anonymous_leaf (inCoercion c) + (* nom de la fonction coercion strength de f diff --git a/vernac/classes.ml b/vernac/classes.ml index 1981e24ae4..9f233a2551 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -21,8 +21,11 @@ open Globnames open Constrintern open Constrexpr open Context.Rel.Declaration +open Class_tactics +open Libobject module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration (*i*) open Decl_kinds @@ -31,32 +34,241 @@ open Entries let refine_instance = ref false let () = Goptions.(declare_bool_option { - optdepr = false; + optdepr = true; optname = "definition of instances by refining"; optkey = ["Refine";"Instance";"Mode"]; optread = (fun () -> !refine_instance); optwrite = (fun b -> refine_instance := b) }) -let typeclasses_db = "typeclass_instances" - let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) - + +let classes_transparent_state () = + try + Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db) + with Not_found -> TransparentState.empty + let () = - Hook.set Typeclasses.add_instance_hint_hook - (fun inst path local info poly -> + Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; + Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state + +let add_instance_hint inst path local info poly = let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) | IsGlobal gr -> Hints.IsGlobRef gr in Flags.silently (fun () -> Hints.add_hints ~local [typeclasses_db] (Hints.HintsResolveEntry - [info, poly, false, Hints.PathHints path, inst'])) ()); - Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; - Hook.set Typeclasses.classes_transparent_state_hook - (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db)) + [info, poly, false, Hints.PathHints path, inst'])) () + +let is_local_for_hint i = + match i.is_global with + | None -> true (* i.e. either no Global keyword not in section, or in section *) + | Some n -> n <> 0 (* i.e. in a section, declare the hint as local + since discharge is managed by rebuild_instance which calls again + add_instance_hint; don't ask hints to take discharge into account + itself *) + +let add_instance check inst = + let poly = Global.is_polymorphic inst.is_impl in + let local = is_local_for_hint inst in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local + inst.is_info poly; + List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path + local pri poly) + (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) + (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) + +let mk_instance cl info glob impl = + let global = + if glob then Some (Lib.sections_depth ()) + else None + in + if match global with Some n -> n>0 && isVarRef impl | _ -> false then + CErrors.user_err (Pp.str "Cannot set Global an instance referring to a section variable."); + { is_class = cl.cl_impl; + is_info = info ; + is_global = global ; + is_impl = impl } + +(* + * instances persistent object + *) +let cache_instance (_, i) = + load_instance i + +let subst_instance (subst, inst) = + { inst with + is_class = fst (subst_global subst inst.is_class); + is_impl = fst (subst_global subst inst.is_impl) } + +let discharge_instance (_, inst) = + match inst.is_global with + | None -> None + | Some n -> + assert (not (isVarRef inst.is_impl)); + Some + { inst with + is_global = Some (pred n); + is_class = inst.is_class; + is_impl = inst.is_impl } + +let is_local i = (i.is_global == None) + +let rebuild_instance inst = + add_instance true inst; + inst + +let classify_instance inst = + if is_local inst then Dispose + else Substitute inst + +let instance_input : instance -> obj = + declare_object + { (default_object "type classes instances state") with + cache_function = cache_instance; + load_function = (fun _ x -> cache_instance x); + open_function = (fun _ x -> cache_instance x); + classify_function = classify_instance; + discharge_function = discharge_instance; + rebuild_function = rebuild_instance; + subst_function = subst_instance } + +let add_instance i = + Lib.add_anonymous_leaf (instance_input i); + add_instance true i + +let warning_not_a_class = + let name = "not-a-class" in + let category = "typeclasses" in + CWarnings.create ~name ~category (fun (n, ty) -> + let env = Global.env () in + let evd = Evd.from_env env in + Pp.(str "Ignored instance declaration for “" + ++ Nametab.pr_global_env Id.Set.empty n + ++ str "â€: “" + ++ Termops.Internal.print_constr_env env evd (EConstr.of_constr ty) + ++ str "†is not a class") + ) + +let declare_instance ?(warn = false) env sigma info local glob = + let ty, _ = Typeops.type_of_global_in_context env glob in + let info = Option.default {hint_priority = None; hint_pattern = None} info in + match class_of_constr env sigma (EConstr.of_constr ty) with + | Some (rels, ((tc,_), args) as _cl) -> + assert (not (isVarRef glob) || local); + add_instance (mk_instance tc info (not local) glob) + | None -> if warn then warning_not_a_class (glob, ty) + +(* + * classes persistent object + *) + +let cache_class (_,c) = load_class c + +let subst_class (subst,cl) = + let do_subst_con c = Mod_subst.subst_constant subst c + and do_subst c = Mod_subst.subst_mps subst c + and do_subst_gr gr = fst (subst_global subst gr) in + let do_subst_ctx = List.Smart.map (RelDecl.map_constr do_subst) in + let do_subst_context (grs,ctx) = + List.Smart.map (Option.Smart.map do_subst_gr) grs, + do_subst_ctx ctx in + let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> + (x, y, Option.Smart.map do_subst_con z)) projs in + { cl_univs = cl.cl_univs; + cl_impl = do_subst_gr cl.cl_impl; + cl_context = do_subst_context cl.cl_context; + cl_props = do_subst_ctx cl.cl_props; + cl_projs = do_subst_projs cl.cl_projs; + cl_strict = cl.cl_strict; + cl_unique = cl.cl_unique } + +let discharge_class (_,cl) = + let open CVars in + let repl = Lib.replacement_context () in + let rel_of_variable_context ctx = List.fold_right + ( fun (decl,_) (ctx', subst) -> + let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in + (decl' :: ctx', NamedDecl.get_id decl :: subst) + ) ctx ([], []) in + let discharge_rel_context (subst, usubst) n rel = + let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in + let fold decl (ctx, k) = + let map c = subst_univs_level_constr usubst (substn_vars k subst c) in + RelDecl.map_constr map decl :: ctx, succ k + in + let ctx, _ = List.fold_right fold rel ([], n) in + ctx + in + let abs_context cl = + match cl.cl_impl with + | VarRef _ | ConstructRef _ -> assert false + | ConstRef cst -> Lib.section_segment_of_constant cst + | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in + let discharge_context ctx' subst (grs, ctx) = + let env = Global.env () in + let sigma = Evd.from_env env in + let grs' = + let newgrs = List.map (fun decl -> + match decl |> RelDecl.get_type |> EConstr.of_constr |> class_of_constr env sigma with + | None -> None + | Some (_, ((tc,_), _)) -> Some tc.cl_impl) + ctx' + in + grs @ newgrs + in grs', discharge_rel_context subst 1 ctx @ ctx' in + try + let info = abs_context cl in + let ctx = info.Lib.abstr_ctx in + let ctx, subst = rel_of_variable_context ctx in + let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in + let context = discharge_context ctx (subst, usubst) cl.cl_context in + let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in + let discharge_proj x = x in + { cl_univs = cl_univs'; + cl_impl = cl.cl_impl; + cl_context = context; + cl_props = props; + cl_projs = List.Smart.map discharge_proj cl.cl_projs; + cl_strict = cl.cl_strict; + cl_unique = cl.cl_unique + } + with Not_found -> (* not defined in the current section *) + cl + +let rebuild_class cl = + try + let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in + set_typeclass_transparency cst false false; cl + with e when CErrors.noncritical e -> cl + +let class_input : typeclass -> obj = + declare_object + { (default_object "type classes state") with + cache_function = cache_class; + load_function = (fun _ -> cache_class); + open_function = (fun _ -> cache_class); + classify_function = (fun x -> Substitute x); + discharge_function = (fun a -> Some (discharge_class a)); + rebuild_function = rebuild_class; + subst_function = subst_class } + +let add_class cl = + Lib.add_anonymous_leaf (class_input cl) + +let add_class env sigma cl = + add_class cl; + List.iter (fun (n, inst, body) -> + match inst with + | Some (Backward, info) -> + (match body with + | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") + | Some b -> declare_instance ~warn:true env sigma (Some info) false (ConstRef b)) + | _ -> ()) + cl.cl_projs let intern_info {hint_priority;hint_pattern} = let env = Global.env() in @@ -69,10 +281,12 @@ let existing_instance glob g info = let c = Nametab.global g in let info = Option.default Hints.empty_hint_info info in let info = intern_info info in - let instance, _ = Typeops.type_of_global_in_context (Global.env ()) c in + let env = Global.env() in + let sigma = Evd.from_env env in + let instance, _ = Typeops.type_of_global_in_context env c in let _, r = Term.decompose_prod_assum instance in - match class_of_constr Evd.empty (EConstr.of_constr r) with - | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob c) + match class_of_constr env sigma (EConstr.of_constr r) with + | Some (_, ((tc,u), _)) -> add_instance (mk_instance tc info glob c) | None -> user_err ?loc:g.CAst.loc ~hdr:"declare_instance" (Pp.str "Constant does not build instances of a declared type class.") @@ -108,7 +322,9 @@ let id_of_class cl = let instance_hook k info global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst imps; let info = intern_info info in - Typeclasses.declare_instance (Some info) (not global) cst; + let env = Global.env () in + let sigma = Evd.from_env env in + declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k info global imps ?hook id decl poly sigma term termtype = @@ -144,14 +360,16 @@ let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps (ConstRef cst) -let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = +let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if program_mode then let hook _ _ vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr imps; let pri = intern_info pri in - Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) + let env = Global.env () in + let sigma = Evd.from_env env in + declare_instance env sigma (Some pri) (not global) (ConstRef cst) in let obls, constr, typ = match term with @@ -163,33 +381,44 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id in let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context sigma in - ignore (Obligations.add_definition id ?term:constr - ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls) + let _progress = Obligations.add_definition id ?term:constr + ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls in + pstate else - Flags.silently (fun () -> + Some Flags.(silently (fun () -> (* spiwack: it is hard to reorder the actions to do the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code the refinement manually.*) let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in - Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) + let pstate = Lemmas.start_proof ~ontop:pstate id ~pl:decl kind sigma (EConstr.of_constr termtype) ~hook:(Lemmas.mk_hook - (fun _ _ _ -> instance_hook k pri global imps ?hook)); + (fun _ _ _ -> instance_hook k pri global imps ?hook)) in (* spiwack: I don't know what to do with the status here. *) - if not (Option.is_empty term) then - let init_refine = - Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); - Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); - Tactics.New.reduce_after_refine; - ] - in - ignore (Pfedit.by init_refine) - else ignore (Pfedit.by (Tactics.auto_intros_tac ids)); - (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) () - -let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = + let pstate = + if not (Option.is_empty term) then + let init_refine = + Tacticals.New.tclTHENLIST [ + Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); + Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); + Tactics.New.reduce_after_refine; + ] + in + let pstate, _ = Pfedit.by init_refine pstate in + pstate + else + let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in + pstate + in + match tac with + | Some tac -> + let pstate, _ = Pfedit.by tac pstate in + pstate + | None -> + pstate) ()) + +let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -269,12 +498,14 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in - if not (Evd.has_undefined sigma) && not (Option.is_empty props) then - declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype - else if program_mode || refine || Option.is_empty props then - declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype - else CErrors.user_err Pp.(str "Unsolved obligations remaining."); - id + let pstate = + if not (Evd.has_undefined sigma) && not (Option.is_empty props) then + (declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype; + None) + else if program_mode || refine || Option.is_empty props then + declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype + else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in + id, pstate let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in @@ -318,7 +549,7 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode +let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -334,7 +565,7 @@ let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode + do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) pri = @@ -344,96 +575,3 @@ let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) interp_instance_context ~program_mode env ctx pl bk cl in do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst instid - -let named_of_rel_context l = - let open Vars in - let acc, ctx = - List.fold_right - (fun decl (subst, ctx) -> - let id = match RelDecl.get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in - let d = match decl with - | LocalAssum (_,t) -> id, None, substl subst t - | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in - (mkVar id :: subst, d :: ctx)) - l ([], []) - in ctx - -let context poly l = - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in - (* Note, we must use the normalized evar from now on! *) - let sigma = Evd.minimize_universes sigma in - let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in - let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in - let ctx = - try named_of_rel_context fullctx - with e when CErrors.noncritical e -> - user_err Pp.(str "Anonymous variables not allowed in contexts.") - in - let univs = - match ctx with - | [] -> assert false - | [_] -> Evd.univ_entry ~poly sigma - | _::_::_ -> - if Lib.sections_are_opened () - then - (* More than 1 variable in a section: we can't associate - universes to any specific variable so we declare them - separately. *) - begin - let uctx = Evd.universe_context_set sigma in - Declare.declare_universe_context poly uctx; - if poly then Polymorphic_entry ([||], Univ.UContext.empty) - else Monomorphic_entry Univ.ContextSet.empty - end - else if poly then - (* Multiple polymorphic axioms: they are all polymorphic the same way. *) - Evd.univ_entry ~poly sigma - else - (* Multiple monomorphic axioms: declare universes separately - to avoid redeclaring them. *) - begin - let uctx = Evd.universe_context_set sigma in - Declare.declare_universe_context poly uctx; - Monomorphic_entry Univ.ContextSet.empty - end - in - let fn status (id, b, t) = - let b, t = Option.map (to_constr sigma) b, to_constr sigma t in - if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - (* Declare the universe context once *) - let decl = match b with - | None -> - (ParameterEntry (None,(t,univs),None), IsAssumption Logical) - | Some b -> - let entry = Declare.definition_entry ~univs ~types:t b in - (DefinitionEntry entry, IsAssumption Logical) - in - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in - match class_of_constr sigma (of_constr t) with - | Some (rels, ((tc,_), args) as _cl) -> - add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (ConstRef cst)); - status - (* declare_subclasses (ConstRef cst) cl *) - | None -> status - else - let test (x, _) = match x with - | ExplByPos (_, Some id') -> Id.equal id id' - | _ -> false - in - let impl = List.exists test impls in - let decl = (Discharge, poly, Definitional) in - let nstatus = match b with - | None -> - pi3 (ComAssumption.declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl - Declaremods.NoInline (CAst.make id)) - | Some b -> - let decl = (Discharge, poly, Definition) in - let entry = Declare.definition_entry ~univs ~types:t b in - let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] in - Lib.sections_are_opened () || Lib.is_modtype_strict () - in - status && nstatus - in - List.fold_left fn true (List.rev ctx) diff --git a/vernac/classes.mli b/vernac/classes.mli index 7e0ec42625..e7f90ff306 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,6 +22,12 @@ val mismatched_props : env -> constr_expr list -> Constr.rel_context -> 'a (** Instance declaration *) +val declare_instance : ?warn:bool -> env -> Evd.evar_map -> + hint_info option -> bool -> GlobRef.t -> unit +(** Declares the given global reference as an instance of its type. + Does nothing — or emit a “not-a-class†warning if the [warn] argument is set — + when said type is not a registered type class. *) + val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) @@ -40,6 +46,7 @@ val declare_instance_constant : unit val new_instance : + pstate:Proof_global.t option -> ?global:bool (** Not global by default. *) -> ?refine:bool (** Allow refinement *) -> program_mode:bool -> @@ -51,7 +58,8 @@ val new_instance : ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr -> - Id.t + (* May open a proof *) + Id.t * Proof_global.t option val declare_new_instance : ?global:bool (** Not global by default. *) -> @@ -62,6 +70,12 @@ val declare_new_instance : Hints.hint_info_expr -> unit +(** {6 Low level interface used by Add Morphism, do not use } *) +val mk_instance : typeclass -> hint_info -> bool -> GlobRef.t -> instance +val add_instance : instance -> unit + +val add_class : env -> Evd.evar_map -> typeclass -> unit + (** Setting opacity *) val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit @@ -69,9 +83,3 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u (** For generation on names based on classes only *) val id_of_class : typeclass -> Id.t - -(** Context command *) - -(** returns [false] if, for lack of section, it declares an assumption - (unless in a module type). *) -val context : Decl_kinds.polymorphic -> local_binder_expr list -> bool diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 37a33daf8f..3406b6276f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -22,6 +22,7 @@ open Decl_kinds open Pretyping open Entries +module RelDecl = Context.Rel.Declaration (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) let axiom_into_instance = ref false @@ -42,7 +43,7 @@ let should_axiom_into_instance = function true | Global | Local -> !axiom_into_instance -let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = +let declare_assumption ~pstate is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with @@ -53,13 +54,15 @@ match local with let _ = declare_variable ident decl in let () = assumption_message ident in let () = - if not !Flags.quiet && Proof_global.there_are_pending_proofs () then + if not !Flags.quiet && Option.has_some pstate then Feedback.msg_info Pp.(str"Variable" ++ spc () ++ Id.print ident ++ strbrk " is not visible from current goals") in let r = VarRef ident in let () = maybe_declare_manual_implicits true r imps in - let () = Typeclasses.declare_instance None true r in + let env = Global.env () in + let sigma = Evd.from_env env in + let () = Classes.declare_instance env sigma None true r in let () = if is_coe then Class.try_add_new_coercion r ~local:true false in (r,Univ.Instance.empty,true) @@ -77,7 +80,9 @@ match local with let () = maybe_declare_manual_implicits false gr imps in let () = Declare.declare_univ_binders gr pl in let () = assumption_message ident in - let () = if do_instance then Typeclasses.declare_instance None false gr in + let env = Global.env () in + let sigma = Evd.from_env env in + let () = if do_instance then Classes.declare_instance env sigma None false gr in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx @@ -96,11 +101,11 @@ let next_uctx = | Polymorphic_entry _ as uctx -> uctx | Monomorphic_entry _ -> empty_uctx -let declare_assumptions idl is_coe k (c,uctx) pl imps nl = +let declare_assumptions ~pstate idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = List.fold_left (fun (refs,status,uctx) id -> let ref',u',status' = - declare_assumption is_coe k (c,uctx) pl imps false nl id in + declare_assumption ~pstate is_coe k (c,uctx) pl imps false nl id in (ref',u')::refs, status' && status, next_uctx uctx) ([],true,uctx) idl in @@ -132,7 +137,7 @@ let process_assumptions_udecls kind l = in udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l -let do_assumptions ~program_mode kind nl l = +let do_assumptions ~pstate ~program_mode kind nl l = let open Context.Named.Declaration in let env = Global.env () in let udecl, l = process_assumptions_udecls kind l in @@ -173,7 +178,7 @@ let do_assumptions ~program_mode kind nl l = let ubinders = Evd.universe_binders sigma in pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in - let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in + let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs @@ -206,3 +211,94 @@ let do_primitive id prim typopt = in let _kn = declare_constant id.CAst.v (PrimitiveEntry entry,IsPrimitive) in Flags.if_verbose Feedback.msg_info Pp.(Id.print id.CAst.v ++ str " is declared") + +let named_of_rel_context l = + let open EConstr.Vars in + let open RelDecl in + let acc, ctx = + List.fold_right + (fun decl (subst, ctx) -> + let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in + let d = match decl with + | LocalAssum (_,t) -> id, None, substl subst t + | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in + (EConstr.mkVar id :: subst, d :: ctx)) + l ([], []) + in ctx + +let context ~pstate poly l = + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in + (* Note, we must use the normalized evar from now on! *) + let sigma = Evd.minimize_universes sigma in + let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in + let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in + let ctx = + try named_of_rel_context fullctx + with e when CErrors.noncritical e -> + user_err Pp.(str "Anonymous variables not allowed in contexts.") + in + let univs = + match ctx with + | [] -> assert false + | [_] -> Evd.univ_entry ~poly sigma + | _::_::_ -> + if Lib.sections_are_opened () + then + (* More than 1 variable in a section: we can't associate + universes to any specific variable so we declare them + separately. *) + begin + let uctx = Evd.universe_context_set sigma in + Declare.declare_universe_context poly uctx; + if poly then Polymorphic_entry ([||], Univ.UContext.empty) + else Monomorphic_entry Univ.ContextSet.empty + end + else if poly then + (* Multiple polymorphic axioms: they are all polymorphic the same way. *) + Evd.univ_entry ~poly sigma + else + (* Multiple monomorphic axioms: declare universes separately + to avoid redeclaring them. *) + begin + let uctx = Evd.universe_context_set sigma in + Declare.declare_universe_context poly uctx; + Monomorphic_entry Univ.ContextSet.empty + end + in + let fn status (id, b, t) = + let b, t = Option.map (EConstr.to_constr sigma) b, EConstr.to_constr sigma t in + if Lib.is_modtype () && not (Lib.sections_are_opened ()) then + (* Declare the universe context once *) + let decl = match b with + | None -> + (ParameterEntry (None,(t,univs),None), IsAssumption Logical) + | Some b -> + let entry = Declare.definition_entry ~univs ~types:t b in + (DefinitionEntry entry, IsAssumption Logical) + in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in + let env = Global.env () in + Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (ConstRef cst); + status + else + let test (x, _) = match x with + | Constrexpr.ExplByPos (_, Some id') -> Id.equal id id' + | _ -> false + in + let impl = List.exists test impls in + let decl = (Discharge, poly, Definitional) in + let nstatus = match b with + | None -> + pi3 (declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl + Declaremods.NoInline (CAst.make id)) + | Some b -> + let decl = (Discharge, poly, Definition) in + let entry = Declare.definition_entry ~univs ~types:t b in + let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in + Lib.sections_are_opened () || Lib.is_modtype_strict () + in + status && nstatus + in + List.fold_left fn true (List.rev ctx) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 2b794b001a..7c64317b70 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -9,29 +9,42 @@ (************************************************************************) open Names -open Constr -open Entries open Vernacexpr open Constrexpr open Decl_kinds (** {6 Parameters/Assumptions} *) -val do_assumptions : program_mode:bool -> locality * polymorphic * assumption_object_kind -> - Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool - -(************************************************************************) -(** Internal API *) -(************************************************************************) - -(** Exported for Classes *) +val do_assumptions + : pstate:Proof_global.t option + -> program_mode:bool + -> locality * polymorphic * assumption_object_kind + -> Declaremods.inline + -> (ident_decl list * constr_expr) with_coercion list + -> bool (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> - types in_universes_entry -> - UnivNames.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Declaremods.inline -> variable CAst.t -> - GlobRef.t * Univ.Instance.t * bool +val declare_assumption + : pstate:Proof_global.t option + -> coercion_flag + -> assumption_kind + -> Constr.types Entries.in_universes_entry + -> UnivNames.universe_binders + -> Impargs.manual_implicits + -> bool (** implicit *) + -> Declaremods.inline + -> variable CAst.t + -> GlobRef.t * Univ.Instance.t * bool + +(** Context command *) + +(** returns [false] if, for lack of section, it declares an assumption + (unless in a module type). *) +val context + : pstate:Proof_global.t option + -> Decl_kinds.polymorphic + -> local_binder_expr list + -> bool val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 28773a3965..feaf47df18 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -90,7 +90,7 @@ let check_definition ~program_mode (ce, evd, _, imps) = check_evars_are_solved ~program_mode env evd; ce -let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = +let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = interp_definition ~program_mode univdecl bl (pi2 k) red_option c ctypopt in @@ -114,4 +114,4 @@ let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - ignore(DeclareDef.declare_definition ident k ?hook_data ce (Evd.universe_binders evd) imps ) + ignore(DeclareDef.declare_definition ~ontop ident k ?hook_data ce (Evd.universe_binders evd) imps) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 9cb6190fcc..12853d83e0 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -16,11 +16,18 @@ open Constrexpr (** {6 Definitions/Let} *) -val do_definition : program_mode:bool -> - ?hook:Lemmas.declaration_hook -> - Id.t -> definition_kind -> universe_decl_expr option -> - local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> unit +val do_definition + : ontop:Proof_global.t option + -> program_mode:bool + -> ?hook:Lemmas.declaration_hook + -> Id.t + -> definition_kind + -> universe_decl_expr option + -> local_binder_expr list + -> red_expr option + -> constr_expr + -> constr_expr option + -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 2f00b41b7c..1912646ffd 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,7 +255,8 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = +let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = + let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -265,8 +266,9 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None + Some + (Lemmas.start_proof_with_initialization ~ontop (local,poly,DefinitionBody Fixpoint) + evd pl (Some(false,indexes,init_tac)) thms None) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -282,15 +284,18 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; - end; + None + end in (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + pstate -let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = +let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = + let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -300,8 +305,8 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None + Some (Lemmas.start_proof_with_initialization ~ontop (Global,poly, DefinitionBody CoFixpoint) + evd pl (Some(true,[],init_tac)) thms None) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -314,24 +319,37 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) - cofixpoint_message fixnames - end; + cofixpoint_message fixnames; + None + end in (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns - -let extract_decreasing_argument limit = function - | (na,CStructRec) -> na - | (na,_) when not limit -> na + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + pstate + +let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v with + | CStructRec na -> na + | (CWfRec (na,_) | CMeasureRec (Some na,_,_)) when not structonly -> na + | CMeasureRec (None,_,_) when not structonly -> + user_err Pp.(str "Decreasing argument must be specificed in measure clause.") | _ -> user_err Pp.(str - "Only structural decreasing is supported for a non-Program Fixpoint") + "Well-founded induction requires Program Fixpoint or Function.") -let extract_fixpoint_components limit l = +let extract_fixpoint_components ~structonly l = let fixl, ntnl = List.split l in let fixl = List.map (fun (({CAst.v=id},pl),ann,bl,typ,def) -> - let ann = extract_decreasing_argument limit ann in + (* This is a special case: if there's only one binder, we pick it as the + recursive argument if none is provided. *) + let ann = Option.map (fun ann -> match bl, ann with + | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | _, x -> x) ann + in + let ann = Option.map (extract_decreasing_argument ~structonly) ann in {fix_name = id; fix_annot = ann; fix_univs = pl; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl @@ -348,16 +366,18 @@ let check_safe () = let flags = Environ.typing_flags (Global.env ()) in flags.check_universes && flags.check_guarded -let do_fixpoint local poly l = - let fixl, ntns = extract_fixpoint_components true l in +let do_fixpoint ~ontop local poly l = + let fixl, ntns = extract_fixpoint_components ~structonly:true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences info in - declare_fixpoint local poly fix possible_indexes ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + let pstate = declare_fixpoint ~ontop local poly fix possible_indexes ntns in + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); + pstate -let do_cofixpoint local poly l = +let do_cofixpoint ~ontop local poly l = let fixl,ntns = extract_cofixpoint_components l in let cofix = interp_fixpoint ~cofix:true fixl ntns in - declare_cofixpoint local poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + let pstate = declare_cofixpoint ~ontop local poly cofix ntns in + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); + pstate diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 9bcb53697b..5937842f17 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,12 +19,14 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : + ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t option val do_cofixpoint : + ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t option (************************************************************************) (** Internal API *) @@ -60,7 +62,7 @@ val interp_recursive : (** Extracting the semantical components out of the raw syntax of (co)fixpoints declarations *) -val extract_fixpoint_components : bool -> +val extract_fixpoint_components : structonly:bool -> (fixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list @@ -81,15 +83,20 @@ val interp_fixpoint : (** [Not used so far] *) val declare_fixpoint : + ontop:Proof_global.t option -> locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - Proof_global.lemma_possible_guards -> decl_notation list -> unit + Proof_global.lemma_possible_guards -> decl_notation list -> + Proof_global.t option -val declare_cofixpoint : locality -> polymorphic -> +val declare_cofixpoint : + ontop:Proof_global.t option -> + locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit + decl_notation list -> + Proof_global.t option (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index ad7c65b70c..20a2db7ca2 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -85,7 +85,7 @@ let rec telescope sigma l = let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx -let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = +let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let open EConstr in let open Vars in let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in @@ -232,7 +232,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let hook = Lemmas.mk_hook (hook sigma) in (* XXX: Grounding non-ground terms here... bad bad *) let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in - let fullctyp = EConstr.to_constr sigma typ in + let fullctyp = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in Obligations.check_evars env sigma; let evars, _, evars_def, evars_typ = Obligations.eterm_obligations env recname sigma 0 fullcoqc fullctyp @@ -304,22 +304,26 @@ let do_program_recursive local poly fixkind fixl ntns = let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> - let recarg = - match n with - | Some n -> mkIdentC n.CAst.v - | None -> - user_err ~hdr:"do_program_fixpoint" - (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn + | [Some { CAst.v = CWfRec (n,r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + let recarg = mkIdentC n.CAst.v in + build_wellfounded (id, pl, bl, typ, out_def def) poly r recarg ntn - | [(n, CMeasureRec (m, r))], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> - build_wellfounded (id, pl, n, bl, typ, out_def def) poly + | [Some { CAst.v = CMeasureRec (n, m, r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + (* We resolve here a clash between the syntax of Program Fixpoint and the one of funind *) + let r = match n, r with + | Some id, None -> + let loc = id.CAst.loc in + Some (CAst.make ?loc @@ CRef(qualid_of_ident ?loc id.CAst.v,None)) + | Some _, Some _ -> + user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") + | _, _ -> r + in + build_wellfounded (id, pl, bl, typ, out_def def) poly (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn - | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> - let fixl,ntns = extract_fixpoint_components true l in - let fixkind = Obligations.IsFixpoint g in + | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> + let fixl,ntns = extract_fixpoint_components ~structonly:true l in + let fixkind = Obligations.IsFixpoint (List.map (fun d -> d.fix_annot) fixl) in do_program_recursive local poly fixkind fixl ntns | _, _ -> diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 7dcd098183..052832244b 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -33,12 +33,12 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_definition ident (local, p, k) ?hook_data ce pl imps = +let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with | Discharge when Lib.sections_are_opened () -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in - let () = if Proof_global.there_are_pending_proofs () then warn_definition_not_visible ident in + let () = if Option.has_some ontop then warn_definition_not_visible ident in VarRef ident | Discharge | Local | Global -> let local = get_locality ident ~kind:"definition" local in @@ -57,9 +57,9 @@ let declare_definition ident (local, p, k) ?hook_data ce pl imps = end; gr -let declare_fix ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = +let declare_fix ~ontop ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - declare_definition f kind ?hook_data ce pl imps + declare_definition ~ontop f kind ?hook_data ce pl imps let check_definition_evars ~allow_evars sigma = let env = Global.env () in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 3f95ec7107..8e4f4bf7fb 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -14,7 +14,8 @@ open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition - : Id.t + : ontop:Proof_global.t option + -> Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> Safe_typing.private_constants Entries.definition_entry @@ -23,7 +24,8 @@ val declare_definition -> GlobRef.t val declare_fix - : ?opaque:bool + : ontop:Proof_global.t option + -> ?opaque:bool -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> definition_kind -> UnivNames.universe_binders diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 1a07d74a0e..568e5b9997 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -245,12 +245,12 @@ type prod_info = production_level * production_position type (_, _) entry = | TTName : ('self, lname) entry | TTReference : ('self, qualid) entry -| TTBigint : ('self, Constrexpr.raw_natural_number) entry +| TTBigint : ('self, string) entry | TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry -| TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry +| TTConstrList : prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry | TTPattern : int -> ('self, cases_pattern_expr) entry | TTOpenBinderList : ('self, local_binder_expr list) entry -| TTClosedBinderList : Tok.t list -> ('self, local_binder_expr list list) entry +| TTClosedBinderList : string Tok.p list -> ('self, local_binder_expr list list) entry type _ any_entry = TTAny : ('s, 'r) entry -> 's any_entry @@ -319,41 +319,49 @@ let is_binder_level from e = match e with let make_sep_rules = function | [tk] -> Atoken tk | tkl -> - let rec mkrule : Tok.t list -> string rules = function - | [] -> Rules ({ norec_rule = Stop }, fun _ -> (* dropped anyway: *) "") + let rec mkrule : 'a Tok.p list -> 'a rules = function + | [] -> Rules (Stop, fun _ -> (* dropped anyway: *) "") | tkn :: rem -> - let Rules ({ norec_rule = r }, f) = mkrule rem in - let r = { norec_rule = Next (r, Atoken tkn) } in + let Rules (r, f) = mkrule rem in + let r = NextNoRec (r, Atoken tkn) in Rules (r, fun _ -> f) in let r = mkrule (List.rev tkl) in Arules [r] -let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) symbol = fun custom p assoc from forpat -> - if custom = InConstrEntry && is_binder_level from p then Aentryl (target_entry InConstrEntry forpat, "200") - else if is_self from p then Aself +type ('s, 'a) mayrec_symbol = +| MayRecNo : ('s, norec, 'a) symbol -> ('s, 'a) mayrec_symbol +| MayRecMay : ('s, mayrec, 'a) symbol -> ('s, 'a) mayrec_symbol + +let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) mayrec_symbol = fun custom p assoc from forpat -> + if custom = InConstrEntry && is_binder_level from p then MayRecNo (Aentryl (target_entry InConstrEntry forpat, "200")) + else if is_self from p then MayRecMay Aself else let g = target_entry custom forpat in let lev = adjust_level assoc from p in begin match lev with - | None -> Aentry g - | Some None -> Anext - | Some (Some (lev, cur)) -> Aentryl (g, string_of_int lev) + | None -> MayRecNo (Aentry g) + | Some None -> MayRecMay Anext + | Some (Some (lev, cur)) -> MayRecNo (Aentryl (g, string_of_int lev)) end -let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) symbol = fun assoc from typ -> match typ with +let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with | TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat | TTConstrList (typ', [], forpat) -> - Alist1 (symbol_of_target InConstrEntry typ' assoc from forpat) + begin match symbol_of_target InConstrEntry typ' assoc from forpat with + | MayRecNo s -> MayRecNo (Alist1 s) + | MayRecMay s -> MayRecMay (Alist1 s) end | TTConstrList (typ', tkl, forpat) -> - Alist1sep (symbol_of_target InConstrEntry typ' assoc from forpat, make_sep_rules tkl) -| TTPattern p -> Aentryl (Constr.pattern, string_of_int p) -| TTClosedBinderList [] -> Alist1 (Aentry Constr.binder) -| TTClosedBinderList tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl) -| TTName -> Aentry Prim.name -| TTOpenBinderList -> Aentry Constr.open_binders -| TTBigint -> Aentry Prim.bigint -| TTReference -> Aentry Constr.global + begin match symbol_of_target InConstrEntry typ' assoc from forpat with + | MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl)) + | MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end +| TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p)) +| TTClosedBinderList [] -> MayRecNo (Alist1 (Aentry Constr.binder)) +| TTClosedBinderList tkl -> MayRecNo (Alist1sep (Aentry Constr.binder, make_sep_rules tkl)) +| TTName -> MayRecNo (Aentry Prim.name) +| TTOpenBinderList -> MayRecNo (Aentry Constr.open_binders) +| TTBigint -> MayRecNo (Aentry Prim.bigint) +| TTReference -> MayRecNo (Aentry Constr.global) let interp_entry forpat e = match e with | ETProdName -> TTAny TTName @@ -395,8 +403,8 @@ match e with | TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (v,true))) - | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (v,true))) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (SPlus,NumTok.int v))) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (SPlus,NumTok.int v))) end | TTReference -> begin match forpat with @@ -406,8 +414,8 @@ match e with | TTConstrList _ -> { subst with constrlists = v :: subst.constrlists } type (_, _) ty_symbol = -| TyTerm : Tok.t -> ('s, string) ty_symbol -| TyNonTerm : 's target * ('s, 'a) entry * ('s, 'a) symbol * bool -> ('s, 'a) ty_symbol +| TyTerm : string Tok.p -> ('s, string) ty_symbol +| TyNonTerm : 's target * ('s, 'a) entry * ('s, 'a) mayrec_symbol * bool -> ('s, 'a) ty_symbol type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule @@ -444,11 +452,23 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> in ty_eval rem f { env with constrs; constrlists; } -let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function -| TyStop -> Stop +type ('s, 'a, 'r) mayrec_rule = +| MayRecRNo : ('s, Extend.norec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule +| MayRecRMay : ('s, Extend.mayrec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule + +let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) mayrec_rule = function +| TyStop -> MayRecRNo Stop | TyMark (_, _, _, r) -> ty_erase r -| TyNext (rem, TyTerm tok) -> Next (ty_erase rem, Atoken tok) -| TyNext (rem, TyNonTerm (_, _, s, _)) -> Next (ty_erase rem, s) +| TyNext (rem, TyTerm tok) -> + begin match ty_erase rem with + | MayRecRNo rem -> MayRecRMay (Next (rem, Atoken tok)) + | MayRecRMay rem -> MayRecRMay (Next (rem, Atoken tok)) end +| TyNext (rem, TyNonTerm (_, _, s, _)) -> + begin match ty_erase rem, s with + | MayRecRNo rem, MayRecNo s -> MayRecRMay (Next (rem, s)) + | MayRecRNo rem, MayRecMay s -> MayRecRMay (Next (rem, s)) + | MayRecRMay rem, MayRecNo s -> MayRecRMay (Next (rem, s)) + | MayRecRMay rem, MayRecMay s -> MayRecRMay (Next (rem, s)) end type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -485,7 +505,7 @@ let rec pure_sublevels' custom assoc from forpat level = function let rem = pure_sublevels' custom assoc from forpat level rem in let push where p rem = match symbol_of_target custom p assoc from forpat with - | Aentryl (_,i) when level <> Some (int_of_string i) -> (where,int_of_string i) :: rem + | MayRecNo (Aentryl (_,i)) when level <> Some (int_of_string i) -> (where,int_of_string i) :: rem | _ -> rem in (match e with | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem @@ -507,7 +527,6 @@ let extend_constr state forpat ng = let (entry, level) = interp_constr_entry_key custom forpat n in let fold (accu, state) pt = let AnyTyRule r = make_ty_rule assoc n forpat pt in - let symbs = ty_erase r in let pure_sublevels = pure_sublevels' custom assoc n forpat level pt in let isforpat = target_to_bool forpat in let needed_levels, state = register_empty_levels state isforpat pure_sublevels in @@ -515,7 +534,11 @@ let extend_constr state forpat ng = let empty_rules = List.map (prepare_empty_levels forpat) needed_levels in let empty = { constrs = []; constrlists = []; binders = []; binderlists = [] } in let act = ty_eval r (make_act forpat ng.notgram_notation) empty in - let rule = (name, p4assoc, [Rule (symbs, act)]) in + let rule = + let r = match ty_erase r with + | MayRecRNo symbs -> Rule (symbs, act) + | MayRecRMay symbs -> Rule (symbs, act) in + name, p4assoc, [r] in let r = ExtendRule (entry, reinit, (pos, [rule])) in (accu @ empty_rules @ [r], state) in diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 89caff847f..bc58993a2e 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -19,17 +19,17 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - ('a raw_abstract_argument_type * ('s, 'a) symbol) Loc.located -> 's grammar_prod_item + ('a raw_abstract_argument_type * ('s, _, 'a) symbol) Loc.located -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) -type ('self, _, 'r) ty_rule = -| TyStop : ('self, 'r, 'r) ty_rule -| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option -> - ('self, 'b -> 'a, 'r) ty_rule +type ('self, 'tr, _, 'r) ty_rule = +| TyStop : ('self, Extend.norec, 'r, 'r) ty_rule +| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Extend.symbol * 'b ty_arg option -> + ('self, Extend.mayrec, 'b -> 'a, 'r) ty_rule type ('self, 'r) any_ty_rule = -| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule +| AnyTyRule : ('self, _, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule let rec ty_rule_of_gram = function | [] -> AnyTyRule TyStop @@ -44,13 +44,13 @@ let rec ty_rule_of_gram = function let r = TyNext (rem, tok, inj) in AnyTyRule r -let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function +let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Extend.rule = function | TyStop -> Extend.Stop | TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r -let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +let rec ty_eval : type s tr a. (s, tr, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f | TyNext (rem, tok, Some inj) -> fun f x -> diff --git a/vernac/egramml.mli b/vernac/egramml.mli index 3689f60383..1cf75a55b1 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : ('a Genarg.raw_abstract_argument_type * - ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item + ('s, _, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : extend_name -> vernac_expr Pcoq.Entry.t option -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 589b15fd41..3f491d1dd4 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -65,8 +65,7 @@ let parse_compat_version = let open Flags in function | "8.10" -> Current | "8.9" -> V8_9 | "8.8" -> V8_8 - | "8.7" -> V8_7 - | ("8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> + | ("8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> CErrors.user_err ~hdr:"get_compat_version" Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") | s -> @@ -80,8 +79,8 @@ GRAMMAR EXTEND Gram vernac_control: FIRST [ [ IDENT "Time"; c = located_vernac -> { VernacTime (false,c) } | IDENT "Redirect"; s = ne_string; c = located_vernac -> { VernacRedirect (s, c) } - | IDENT "Timeout"; n = natural; v = vernac_control -> { VernacTimeout(n,v) } - | IDENT "Fail"; v = vernac_control -> { VernacFail v } + | IDENT "Timeout"; n = natural; v = located_vernac -> { VernacTimeout(n,v) } + | IDENT "Fail"; v = located_vernac -> { VernacFail v } | v = decorated_vernac -> { let (f, v) = v in VernacExpr(f, v) } ] ] ; @@ -294,7 +293,7 @@ GRAMMAR EXTEND Gram | IDENT "Conjectures" -> { ("Conjectures", (NoDischarge, Conjectural)) } ] ] ; inline: - [ [ IDENT "Inline"; "("; i = INT; ")" -> { InlineAt (int_of_string i) } + [ [ IDENT "Inline"; "("; i = natural; ")" -> { InlineAt i } | IDENT "Inline" -> { DefaultInline } | -> { NoInline } ] ] ; @@ -607,8 +606,8 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; functor_app_annot: - [ [ "["; IDENT "inline"; "at"; IDENT "level"; i = INT; "]" -> - { InlineAt (int_of_string i) } + [ [ "["; IDENT "inline"; "at"; IDENT "level"; i = natural; "]" -> + { InlineAt i } | "["; IDENT "no"; IDENT "inline"; "]" -> { NoInline } | -> { DefaultInline } ] ] @@ -847,8 +846,7 @@ GRAMMAR EXTEND Gram strategy_level: [ [ IDENT "expand" -> { Conv_oracle.Expand } | IDENT "opaque" -> { Conv_oracle.Opaque } - | n=INT -> { Conv_oracle.Level (int_of_string n) } - | "-"; n=INT -> { Conv_oracle.Level (- int_of_string n) } + | n=integer -> { Conv_oracle.Level n } | IDENT "transparent" -> { Conv_oracle.transparent } ] ] ; instance_name: @@ -877,10 +875,10 @@ GRAMMAR EXTEND Gram GLOBAL: command query_command class_rawexpr gallina_ext; gallina_ext: - [ [ IDENT "Export"; "Set"; table = option_table; v = option_value -> + [ [ IDENT "Export"; "Set"; table = option_table; v = option_setting -> { VernacSetOption (true, table, v) } | IDENT "Export"; IDENT "Unset"; table = option_table -> - { VernacUnsetOption (true, table) } + { VernacSetOption (true, table, OptionUnset) } ] ]; command: @@ -945,10 +943,10 @@ GRAMMAR EXTEND Gram { VernacAddMLPath (true, dir) } (* For acting on parameter tables *) - | "Set"; table = option_table; v = option_value -> + | "Set"; table = option_table; v = option_setting -> { VernacSetOption (false, table, v) } | IDENT "Unset"; table = option_table -> - { VernacUnsetOption (false, table) } + { VernacSetOption (false, table, OptionUnset) } | IDENT "Print"; IDENT "Table"; table = option_table -> { VernacPrintOption table } @@ -1059,10 +1057,10 @@ GRAMMAR EXTEND Gram | IDENT "Library"; qid = global -> { LocateLibrary qid } | IDENT "Module"; qid = global -> { LocateModule qid } ] ] ; - option_value: - [ [ -> { BoolValue true } - | n = integer -> { IntValue (Some n) } - | s = STRING -> { StringValue s } ] ] + option_setting: + [ [ -> { OptionSetTrue } + | n = integer -> { OptionSetInt n } + | s = STRING -> { OptionSetString s } ] ] ; option_ref_value: [ [ id = global -> { QualidRefValue id } @@ -1132,10 +1130,10 @@ GRAMMAR EXTEND Gram (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> - { VernacSetOption (false, ["Ltac";"Debug"], BoolValue true) } + { VernacSetOption (false, ["Ltac";"Debug"], OptionSetTrue) } | IDENT "Debug"; IDENT "Off" -> - { VernacSetOption (false, ["Ltac";"Debug"], BoolValue false) } + { VernacSetOption (false, ["Ltac";"Debug"], OptionUnset) } (* registration of a custom reduction *) diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 32754478a5..082b22b373 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -601,7 +601,7 @@ let rec explain_evar_kind env sigma evk ty = (pr_leconstr_env env sigma ty') src let explain_typeclass_resolution env sigma evi k = - match Typeclasses.class_of_constr sigma evi.evar_concl with + match Typeclasses.class_of_constr env sigma evi.evar_concl with | Some _ -> let env = Evd.evar_filtered_env evi in fnl () ++ str "Could not find an instance for " ++ @@ -614,7 +614,7 @@ let explain_placeholder_kind env sigma c e = | Some (SeveralInstancesFound n) -> strbrk " (several distinct possible type class instances found)" | None -> - match Typeclasses.class_of_constr sigma c with + match Typeclasses.class_of_constr env sigma c with | Some _ -> strbrk " (no type class instance found)" | _ -> mt () @@ -731,7 +731,9 @@ let explain_undeclared_universe env sigma l = spc () ++ str "(maybe a bugged tactic)." let explain_disallowed_sprop () = - Pp.(str "SProp not allowed, you need to use -allow-sprop.") + Pp.(strbrk "SProp not allowed, you need to " + ++ str "Set Allow StrictProp" + ++ strbrk " or to use the -allow-sprop command-line-flag.") let explain_bad_relevance env = strbrk "Bad relevance (maybe a bugged tactic)." diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 1e733acc59..642695bda4 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -313,7 +313,9 @@ let warn_cannot_build_congruence = strbrk "Cannot build congruence scheme because eq is not found") let declare_congr_scheme ind = - if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin + let env = Global.env () in + let sigma = Evd.from_env env in + if Hipattern.is_equality_type env sigma (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true with e when CErrors.noncritical e -> false diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 0d0732cbb4..1c7cc5e636 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -213,8 +213,11 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let default_thm_id = Id.of_string "Unnamed_thm" -let fresh_name_for_anonymous_theorem () = - let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in +let fresh_name_for_anonymous_theorem ~pstate = + let avoid = match pstate with + | None -> Id.Set.empty + | Some pstate -> Id.Set.of_list (Proof_global.get_all_proof_names pstate) + in next_global_ident_away default_thm_id avoid let check_name_freshness locality {CAst.loc;v=id} : unit = @@ -224,7 +227,7 @@ let check_name_freshness locality {CAst.loc;v=id} : unit = then user_err ?loc (Id.print id ++ str " already exists.") -let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in let k = IsAssumption Conjectural in match body with @@ -260,7 +263,6 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) | _ -> - let sigma, env = Pfedit.get_current_context () in anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in let body_i = body_i body in match locality with @@ -333,7 +335,7 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : declaration_hook option) c = +let start_proof ~ontop id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard @@ -344,7 +346,7 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : | None -> initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - Proof_global.start_proof sigma id ?pl kind goals terminator + Proof_global.start_proof ~ontop sigma id ?pl kind goals terminator let rec_tac_initializer finite guard thms snl = if finite then @@ -360,7 +362,7 @@ let rec_tac_initializer finite guard thms snl = | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = +let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms snl = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> @@ -386,18 +388,20 @@ let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = let norm c = EConstr.to_constr (Evd.from_ctx ctx) c in let body = Option.map EConstr.of_constr body in let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in - List.map_i (save_remaining_recthms kind norm uctx body opaq) 1 other_thms in + let env = Global.env () in + List.map_i (save_remaining_recthms env sigma kind norm uctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in - start_proof id ~pl:decl kind sigma t ~hook ~compute_guard:guard; - ignore (Proof_global.with_current_proof (fun _ p -> + let pstate = start_proof ~ontop id ~pl:decl kind sigma t ~hook ~compute_guard:guard in + let pstate, _ = Proof_global.with_current_proof (fun _ p -> match init_tac with | None -> p,(true,[]) - | Some tac -> Proof.run_tactic Global.(env ()) tac p)) + | Some tac -> Proof.run_tactic Global.(env ()) tac p) pstate in + pstate -let start_proof_com ~program_mode ?inference_hook ?hook kind thms = +let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in @@ -429,7 +433,7 @@ let start_proof_com ~program_mode ?inference_hook ?hook kind thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization ?hook kind evd decl recguard thms snl + start_proof_with_initialization ~ontop ?hook kind evd decl recguard thms snl (* Saving a proof *) @@ -444,58 +448,65 @@ let () = optread = (fun () -> !keep_admitted_vars); optwrite = (fun b -> keep_admitted_vars := b) } -let save_proof ?proof = function - | Vernacexpr.Admitted -> - let pe = - let open Proof_global in - match proof with - | Some ({ id; entries; persistence = k; universes }, _) -> - if List.length entries <> 1 then - user_err Pp.(str "Admitted does not support multiple statements"); - let { const_entry_secctx; const_entry_type } = List.hd entries in - if const_entry_type = None then - user_err Pp.(str "Admitted requires an explicit statement"); - let typ = Option.get const_entry_type in - let ctx = UState.univ_entry ~poly:(pi2 k) universes in - let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in - Admitted(id, k, (sec_vars, (typ, ctx), None), universes) - | None -> - let pftree = Proof_global.give_me_the_proof () in - let gk = Proof_global.get_current_persistence () in - let Proof.{ name; poly; entry } = Proof.data pftree in - let typ = match Proofview.initial_goals entry with - | [typ] -> snd typ - | _ -> - CErrors.anomaly - ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") - in - let typ = EConstr.Unsafe.to_constr typ in - let universes = Proof.((data pftree).initial_euctx) in - (* This will warn if the proof is complete *) - let pproofs, _univs = - Proof_global.return_proof ~allow_partial:true () in - let sec_vars = - if not !keep_admitted_vars then None - else match Proof_global.get_used_variables(), pproofs with - | Some _ as x, _ -> x - | None, (pproof, _) :: _ -> - let env = Global.env () in - let ids_typ = Environ.global_vars_set env typ in - let ids_def = Environ.global_vars_set env pproof in - Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) - | _ -> None in - let decl = Proof_global.get_universe_decl () in - let ctx = UState.check_univ_decl ~poly universes decl in - Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) - in - Proof_global.apply_terminator (Proof_global.get_terminator ()) pe - | Vernacexpr.Proved (opaque,idopt) -> - let (proof_obj,terminator) = - match proof with - | None -> - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) - | Some proof -> proof +let save_proof_admitted ?proof ~pstate = + let pe = + let open Proof_global in + match proof with + | Some ({ id; entries; persistence = k; universes }, _) -> + if List.length entries <> 1 then + user_err Pp.(str "Admitted does not support multiple statements"); + let { const_entry_secctx; const_entry_type } = List.hd entries in + if const_entry_type = None then + user_err Pp.(str "Admitted requires an explicit statement"); + let typ = Option.get const_entry_type in + let ctx = UState.univ_entry ~poly:(pi2 k) universes in + let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in + Admitted(id, k, (sec_vars, (typ, ctx), None), universes) + | None -> + let pftree = Proof_global.give_me_the_proof pstate in + let gk = Proof_global.get_current_persistence pstate in + let Proof.{ name; poly; entry } = Proof.data pftree in + let typ = match Proofview.initial_goals entry with + | [typ] -> snd typ + | _ -> + CErrors.anomaly + ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") in - (* if the proof is given explicitly, nothing has to be deleted *) - if Option.is_empty proof then Proof_global.discard_current (); - Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))) + let typ = EConstr.Unsafe.to_constr typ in + let universes = Proof.((data pftree).initial_euctx) in + (* This will warn if the proof is complete *) + let pproofs, _univs = + Proof_global.return_proof ~allow_partial:true pstate in + let sec_vars = + if not !keep_admitted_vars then None + else match Proof_global.get_used_variables pstate, pproofs with + | Some _ as x, _ -> x + | None, (pproof, _) :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + let ids_def = Environ.global_vars_set env pproof in + Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) + | _ -> None in + let decl = Proof_global.get_universe_decl pstate in + let ctx = UState.check_univ_decl ~poly universes decl in + Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) + in + Proof_global.apply_terminator (Proof_global.get_terminator pstate) pe + +let save_proof_proved ?proof ?pstate ~opaque ~idopt = + (* Invariant (uh) *) + if Option.is_empty pstate && Option.is_empty proof then + user_err (str "No focused proof (No proof-editing in progress)."); + let (proof_obj,terminator) = + match proof with + | None -> + (* XXX: The close_proof and proof state API should be refactored + so it is possible to insert proofs properly into the state *) + let pstate = Option.get pstate in + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pstate + | Some proof -> proof + in + (* if the proof is given explicitly, nothing has to be deleted *) + let pstate = if Option.is_empty proof then Proof_global.discard_current Option.(get pstate) else pstate in + Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))); + pstate diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 72c666e903..1f70cfa1ad 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -37,30 +37,32 @@ val call_hook -> ?fix_exn:Future.fix_exn -> hook_type -val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> +val start_proof : ontop:Proof_global.t option -> Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> unit + ?hook:declaration_hook -> EConstr.types -> Proof_global.t -val start_proof_com : - program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> - ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list -> - unit +val start_proof_com + : program_mode:bool + -> ontop:Proof_global.t option + -> ?inference_hook:Pretyping.inference_hook + -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list + -> Proof_global.t -val start_proof_with_initialization : +val start_proof_with_initialization : ontop:Proof_global.t option -> ?hook:declaration_hook -> goal_kind -> Evd.evar_map -> UState.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * - (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> - int list option -> unit + (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + -> int list option -> Proof_global.t val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator -val fresh_name_for_anonymous_theorem : unit -> Id.t +val fresh_name_for_anonymous_theorem : pstate:Proof_global.t option -> Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) @@ -69,4 +71,14 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val (** {6 ... } *) -val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit +val save_proof_admitted + : ?proof:Proof_global.closed_proof + -> pstate:Proof_global.t + -> unit + +val save_proof_proved + : ?proof:Proof_global.closed_proof + -> ?pstate:Proof_global.t + -> opaque:Proof_global.opacity_flag + -> idopt:Names.lident option + -> Proof_global.t option diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 3da12e7714..843296d24e 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -23,7 +23,6 @@ open Libobject open Constrintern open Vernacexpr open Libnames -open Tok open Notation open Nameops @@ -251,7 +250,7 @@ let quote_notation_token x = let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> - (try let _ = Bigint.of_string x in true with Failure _ -> false) + NumTok.of_string x <> None | _ -> false @@ -575,20 +574,20 @@ let is_not_small_constr = function | _ -> false let rec define_keywords_aux = function - | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l + | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(Tok.PIDENT (Some k)) :: l when is_not_small_constr e -> Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); CLexer.add_keyword k; - n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l + n1 :: GramConstrTerminal(Tok.PKEYWORD k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l | [] -> [] (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function - | GramConstrTerminal(IDENT k)::l -> + | GramConstrTerminal(Tok.PIDENT (Some k))::l -> Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); CLexer.add_keyword k; - GramConstrTerminal(KEYWORD k) :: define_keywords_aux l + GramConstrTerminal(Tok.PKEYWORD k) :: define_keywords_aux l | l -> define_keywords_aux l let distribute a ll = List.map (fun l -> a @ l) ll diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 9aca48f529..1b1c618dc7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -295,7 +295,7 @@ type obligation = type obligations = (obligation array * int) type fixpoint_kind = - | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of lident option list | IsCoFixpoint type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -456,7 +456,7 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let declare_definition prg = +let declare_definition ~ontop prg = let varsubst = obligation_substitution true prg in let body, typ = subst_prog varsubst prg in let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) @@ -475,7 +475,7 @@ let declare_definition prg = let () = progmap_remove prg in let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition prg.prg_name + DeclareDef.declare_definition ~ontop prg.prg_name prg.prg_kind ce ubinders prg.prg_implicits ?hook_data let rec lam_index n t acc = @@ -486,7 +486,7 @@ let rec lam_index n t acc = lam_index n b (succ acc) | _ -> raise Not_found -let compute_possible_guardness_evidences (n,_) fixbody fixtype = +let compute_possible_guardness_evidences n fixbody fixtype = match n with | Some { CAst.loc; v = n } -> [lam_index n fixbody 0] | None -> @@ -554,16 +554,14 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let univs = UState.univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 - (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) - fixnames fixdecls fixtypes fiximps - in - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; - Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; - let gr = List.hd kns in - Lemmas.call_hook ?hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; - List.iter progmap_remove l; gr + let kns = List.map4 (DeclareDef.declare_fix ~ontop:None ~opaque (local, poly, kind) UnivNames.empty_binders univs) + fixnames fixdecls fixtypes fiximps in + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; + Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; + let gr = List.hd kns in + Lemmas.call_hook ?hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; + List.iter progmap_remove l; gr let decompose_lam_prod c ty = let open Context.Rel.Declaration in @@ -763,7 +761,7 @@ let update_obls prg obls rem = else ( match prg'.prg_deps with | [] -> - let kn = declare_definition prg' in + let kn = declare_definition ~ontop:None prg' in progmap_remove prg'; Defined kn | l -> @@ -948,7 +946,7 @@ let obligation_hook prg obl num auto ctx' _ _ gr = ignore (auto (Some prg.prg_name) None deps) end -let rec solve_obligation prg num tac = +let rec solve_obligation ~ontop prg num tac = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in @@ -967,20 +965,21 @@ let rec solve_obligation prg num tac = let auto n tac oblset = auto_solve_obligations n ~oblset tac in let terminator ?hook guard = Proof_global.make_terminator - (obligation_terminator ?hook prg.prg_name num guard auto) in + (obligation_terminator prg.prg_name num guard ?hook auto) in let hook = Lemmas.mk_hook (obligation_hook prg obl num auto) in - let () = Lemmas.start_proof ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in - let _ = Pfedit.by !default_tactic in - Option.iter (fun tac -> Proof_global.set_endline_tactic tac) tac + let pstate = Lemmas.start_proof ~ontop ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in + let pstate = fst @@ Pfedit.by !default_tactic pstate in + let pstate = Option.cata (fun tac -> Proof_global.set_endline_tactic tac pstate) pstate tac in + pstate -and obligation (user_num, name, typ) tac = +and obligation ~ontop (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in let obls, rem = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with - None -> solve_obligation prg num tac + | None -> solve_obligation ~ontop prg num tac | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) @@ -1113,7 +1112,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); - let cst = declare_definition prg in + let cst = declare_definition ~ontop:None prg in Defined cst) else ( let len = Array.length obls in @@ -1180,7 +1179,7 @@ let admit_obligations n = let prg = get_prog_err n in admit_prog prg -let next_obligation n tac = +let next_obligation ~ontop n tac = let prg = match n with | None -> get_any_prog_err () | Some _ -> get_prog_err n @@ -1191,7 +1190,7 @@ let next_obligation n tac = | Some i -> i | None -> anomaly (Pp.str "Could not find a solvable obligation.") in - solve_obligation prg i tac + solve_obligation ~ontop prg i tac let check_program_libraries () = Coqlib.check_required_library Coqlib.datatypes_module_name; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index c5720363b4..d25daeed9c 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -70,7 +70,7 @@ type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type fixpoint_kind = - | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of lident option list | IsCoFixpoint val add_mutual_definitions : @@ -85,10 +85,17 @@ val add_mutual_definitions : notations -> fixpoint_kind -> unit -val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Genarg.glob_generic_argument option -> unit - -val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit +val obligation + : ontop:Proof_global.t option + -> int * Names.Id.t option * Constrexpr.constr_expr option + -> Genarg.glob_generic_argument option + -> Proof_global.t + +val next_obligation + : ontop:Proof_global.t option + -> Names.Id.t option + -> Genarg.glob_generic_argument option + -> Proof_global.t val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 506c3f9f49..4e4d431e89 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -173,15 +173,10 @@ open Pputils pr_opt (prlist_with_sep sep pr_option_ref_value) b let pr_set_option a b = - let pr_opt_value = function - | IntValue None -> assert false - (* This should not happen because of the grammar *) - | IntValue (Some n) -> spc() ++ int n - | StringValue s -> spc() ++ str s - | StringOptValue None -> mt() - | StringOptValue (Some s) -> spc() ++ str s - | BoolValue b -> mt() - in pr_printoption a None ++ pr_opt_value b + pr_printoption a None ++ (match b with + | OptionUnset | OptionSetTrue -> mt() + | OptionSetInt n -> spc() ++ int n + | OptionSetString s -> spc() ++ quote (str s)) let pr_opt_hintbases l = match l with | [] -> mt() @@ -1140,15 +1135,11 @@ open Pputils hov 1 (keyword "Strategy" ++ spc() ++ hv 0 (prlist_with_sep sep pr_line l)) ) - | VernacUnsetOption (export, na) -> - let export = if export then keyword "Export" ++ spc () else mt () in - return ( - hov 1 (export ++ keyword "Unset" ++ spc() ++ pr_printoption na None) - ) | VernacSetOption (export, na,v) -> let export = if export then keyword "Export" ++ spc () else mt () in + let set = if v == OptionUnset then "Unset" else "Set" in return ( - hov 2 (export ++ keyword "Set" ++ spc() ++ pr_set_option na v) + hov 2 (export ++ keyword set ++ spc() ++ pr_set_option na v) ) | VernacAddOption (na,l) -> return ( @@ -1277,9 +1268,9 @@ let pr_vernac_attributes = return (keyword "Time" ++ spc() ++ pr_vernac_control v) | VernacRedirect (s, {v}) -> return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) - | VernacTimeout(n,v) -> + | VernacTimeout(n,{v}) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) - | VernacFail v -> + | VernacFail {v} -> return (keyword "Fail" ++ spc() ++ pr_vernac_control v) let pr_vernac v = diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 526845084a..1d089d0a55 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -172,11 +172,12 @@ let value = ref None let using_to_string us = Pp.string_of_ppcmds (Ppvernac.pr_using us) let using_from_string us = Pcoq.Entry.parse G_vernac.section_subset_expr (Pcoq.Parsable.make (Stream.of_string us)) +let proof_using_opt_name = ["Default";"Proof";"Using"] let () = Goptions.(declare_stringopt_option { optdepr = false; optname = "default value for Proof using"; - optkey = ["Default";"Proof";"Using"]; + optkey = proof_using_opt_name; optread = (fun () -> Option.map using_to_string !value); optwrite = (fun b -> value := Option.map using_from_string b); }) diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index 7d1110aaa2..702043a4a9 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -21,3 +21,6 @@ val suggest_constant : Environ.env -> Names.Constant.t -> unit val suggest_variable : Environ.env -> Names.Id.t -> unit val get_default_proof_using : unit -> Vernacexpr.section_subset_expr option + +val proof_using_opt_name : string list +(** For the stm *) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 994fad85f0..d474ef8637 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -55,7 +55,7 @@ module Vernac_ = let act_vernac v loc = Some CAst.(make ~loc v) in let act_eoi _ loc = None in let rule = [ - Rule (Next (Stop, Atoken Tok.EOI), act_eoi); + Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); Rule (Next (Stop, Aentry vernac_control), act_vernac); ] in Pcoq.grammar_extend main_entry None (None, [None, None, rule]) diff --git a/vernac/record.ml b/vernac/record.ml index 23274040b0..74e5a03659 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -30,6 +30,7 @@ open Constrexpr open Constrexpr_ops open Goptions open Context.Rel.Declaration +open Libobject module RelDecl = Context.Rel.Declaration @@ -373,6 +374,27 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f open Typeclasses +let load_structure i (_, structure) = + Recordops.register_structure (Global.env()) structure + +let cache_structure o = + load_structure 1 o + +let subst_structure (subst, (id, kl, projs as obj)) = + Recordops.subst_structure subst obj + +let discharge_structure (_, x) = Some x + +let inStruc : Recordops.struc_tuple -> obj = + declare_object {(default_object "STRUCTURE") with + cache_function = cache_structure; + load_function = load_structure; + subst_function = subst_structure; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_structure } + +let declare_structure_entry o = + Lib.add_anonymous_leaf (inStruc o) let declare_structure ~cum finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data = let nparams = List.length params in @@ -443,7 +465,7 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in let build = ConstructRef cstr in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in - let () = Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs) in + let () = declare_structure_entry (cstr, List.rev kinds, List.rev sp_projs) in rsp in List.mapi map record_data @@ -520,8 +542,10 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity List.map map inds in let ctx_context = + let env = Global.env () in + let sigma = Evd.from_env env in List.map (fun decl -> - match Typeclasses.class_of_constr Evd.empty (EConstr.of_constr (RelDecl.get_type decl)) with + match Typeclasses.class_of_constr env sigma (EConstr.of_constr (RelDecl.get_type decl)) with | Some (_, ((cl,_), _)) -> Some cl.cl_impl | None -> None) params, params @@ -548,12 +572,14 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity cl_props = fields; cl_projs = projs } in - add_class k; impl + let env = Global.env () in + let sigma = Evd.from_env env in + Classes.add_class env sigma k; impl in List.map map data -let add_constant_class env cst = +let add_constant_class env sigma cst = let ty, univs = Typeops.type_of_global_in_context env (ConstRef cst) in let r = (Environ.lookup_constant cst env).const_relevance in let ctx, arity = decompose_prod_assum ty in @@ -566,10 +592,11 @@ let add_constant_class env cst = cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } - in add_class tc; + in + Classes.add_class env sigma tc; set_typeclass_transparency (EvalConstRef cst) false false - -let add_inductive_class env ind = + +let add_inductive_class env sigma ind = let mind, oneind = Inductive.lookup_mind_specif env ind in let k = let ctx = oneind.mind_arity_ctxt in @@ -586,7 +613,8 @@ let add_inductive_class env ind = cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } - in add_class k + in + Classes.add_class env sigma k let warn_already_existing_class = CWarnings.create ~name:"already-existing-class" ~category:"automation" Pp.(fun g -> @@ -594,11 +622,12 @@ let warn_already_existing_class = let declare_existing_class g = let env = Global.env () in + let sigma = Evd.from_env env in if Typeclasses.is_class g then warn_already_existing_class g else match g with - | ConstRef x -> add_constant_class env x - | IndRef x -> add_inductive_class env x + | ConstRef x -> add_constant_class env sigma x + | IndRef x -> add_inductive_class env sigma x | _ -> user_err ~hdr:"declare_existing_class" (Pp.str"Unsupported class type, only constants and inductives are allowed") diff --git a/vernac/record.mli b/vernac/record.mli index 9852840d12..12a2a765b5 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -24,6 +24,8 @@ val declare_projections : Constr.rel_context -> (Name.t * bool) list * Constant.t option list +val declare_structure_entry : Recordops.struc_tuple -> unit + val definition_structure : universe_decl_expr option -> inductive_kind -> template:bool option -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> diff --git a/vernac/search.ml b/vernac/search.ml index 6610789626..e41378908f 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -59,11 +59,16 @@ let iter_constructors indsp u fn env nconstr = let iter_named_context_name_type f = List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) +let get_current_or_goal_context ?pstate glnum = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_goal_context p glnum + (* General search over hypothesis of a goal *) -let iter_hypothesis glnum (fn : GlobRef.t -> env -> constr -> unit) = +let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in let iter_hyp idh typ = fn (VarRef idh) env typ in - let evmap,e = Pfedit.get_goal_context glnum in + let evmap,e = get_current_or_goal_context ?pstate glnum in let pfctxt = named_context e in iter_named_context_name_type iter_hyp pfctxt @@ -99,10 +104,10 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = try Declaremods.iter_all_segments iter_obj with Not_found -> () -let generic_search glnumopt fn = +let generic_search ?pstate glnumopt fn = (match glnumopt with | None -> () - | Some glnum -> iter_hypothesis glnum fn); + | Some glnum -> iter_hypothesis ?pstate glnum fn); iter_declarations fn (** This module defines a preference on constrs in the form of a @@ -221,7 +226,7 @@ let search_about_filter query gr env typ = match query with (** SearchPattern *) -let search_pattern gopt pat mods pr_search = +let search_pattern ?pstate gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && @@ -231,7 +236,7 @@ let search_pattern gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** SearchRewrite *) @@ -243,7 +248,7 @@ let rewrite_pat1 pat = let rewrite_pat2 pat = PApp (PRef (eq ()), [| PMeta None; PMeta None; pat |]) -let search_rewrite gopt pat mods pr_search = +let search_rewrite ?pstate gopt pat mods pr_search = let pat1 = rewrite_pat1 pat in let pat2 = rewrite_pat2 pat in let blacklist_filter = blacklist_filter_aux () in @@ -256,11 +261,11 @@ let search_rewrite gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** Search *) -let search_by_head gopt pat mods pr_search = +let search_by_head ?pstate gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && @@ -270,11 +275,11 @@ let search_by_head gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** SearchAbout *) -let search_about gopt items mods pr_search = +let search_about ?pstate gopt items mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in @@ -286,7 +291,7 @@ let search_about gopt items mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter type search_constraint = | Name_Pattern of Str.regexp @@ -301,7 +306,7 @@ type 'a coq_object = { coq_object_object : 'a; } -let interface_search = +let interface_search ?pstate = let rec extract_flags name tpe subtpe mods blacklist = function | [] -> (name, tpe, subtpe, mods, blacklist) | (Name_Pattern regexp, b) :: l -> @@ -371,7 +376,7 @@ let interface_search = let iter ref env typ = if filter_function ref env typ then print_function ref env typ in - let () = generic_search glnum iter in + let () = generic_search ?pstate glnum iter in !ans let blacklist_filter ref env typ = diff --git a/vernac/search.mli b/vernac/search.mli index ecbb02bc68..0f94ddc5b6 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -39,13 +39,13 @@ val search_about_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : int option -> (bool * glob_search_about_item) list +val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -66,12 +66,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : int option -> display_function -> unit +val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index ce93a8baaf..7f5c265eea 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -12,6 +12,7 @@ Vernacextend Ppvernac Proof_using Lemmas +Canonical Class Egramcoq Metasyntax @@ -21,11 +22,11 @@ Indschemes DeclareDef Obligations ComDefinition +Classes ComAssumption ComInductive ComFixpoint ComProgramFixpoint -Classes Record Assumptions Vernacstate diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 4250ddb02c..3a305c3b61 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -44,6 +44,28 @@ let vernac_pperr_endline pp = (* Misc *) +let there_are_pending_proofs ~pstate = + not Option.(is_empty pstate) + +let check_no_pending_proof ~pstate = + if there_are_pending_proofs ~pstate then + user_err Pp.(str "Command not supported (Open proofs remain)") + +let vernac_require_open_proof ~pstate f = + match pstate with + | Some pstate -> f ~pstate + | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") + +let get_current_or_global_context ~pstate = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_current_context p + +let get_goal_or_global_context ~pstate glnum = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_goal_context p glnum + let cl_of_qualid = function | FunClass -> Classops.CL_FUN | SortClass -> Classops.CL_SORT @@ -72,30 +94,37 @@ end (*******************) (* "Show" commands *) -let show_proof () = +let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) - let p = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in - let pprf = Proof.partial_proof p in - Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + try + let pstate = Option.get pstate in + let p = Proof_global.give_me_the_proof pstate in + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof p in + Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + (* We print nothing if there are no goals left *) + with + | Pfedit.NoSuchGoal + | Option.IsNone -> + user_err (str "No goals to show.") -let show_top_evars () = +let show_top_evars ~pstate = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = Proof_global.give_me_the_proof () in + let pfts = Proof_global.give_me_the_proof pstate in let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) -let show_universes () = - let pfts = Proof_global.give_me_the_proof () in +let show_universes ~pstate = + let pfts = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pfts in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx (* Simulate the Intro(s) tactic *) -let show_intro all = +let show_intro ~pstate all = let open EConstr in - let pf = Proof_global.give_me_the_proof() in + let pf = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pf in if not (List.is_empty goals) then begin let gl = {Evd.it=List.hd goals ; sigma = sigma; } in @@ -224,7 +253,7 @@ let print_modtype qid = with Not_found -> user_err (str"Unknown Module Type or Module " ++ pr_qualid qid) -let print_namespace ns = +let print_namespace ~pstate ns = let ns = List.rev (Names.DirPath.repr ns) in (* [match_dirpath], [match_modulpath] are helpers for [matches] which checks whether a constant is in the namespace [ns]. *) @@ -272,10 +301,10 @@ let print_namespace ns = let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in print_list Id.print qn in - let print_constant k body = + let print_constant ~pstate k body = (* FIXME: universes *) let t = body.Declarations.const_type in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_or_global_context ~pstate in print_kn k ++ str":" ++ spc() ++ Printer.pr_type_env env sigma t in let matches mp = match match_modulepath ns mp with @@ -285,7 +314,7 @@ let print_namespace ns = Environ.fold_constants (fun c body acc -> let kn = Constant.user c in if matches (KerName.modpath kn) - then acc++fnl()++hov 2 (print_constant kn body) + then acc++fnl()++hov 2 (print_constant ~pstate kn body) else acc) (Global.env ()) (str"") in @@ -515,7 +544,7 @@ let () = (***********) (* Gallina *) -let start_proof_and_print ~program_mode ?hook k l = +let start_proof_and_print ~program_mode ~pstate ?hook k l = let inference_hook = if program_mode then let hook env sigma ev = @@ -537,18 +566,18 @@ let start_proof_and_print ~program_mode ?hook k l = in Some hook else None in - start_proof_com ~program_mode ?inference_hook ?hook k l + start_proof_com ~program_mode ~ontop:pstate ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> Some (Class.add_coercion_hook p) | CanonicalStructure -> - Some (Lemmas.mk_hook (fun _ _ _ -> Recordops.declare_canonical_structure)) + Some (Lemmas.mk_hook (fun _ _ _ -> Canonical.declare_canonical_structure)) | SubClass -> Some (Class.add_subclass_hook p) | _ -> None -let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = +let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in @@ -563,41 +592,47 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = let program_mode = atts.program in let name = match id with - | Anonymous -> fresh_name_for_anonymous_theorem () + | Anonymous -> fresh_name_for_anonymous_theorem ~pstate | Name n -> n in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) - ?hook [(CAst.make ?loc name, pl), (bl, t)] + Some (start_proof_and_print ~program_mode ~pstate (local, atts.polymorphic, DefinitionBody kind) + ?hook [(CAst.make ?loc name, pl), (bl, t)]) | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with - | None -> None - | Some r -> - let sigma, env = Pfedit.get_current_context () in - Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode name - (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook) - -let vernac_start_proof ~atts kind l = + | None -> None + | Some r -> + let sigma, env = get_current_or_global_context ~pstate in + Some (snd (Hook.get f_interp_redexp env sigma r)) in + ComDefinition.do_definition ~ontop:pstate ~program_mode name + (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; + pstate + ) + +let vernac_start_proof ~atts ~pstate kind l = let open DefAttributes in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l + Some (start_proof_and_print ~pstate ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l) -let vernac_end_proof ?proof = function - | Admitted -> save_proof ?proof Admitted - | Proved (_,_) as e -> save_proof ?proof e +let vernac_end_proof ?pstate ?proof = function + | Admitted -> + vernac_require_open_proof ~pstate (save_proof_admitted ?proof); + pstate + | Proved (opaque,idopt) -> + save_proof_proved ?pstate ?proof ~opaque ~idopt -let vernac_exact_proof c = +let vernac_exact_proof ~pstate c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) - let status = Pfedit.by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Proof_global.Opaque,None))); - if not status then Feedback.feedback Feedback.AddedAxiom + let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in + let pstate = save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate -let vernac_assumption ~atts discharge kind l nl = +let vernac_assumption ~atts ~pstate discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in @@ -607,7 +642,7 @@ let vernac_assumption ~atts discharge kind l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in + let status = ComAssumption.do_assumptions ~pstate ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let is_polymorphic_inductive_cumulativity = @@ -772,28 +807,28 @@ let vernac_inductive ~atts cum lo finite indl = in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] *) -let vernac_fixpoint ~atts discharge l = +let vernac_fixpoint ~atts ~pstate discharge l : Proof_global.t option = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; (* XXX: Switch to the attribute system and match on ~atts *) let do_fixpoint = if atts.program then - ComProgramFixpoint.do_fixpoint + fun local sign l -> ComProgramFixpoint.do_fixpoint local sign l; None else - ComFixpoint.do_fixpoint + ComFixpoint.do_fixpoint ~ontop:pstate in do_fixpoint local atts.polymorphic l -let vernac_cofixpoint ~atts discharge l = +let vernac_cofixpoint ~atts ~pstate discharge l = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; let do_cofixpoint = if atts.program then - ComProgramFixpoint.do_cofixpoint + fun local sign l -> ComProgramFixpoint.do_cofixpoint local sign l; None else - ComFixpoint.do_cofixpoint + ComFixpoint.do_cofixpoint ~ontop:pstate in do_cofixpoint local atts.polymorphic l @@ -851,14 +886,14 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export -let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = +let vernac_define_module ~pstate export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> - Proof_global.check_no_pending_proof (); + check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -898,13 +933,13 @@ let vernac_end_module export {loc;v=id} = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export -let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = +let vernac_declare_module_type ~pstate {loc;v=id} binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with | [] -> - Proof_global.check_no_pending_proof (); + check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -951,8 +986,8 @@ let vernac_include l = (* Sections *) -let vernac_begin_section ({v=id} as lid) = - Proof_global.check_no_pending_proof (); +let vernac_begin_section ~pstate ({v=id} as lid) = + check_no_pending_proof ~pstate; Dumpglob.dump_definition lid true "sec"; Lib.open_section id @@ -965,8 +1000,8 @@ let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) -let vernac_end_segment ({v=id} as lid) = - Proof_global.check_no_pending_proof (); +let vernac_end_segment ~pstate ({v=id} as lid) = + check_no_pending_proof ~pstate; match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1006,7 +1041,7 @@ let vernac_require from import qidl = (* Coercions and canonical structures *) let vernac_canonical r = - Recordops.declare_canonical_structure (smart_global r) + Canonical.declare_canonical_structure (smart_global r) let vernac_coercion ~atts ref qids qidt = let local, polymorphic = Attributes.(parse Notations.(locality ++ polymorphic) atts) in @@ -1031,7 +1066,7 @@ let vernac_instance ~atts sup inst props pri = let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = atts.program in - ignore(Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri) + Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri let vernac_declare_instance ~atts sup inst pri = let open DefAttributes in @@ -1039,8 +1074,8 @@ let vernac_declare_instance ~atts sup inst pri = Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri -let vernac_context ~poly l = - if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~pstate ~poly l = + if not (ComAssumption.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_existing_instance ~section_local insts = let glob = not section_local in @@ -1061,21 +1096,22 @@ let focus_command_cond = Proof.no_cond command_focus there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) -let vernac_solve_existential = Pfedit.instantiate_nth_evar_com +let vernac_solve_existential ~pstate n com = + Proof_global.simple_with_current_proof (fun _ p -> + let intern env sigma = Constrintern.intern_constr env sigma com in + Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate -let vernac_set_end_tac tac = +let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in - if not (Proof_global.there_are_pending_proofs ()) then - user_err Pp.(str "Unknown command of the non proof-editing mode."); - Proof_global.set_endline_tactic tac - (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables e = +let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = - List.map snd (initial_goals (Proof_global.give_me_the_proof ())) in + List.map snd (initial_goals (Proof_global.give_me_the_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1084,10 +1120,10 @@ let vernac_set_used_variables e = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - ignore (Proof_global.set_used_variables l); - Proof_global.with_current_proof begin fun _ p -> + let _, pstate = Proof_global.set_used_variables pstate l in + fst @@ Proof_global.with_current_proof begin fun _ p -> (p, ()) - end + end pstate (*****************************) (* Auxiliary file management *) @@ -1132,12 +1168,10 @@ let vernac_chdir = function (* State management *) let vernac_write_state file = - Proof_global.discard_all (); let file = CUnix.make_suffix file ".coq" in States.extern_state file let vernac_restore_state file = - Proof_global.discard_all (); let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in States.intern_state file @@ -1673,18 +1707,17 @@ let get_option_locality export local = let vernac_set_option0 ~local export key opt = let locality = get_option_locality export local in match opt with - | StringValue s -> set_string_option_value_gen ~locality key s - | StringOptValue (Some s) -> set_string_option_value_gen ~locality key s - | StringOptValue None -> unset_option_value_gen ~locality key - | IntValue n -> set_int_option_value_gen ~locality key n - | BoolValue b -> set_bool_option_value_gen ~locality key b + | OptionUnset -> unset_option_value_gen ~locality key + | OptionSetString s -> set_string_option_value_gen ~locality key s + | OptionSetInt n -> set_int_option_value_gen ~locality key (Some n) + | OptionSetTrue -> set_bool_option_value_gen ~locality key true let vernac_set_append_option ~local export key s = let locality = get_option_locality export local in set_string_option_append_value_gen ~locality key s let vernac_set_option ~local export table v = match v with -| StringValue s -> +| OptionSetString s -> (* We make a special case for warnings because appending is their natural semantics *) if CString.List.equal table ["Warnings"] then @@ -1697,10 +1730,6 @@ let vernac_set_option ~local export table v = match v with vernac_set_option0 ~local export table v | _ -> vernac_set_option0 ~local export table v -let vernac_unset_option ~local export key = - let locality = get_option_locality export local in - unset_option_value_gen ~locality key - let vernac_add_option key lv = let f = function | StringRefValue s -> (get_string_table key)#add s @@ -1730,9 +1759,14 @@ let vernac_print_option key = try print_option_value key with Not_found -> error_undeclared_key key -let get_current_context_of_args = function - | Some n -> Pfedit.get_goal_context n - | None -> Pfedit.get_current_context () +let get_current_context_of_args ~pstate = + match pstate with + | None -> fun _ -> + let env = Global.env () in Evd.(from_env env, env) + | Some pstate -> + function + | Some n -> Pfedit.get_goal_context pstate n + | None -> Pfedit.get_current_context pstate let query_command_selector ?loc = function | None -> None @@ -1740,9 +1774,9 @@ let query_command_selector ?loc = function | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ~atts redexp glopt rc = +let vernac_check_may_eval ~pstate ~atts redexp glopt rc = let glopt = query_command_selector glopt in - let (sigma, env) = get_current_context_of_args glopt in + let sigma, env = get_current_context_of_args ~pstate glopt in let sigma, c = interp_open_constr env sigma rc in let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Evarconv.check_problems_are_solved env sigma; @@ -1796,27 +1830,33 @@ let vernac_global_check c = pr_universe_ctx_set sigma uctx -let get_nth_goal n = - let pf = Proof_global.give_me_the_proof() in +let get_nth_goal ~pstate n = + let pf = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl exception NoHyp + (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) -let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = +let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let open Context.Named.Declaration in try + (* Fallback early to globals *) + let pstate = match pstate with + | None -> raise Not_found + | Some pstate -> pstate + in (* FIXME error on non None udecl if we find the hyp. *) let glnumopt = query_command_selector ?loc glopt in let gl,id = match glnumopt, ref_or_by_not.v with | None,AN qid when qualid_is_ident qid -> (* goal number not given, catch any failure *) - (try get_nth_goal 1, qualid_basename qid with _ -> raise NoHyp) + (try get_nth_goal ~pstate 1, qualid_basename qid with _ -> raise NoHyp) | Some n,AN qid when qualid_is_ident qid -> (* goal number given, catch if wong *) - (try get_nth_goal n, qualid_basename qid + (try get_nth_goal ~pstate n, qualid_basename qid with Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) @@ -1826,15 +1866,16 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Pfedit.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_or_global_context ~pstate in print_about env sigma ref_or_by_not udecl -let vernac_print ~atts env sigma = +let vernac_print ~(pstate : Proof_global.t option) ~atts = + let sigma, env = get_current_or_global_context ~pstate in function | PrintTables -> print_tables () | PrintFullContext-> print_full_context_typ env sigma @@ -1845,7 +1886,7 @@ let vernac_print ~atts env sigma = | PrintModules -> print_modules () | PrintModule qid -> print_module qid | PrintModuleType qid -> print_modtype qid - | PrintNamespace ns -> print_namespace ns + | PrintNamespace ns -> print_namespace ~pstate ns | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () | PrintDebugGC -> Mltop.print_gc () @@ -1862,7 +1903,13 @@ let vernac_print ~atts env sigma = | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) - | PrintHintGoal -> Hints.pr_applicable_hint () + | PrintHintGoal -> + begin match pstate with + | Some pstate -> + Hints.pr_applicable_hint pstate + | None -> + str "No proof in progress" + end | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma | PrintScopes -> @@ -1872,7 +1919,7 @@ let vernac_print ~atts env sigma = | PrintVisibility s -> Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> - print_about_hyp_globs ref_or_by_not udecl glnumopt + print_about_hyp_globs ~pstate ref_or_by_not udecl glnumopt | PrintImplicit qid -> dump_global qid; print_impargs qid @@ -1937,16 +1984,16 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let vernac_search ~atts s gopt r = +let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> (* 1st goal by default if it exists, otherwise no goal at all *) - (try snd (Pfedit.get_goal_context 1) , Some 1 + (try snd (get_goal_or_global_context ~pstate 1) , Some 1 with _ -> Global.env (),None) (* if goal selector is given and wrong, then let exceptions be raised. *) - | Some g -> snd (Pfedit.get_goal_context g) , Some g + | Some g -> snd (get_goal_or_global_context ~pstate g) , Some g in let get_pattern c = snd (intern_constr_pattern env Evd.(from_env env) c) in let pr_search ref env c = @@ -1961,21 +2008,21 @@ let vernac_search ~atts s gopt r = in match s with | SearchPattern c -> - (Search.search_pattern gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_pattern ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> - (Search.search_rewrite gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> - (Search.search_by_head gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchAbout sl -> - (Search.search_about gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> + (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search -let vernac_locate = function +let vernac_locate ~pstate = function | LocateAny {v=AN qid} -> print_located_qualid qid | LocateTerm {v=AN qid} -> print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> - let _, env = Pfedit.get_current_context () in + let _, env = get_current_or_global_context ~pstate in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc | LocateLibrary qid -> print_located_library qid @@ -1983,9 +2030,9 @@ let vernac_locate = function | LocateOther (s, qid) -> print_located_other s qid | LocateFile f -> locate_file f -let vernac_register qid r = +let vernac_register ~pstate qid r = let gr = Smartlocate.global_with_alias qid in - if Proof_global.there_are_pending_proofs () then + if there_are_pending_proofs ~pstate then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); match r with | RegisterInline -> @@ -2029,8 +2076,8 @@ let vernac_unfocus () = (fun _ p -> Proof.unfocus command_focus p ()) (* Checks that a proof is fully unfocused. Raises an error if not. *) -let vernac_unfocused () = - let p = Proof_global.give_me_the_proof () in +let vernac_unfocused ~pstate = + let p = Proof_global.give_me_the_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else @@ -2060,25 +2107,39 @@ let vernac_bullet (bullet : Proof_bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> Proof_bullet.put p bullet) -let vernac_show = function - | ShowScript -> assert false (* Only the stm knows the script *) - | ShowGoal goalref -> - let proof = Proof_global.give_me_the_proof () in - begin match goalref with - | OpenSubgoals -> pr_open_subgoals ~proof - | NthGoal n -> pr_nth_open_subgoal ~proof n - | GoalId id -> pr_goal_by_id ~proof id +let vernac_show ~pstate = + match pstate with + (* Show functions that don't require a proof state *) + | None -> + begin function + | ShowProof -> show_proof ~pstate + | ShowMatch id -> show_match id + | ShowScript -> assert false (* Only the stm knows the script *) + | _ -> + user_err (str "This command requires an open proof.") + end + (* Show functions that require a proof state *) + | Some pstate -> + begin function + | ShowGoal goalref -> + let proof = Proof_global.give_me_the_proof pstate in + begin match goalref with + | OpenSubgoals -> pr_open_subgoals ~proof + | NthGoal n -> pr_nth_open_subgoal ~proof n + | GoalId id -> pr_goal_by_id ~proof id + end + | ShowExistentials -> show_top_evars ~pstate + | ShowUniverses -> show_universes ~pstate + | ShowProofNames -> + pr_sequence Id.print (Proof_global.get_all_proof_names pstate) + | ShowIntros all -> show_intro ~pstate all + | ShowProof -> show_proof ~pstate:(Some pstate) + | ShowMatch id -> show_match id + | ShowScript -> assert false (* Only the stm knows the script *) end - | ShowProof -> show_proof () - | ShowExistentials -> show_top_evars () - | ShowUniverses -> show_universes () - | ShowProofNames -> - pr_sequence Id.print (Proof_global.get_all_proof_names()) - | ShowIntros all -> show_intro all - | ShowMatch id -> show_match id - -let vernac_check_guard () = - let pts = Proof_global.give_me_the_proof () in + +let vernac_check_guard ~pstate = + let pts = Proof_global.give_me_the_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try @@ -2089,45 +2150,7 @@ let vernac_check_guard () = (str ("Condition violated: ") ++s) in message -exception End_of_input - -(* XXX: This won't properly set the proof mode, as of today, it is - controlled by the STM. Thus, we would need access information from - the classifier. The proper fix is to move it to the STM, however, - the way the proof mode is set there makes the task non trivial - without a considerable amount of refactoring. - *) -let vernac_load interp fname = - if Proof_global.there_are_pending_proofs () then - CErrors.user_err Pp.(str "Load is not supported inside proofs."); - let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing - (fun po -> - match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with - | Some x -> x - | None -> raise End_of_input) in - let fname = - Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in - let fname = CUnix.make_suffix fname ".v" in - let input = - let longfname = Loadpath.locate_file fname in - let in_chan = open_utf8_file_in longfname in - Pcoq.Parsable.make ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in - begin - try while true do - let proof_mode = - if Proof_global.there_are_pending_proofs () then - Some (get_default_proof_mode ()) - else - None - in - interp (parse_sentence proof_mode input).CAst.v; - done - with End_of_input -> () - end; - (* If Load left a proof open, we fail too. *) - if Proof_global.there_are_pending_proofs () then - CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs.") - +(* Attributes *) let with_locality ~atts f = let local = Attributes.(parse locality atts) in f ~local @@ -2147,17 +2170,69 @@ let with_def_attributes ~atts f = if atts.DefAttributes.program then Obligations.check_program_libraries (); f ~atts +(** A global default timeout, controlled by option "Set Default Timeout n". + Use "Unset Default Timeout" to deactivate it (or set it to 0). *) + +let default_timeout = ref None + +(* Timeout *) +let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = + match !default_timeout, timeout with + | _, Some n + | Some n, None -> + Control.timeout n f x Timeout + | None, None -> + f x + +(* Fail *) +exception HasNotFailed +exception HasFailed of Pp.t + +let test_mode = ref false + +(* XXX STATE: this type hints that restoring the state should be the + caller's responsibility *) +let with_fail ~st f = + try + (* If the command actually works, ignore its effects on the state. + * Note that error has to be printed in the right state, hence + * within the purified function *) + try let _ = f () in raise HasNotFailed + with + | HasNotFailed as e -> raise e + | e -> + let e = CErrors.push e in + raise (HasFailed (CErrors.iprint + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) + with e when CErrors.noncritical e -> + (* Restore the previous state XXX Careful here with the cache! *) + Vernacstate.invalidate_cache (); + Vernacstate.unfreeze_interp_state st; + let (e, _) = CErrors.push e in + match e with + | HasNotFailed -> + user_err ~hdr:"Fail" (str "The command has not failed!") + | HasFailed msg -> + if not !Flags.quiet || !test_mode then Feedback.msg_info + (str "The command has indeed failed with message:" ++ fnl () ++ msg) + | _ -> assert false + +let locate_if_not_already ?loc (e, info) = + match Loc.get_loc info with + | None -> (e, Option.cata (Loc.add_loc info) info loc) + | Some l -> (e, info) + +exception End_of_input + (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ~atts ~st c = +let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = + let pstate = st.Vernacstate.proof in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with - (* Loading a file requires access to the control interpreter *) - | VernacLoad _ -> assert false - (* The STM should handle that, but LOAD bypasses the STM... *) | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") @@ -2173,152 +2248,370 @@ let interp ?proof ~atts ~st c = (* This one is possible to handle here *) | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") + (* Loading a file requires access to the control interpreter so + [vernac_load] is mutually-recursive with [interp_expr] *) + | VernacLoad (verbosely,fname) -> + unsupported_attributes atts; + vernac_load ?proof ~verbosely ~st fname + (* Syntax *) | VernacSyntaxExtension (infix, sl) -> - with_module_locality ~atts vernac_syntax_extension infix sl - | VernacDeclareScope sc -> with_module_locality ~atts vernac_declare_scope sc - | VernacDelimiters (sc,lr) -> with_module_locality ~atts vernac_delimiters sc lr - | VernacBindScope (sc,rl) -> with_module_locality ~atts vernac_bind_scope sc rl - | VernacOpenCloseScope (b, s) -> with_section_locality ~atts vernac_open_close_scope (b,s) - | VernacInfix (mv,qid,sc) -> with_module_locality ~atts vernac_infix mv qid sc - | VernacNotation (c,infpl,sc) -> with_module_locality ~atts vernac_notation c infpl sc + with_module_locality ~atts vernac_syntax_extension infix sl; + pstate + | VernacDeclareScope sc -> + with_module_locality ~atts vernac_declare_scope sc; + pstate + | VernacDelimiters (sc,lr) -> + with_module_locality ~atts vernac_delimiters sc lr; + pstate + | VernacBindScope (sc,rl) -> + with_module_locality ~atts vernac_bind_scope sc rl; + pstate + | VernacOpenCloseScope (b, s) -> + with_section_locality ~atts vernac_open_close_scope (b,s); + pstate + | VernacInfix (mv,qid,sc) -> + with_module_locality ~atts vernac_infix mv qid sc; + pstate + | VernacNotation (c,infpl,sc) -> + with_module_locality ~atts vernac_notation c infpl sc; + pstate | VernacNotationAddFormat(n,k,v) -> unsupported_attributes atts; - Metasyntax.add_notation_extra_printing_rule n k v + Metasyntax.add_notation_extra_printing_rule n k v; + pstate | VernacDeclareCustomEntry s -> - with_module_locality ~atts vernac_custom_entry s + with_module_locality ~atts vernac_custom_entry s; + pstate (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> - with_def_attributes ~atts vernac_definition discharge kind lid d - | VernacStartTheoremProof (k,l) -> with_def_attributes vernac_start_proof ~atts k l - | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof e - | VernacExactProof c -> unsupported_attributes atts; vernac_exact_proof c + with_def_attributes ~atts vernac_definition ~pstate discharge kind lid d + | VernacStartTheoremProof (k,l) -> + with_def_attributes ~atts vernac_start_proof ~pstate k l + | VernacEndProof e -> + unsupported_attributes atts; + vernac_end_proof ?proof ?pstate e + | VernacExactProof c -> + unsupported_attributes atts; + vernac_require_open_proof ~pstate (vernac_exact_proof c) | VernacAssumption ((discharge,kind),nl,l) -> - with_def_attributes vernac_assumption ~atts discharge kind l nl - | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l - | VernacFixpoint (discharge, l) -> with_def_attributes vernac_fixpoint ~atts discharge l - | VernacCoFixpoint (discharge, l) -> with_def_attributes vernac_cofixpoint ~atts discharge l - | VernacScheme l -> unsupported_attributes atts; vernac_scheme l - | VernacCombinedScheme (id, l) -> unsupported_attributes atts; vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe ~poly:(only_polymorphism atts) l - | VernacConstraint l -> vernac_constraint ~poly:(only_polymorphism atts) l + with_def_attributes ~atts vernac_assumption ~pstate discharge kind l nl; + pstate + | VernacInductive (cum, priv, finite, l) -> + vernac_inductive ~atts cum priv finite l; + pstate + | VernacFixpoint (discharge, l) -> + with_def_attributes ~atts vernac_fixpoint ~pstate discharge l + | VernacCoFixpoint (discharge, l) -> + with_def_attributes ~atts vernac_cofixpoint ~pstate discharge l + | VernacScheme l -> + unsupported_attributes atts; + vernac_scheme l; + pstate + | VernacCombinedScheme (id, l) -> + unsupported_attributes atts; + vernac_combined_scheme id l; + pstate + | VernacUniverse l -> + vernac_universe ~poly:(only_polymorphism atts) l; + pstate + | VernacConstraint l -> + vernac_constraint ~poly:(only_polymorphism atts) l; + pstate (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> - unsupported_attributes atts; vernac_declare_module export lid bl mtyo + unsupported_attributes atts; + vernac_declare_module export lid bl mtyo; + pstate | VernacDefineModule (export,lid,bl,mtys,mexprl) -> - unsupported_attributes atts; vernac_define_module export lid bl mtys mexprl + unsupported_attributes atts; + vernac_define_module ~pstate export lid bl mtys mexprl; + pstate | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> - unsupported_attributes atts; vernac_declare_module_type lid bl mtys mtyo + unsupported_attributes atts; + vernac_declare_module_type ~pstate lid bl mtys mtyo; + pstate | VernacInclude in_asts -> - unsupported_attributes atts; vernac_include in_asts + unsupported_attributes atts; + vernac_include in_asts; + pstate (* Gallina extensions *) - | VernacBeginSection lid -> unsupported_attributes atts; vernac_begin_section lid + | VernacBeginSection lid -> + unsupported_attributes atts; + vernac_begin_section ~pstate lid; + pstate - | VernacEndSegment lid -> unsupported_attributes atts; vernac_end_segment lid + | VernacEndSegment lid -> + unsupported_attributes atts; + vernac_end_segment ~pstate lid; + pstate - | VernacNameSectionHypSet (lid, set) -> unsupported_attributes atts; vernac_name_sec_hyp lid set + | VernacNameSectionHypSet (lid, set) -> + unsupported_attributes atts; + vernac_name_sec_hyp lid set; + pstate - | VernacRequire (from, export, qidl) -> unsupported_attributes atts; vernac_require from export qidl - | VernacImport (export,qidl) -> unsupported_attributes atts; vernac_import export qidl - | VernacCanonical qid -> unsupported_attributes atts; vernac_canonical qid - | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t + | VernacRequire (from, export, qidl) -> + unsupported_attributes atts; + vernac_require from export qidl; + pstate + | VernacImport (export,qidl) -> + unsupported_attributes atts; + vernac_import export qidl; + pstate + | VernacCanonical qid -> + unsupported_attributes atts; + vernac_canonical qid; + pstate + | VernacCoercion (r,s,t) -> + vernac_coercion ~atts r s t; + pstate | VernacIdentityCoercion ({v=id},s,t) -> - vernac_identity_coercion ~atts id s t + vernac_identity_coercion ~atts id s t; + pstate (* Type classes *) | VernacInstance (sup, inst, props, info) -> - with_def_attributes vernac_instance ~atts sup inst props info + snd @@ with_def_attributes ~atts (vernac_instance ~pstate sup inst props info) | VernacDeclareInstance (sup, inst, info) -> - with_def_attributes vernac_declare_instance ~atts sup inst info - | VernacContext sup -> vernac_context ~poly:(only_polymorphism atts) sup - | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts - | VernacExistingClass id -> unsupported_attributes atts; vernac_existing_class id + with_def_attributes ~atts vernac_declare_instance sup inst info; + pstate + | VernacContext sup -> + let () = vernac_context ~pstate ~poly:(only_polymorphism atts) sup in + pstate + | VernacExistingInstance insts -> + with_section_locality ~atts vernac_existing_instance insts; + pstate + | VernacExistingClass id -> + unsupported_attributes atts; + vernac_existing_class id; + pstate (* Solving *) - | VernacSolveExistential (n,c) -> unsupported_attributes atts; vernac_solve_existential n c + | VernacSolveExistential (n,c) -> + unsupported_attributes atts; + Some (vernac_require_open_proof ~pstate (vernac_solve_existential n c)) (* Auxiliary file and library management *) - | VernacAddLoadPath (isrec,s,alias) -> unsupported_attributes atts; vernac_add_loadpath isrec s alias - | VernacRemoveLoadPath s -> unsupported_attributes atts; vernac_remove_loadpath s - | VernacAddMLPath (isrec,s) -> unsupported_attributes atts; vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> with_locality ~atts vernac_declare_ml_module l - | VernacChdir s -> unsupported_attributes atts; vernac_chdir s + | VernacAddLoadPath (isrec,s,alias) -> + unsupported_attributes atts; + vernac_add_loadpath isrec s alias; + pstate + | VernacRemoveLoadPath s -> + unsupported_attributes atts; + vernac_remove_loadpath s; + pstate + | VernacAddMLPath (isrec,s) -> + unsupported_attributes atts; + vernac_add_ml_path isrec s; + pstate + | VernacDeclareMLModule l -> + with_locality ~atts vernac_declare_ml_module l; + pstate + | VernacChdir s -> + unsupported_attributes atts; + vernac_chdir s; + pstate (* State management *) - | VernacWriteState s -> unsupported_attributes atts; vernac_write_state s - | VernacRestoreState s -> unsupported_attributes atts; vernac_restore_state s + | VernacWriteState s -> + unsupported_attributes atts; + vernac_write_state s; + pstate + | VernacRestoreState s -> + unsupported_attributes atts; + vernac_restore_state s; + pstate (* Commands *) | VernacCreateHintDb (dbname,b) -> - with_module_locality ~atts vernac_create_hintdb dbname b + with_module_locality ~atts vernac_create_hintdb dbname b; + pstate | VernacRemoveHints (dbnames,ids) -> - with_module_locality ~atts vernac_remove_hints dbnames ids + with_module_locality ~atts vernac_remove_hints dbnames ids; + pstate | VernacHints (dbnames,hints) -> - vernac_hints ~atts dbnames hints + vernac_hints ~atts dbnames hints; + pstate | VernacSyntacticDefinition (id,c,b) -> - with_module_locality ~atts vernac_syntactic_definition id c b + with_module_locality ~atts vernac_syntactic_definition id c b; + pstate | VernacArguments (qid, args, more_implicits, nargs, flags) -> - with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags - | VernacReserve bl -> unsupported_attributes atts; vernac_reserve bl - | VernacGeneralizable gen -> with_locality ~atts vernac_generalizable gen - | VernacSetOpacity qidl -> with_locality ~atts vernac_set_opacity qidl - | VernacSetStrategy l -> with_locality ~atts vernac_set_strategy l - | VernacSetOption (export, key,v) -> vernac_set_option ~local:(only_locality atts) export key v - | VernacUnsetOption (export, key) -> vernac_unset_option ~local:(only_locality atts) export key - | VernacRemoveOption (key,v) -> unsupported_attributes atts; vernac_remove_option key v - | VernacAddOption (key,v) -> unsupported_attributes atts; vernac_add_option key v - | VernacMemOption (key,v) -> unsupported_attributes atts; vernac_mem_option key v - | VernacPrintOption key -> unsupported_attributes atts; vernac_print_option key + with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags; + pstate + | VernacReserve bl -> + unsupported_attributes atts; + vernac_reserve bl; + pstate + | VernacGeneralizable gen -> + with_locality ~atts vernac_generalizable gen; + pstate + | VernacSetOpacity qidl -> + with_locality ~atts vernac_set_opacity qidl; + pstate + | VernacSetStrategy l -> + with_locality ~atts vernac_set_strategy l; + pstate + | VernacSetOption (export, key,v) -> + vernac_set_option ~local:(only_locality atts) export key v; + pstate + | VernacRemoveOption (key,v) -> + unsupported_attributes atts; + vernac_remove_option key v; + pstate + | VernacAddOption (key,v) -> + unsupported_attributes atts; + vernac_add_option key v; + pstate + | VernacMemOption (key,v) -> + unsupported_attributes atts; + vernac_mem_option key v; + pstate + | VernacPrintOption key -> + unsupported_attributes atts; + vernac_print_option key; + pstate | VernacCheckMayEval (r,g,c) -> - Feedback.msg_notice @@ vernac_check_may_eval ~atts r g c - | VernacDeclareReduction (s,r) -> with_locality ~atts vernac_declare_reduction s r + Feedback.msg_notice @@ + vernac_check_may_eval ~pstate ~atts r g c; + pstate + | VernacDeclareReduction (s,r) -> + with_locality ~atts vernac_declare_reduction s r; + pstate | VernacGlobalCheck c -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_global_check c + Feedback.msg_notice @@ vernac_global_check c; + pstate | VernacPrint p -> - let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice @@ vernac_print ~atts env sigma p - | VernacSearch (s,g,r) -> unsupported_attributes atts; vernac_search ~atts s g r + Feedback.msg_notice @@ vernac_print ~pstate ~atts p; + pstate + | VernacSearch (s,g,r) -> + unsupported_attributes atts; + vernac_search ~pstate ~atts s g r; + pstate | VernacLocate l -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_locate l - | VernacRegister (qid, r) -> unsupported_attributes atts; vernac_register qid r - | VernacPrimitive (id, prim, typopt) -> unsupported_attributes atts; ComAssumption.do_primitive id prim typopt - | VernacComments l -> unsupported_attributes atts; - Flags.if_verbose Feedback.msg_info (str "Comments ok\n") + Feedback.msg_notice @@ vernac_locate ~pstate l; + pstate + | VernacRegister (qid, r) -> + unsupported_attributes atts; + vernac_register ~pstate qid r; + pstate + | VernacPrimitive (id, prim, typopt) -> + unsupported_attributes atts; + ComAssumption.do_primitive id prim typopt; + pstate + | VernacComments l -> + unsupported_attributes atts; + Flags.if_verbose Feedback.msg_info (str "Comments ok\n"); + pstate (* Proof management *) - | VernacFocus n -> unsupported_attributes atts; vernac_focus n - | VernacUnfocus -> unsupported_attributes atts; vernac_unfocus () - | VernacUnfocused -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_unfocused () - | VernacBullet b -> unsupported_attributes atts; vernac_bullet b - | VernacSubproof n -> unsupported_attributes atts; vernac_subproof n - | VernacEndSubproof -> unsupported_attributes atts; vernac_end_subproof () - | VernacShow s -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_show s - | VernacCheckGuard -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_check_guard () - | VernacProof (tac, using) -> unsupported_attributes atts; + | VernacFocus n -> + unsupported_attributes atts; + Option.map (vernac_focus n) pstate + | VernacUnfocus -> + unsupported_attributes atts; + Option.map (vernac_unfocus ()) pstate + | VernacUnfocused -> + unsupported_attributes atts; + Option.iter (fun pstate -> Feedback.msg_notice @@ vernac_unfocused ~pstate) pstate; + pstate + | VernacBullet b -> + unsupported_attributes atts; + Option.map (vernac_bullet b) pstate + | VernacSubproof n -> + unsupported_attributes atts; + Option.map (vernac_subproof n) pstate + | VernacEndSubproof -> + unsupported_attributes atts; + Option.map (vernac_end_subproof ()) pstate + | VernacShow s -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_show ~pstate s; + pstate + | VernacCheckGuard -> + unsupported_attributes atts; + Feedback.msg_notice @@ + vernac_require_open_proof ~pstate (vernac_check_guard); + pstate + | VernacProof (tac, using) -> + unsupported_attributes atts; let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); - Option.iter vernac_set_end_tac tac; - Option.iter vernac_set_used_variables using - | VernacProofMode mn -> unsupported_attributes atts; () + let pstate = + vernac_require_open_proof ~pstate (fun ~pstate -> + let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in + Option.cata (vernac_set_used_variables ~pstate) pstate using) + in Some pstate + | VernacProofMode mn -> + unsupported_attributes atts; + pstate (* Extensions *) | VernacExtend (opn,args) -> (* XXX: Here we are returning the state! :) *) - let _st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in - () + let st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in + st.Vernacstate.proof -(** A global default timeout, controlled by option "Set Default Timeout n". - Use "Unset Default Timeout" to deactivate it (or set it to 0). *) - -let default_timeout = ref None +(* XXX: This won't properly set the proof mode, as of today, it is + controlled by the STM. Thus, we would need access information from + the classifier. The proper fix is to move it to the STM, however, + the way the proof mode is set there makes the task non trivial + without a considerable amount of refactoring. + *) +and vernac_load ?proof ~verbosely ~st fname = + let pstate = st.Vernacstate.proof in + if there_are_pending_proofs ~pstate then + CErrors.user_err Pp.(str "Load is not supported inside proofs."); + (* Open the file *) + let fname = + Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in + let fname = CUnix.make_suffix fname ".v" in + let input = + let longfname = Loadpath.locate_file fname in + let in_chan = open_utf8_file_in longfname in + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile longfname)) (Stream.of_channel in_chan) in + (* Parsing loop *) + let v_mod = if verbosely then Flags.verbosely else Flags.silently in + let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing + (fun po -> + match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with + | Some x -> x + | None -> raise End_of_input) in + let rec load_loop ~pstate = + try + let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) pstate in + let pstate = + v_mod (interp_control ?proof ~st:{ st with Vernacstate.proof = pstate }) + (parse_sentence proof_mode input) in + load_loop ~pstate + with + End_of_input -> + pstate + in + let pstate = load_loop ~pstate in + (* If Load left a proof open, we fail too. *) + if there_are_pending_proofs ~pstate then + CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); + pstate + +and interp_control ?proof ~st = function + | { v=VernacExpr (atts, cmd) } -> + interp_expr ?proof ~atts ~st cmd + | { v=VernacFail v } -> + with_fail ~st (fun () -> interp_control ?proof ~st v); + st.Vernacstate.proof + | { v=VernacTimeout (timeout,v) } -> + vernac_timeout ~timeout (interp_control ?proof ~st) v + | { v=VernacRedirect (s, v) } -> + Topfmt.with_output_to_file s (interp_control ?proof ~st) v + | { v=VernacTime (batch, cmd) }-> + let header = if batch then Topfmt.pr_cmd_header cmd else Pp.mt () in + System.with_time ~batch ~header (interp_control ?proof ~st) cmd let () = declare_int_option @@ -2328,112 +2621,17 @@ let () = optread = (fun () -> !default_timeout); optwrite = ((:=) default_timeout) } -(** When interpreting a command, the current timeout is initially - the default one, but may be modified locally by a Timeout command. *) - -let current_timeout = ref None - -let vernac_timeout f = - match !current_timeout, !default_timeout with - | Some n, _ | None, Some n -> - let f () = f (); current_timeout := None in - Control.timeout n f () Timeout - | None, None -> f () - -let restore_timeout () = current_timeout := None - -let locate_if_not_already ?loc (e, info) = - match Loc.get_loc info with - | None -> (e, Option.cata (Loc.add_loc info) info loc) - | Some l -> (e, info) - -exception HasNotFailed -exception HasFailed of Pp.t - -let test_mode = ref false - -(* XXX STATE: this type hints that restoring the state should be the - caller's responsibility *) -let with_fail st b f = - if not b - then f () - else begin try - (* If the command actually works, ignore its effects on the state. - * Note that error has to be printed in the right state, hence - * within the purified function *) - try f (); raise HasNotFailed - with - | HasNotFailed as e -> raise e - | e -> - let e = CErrors.push e in - raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) - with e when CErrors.noncritical e -> - (* Restore the previous state XXX Careful here with the cache! *) - Vernacstate.invalidate_cache (); - Vernacstate.unfreeze_interp_state st; - let (e, _) = CErrors.push e in - match e with - | HasNotFailed -> - user_err ~hdr:"Fail" (str "The command has not failed!") - | HasFailed msg -> - if not !Flags.quiet || !test_mode then Feedback.msg_info - (str "The command has indeed failed with message:" ++ fnl () ++ msg) - | _ -> assert false - end - -let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = - let rec control = function - | VernacExpr (atts, v) -> - aux ~atts v - | VernacFail v -> with_fail st true (fun () -> control v) - | VernacTimeout (n,v) -> - current_timeout := Some n; - control v - | VernacRedirect (s, {v}) -> - Topfmt.with_output_to_file s control v - | VernacTime (batch, com) -> - let header = if batch then Topfmt.pr_cmd_header com else Pp.mt () in - System.with_time ~batch ~header control com.CAst.v; - - and aux ~atts : _ -> unit = - function - - | VernacLoad (_,fname) -> - unsupported_attributes atts; - vernac_load control fname - - | c -> - (* NB: we keep polymorphism and program in the attributes, we're - just parsing them to do our option magic. *) - try - vernac_timeout begin fun () -> - if verbosely - then Flags.verbosely (interp ?proof ~atts ~st) c - else Flags.silently (interp ?proof ~atts ~st) c; - end - with - | reraise when - (match reraise with - | Timeout -> true - | e -> CErrors.noncritical e) - -> - let e = CErrors.push reraise in - let e = locate_if_not_already ?loc e in - let () = restore_timeout () in - iraise e - in - if verbosely - then Flags.verbosely control c - else control c - (* Be careful with the cache here in case of an exception. *) -let interp ?verbosely ?proof ~st cmd = +let interp ?(verbosely=true) ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; - try - interp ?verbosely ?proof ~st cmd; - Vernacstate.freeze_interp_state ~marshallable:false + try vernac_timeout (fun st -> + let v_mod = if verbosely then Flags.verbosely else Flags.silently in + let pstate = v_mod (interp_control ?proof ~st) cmd in + Vernacstate.Proof_global.set pstate; + Vernacstate.freeze_interp_state ~marshallable:false + ) st with exn -> let exn = CErrors.push exn in + let exn = locate_if_not_already ?loc:cmd.CAst.loc exn in Vernacstate.invalidate_cache (); iraise exn diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index f43cec48e9..71cc29b6e1 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -33,15 +33,17 @@ val interp : val make_cases : string -> string list list -(* XXX STATE: this type hints that restoring the state should be the - caller's responsibility *) -val with_fail : Vernacstate.t -> bool -> (unit -> unit) -> unit +(** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) +val with_fail : st:Vernacstate.t -> (unit -> 'a) -> unit val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t +(** Helper *) +val vernac_require_open_proof : pstate:Proof_global.t option -> (pstate:Proof_global.t -> 'a) -> 'a + (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d1da7c0602..d0dae1aa53 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -109,11 +109,11 @@ type onlyparsing_flag = Flags.compat_version option which this notation is trying to be compatible with *) type locality_flag = bool (* true = Local *) -type option_value = Goptions.option_value = - | BoolValue of bool - | IntValue of int option - | StringValue of string - | StringOptValue of string option +type option_setting = + | OptionUnset + | OptionSetTrue + | OptionSetInt of int + | OptionSetString of string type option_ref_value = | StringRefValue of string @@ -129,7 +129,7 @@ type definition_expr = * constr_expr option type fixpoint_expr = - ident_decl * (lident option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option + ident_decl * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr option type cofixpoint_expr = ident_decl * local_binder_expr list * constr_expr * constr_expr option @@ -363,8 +363,7 @@ type nonrec vernac_expr = | VernacSetOpacity of (Conv_oracle.level * qualid or_by_notation list) | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list - | VernacUnsetOption of export_flag * Goptions.option_name - | VernacSetOption of export_flag * Goptions.option_name * option_value + | VernacSetOption of export_flag * Goptions.option_name * option_setting | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list @@ -405,11 +404,5 @@ type vernac_control = the flag is used to print differently in `-time` vs `Time foo` *) | VernacTime of bool * vernac_control CAst.t | VernacRedirect of string * vernac_control CAst.t - | VernacTimeout of int * vernac_control - | VernacFail of vernac_control - -(** Deprecated *) - -type vernac_implicit_status = Impargs.implicit_kind = - | Implicit [@ocaml.deprecated] | MaximallyImplicit [@ocaml.deprecated] | NotImplicit [@ocaml.deprecated] -[@@ocaml.deprecated "Use [Impargs.implicit_kind]"] + | VernacTimeout of int * vernac_control CAst.t + | VernacFail of vernac_control CAst.t diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 4bfe5c66b5..ef06e59316 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -169,7 +169,7 @@ let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_comm | Some Refl -> untype_command ty (f v) args end -let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Extend.norec, a) Extend.symbol = let open Extend in function | TUlist1 l -> Alist1 (untype_user_symbol l) | TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 0fdd2faafa..704c5b2170 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -17,14 +17,14 @@ let rec under_control = function | VernacExpr (_, c) -> c | VernacRedirect (_,{CAst.v=c}) | VernacTime (_,{CAst.v=c}) - | VernacFail c - | VernacTimeout (_,c) -> under_control c + | VernacFail {CAst.v=c} + | VernacTimeout (_,{CAst.v=c}) -> under_control c let rec has_Fail = function | VernacExpr _ -> false | VernacRedirect (_,{CAst.v=c}) | VernacTime (_,{CAst.v=c}) - | VernacTimeout (_,c) -> has_Fail c + | VernacTimeout (_,{CAst.v=c}) -> has_Fail c | VernacFail _ -> true (* Navigation commands are allowed in a coqtop session but not in a .v file *) @@ -41,7 +41,7 @@ let is_navigation_vernac c = let rec is_deep_navigation_vernac = function | VernacTime (_,{CAst.v=c}) -> is_deep_navigation_vernac c | VernacRedirect (_, {CAst.v=c}) - | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c + | VernacTimeout (_,{CAst.v=c}) | VernacFail {CAst.v=c} -> is_navigation_vernac c | VernacExpr _ -> false (* NB: Reset is now allowed again as asked by A. Chlipala *) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index c691dc8559..77f54361da 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -28,10 +28,10 @@ module Parser = struct end type t = { - parsing: Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool; (* is the state trimmed down (libstack) *) + parsing : Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t option; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } let s_cache = ref None @@ -55,14 +55,14 @@ let do_if_not_cached rf f v = let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); - proof = update_cache s_proof (Proof_global.freeze ~marshallable); + proof = !s_proof; shallow = false; parsing = Parser.cur_state (); } let unfreeze_interp_state { system; proof; parsing } = do_if_not_cached s_cache States.unfreeze system; - do_if_not_cached s_proof Proof_global.unfreeze proof; + s_proof := proof; Pcoq.unfreeze parsing let make_shallow st = @@ -71,3 +71,75 @@ let make_shallow st = system = States.replace_lib st.system @@ Lib.drop_objects lib; shallow = true; } + +(* Compatibility module *) +module Proof_global = struct + + let get () = !s_proof + let set x = s_proof := x + + let freeze ~marshallable:_ = get () + let unfreeze x = s_proof := Some x + + exception NoCurrentProof + + let () = + CErrors.register_handler begin function + | NoCurrentProof -> + CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") + | _ -> raise CErrors.Unhandled + end + + open Proof_global + + let cc f = match !s_proof with + | None -> raise NoCurrentProof + | Some x -> f x + + let dd f = match !s_proof with + | None -> raise NoCurrentProof + | Some x -> s_proof := Some (f x) + + let there_are_pending_proofs () = !s_proof <> None + let get_open_goals () = cc get_open_goals + + let set_terminator x = dd (set_terminator x) + let give_me_the_proof_opt () = Option.map give_me_the_proof !s_proof + let give_me_the_proof () = cc give_me_the_proof + let get_current_proof_name () = cc get_current_proof_name + + let simple_with_current_proof f = + dd (simple_with_current_proof f) + + let with_current_proof f = + let pf, res = cc (with_current_proof f) in + s_proof := Some pf; res + + let install_state s = s_proof := Some s + + let return_proof ?allow_partial () = + cc (return_proof ?allow_partial) + + let close_future_proof ~opaque ~feedback_id pf = + cc (fun st -> close_future_proof ~opaque ~feedback_id st pf) + + let close_proof ~opaque ~keep_body_ucst_separate f = + cc (close_proof ~opaque ~keep_body_ucst_separate f) + + let discard_all () = s_proof := None + let update_global_env () = dd update_global_env + + let get_current_context () = cc Pfedit.get_current_context + + let get_all_proof_names () = + try cc get_all_proof_names + with NoCurrentProof -> [] + + let copy_terminators ~src ~tgt = + match src, tgt with + | None, None -> None + | Some _ , None -> None + | None, Some x -> Some x + | Some src, Some tgt -> Some (copy_terminators ~src ~tgt) + +end diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 581c23386a..b79f97796f 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -19,10 +19,10 @@ module Parser : sig end type t = { - parsing: Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool; (* is the state trimmed down (libstack) *) + parsing : Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t option; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } val freeze_interp_state : marshallable:bool -> t @@ -32,3 +32,53 @@ val make_shallow : t -> t (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit + +(* Compatibility module: Do Not Use *) +module Proof_global : sig + + open Proof_global + + (* Low-level stuff *) + val get : unit -> t option + val set : t option -> unit + + val freeze : marshallable:bool -> t option + val unfreeze : t -> unit + + exception NoCurrentProof + + val there_are_pending_proofs : unit -> bool + val get_open_goals : unit -> int + + val set_terminator : proof_terminator -> unit + val give_me_the_proof : unit -> Proof.t + val give_me_the_proof_opt : unit -> Proof.t option + val get_current_proof_name : unit -> Names.Id.t + + val simple_with_current_proof : + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit + + val with_current_proof : + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a + + val install_state : t -> unit + + val return_proof : ?allow_partial:bool -> unit -> closed_proof_output + + val close_future_proof : + opaque:opacity_flag -> + feedback_id:Stateid.t -> + closed_proof_output Future.computation -> closed_proof + + val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + + val discard_all : unit -> unit + val update_global_env : unit -> unit + + val get_current_context : unit -> Evd.evar_map * Environ.env + + val get_all_proof_names : unit -> Names.Id.t list + + val copy_terminators : src:t option -> tgt:t option -> t option + +end |