diff options
266 files changed, 3303 insertions, 1874 deletions
diff --git a/.gitattributes b/.gitattributes index 6af0a106ba..00f78b4494 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,5 +1,3 @@ -.dir-locals.el export-ignore .gitattributes export-ignore .gitignore export-ignore .mailmap export-ignore -TODO export-ignore diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ae55302d11..1814aaff10 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -60,6 +60,7 @@ before_script: paths: - _install_ci - config/Makefile + - test-suite/misc/universes/all_stdlib.v expire_in: 1 week script: - set -e @@ -70,6 +71,7 @@ before_script: - echo 'start:coq.build' - make -j ${NJOBS} + - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' - echo 'start:coq.install' @@ -309,7 +311,7 @@ ci-hott: <<: *ci-template-vars EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" -ci-iris-coq: +ci-iris-lambda-rust: <<: *ci-template ci-math-classes: diff --git a/.travis.yml b/.travis.yml index 6c926aacbd..8d70e346ad 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,6 +31,7 @@ env: # system is == 4.02.3 - COMPILER="system" - CAMLP5_VER="6.14" + - FINDLIB_VER="1.4.1" - NATIVE_COMP="yes" - COQ_DEST="-local" # Main test suites @@ -38,6 +39,7 @@ env: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" - TEST_TARGET="validate" TW="travis_wait" - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" + - TEST_TARGET="validate" COMPILER="4.05.0+flambda" CAMLP5_VER="7.01" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" NATIVE_COMP="no" - TEST_TARGET="ci-bignums TIMED=1" - TEST_TARGET="ci-color TIMED=1" - TEST_TARGET="ci-compcert TIMED=1" @@ -49,7 +51,7 @@ env: - TEST_TARGET="ci-flocq TIMED=1" - TEST_TARGET="ci-formal-topology TIMED=1" - TEST_TARGET="ci-hott TIMED=1" - - TEST_TARGET="ci-iris-coq TIMED=1" + - TEST_TARGET="ci-iris-lambda-rust TIMED=1" - TEST_TARGET="ci-math-classes TIMED=1" - TEST_TARGET="ci-math-comp TIMED=1" - TEST_TARGET="ci-sf TIMED=1" @@ -62,9 +64,6 @@ env: matrix: - allow_failures: - - env: TEST_TARGET="ci-geocoq TIMED=1" - include: # Full Coq test-suite with two compilers - env: @@ -95,6 +94,7 @@ matrix: - env: - TEST_TARGET="test-suite" - COMPILER="4.05.0" + - FINDLIB_VER="1.7.3" - CAMLP5_VER="7.01" - EXTRA_CONF="-coqide opt -with-doc yes" - EXTRA_OPAM="lablgtk-extras hevea" @@ -104,6 +104,21 @@ matrix: - avsm packages: *extra-packages + # Full test-suite with flambda + - env: + - TEST_TARGET="test-suite" + - COMPILER="4.05.0+flambda" + - FINDLIB_VER="1.7.3" + - CAMLP5_VER="7.01" + - NATIVE_COMP="no" + - EXTRA_CONF="-coqide opt -with-doc yes -flambda-opts -O3" + - EXTRA_OPAM="lablgtk-extras hevea" + addons: + apt: + sources: + - avsm + packages: *extra-packages + # Ocaml warnings with two compilers - env: - TEST_TARGET="coqocaml" @@ -125,6 +140,7 @@ matrix: - TEST_TARGET="coqocaml" - COMPILER="4.05.0" - CAMLP5_VER="7.01" + - FINDLIB_VER="1.7.3" - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras hevea" # dummy target @@ -136,20 +152,18 @@ matrix: packages: *coqide-packages - os: osx - osx_image: xcode8.3 env: - TEST_TARGET="test-suite" - COMPILER="4.02.3" - - CAMLP5_VER="6.17" + - CAMLP5_VER="6.17" - NATIVE_COMP="no" - COQ_DEST="-local" before_install: - - brew update --debug --verbose + - brew update - brew install opam gnu-time - - if: NOT type IS pull_request + - if: NOT (type = pull_request) os: osx - osx_image: xcode8.3 env: - TEST_TARGET="" - COMPILER="4.02.3" @@ -159,7 +173,7 @@ matrix: - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras" before_install: - - brew update --debug --verbose + - brew update - brew install opam gnu-time gtk+ expat gtksourceview libxml2 gdk-pixbuf python3 - pip3 install macpack before_deploy: @@ -173,14 +187,6 @@ matrix: skip_cleanup: true on: all_branches: true - - provider: releases - api_key: - secure: "Z/ewvydCLXEhlBBtQGYm2nZ8o+2RP+MwA5uEDuu6mEpZttUZAYaoHivChxADLXz8LNKvUloIeBeIL/PrLk6QnhSur/s2iEYHssrnl99SkAPtoWggyfsdacuKLMkpLoZGOBIEYKPuXuEZyqvugSUO42rSya1zdjcnXc4l+E/bXMc=" - file: _build/*.dmg - skip_cleanup: true - on: - tags: true - repo: coq/coq before_install: - if [ "${TRAVIS_PULL_REQUEST}" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi @@ -189,7 +195,7 @@ install: - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y - eval $(opam config env) - opam config list -- opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${EXTRA_OPAM} +- opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind.${FINDLIB_VER} ${EXTRA_OPAM} - opam list script: diff --git a/API/API.ml b/API/API.ml index 46ad36d36d..bf99d0febd 100644 --- a/API/API.ml +++ b/API/API.ml @@ -212,7 +212,7 @@ module Pputils = Pputils module Ppconstr = Ppconstr module Printer = Printer (* module Printmod *) -(* module Prettyp *) +module Prettyp = Prettyp module Ppvernac = Ppvernac (******************************************************************************) diff --git a/API/API.mli b/API/API.mli index 3ed326ff0e..5e41464c80 100644 --- a/API/API.mli +++ b/API/API.mli @@ -1795,6 +1795,7 @@ sig val pr_path : full_path -> Pp.t val make_path : Names.DirPath.t -> Names.Id.t -> full_path val eq_full_path : full_path -> full_path -> bool + val repr_path : full_path -> Names.DirPath.t * Names.Id.t val dirpath : full_path -> Names.DirPath.t val path_of_string : string -> full_path @@ -1913,7 +1914,11 @@ module Summary : sig type frozen - type marshallable + + type marshallable = + [ `Yes (* Full data will be marshalled to disk *) + | `No (* Full data will be store in memory, e.g. for Undo *) + | `Shallow ] (* Only part of the data will be marshalled to a slave process *) type 'a summary_declaration = { freeze_function : marshallable -> 'a; @@ -1935,24 +1940,19 @@ module Nametab : sig exception GlobalizationError of Libnames.qualid - type ltac_constant = Names.KerName.t - val global : Libnames.reference -> Globnames.global_reference val global_of_path : Libnames.full_path -> Globnames.global_reference val shortest_qualid_of_global : Names.Id.Set.t -> Globnames.global_reference -> Libnames.qualid val path_of_global : Globnames.global_reference -> Libnames.full_path val locate_extended : Libnames.qualid -> Globnames.extended_global_reference val full_name_module : Libnames.qualid -> Names.DirPath.t - val locate_tactic : Libnames.qualid -> Names.KerName.t val pr_global_env : Names.Id.Set.t -> Globnames.global_reference -> Pp.t - val shortest_qualid_of_tactic : Names.KerName.t -> Libnames.qualid val basename_of_global : Globnames.global_reference -> Names.Id.t type visibility = | Until of int | Exactly of int - val push_tactic : visibility -> Libnames.full_path -> Names.KerName.t -> unit val error_global_not_found : ?loc:Loc.t -> Libnames.qualid -> 'a val shortest_qualid_of_module : Names.ModPath.t -> Libnames.qualid val dirpath_of_module : Names.ModPath.t -> Names.DirPath.t @@ -1960,6 +1960,40 @@ sig val dirpath_of_global : Globnames.global_reference -> Names.DirPath.t val locate : Libnames.qualid -> Globnames.global_reference val locate_constant : Libnames.qualid -> Names.Constant.t + + (** NOT FOR PUBLIC USE YET. Plugin writers, please do not rely on this API. *) + + module type UserName = sig + type t + val equal : t -> t -> bool + val to_string : t -> string + val repr : t -> Names.Id.t * Names.Id.t list + end + + module type EqualityType = + sig + type t + val equal : t -> t -> bool + end + + module type NAMETREE = sig + type elt + type t + type user_name + + val empty : t + val push : visibility -> user_name -> elt -> t -> t + val locate : Libnames.qualid -> t -> elt + val find : user_name -> t -> elt + val exists : user_name -> t -> bool + val user_name : Libnames.qualid -> t -> user_name + val shortest_qualid : Names.Id.Set.t -> user_name -> t -> Libnames.qualid + val find_prefixes : Libnames.qualid -> t -> elt list + end + + module Make (U : UserName) (E : EqualityType) : + NAMETREE with type user_name = U.t and type elt = E.t + end module Global : @@ -2030,7 +2064,8 @@ end module States : sig - val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b + type state + val with_state_protection : ('a -> 'b) -> 'a -> 'b end @@ -3683,7 +3718,7 @@ sig | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * Feedback.route_id - | VtBack of vernac_part_of_script * Stateid.t + | VtMeta | VtUnknown and vernac_qed_type = | VtKeep @@ -4482,6 +4517,9 @@ end module Proof_global : sig + + type state + type proof_mode = { name : string; set : unit -> unit ; @@ -4631,6 +4669,7 @@ sig val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Names.Id.Set.t val pf_concl : 'a Proofview.Goal.t -> EConstr.types val pf_get_new_id : Names.Id.t -> 'a Proofview.Goal.t -> Names.Id.t + val pf_get_hyp : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.named_declaration val pf_get_hyp_typ : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.types val pf_get_type_of : 'a Proofview.Goal.t -> EConstr.constr -> EConstr.types val pf_global : Names.Id.t -> 'a Proofview.Goal.t -> Globnames.global_reference @@ -4883,7 +4922,6 @@ module G_proofs : sig val hint : Vernacexpr.hints_expr Pcoq.Gram.entry - val hint_proof_using : 'a Pcoq.Gram.entry -> 'a option -> 'a option end @@ -4975,6 +5013,21 @@ sig val pr_transparent_state : Names.transparent_state -> Pp.t end +module Prettyp : +sig + type 'a locatable_info = { + locate : Libnames.qualid -> 'a option; + locate_all : Libnames.qualid -> 'a list; + shortest_qualid : 'a -> Libnames.qualid; + name : 'a -> Pp.t; + print : 'a -> Pp.t; + about : 'a -> Pp.t; + } + + val register_locatable : string -> 'a locatable_info -> unit + val print_located_other : string -> Libnames.reference -> Pp.t +end + (************************************************************************) (* End of modules from printing/ *) (************************************************************************) @@ -5284,6 +5337,11 @@ sig | Naive | FirstSolved | AllMatches + type inj_flags = { + keep_proof_equalities : bool; (* One may want it or not *) + injection_in_context : bool; (* For regularity; one may want it from ML code but not interactively *) + injection_pattern_l2r_order : bool; (* Compatibility option: no reason not to want it *) + } val build_selector : Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.types -> @@ -5292,20 +5350,20 @@ sig val general_rewrite : orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr -> unit Proofview.tactic - val inj : Tactypes.intro_patterns option -> Misctypes.evars_flag -> + val inj : inj_flags option -> Tactypes.intro_patterns option -> Misctypes.evars_flag -> Misctypes.clear_flag -> EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic val general_multi_rewrite : Misctypes.evars_flag -> (bool * Misctypes.multi * Misctypes.clear_flag * Tactypes.delayed_open_constr_with_bindings) list -> Locus.clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic val replace_in_clause_maybe_by : EConstr.constr -> EConstr.constr -> Locus.clause -> unit Proofview.tactic option -> unit Proofview.tactic val replace_term : bool option -> EConstr.constr -> Locus.clause -> unit Proofview.tactic - val dEq : Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic + val dEq : keep_proofs:bool option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic val discr_tac : Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - val injClause : Tactypes.intro_patterns option -> Misctypes.evars_flag -> + val injClause : inj_flags option -> Tactypes.intro_patterns option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic - val simpleInjClause : Misctypes.evars_flag -> + val simpleInjClause : inj_flags option -> Misctypes.evars_flag -> EConstr.constr Misctypes.with_bindings Misctypes.destruction_arg option -> unit Proofview.tactic val rewriteInConcl : bool -> EConstr.constr -> unit Proofview.tactic @@ -5339,8 +5397,8 @@ sig ?tac:(unit Proofview.tactic * conditions) -> EConstr.constr Misctypes.with_bindings -> Misctypes.evars_flag -> unit Proofview.tactic val discriminable : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool val discrHyp : Names.Id.t -> unit Proofview.tactic - val injectable : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool - val injHyp : Misctypes.clear_flag -> Names.Id.t -> unit Proofview.tactic + val injectable : Environ.env -> Evd.evar_map -> keep_proofs:(bool option) -> EConstr.constr -> EConstr.constr -> bool + val injHyp : inj_flags option -> Misctypes.clear_flag -> Names.Id.t -> unit Proofview.tactic val subst_gen : bool -> Names.Id.t list -> unit Proofview.tactic end @@ -5742,6 +5800,16 @@ end module Vernacentries : sig + + type interp_state = { (* TODO: inline records in OCaml 4.03 *) + system : States.state; (* summary + libstack *) + proof : Proof_global.state; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) + } + + val freeze_interp_state : Summary.marshallable -> interp_state + val unfreeze_interp_state : interp_state -> unit + val dump_global : Libnames.reference Misctypes.or_by_notation -> unit val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t @@ -5768,9 +5836,12 @@ end module Stm : sig - type state - val state_of_id : - Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] + type doc + + val get_doc : Feedback.doc_id -> doc + + val state_of_id : doc:doc -> + Stateid.t -> [ `Valid of Vernacentries.interp_state option | `Expired | `Error of exn ] end (************************************************************************) @@ -5,6 +5,8 @@ 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. Tactics @@ -12,15 +14,41 @@ Tactics utility. The command "Set NativeCompute Profiling" enables profiling, and "Set NativeCompute Profile Filename" customizes the profile filename. - -Changes from 8.7+beta1 to 8.7.0 +- The tactic "omega" is now aware of the bodies of context variables + such as "x := 5 : Z" (see BZ#148). This could be disabled via + Unset Omega UseLocalDefs. +- The tactic "romega" is also aware now of the bodies of context variables. +- Tactic "decide equality" now able to manage constructors which + contain proofs. + +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: + +- BZ#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 =============================== @@ -2368,7 +2396,7 @@ Tactics 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 #1101) +- Fixed various bugs about (setoid) rewrite ... in ... (in particular BZ#1101) - "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 @@ -2945,11 +2973,11 @@ Incompatibilities Bugs - Improved localisation of errors in Syntactic Definitions -- Induction principle creation failure in presence of let-in fixed (#238) -- Inversion bugs fixed (#212 and #220) -- Omega bug related to Set fixed (#180) -- Type-checking inefficiency of nested destructuring let-in fixed (#216) -- Improved handling of let-in during holes resolution phase (#239) +- Induction principle creation failure in presence of let-in fixed (BZ#238) +- Inversion bugs fixed (BZ#212 and BZ#220) +- Omega bug related to Set fixed (BZ#180) +- Type-checking inefficiency of nested destructuring let-in fixed (BZ#216) +- Improved handling of let-in during holes resolution phase (BZ#239) Efficiency @@ -2962,18 +2990,18 @@ 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 (PR#182) - - Invalid argument bug in Exact tactic solved (PR#183) - - Colliding bound names bug fixed (PR#202) - - Wrong non-recursivity test for Record fixed (PR#189) - - Out of memory/seg fault bug related to parametric inductive fixed (PR#195) + - Checking of names already existing in Assert added (BZ#182) + - Invalid argument bug in Exact tactic solved (BZ#183) + - Colliding bound names bug fixed (BZ#202) + - Wrong non-recursivity test for Record fixed (BZ#189) + - Out of memory/seg fault bug related to parametric inductive fixed (BZ#195) - 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 (PR#192) + LetTac (BZ#192) Changes from V7.2 to V7.3 ========================= diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index c935b6b140..db02f78344 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -4,13 +4,13 @@ Thank you for your interest in contributing to Coq! There are many ways to contr ## Bug Reports -Bug reports are enormously useful to identify issues with Coq; we can't fix what we don't know about. Bug reports should all be filed on the [Coq Bugzilla](https://coq.inria.fr/bugs/) (you'll have to make an account). You can file a bug for any of the following: +Bug reports are enormously useful to identify issues with Coq; we can't fix what we don't know about. To report a bug, please open an issue in the [Coq issue tracker](https://github.com/coq/coq/issues) (you'll need a GitHub account). You can file a bug for any of the following: - An anomaly. These are always considered bugs, so Coq will even ask you to file a bug report! - An error you didn't expect. If you're not sure whether it's a bug or intentional, feel free to file a bug anyway. We may want to improve the documentation or error message. - Missing documentation. It's helpful to track where the documentation should be improved, so please file a bug if you can't find or don't understand some bit of documentation. - An error message that wasn't as helpful as you'd like. Bonus points for suggesting what information would have helped you. -- Bugs in CoqIDE should also be filed on the Bugzilla. Bugs in the Emacs plugin should be filed against [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are specific to company-coq features. +- Bugs in CoqIDE should also be filed in the [Coq issue tracker](https://github.com/coq/coq/issues). Bugs in the Emacs plugin should be filed against [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are specific to company-coq features. It would help if you search the existing issues before reporting a bug. This can be difficult, so consider it extra credit. We don't mind duplicate bug reports. @@ -40,7 +40,7 @@ Here are a few tags Coq developers may add to your PR and what they mean. In gen Currently the process for contributing to the documentation is the same as for changing anything else in Coq, so please submit a pull request as described above. -Bugzilla includes a component to mark bugs related to documentation. You can view a list of documentation-related bugs using a [Bugzilla search](https://coq.inria.fr/bugs/buglist.cgi?component=Doc&list_id=455006&product=Coq&resolution=---). Many of these bugs can be fixed by contributing writing, without knowledge of Coq's OCaml source code. +Our issue tracker includes a flag to mark bugs related to documentation. You can view a list of documentation-related bugs using a [GitHub issue search](https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22). Many of these bugs can be fixed by contributing writing, without knowledge of Coq's OCaml source code. The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) are at [`doc/refman`](/doc/refman). These are written in LaTeX and compiled to HTML with [HeVeA](http://hevea.inria.fr/). @@ -1,5 +1,5 @@ - INSTALLATION PROCEDURES FOR THE COQ V8.6 SYSTEM + INSTALLATION PROCEDURES FOR THE COQ V8.7 SYSTEM ----------------------------------------------- @@ -27,19 +27,16 @@ WHAT DO YOU NEED ? port install coq - To compile Coq V8.6 yourself, you need: + To compile Coq V8.7 yourself, you need: - - OCaml version 4.02.1 or later - (available at http://caml.inria.fr/) + - OCaml version 4.02.3 or later + (available at https://ocaml.org/) - OCaml version 4.02.0 is not supported because of a severe performance - issue increasing compilation time. + - Findlib (version >= 1.4.1) + (available at http://projects.camlcity.org/projects/findlib.html) - - Findlib (included in OCaml binary distribution under windows, - probably available in your distribution and for sure at - http://projects.camlcity.org/projects/findlib.html) - - - Camlp5 (version >= 6.02) + - Camlp5 (version >= 6.14) + (available at https://camlp5.github.io/) - GNU Make version 3.81 or later @@ -48,6 +45,12 @@ WHAT DO YOU NEED ? - for Coqide, the Lablgtk development files, and the GTK libraries incuding gtksourceview, see INSTALL.ide for more details + Opam (https://opam.ocaml.org/) is recommended to install ocaml and + the corresponding packages. + + $ opam install ocamlfind camlp5 lablgtk-extras + + should get you a reasonable OCaml environment to compile Coq. QUICK INSTALLATION PROCEDURE. ============================= @@ -125,6 +128,26 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). Use <command> to open an URL in a browser. %s must appear in <command>, and will be replaced by the URL. +-flambda-opts <flags> + This experimental option will pass specific user flags to the + OCaml optimizing compiler. In most cases, this option is used + to tweak the flambda backend; we recommend using + + -flambda-opts `-O3 -unbox-closures` + + but of course you are free to try with a different combination + of flags. You can read more at + https://caml.inria.fr/pub/docs/manual-ocaml/flambda.html + + There is a known problem with certain OCaml versions and + `native_compute`, that will make compilation to require + a large amount of RAM (>= 10GiB) in some particular files. + + We recommend disabling native compilation (`-native-compiler no`) + with flambda unless you use a modern (>= 4.06.0) OCaml. + + c.f. https://caml.inria.fr/mantis/view.php?id=7630 + 5- Still in the root directory, do make diff --git a/ISSUE_TEMPLATE.md b/ISSUE_TEMPLATE.md new file mode 100644 index 0000000000..c9cb516cd3 --- /dev/null +++ b/ISSUE_TEMPLATE.md @@ -0,0 +1,18 @@ +<!-- Thank you for your contribution. + Please complete the following information when reporting a bug. --> + +#### Version + +<!-- You can get this information by running `coqtop -v`. --> + + +#### Operating system + + +#### Description of the problem + +<!-- It is helpful to provide enough information so that we can reproduce the bug. + In particular, please include a code example which produces it. + If the example is small, you can include it here between ``` ```. + Otherwise, please provide a link to a repository, a gist (https://gist.github.com) + or drag-and-drop a `.zip` archive. --> diff --git a/Makefile.build b/Makefile.build index 26a40c6cc1..991942bf0a 100644 --- a/Makefile.build +++ b/Makefile.build @@ -195,8 +195,8 @@ MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) -BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) -OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) +BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) +OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$<),, -I ide -I ide/utils) # On MacOS, the binaries are signed, except our private ones @@ -428,11 +428,22 @@ tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # may still be missing or not taken in account yet by make when coqdep_boot # is being built. -COQDEPBOOTSRC := lib/minisys.cmo \ +# Remember to update the dependencies below when you add files! + +COQDEPBOOTSRC := \ + lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo lib/minisys.cmo \ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo -tools/coqdep_lexer.cmo : tools/coqdep_lexer.cmi -tools/coqdep_lexer.cmx : tools/coqdep_lexer.cmi +lib/segmenttree.cmo : lib/segmenttree.cmi +lib/segmenttree.cmx : lib/segmenttree.cmi +lib/unicodetable.cmo : lib/segmenttree.cmo +lib/unicodetable.cmx : lib/segmenttree.cmx +lib/unicode.cmo : lib/unicodetable.cmo lib/unicode.cmi +lib/unicode.cmx : lib/unicodetable.cmx lib/unicode.cmi +lib/minisys.cmo : lib/unicode.cmo +lib/minisys.cmx : lib/unicode.cmx +tools/coqdep_lexer.cmo : lib/unicode.cmi tools/coqdep_lexer.cmi +tools/coqdep_lexer.cmx : lib/unicode.cmx tools/coqdep_lexer.cmi tools/coqdep_common.cmo : lib/minisys.cmo tools/coqdep_lexer.cmi tools/coqdep_common.cmi tools/coqdep_common.cmx : lib/minisys.cmx tools/coqdep_lexer.cmx tools/coqdep_common.cmi tools/coqdep_boot.cmo : tools/coqdep_common.cmi @@ -448,7 +459,8 @@ $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) # The full coqdep (unused by this build, but distributed by make install) -COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo lib/minisys.cmo \ +COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo \ + lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo lib/minisys.cmo \ lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \ tools/coqdep.cmo diff --git a/Makefile.ci b/Makefile.ci index b5a26d96e8..54ebf211f9 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -11,7 +11,7 @@ CI_TARGETS=ci-all \ ci-formal-topology \ ci-geocoq \ ci-hott \ - ci-iris-coq \ + ci-iris-lambda-rust \ ci-math-classes \ ci-math-comp \ ci-metacoq \ diff --git a/Makefile.ide b/Makefile.ide index 542d8c252d..7593a9f2ea 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -153,10 +153,12 @@ install-ide-bin: install-ide-toploop: ifeq ($(BEST),opt) + $(MKDIR) $(FULLCOQLIB)/toploop/ $(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ endif install-ide-toploop-byte: ifneq ($(BEST),opt) + $(MKDIR) $(FULLCOQLIB)/toploop/ $(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/ endif diff --git a/Makefile.install b/Makefile.install index 4800f8f3fa..55229deb96 100644 --- a/Makefile.install +++ b/Makefile.install @@ -77,6 +77,7 @@ endif install-byte: install-coqide-byte $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQTOPBYTE) $(FULLBINDIR) + $(MKDIR) $(FULLCOQLIB)/toploop $(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/ $(INSTALLSH) $(FULLCOQLIB) $(LINKCMO) $(PLUGINS) ifndef CUSTOM @@ -1,6 +1,6 @@ # Coq -[](https://travis-ci.org/coq/coq/builds) [](https://gitter.im/coq/coq) +[](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) [](https://gitter.im/coq/coq) Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an @@ -42,7 +42,7 @@ For any questions/suggestions about the Coq Club, please write to `coq-club-request@inria.fr`. ## Bugs report -Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria.fr/bugs). +Please report any bug in [our issue tracker](https://github.com/coq/coq/issues). To be effective, bug reports should mention the OCaml version used to compile and run Coq, the Coq version (`coqtop -v`), the configuration diff --git a/config/coq_config.mli b/config/coq_config.mli index b0f39e9d28..6a834a3049 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -36,6 +36,7 @@ val camlp4compat : string (* compatibility argument to camlp4/5 *) val coqideincl : string (* arguments for building coqide (e.g. lablgtk) *) val cflags : string (* arguments passed to gcc *) +val caml_flags : string (* arguments passed to ocamlc (ie. CAMLFLAGS) *) val best : string (* byte/opt *) val arch : string (* architecture *) @@ -48,6 +49,7 @@ val vmbyteflags : string list (* -custom/-dllib -lcoqrun *) val version : string (* version number of Coq *) val caml_version : string (* OCaml version used to compile Coq *) +val caml_version_nums : int list (* OCaml version used to compile Coq by components *) val date : string (* release date *) val compile_date : string (* compile date *) val vo_magic_number : int @@ -59,7 +61,6 @@ val plugins_dirs : string list val all_src_dirs : string list val exec_extension : string (* "" under Unix, ".exe" under MS-windows *) -val with_geoproof : bool ref (* to (de)activate functions specific to Geoproof with Coqide *) val browser : string (** default web browser to use, may be overridden by environment @@ -71,6 +72,8 @@ val gtk_platform : [`QUARTZ | `WIN32 | `X11] val has_natdynlink : bool val natdynlinkflag : string (* special cases of natdynlink (e.g. MacOS 10.5) *) +val flambda_flags : string list + val wwwcoq : string val wwwrefman : string val wwwbugtracker : string diff --git a/configure.ml b/configure.ml index b5e4567792..0952b15f58 100644 --- a/configure.ml +++ b/configure.ml @@ -206,7 +206,7 @@ let get_date () = let year = 1900+now.Unix.tm_year in let month = months.(now.Unix.tm_mon) in sprintf "%s %d" month year, - sprintf "%s %d %d %d:%d:%d" (String.sub month 0 3) now.Unix.tm_mday year + sprintf "%s %d %d %d:%02d:%02d" (String.sub month 0 3) now.Unix.tm_mday year now.Unix.tm_hour now.Unix.tm_min now.Unix.tm_sec let short_date, full_date = get_date () @@ -258,15 +258,11 @@ module Prefs = struct let macintegration = ref true let browser = ref (None : string option) let withdoc = ref false - let geoproof = ref false let byteonly = ref false + let flambda_flags = ref [] let debug = ref true let profile = ref false let annotate = ref false - (* Note, disabling this should be OK, but be careful with the - sharing invariants. - *) - let safe_string = ref true let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false @@ -309,6 +305,9 @@ let args_options = Arg.align [ "-camlp5dir", Arg.String (fun s -> Prefs.camlp5dir:=Some s), "<dir> Specifies where is the Camlp5 library and tells to use it"; + "-flambda-opts", + Arg.String (fun s -> Prefs.flambda_flags := string_split ' ' s), + "<flags> Specifies additional flags to be passed to the flambda optimizing compiler"; "-arch", arg_string_option Prefs.arch, "<arch> Specifies the architecture"; "-natdynlink", arg_bool Prefs.natdynlink, @@ -321,8 +320,6 @@ let args_options = Arg.align [ "<command> Use <command> to open URL %s"; "-with-doc", arg_bool Prefs.withdoc, "(yes|no) Compile the documentation or not"; - "-with-geoproof", arg_bool Prefs.geoproof, - "(yes|no) Use Geoproof binding or not"; "-byte-only", Arg.Set Prefs.byteonly, " Compiles only bytecode version of Coq"; "-nodebug", Arg.Clear Prefs.debug, @@ -376,8 +373,9 @@ let coq_annotate_flag = then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot" else "" -let coq_safe_string = - if !Prefs.safe_string then "-safe-string" else "" +(* This variable can be overriden only for debug purposes, use with + care. *) +let coq_safe_string = "-safe-string" let cflags = "-Wall -Wno-unused -g -O2" @@ -512,19 +510,22 @@ let camltag = match caml_version_list with 50: unexpected documentation comment: too common and annoying to avoid 56: unreachable match case: the [_ -> .] syntax doesn't exist in 4.02.3 *) -let coq_warn_flags = - let warnings = "-w +a-4-9-27-41-42-44-45-48-50" in - let errors = +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50" +let coq_warn_error = if !Prefs.warn_error then "-warn-error +a" ^ (if caml_version_nums > [4;2;3] then "-56" else "") else "" - in - warnings ^ " " ^ errors +(* Flags used to compile Coq and plugins (via coq_makefile) *) +let caml_flags = + Printf.sprintf "-thread -rectypes %s %s %s" coq_warnings coq_annotate_flag coq_safe_string +(* Flags used to compile Coq but _not_ plugins (via coq_makefile) *) +let coq_caml_flags = + coq_warn_error (** * CamlpX configuration *) @@ -949,7 +950,6 @@ let config_runtime () = let vmbyteflags = config_runtime () - (** * Summary of the configuration *) let print_summary () = @@ -964,6 +964,7 @@ let print_summary () = pr " OCaml version : %s\n" caml_version; pr " OCaml binaries in : %s\n" camlbin; pr " OCaml library in : %s\n" camllib; + pr " OCaml flambda flags : %s\n" (String.concat " " !Prefs.flambda_flags); pr " %s version : %s\n" capitalized_camlpX camlpX_version; pr " %s binaries in : %s\n" capitalized_camlpX camlpXbindir; pr " %s library in : %s\n" capitalized_camlpX camlpXlibdir; @@ -1013,7 +1014,6 @@ let write_dbg_wrapper f = let _ = write_dbg_wrapper "dev/ocamldebug-coq" - (** * Build the config/coq_config.ml file *) let write_configml f = @@ -1024,8 +1024,9 @@ let write_configml f = let pr_b = pr "let %s = %B\n" in let pr_i = pr "let %s = %d\n" in let pr_p s o = pr "let %s = %S\n" s - (match o with Relative s -> s | Absolute s -> s) - in + (match o with Relative s -> s | Absolute s -> s) in + let pr_l n l = pr "let %s = [%s]\n" n (String.concat ";" (List.map (fun s -> "\"" ^ s ^ "\"") l)) in + let pr_li n l = pr "let %s = [%s]\n" n (String.concat ";" (List.map string_of_int l)) in pr "(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)\n"; pr "(* Exact command that generated this file: *)\n"; pr "(* %s *)\n\n" (String.concat " " (Array.to_list Sys.argv)); @@ -1050,10 +1051,12 @@ let write_configml f = pr_s "camlp4lib" camlpXlibdir; pr_s "camlp4compat" camlp4compat; pr_s "cflags" cflags; + pr_s "caml_flags" caml_flags; pr_s "best" best_compiler; pr_s "osdeplibs" osdeplibs; pr_s "version" coq_version; pr_s "caml_version" caml_version; + pr_li "caml_version_nums" caml_version_nums; pr_s "date" short_date; pr_s "compile_date" full_date; pr_s "arch" arch; @@ -1064,9 +1067,9 @@ let write_configml f = pr "let gtk_platform = `%s\n" !idearchdef; pr_b "has_natdynlink" hasnatdynlink; pr_s "natdynlinkflag" natdynlinkflag; + pr_l "flambda_flags" !Prefs.flambda_flags; pr_i "vo_magic_number" vo_magic; pr_i "state_magic_number" state_magic; - pr "let with_geoproof = ref %B\n" !Prefs.geoproof; pr_s "browser" browser; pr_s "wwwcoq" !Prefs.coqwebsite; pr_s "wwwbugtracker" (!Prefs.coqwebsite ^ "bugs/"); @@ -1156,9 +1159,11 @@ let write_makefile f = pr "CAMLHLIB=%S\n\n" camllib; pr "# Caml link command and Caml make top command\n"; pr "# Caml flags\n"; - pr "CAMLFLAGS=-rectypes %s %s %s\n" coq_warn_flags coq_annotate_flag coq_safe_string; + pr "CAMLFLAGS=%s %s\n" caml_flags coq_caml_flags; pr "# User compilation flag\n"; pr "USERFLAGS=\n\n"; + (* XXX make this configurable *) + pr "FLAMBDA_FLAGS=%s\n" (String.concat " " !Prefs.flambda_flags); pr "# Flags for GCC\n"; pr "CFLAGS=%s\n\n" cflags; pr "# Compilation debug flags\n"; diff --git a/dev/Bugzilla_Coq_autolink.user.js b/dev/Bugzilla_Coq_autolink.user.js new file mode 100644 index 0000000000..ed056021b3 --- /dev/null +++ b/dev/Bugzilla_Coq_autolink.user.js @@ -0,0 +1,25 @@ +// ==UserScript== +// @name Bugzilla Coq autolink +// @namespace CoqScript +// @include https://coq.inria.fr/bugs/* +// @description Makes #XXXX into links to Github Coq PRs +// @version 1 +// @grant none +// ==/UserScript== + +var regex = /#(\d+)/g; +var substr = '<a href="https://github.com/coq/coq/pull/$1">$&</a>'; + +function doNode(node) +{ + node.innerHTML = node.innerHTML.replace(regex,substr); +} + +var comments = document.getElementsByClassName("bz_comment_table")[0]; +var pars = comments.getElementsByClassName("bz_comment_text"); + +for(var j=0; j<pars.length; j++) +{ + doNode(pars[j]); +} + diff --git a/dev/Coq_Bugzilla_autolink.user.js b/dev/Coq_Bugzilla_autolink.user.js index 371c5adc00..5ff618a839 100644 --- a/dev/Coq_Bugzilla_autolink.user.js +++ b/dev/Coq_Bugzilla_autolink.user.js @@ -10,25 +10,59 @@ var regex = /BZ#(\d+)/g; var substr = '<a href="https://coq.inria.fr/bugs/show_bug.cgi?id=$1">$&</a>'; -function doNode(node) +function doTitle(node) { node.innerHTML = node.innerHTML.replace(regex,substr); } +function filter(node) +{ + if (node.nodeName == '#text') + { + return NodeFilter.FILTER_ACCEPT; + } + else if(node.nodeName == 'A') + { + return NodeFilter.FILTER_REJECT; + } + return NodeFilter.FILTER_SKIP; +} var comments = document.getElementsByClassName("comment-body"); -for(var i=0; i<comments.length; i++) +function doNode(parent) { - var pars = comments[i].getElementsByTagName("p"); - for(var j=0; j<pars.length; j++) + var nodes = document.createTreeWalker(parent,NodeFilter.SHOW_ALL,{ acceptNode : filter },false); + var node; + while(node=nodes.nextNode()) { - doNode(pars[j]); + var content = node.textContent; + var matches = regex.exec(content); + + if(matches && matches.length > 1) + { + var range = document.createRange(); + var start = content.search(regex); + var end = start + matches[0].length; + range.setStart(node, start); + range.setEnd(node, end); + var linkNode = document.createElement("a"); + linkNode.href = "https://coq.inria.fr/bugs/show_bug.cgi?id=" + matches[1]; + range.surroundContents(linkNode); + + //handle multiple matches in one text node + doNode(linkNode.parentNode); + } } } +for(var i=0; i<comments.length; i++) +{ + doNode(comments[i]); +} + // usually 1 or 0 titles... var titles = document.getElementsByClassName("js-issue-title"); for(var i=0; i<titles.length; i++) { - doNode(titles[i]); + doTitle(titles[i]); } diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8e7265969b..9be882bb3c 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -43,14 +43,14 @@ : ${Iris_CI_BRANCH:=master} : ${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq.git} +: ${lambdaRust_CI_BRANCH:=master} +: ${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/FP/LambdaRust-coq.git} + ######################################################################## # HoTT ######################################################################## -# Temporary overlay -: ${HoTT_CI_BRANCH:=ocaml.4.02.3} -: ${HoTT_CI_GITURL:=https://github.com/ejgallego/HoTT.git} -# : ${HoTT_CI_BRANCH:=master} -# : ${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT.git} +: ${HoTT_CI_BRANCH:=master} +: ${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT.git} ######################################################################## # GeoCoq @@ -73,8 +73,8 @@ ######################################################################## # CompCert ######################################################################## -: ${CompCert_CI_BRANCH:=less_init_plugins} -: ${CompCert_CI_GITURL:=https://github.com/letouzey/CompCert.git} +: ${CompCert_CI_BRANCH:=master} +: ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} ######################################################################## # VST @@ -127,5 +127,5 @@ ######################################################################## # Bignums ######################################################################## -: ${bignums_CI_BRANCH:=fix-thunk-printer} -: ${bignums_CI_GITURL:=https://github.com/ppedrot/bignums.git} +: ${bignums_CI_BRANCH:=master} +: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index eadeb7c38c..8e6448e764 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -8,9 +8,5 @@ GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} ( cd ${GeoCoq_CI_DIR} && \ - ./configure.sh && \ - sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ - sed -i.bak '/Elements\/Book_1\.v/d' Make && \ - sed -i.bak '/Elements\/Book_3\.v/d' Make && \ - coq_makefile -f Make -o Makefile && \ + ./configure-ci.sh && \ make ) diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh deleted file mode 100755 index 2d127ddc1b..0000000000 --- a/dev/ci/ci-iris-coq.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh - -stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp - -Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq - -install_ssreflect - -# Setup Iris first, as it is needed to compute the dependencies - -git_checkout ${Iris_CI_BRANCH} ${Iris_CI_GITURL} ${Iris_CI_DIR} -read -a IRIS_DEP < ${Iris_CI_DIR}/opam.pins - -# Setup stdpp -stdpp_CI_GITURL=${IRIS_DEP[1]}.git -stdpp_CI_COMMIT=${IRIS_DEP[2]} - -git_checkout ${stdpp_CI_BRANCH} ${stdpp_CI_GITURL} ${stdpp_CI_DIR} ${stdpp_CI_COMMIT} - -( cd ${stdpp_CI_DIR} && make && make install ) - -# Build iris now -( cd ${Iris_CI_DIR} && make ) diff --git a/dev/ci/ci-iris-lambda-rust.sh b/dev/ci/ci-iris-lambda-rust.sh new file mode 100755 index 0000000000..cf24d202d9 --- /dev/null +++ b/dev/ci/ci-iris-lambda-rust.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp +Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq +lambdaRust_CI_DIR=${CI_BUILD_DIR}/lambdaRust + +install_ssreflect + +# Add or update the opam repo we need for dependency resolution +opam repo add iris-dev https://gitlab.mpi-sws.org/FP/opam-dev.git -p 0 || opam update iris-dev + +# Setup lambdaRust first +git_checkout ${lambdaRust_CI_BRANCH} ${lambdaRust_CI_GITURL} ${lambdaRust_CI_DIR} + +# Extract required version of Iris +Iris_VERSION=$(cat ${lambdaRust_CI_DIR}/opam | fgrep coq-iris | egrep 'dev\.([0-9.-]+)' -o) +Iris_URL=$(opam show coq-iris.$Iris_VERSION -f upstream-url) +read -a Iris_URL_PARTS <<< $(echo $Iris_URL | tr '#' ' ') + +# Setup Iris +git_checkout ${Iris_CI_BRANCH} ${Iris_URL_PARTS[0]} ${Iris_CI_DIR} ${Iris_URL_PARTS[1]} + +# Extract required version of std++ +stdpp_VERSION=$(cat ${Iris_CI_DIR}/opam | fgrep coq-stdpp | egrep 'dev\.([0-9.-]+)' -o) +stdpp_URL=$(opam show coq-stdpp.$stdpp_VERSION -f upstream-url) +read -a stdpp_URL_PARTS <<< $(echo $stdpp_URL | tr '#' ' ') + +# Setup std++ +git_checkout ${stdpp_CI_BRANCH} ${stdpp_URL_PARTS[0]} ${stdpp_CI_DIR} ${stdpp_URL_PARTS[1]} + +# Build std++ +( cd ${stdpp_CI_DIR} && make && make install ) + +# Build iris +( cd ${Iris_CI_DIR} && make && make install ) + +# Build lambdaRust +( cd ${lambdaRust_CI_DIR} && make && make install ) diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 5ed74917aa..6ade6576f7 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -32,6 +32,12 @@ We renamed the following datatypes: - `Pp.std_ppcmds` -> `Pp.t` +Some tactics and related functions now support static configurability, e.g.: + +- injectable, dEq, etc. takes an argument ~keep_proofs which, + - if None, tells to behave as told with the flag Keep Proof Equalities + - if Some b, tells to keep proof equalities iff b is true + ## Changes between Coq 8.6 and Coq 8.7 ### Ocaml @@ -40,6 +46,9 @@ Coq is compiled with `-safe-string` enabled and requires plugins to do the same. This means that code using `String` in an imperative way will fail to compile now. They should switch to `Bytes.t` +Configure supports passing flambda options, use `-flambda-opts OPTS` +with a flambda-enabled Ocaml to tweak the compilation to your taste. + ### ML API - Added two functions for declaring hooks to be executed in reduction @@ -641,6 +650,12 @@ The main search functions now take a function iterating over the results. This allows for clients to use streaming or more economic printing. +### XML Protocol + +- In several places, flat text wrapped in `<string>` tags now appears as structured text inside `<richpp>` tags. + +- The "errormsg" feedback has been replaced by a "message" feedback which contains `<feedback\_content>` tag, with a message_level attribute of "error". + ## Changes between Coq 8.4 and Coq 8.5 ### Refactoring : more mli interfaces and simpler grammar.cma diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index cf7d205d8b..18f6288f6f 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -1,4 +1,4 @@ -#Coq XML Protocol for Coq 8.6# +# Coq XML Protocol This document is based on documentation originally written by CJ Bell for his [vscoq](https://github.com/siegebell/vscoq/) project. @@ -12,11 +12,7 @@ A somewhat out-of-date description of the async state machine is [documented here](https://github.com/ejgallego/jscoq/blob/master/etc/notes/coq-notes.md). OCaml types for the protocol can be found in the [`ide/interface.mli` file](/ide/interface.mli). -# CHANGES -## Changes from 8.5: - * In several places, flat text wrapped in <string> tags now appears as structured text inside <richpp> tags - * The "errormsg" feedback has been replaced by a "message" feedback which contains - <feedback\_content> tag, with a message_level attribute of "error" +Changes to the XML protocol are documented as part of [`dev/doc/changes.txt`](/dev/doc/changes.txt). * [Commands](#commands) - [About](#command-about) diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index 1c415eca69..5d151381ff 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -52,20 +52,7 @@ <h2 style="text-align:center; font-size: 150%">The Coq Development Team</h2> <br /><br /><br /> -<div style="text-align: left; font-size: 80%; text-indent: 0pt"> -<ul style="list-style: none; margin-left: 0pt"> - <li>V7.x © INRIA 1999-2004</li> - <li>V8.0 © INRIA 2004-2008</li> - <li>V8.1 © INRIA 2006-2011</li> - <li>V8.2 © INRIA 2008-2011</li> - <li>V8.3 © INRIA 2010-2011</li> - <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015-2016</li> - <li>V8.6 © INRIA 2016</li> -</ul> - -<p style="text-indent:0pt">This research was partly supported by IST - working group ``Types''</p> +<p style="text-indent:0pt">Copyright © INRIA 1999-2017</p> <p style="text-indent:0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p> diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 25fb56320b..6053131045 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -30,20 +30,7 @@ <br /><br /><br /> -<div style="text-align: left; font-size: 80%; text-indent: 0pt"> -<ul style="list-style: none; margin-left: 0pt"> - <li>V7.x © INRIA 1999-2004</li> - <li>V8.0 © INRIA 2004-2008</li> - <li>V8.1 © INRIA 2006-2011</li> - <li>V8.2 © INRIA 2008-2011</li> - <li>V8.3 © INRIA 2010-2011</li> - <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015-2016</li> - <li>V8.6 © INRIA 2016</li> -</ul> - -<p style="text-indent:0pt">This research was partly supported by IST - working group ``Types''</p> +<p style="text-indent:0pt">Copyright © INRIA 1999-2017</p> <p style="text-indent: 0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p> diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex index 213fb03137..541d39501b 100644 --- a/doc/faq/FAQ.tex +++ b/doc/faq/FAQ.tex @@ -2413,15 +2413,14 @@ You can use {\tt coq\_tex}. \Question{How can I cite the {\Coq} reference manual?} -You can use this bibtex entry: +You can use this bibtex entry (to adapt to the appropriate version): \begin{verbatim} -@Manual{Coq:manual, - title = {The Coq proof assistant reference manual}, - author = {\mbox{The Coq development team}}, - organization = {LogiCal Project}, - note = {Version 8.2}, - year = {2009}, - url = "http://coq.inria.fr" +@manual{Coq:manual, + author = {{Coq} {Development} {Team}, The}, + title = {The {Coq} Proof Assistant Reference Manual, version 8.7}, + month = Oct, + year = {2017}, + url = {http://coq.inria.fr} } \end{verbatim} diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 9790111f14..8b1fc7c8f3 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -107,6 +107,15 @@ The following command-line options are recognized by the commands {\tt recursively available from {\Coq} using absolute names (extending the {\dirpath} prefix) (see Section~\ref{LongNames}). + Note that only those subdirectories and files which obey the lexical + conventions of what is an {\ident} (see Section~\ref{lexical}) + are taken into account. Conversely, the underlying file systems or + operating systems may be more restrictive than {\Coq}. While Linux's + ext4 file system supports any {\Coq} recursive layout + (within the limit of 255 bytes per file name), the default on NTFS + (Windows) or HFS+ (MacOS X) file systems is on the contrary to + disallow two files differing only in the case in the same directory. + \SeeAlso Section~\ref{Libraries}. \item[{\tt -R} {\em directory} {\dirpath}]\ % @@ -205,11 +214,6 @@ The following command-line options are recognized by the commands {\tt % % Switch on the debug flag. -\item[{\tt -with-geoproof} (yes|no)]\ % - - Enable or not special functions for Geoproof within {\CoqIDE} (default - is yes). - \item[{\tt -color} (on|off|auto)]\ % Enable or not the coloring of output of {\tt coqtop}. Default is auto, diff --git a/doc/refman/RefMan-ide.tex b/doc/refman/RefMan-ide.tex index 75f3d18ded..436099e74d 100644 --- a/doc/refman/RefMan-ide.tex +++ b/doc/refman/RefMan-ide.tex @@ -13,8 +13,7 @@ line. Without argument, the main screen is displayed with an ``unnamed buffer'', and with a file name as argument, another buffer displaying the contents of that file. Additionally, \verb|coqide| accepts the same options as \verb|coqtop|, given in Chapter~\ref{Addoc-coqc}, the ones having -obviously no meaning for \CoqIDE{} being ignored. Additionally, \verb|coqide| accepts the option \verb|-enable-geoproof| to enable the support for \emph{GeoProof} \footnote{\emph{GeoProof} is dynamic geometry software which can be used in conjunction with \CoqIDE{} to interactively build a Coq statement corresponding to a geometric figure. More information about \emph{GeoProof} can be found here: \url{http://home.gna.org/geoproof/} }. - +obviously no meaning for \CoqIDE{} being ignored. \begin{figure}[t] \begin{center} diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 339c6a248e..eabfb7b398 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -478,8 +478,6 @@ type clear_dependency_error = exception ClearDependencyError of Id.t * clear_dependency_error -let cleared = Store.field () - exception Depends of Id.t let rec check_and_clear_in_constr env evdref err ids global c = @@ -552,13 +550,6 @@ let rec check_and_clear_in_constr env evdref err ids global c = let evd = !evdref in let (evd,_) = restrict_evar evd evk filter None in evdref := evd; - (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) - let evi = Evd.find !evdref evk in - let extra = evi.evar_extra in - let extra' = Store.set extra cleared true in - let evi' = { evi with evar_extra = extra' } in - evdref := Evd.add !evdref evk evi' ; - (* spiwack: /hacking session *) Evd.existential_value !evdref ev | _ -> map_constr (check_and_clear_in_constr env evdref err ids global) c @@ -665,11 +656,9 @@ let rec advance sigma evk = match evi.evar_body with | Evar_empty -> Some evk | Evar_defined v -> - if Option.default false (Store.get evi.evar_extra cleared) then - let (evk,_) = Term.destEvar v in - advance sigma evk - else - None + match is_restricted_evar evi with + | Some evk -> advance sigma evk + | None -> None (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 14173e774d..ee0fae3d46 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -204,10 +204,6 @@ type clear_dependency_error = exception ClearDependencyError of Id.t * clear_dependency_error -(* spiwack: marks an evar that has been "defined" by clear. - used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) -val cleared : bool Store.field - val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types -> Id.Set.t -> named_context_val * types diff --git a/engine/evd.ml b/engine/evd.ml index f1b5419dec..324f883e8e 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -630,7 +630,9 @@ let evar_source evk d = (find d evk).evar_source let evar_ident evk evd = EvNames.ident evk evd.evar_names let evar_key id evd = EvNames.key id evd.evar_names -let define_aux def undef evk body = +let restricted = Store.field () + +let define_aux ?dorestrict def undef evk body = let oldinfo = try EvMap.find evk undef with Not_found -> @@ -640,7 +642,10 @@ let define_aux def undef evk body = anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar.") in let () = assert (oldinfo.evar_body == Evar_empty) in - let newinfo = { oldinfo with evar_body = Evar_defined body } in + let evar_extra = match dorestrict with + | Some evk' -> Store.set oldinfo.evar_extra restricted evk' + | None -> oldinfo.evar_extra in + let newinfo = { oldinfo with evar_body = Evar_defined body; evar_extra } in EvMap.add evk newinfo def, EvMap.remove evk undef (* define the existential of section path sp as the constr body *) @@ -653,6 +658,9 @@ let define evk body evd = let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } +let is_restricted_evar evi = + Store.get evi.evar_extra restricted + let restrict evk filter ?candidates ?src evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in @@ -667,7 +675,7 @@ let restrict evk filter ?candidates ?src evd = let ctxt = Filter.filter_list filter (evar_context evar_info) in let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in - let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in + let (defn_evars, undf_evars) = define_aux ~dorestrict:evk' evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; defn_evars; last_mods; evar_names }, evk' diff --git a/engine/evd.mli b/engine/evd.mli index abcabe8157..96e4b6acce 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -31,7 +31,7 @@ open Environ (** {6 Evars} *) type evar = existential_key -(** Existential variables. TODO: Should be made opaque one day. *) +(** Existential variables. *) val string_of_existential : evar -> string @@ -244,6 +244,9 @@ val restrict : evar -> Filter.t -> ?candidates:constr list -> (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) +val is_restricted_evar : evar_info -> evar option +(** Tell if an evar comes from restriction of another evar, and if yes, which *) + val downcast : evar -> types -> evar_map -> evar_map (** Change the type of an undefined evar to a new type assumed to be a subtype of its current type; subtyping must be ensured by caller *) diff --git a/engine/namegen.ml b/engine/namegen.ml index 1dd29e6eae..2e62b89011 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -43,6 +43,8 @@ let default_non_dependent_ident = Id.of_string default_non_dependent_string let default_dependent_ident = Id.of_string "x" +let default_generated_non_letter_string = "x" + (**********************************************************************) (* Globality of identifiers *) @@ -107,7 +109,17 @@ let head_name sigma c = (* Find the head constant of a constr if any *) hdrec c let lowercase_first_char id = (* First character of a constr *) - Unicode.lowercase_first_char (Id.to_string id) + let s = Id.to_string id in + match Unicode.split_at_first_letter s with + | None -> + (* General case: nat -> n *) + Unicode.lowercase_first_char s + | Some (s,s') -> + if String.length s' = 0 then + (* No letter, e.g. __, or __'_, etc. *) + default_generated_non_letter_string + else + s ^ Unicode.lowercase_first_char s' let sort_hdchar = function | Prop(_) -> "P" diff --git a/engine/proofview.ml b/engine/proofview.ml index eef2b83f44..598358c472 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -153,8 +153,12 @@ let focus i j sp = ( { sp with comb = new_comb } , context ) (** [undefined defs l] is the list of goals in [l] which are still - unsolved (after advancing cleared goals). *) -let undefined defs l = CList.map_filter (Evarutil.advance defs) l + unsolved (after advancing cleared goals). Note that order matters. *) +let undefined defs l = + List.fold_right (fun evk l -> + match Evarutil.advance defs evk with + | Some evk -> List.add_set Evar.equal evk l + | None -> l) l [] (** Unfocuses a proofview with respect to a context. *) let unfocus c sp = diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 0dd08293c8..ded28a998e 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -422,7 +422,7 @@ object(self) let rec eat_feedback n = if n = 0 then true else let msg = Queue.pop feedbacks in - let id = msg.id in + let id = msg.span_id in let sentence = let finder _ state_id s = match state_id, id with diff --git a/ide/coqide.ml b/ide/coqide.ml index 2c8ce0049e..842d068592 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1325,25 +1325,6 @@ let main files = Minilib.log "End of Coqide.main" -(** {2 Geoproof } *) - -(** This function check every tenth of second if GeoProof has send - something on his private clipboard *) - -let check_for_geoproof_input () = - let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in - let handler () = match cb_Dr#text with - |None -> true - |Some "Ack" -> true - |Some s -> - on_current_term (fun sn -> sn.buffer#insert (s ^ "\n")); - (* cb_Dr#clear does not work so i use : *) - cb_Dr#set_text "Ack"; - true - in - ignore (GMain.Timeout.add ~ms:100 ~callback:handler) - - (** {2 Argument parsing } *) (** By default, the coqtop we try to launch is exactly the current coqide diff --git a/ide/coqide.mli b/ide/coqide.mli index 39b4d9ae2f..42dab9ec55 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -40,5 +40,3 @@ val set_signal_handlers : unit -> unit (** Emergency saving of opened files as "foo.v.crashcoqide", and exit (if the integer isn't 127). *) val crash_save : int -> unit - -val check_for_geoproof_input : unit -> unit diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index 73a30b18f1..8d99cc3e66 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -142,7 +142,6 @@ let () = Coq.check_connection args; Coqide.sup_args := args; Coqide.main files; - if !Coq_config.with_geoproof then Coqide.check_for_geoproof_input (); os_specific_init (); try GMain.main (); diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index f00b1e1421..7cbab56d44 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -76,10 +76,16 @@ let ide_cmd_checks ~id (loc,ast) = (** Interpretation (cf. [Ide_intf.interp]) *) +let ide_doc = ref None +let get_doc () = Option.get !ide_doc +let set_doc doc = ide_doc := Some doc + let add ((s,eid),(sid,verbose)) = + let doc = get_doc () in let pa = Pcoq.Gram.parsable (Stream.of_string s) in - let loc_ast = Stm.parse_sentence sid pa in - let newid, rc = Stm.add ~ontop:sid verbose loc_ast in + let loc_ast = Stm.parse_sentence ~doc sid pa in + let doc, newid, rc = Stm.add ~doc ~ontop:sid verbose loc_ast in + set_doc doc; let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in ide_cmd_checks ~id:newid loc_ast; (* TODO: the "" parameter is a leftover of the times the protocol @@ -94,9 +100,10 @@ let add ((s,eid),(sid,verbose)) = newid, (rc, "") let edit_at id = - match Stm.edit_at id with - | `NewTip -> CSig.Inl () - | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip)) + let doc = get_doc () in + match Stm.edit_at ~doc id with + | doc, `NewTip -> set_doc doc; CSig.Inl () + | doc, `Focus { Stm.start; stop; tip} -> set_doc doc; CSig.Inr (start, (stop, tip)) (* TODO: the "" parameter is a leftover of the times the protocol * used to include stderr/stdout output. @@ -109,12 +116,14 @@ let edit_at id = *) let query (route, (s,id)) = let pa = Pcoq.Gram.parsable (Stream.of_string s) in - Stm.query ~at:id ~route pa + let doc = get_doc () in + Stm.query ~at:id ~doc ~route pa let annotate phrase = + let doc = get_doc () in let (loc, ast) = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in - Stm.parse_sentence (Stm.get_current_state ()) pa + Stm.parse_sentence ~doc (Stm.get_current_state ~doc) pa in (* XXX: Width should be a parameter of annotate... *) Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) @@ -196,7 +205,8 @@ let export_pre_goals pgs = } let goals () = - Stm.finish (); + let doc = get_doc () in + set_doc @@ Stm.finish ~doc; try let pfts = Proof_global.give_me_the_proof () in Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) @@ -204,7 +214,8 @@ let goals () = let evars () = try - Stm.finish (); + let doc = get_doc () in + set_doc @@ Stm.finish ~doc; let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in @@ -230,12 +241,17 @@ let hints () = (** Other API calls *) +let wait () = + let doc = get_doc () in + set_doc (Stm.wait ~doc) + let status force = (** We remove the initial part of the current [DirPath.t] (usually Top in an interactive session, cf "coqtop -top"), and display the other parts (opened sections and modules) *) - Stm.finish (); - if force then Stm.join (); + set_doc (Stm.finish ~doc:(get_doc ())); + if force then + set_doc (Stm.join ~doc:(get_doc ())); let path = let l = Names.DirPath.repr (Lib.cwd ()) in List.rev_map Names.Id.to_string l @@ -252,7 +268,7 @@ let status force = Interface.status_path = path; Interface.status_proofname = proof; Interface.status_allproofs = allproofs; - Interface.status_proofnum = Stm.current_proof_depth (); + Interface.status_proofnum = Stm.current_proof_depth ~doc:(get_doc ()); } let export_coq_object t = { @@ -356,22 +372,23 @@ let init = fun file -> if !initialized then anomaly (str "Already initialized.") else begin - let init_sid = Stm.get_current_state () in + let init_sid = Stm.get_current_state ~doc:(get_doc ()) in initialized := true; match file with | None -> init_sid | Some file -> let dir = Filename.dirname file in let open Loadpath in let open CUnix in - let initial_id, _ = + let doc, initial_id, _ = + let doc = get_doc () in if not (is_in_load_paths (physical_path_of_string dir)) then begin let pa = Pcoq.Gram.parsable (Stream.of_string (Printf.sprintf "Add LoadPath \"%s\". " dir)) in - let loc_ast = Stm.parse_sentence init_sid pa in - Stm.add false ~ontop:init_sid loc_ast - end else init_sid, `NewTip in + let loc_ast = Stm.parse_sentence ~doc init_sid pa in + Stm.add false ~doc ~ontop:init_sid loc_ast + end else doc, init_sid, `NewTip in if Filename.check_suffix file ".v" then Stm.set_compilation_hints file; - Stm.finish (); + set_doc (Stm.finish ~doc); initial_id end @@ -413,7 +430,7 @@ let eval_call c = Interface.quit = (fun () -> quit := true); Interface.init = interruptible init; Interface.about = interruptible about; - Interface.wait = interruptible Stm.wait; + Interface.wait = interruptible wait; Interface.interp = interruptible interp; Interface.handle_exn = handle_exn; Interface.stop_worker = Stm.stop_worker; @@ -449,7 +466,8 @@ let msg_format = ref (fun () -> Xmlprotocol.Richpp margin ) -let loop () = +let loop doc = + set_doc doc; init_signal_handler (); catch_break := false; let in_ch, out_ch = Spawned.get_channels () in diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index b452b0a13f..aaa24a2a95 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -939,7 +939,7 @@ let of_edit_or_state_id id = ["object","state"], of_stateid id let of_feedback msg = let content = of_feedback_content msg.contents in - let obj, id = of_edit_or_state_id msg.id in + let obj, id = of_edit_or_state_id msg.span_id in let route = string_of_int msg.route in Element ("feedback", obj @ ["route",route], [id;content]) @@ -947,8 +947,9 @@ let of_feedback msg_fmt = msg_format := msg_fmt; of_feedback let to_feedback xml = match xml with - | Element ("feedback", ["object","state";"route",route], [id;content]) -> { - id = to_stateid id; + | Element ("feedback", ["object","state";"route",route], [id;content]) -> { + doc_id = 0; + span_id = to_stateid id; route = int_of_string route; contents = to_feedback_content content } | x -> raise (Marshal_error("feedback",x)) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1cea307d76..a0a749bfb3 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2132,8 +2132,7 @@ let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = ~pattern_mode:true ~ltacvars env c in pattern_of_glob_constr c -let interp_notation_constr ?(impls=empty_internalization_env) nenv a = - let env = Global.env () in +let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = (* [vl] is intended to remember the scope of the free variables of [a] *) let vl = Id.Map.map (fun typ -> (ref true, ref None, typ)) nenv.ninterp_var_type in let c = internalize (Global.env()) {ids = extract_ids env; unb = false; @@ -2212,4 +2211,3 @@ let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_ let int_env,bl = intern_context global_level env impl_env params in let x = interp_glob_context_evars env evdref shift bl in int_env, x - diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 0a4eaf8382..75e99dd9b1 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -182,7 +182,7 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> Globnames.global_ (** 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. *) -val interp_notation_constr : ?impls:internalization_env -> +val interp_notation_constr : env -> ?impls:internalization_env -> notation_interp_env -> constr_expr -> (bool * subscopes * notation_var_internalization_type) Id.Map.t * notation_constr * reversibility_flag diff --git a/vernac/discharge.ml b/interp/discharge.ml index 0e4bbd2993..0e4bbd2993 100644 --- a/vernac/discharge.ml +++ b/interp/discharge.ml diff --git a/vernac/discharge.mli b/interp/discharge.mli index c8c7e3b8b8..c8c7e3b8b8 100644 --- a/vernac/discharge.mli +++ b/interp/discharge.mli diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 03e8ea43d1..ea412a7d6a 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -91,7 +91,7 @@ type locatable = | LocateTerm of reference or_by_notation | LocateLibrary of reference | LocateModule of reference - | LocateTactic of reference + | LocateOther of string * reference | LocateFile of string type showable = @@ -236,6 +236,7 @@ type scheme = type section_subset_expr = | SsEmpty + | SsType | SsSingl of lident | SsCompl of section_subset_expr | SsUnion of section_subset_expr * section_subset_expr @@ -501,7 +502,7 @@ type vernac_type = | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * Feedback.route_id - | VtBack of vernac_part_of_script * Stateid.t + | VtMeta | VtUnknown and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) and vernac_start = string * opacity_guarantee * Id.t list diff --git a/kernel/context.ml b/kernel/context.ml index 929324efec..d635c4515b 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -379,8 +379,9 @@ struct (** Return the number of {e local declarations} in a given named-context. *) let length = List.length -(** Return a declaration designated by a given de Bruijn index. - @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function +(** Return a declaration designated by a given identifier + @raise Not_found if the designated identifier is not present in the designated named-context. *) + let rec lookup id = function | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl | _ :: sign -> lookup id sign | [] -> raise Not_found diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index d2b41aae98..8568bf14b8 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -166,16 +166,10 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = let mb_mp1 = lookup_module mp1 env in let mtb_mp1 = module_type_of_module mb_mp1 in let cst = match old.mod_expr with - | Abstract -> - begin - try - let mtb_old = module_type_of_module old in - let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in - Univ.ContextSet.add_constraints chk_cst old.mod_constraints - with Failure _ -> - (* TODO: where can a Failure come from ??? *) - error_incorrect_with_constraint lab - end + | Abstract -> + let mtb_old = module_type_of_module old in + let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in + Univ.ContextSet.add_constraints chk_cst old.mod_constraints | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; old.mod_constraints diff --git a/kernel/names.ml b/kernel/names.ml index e524f4258d..cb27104d15 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -113,8 +113,7 @@ struct module Self_Hashcons = struct - type _t = t - type t = _t + type nonrec t = t type u = Id.t -> Id.t let hashcons hident = function | Name id -> Name (hident id) @@ -236,8 +235,7 @@ struct module Self_Hashcons = struct - type _t = t - type t = _t + type nonrec t = t type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t) let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) let eq ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = @@ -869,8 +867,7 @@ struct module Self_Hashcons = struct - type _t = t - type t = _t + type nonrec t = t type u = Constant.t -> Constant.t let hashcons hc (c,b) = (hc c,b) let eq ((c,b) as x) ((c',b') as y) = diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 665ddf7a65..e9c0e171ac 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -74,7 +74,7 @@ let call_compiler ?profile:(profile=false) ml_filename = let remove f = if Sys.file_exists f then Sys.remove f in remove link_filename; remove (f ^ ".cmi"); - let initial_args = + let initial_args = if Dynlink.is_native then ["opt"; "-shared"] else @@ -86,9 +86,20 @@ let call_compiler ?profile:(profile=false) ml_filename = else [] in + let flambda_args = + if Coq_config.caml_version_nums >= [4;3;0] then + (* We play safe for now, and use the native compiler + with -Oclassic, however it is likely that `native_compute` + users can benefit from tweaking here. + *) + ["-Oclassic"] + else + [] + in let args = initial_args @ - profile_args @ + profile_args @ + flambda_args @ ("-o"::link_filename ::"-rectypes" ::"-w"::"a" diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 5e20c1b514..400f9feeea 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -78,12 +78,12 @@ let subst_opaque sub = function let iter_direct_opaque f = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> - Direct (d,Future.chain ~pure:true cu (fun (c, u) -> f c; c, u)) + Direct (d,Future.chain cu (fun (c, u) -> f c; c, u)) let discharge_direct_opaque ~cook_constr ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> - Direct (ci::d,Future.chain ~pure:true cu (fun (c, u) -> cook_constr c, u)) + Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) let join_opaque { opaque_val = prfs; opaque_dir = odp } = function | Direct (_,cu) -> ignore(Future.join cu) @@ -105,7 +105,7 @@ let force_proof { opaque_val = prfs; opaque_dir = odp } = function | Indirect (l,dp,i) -> let pt = if DirPath.equal dp odp - then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst + then Future.chain (snd (Int.Map.find i prfs)) fst else !get_opaque dp i in let c = Future.force pt in force_constr (List.fold_right subst_substituted l (from_val c)) @@ -120,20 +120,20 @@ let force_constraints { opaque_val = prfs; opaque_dir = odp } = function | Some u -> Future.force u let get_constraints { opaque_val = prfs; opaque_dir = odp } = function - | Direct (_,cu) -> Some(Future.chain ~pure:true cu snd) + | Direct (_,cu) -> Some(Future.chain cu snd) | Indirect (_,dp,i) -> if DirPath.equal dp odp - then Some(Future.chain ~pure:true (snd (Int.Map.find i prfs)) snd) + then Some(Future.chain (snd (Int.Map.find i prfs)) snd) else !get_univ dp i let get_proof { opaque_val = prfs; opaque_dir = odp } = function - | Direct (_,cu) -> Future.chain ~pure:true cu fst + | Direct (_,cu) -> Future.chain cu fst | Indirect (l,dp,i) -> let pt = if DirPath.equal dp odp - then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst + then Future.chain (snd (Int.Map.find i prfs)) fst else !get_opaque dp i in - Future.chain ~pure:true pt (fun c -> + Future.chain pt (fun c -> force_constr (List.fold_right subst_substituted l (from_val c))) module FMap = Future.UUIDMap diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ad622b07d8..fd024b2157 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -683,12 +683,15 @@ let build_module_body params restype senv = with one extra component and some updated fields (constraints, required, etc) *) +let allow_delayed_constants = ref false + let propagate_senv newdef newenv newresolver senv oldsenv = let now_cst, later_cst = List.partition Future.is_val senv.future_cst in (* This asserts that after Paral-ITP, standard vo compilation is behaving * exctly as before: the same universe constraints are added to modules *) - if !Flags.compilation_mode = Flags.BuildVo && - !Flags.async_proofs_mode = Flags.APoff then assert(later_cst = []); + if not !allow_delayed_constants && later_cst <> [] then + CErrors.anomaly ~label:"safe_typing" + Pp.(str "True Future.t were created for opaque constants even if -async-proofs is off"); { oldsenv with env = newenv; modresolver = newresolver; diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 752fdd793e..f0f273f354 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -158,6 +158,10 @@ val add_module_parameter : MBId.t -> Entries.module_struct_entry -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer +(** Traditional mode: check at end of module that no future was + created. *) +val allow_delayed_constants : bool ref + (** The optional result type is given without its functorial part *) val end_module : diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 3f42c348fc..f93b24b3ee 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -266,7 +266,7 @@ let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = - Future.chain ~pure:true body (fun ((body,uctx),side_eff) -> + Future.chain body (fun ((body,uctx),side_eff) -> let j, uctx = match trust with | Pure -> let env = push_context_set uctx env in @@ -367,7 +367,7 @@ let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry cook_context = None; } -let record_aux env s_ty s_bo suggested_expr = +let record_aux env s_ty s_bo = let in_ty = keep_hyps env s_ty in let v = String.concat " " @@ -376,10 +376,7 @@ let record_aux env s_ty s_bo suggested_expr = if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None else Some (Id.to_string id)) (keep_hyps env s_bo)) in - Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) - -let suggest_proof_using = ref (fun _ _ _ _ _ -> "") -let set_suggest_proof_using f = suggest_proof_using := f + Aux_file.record_in_aux "context_used" v let build_constant_declaration kn env result = let open Cooking in @@ -425,17 +422,13 @@ let build_constant_declaration kn env result = (Opaqueproof.force_proof (opaque_tables env) lc) in (* we force so that cst are added to the env immediately after *) ignore(Opaqueproof.force_constraints (opaque_tables env) lc); - let expr = - !suggest_proof_using (Constant.to_string kn) - env vars ids_typ context_ids in - if !Flags.compilation_mode = Flags.BuildVo then - record_aux env ids_typ vars expr; + if !Flags.record_aux_file then record_aux env ids_typ vars; vars in keep_hyps env (Idset.union ids_typ ids_def), def | None -> - if !Flags.compilation_mode = Flags.BuildVo then - record_aux env Id.Set.empty Id.Set.empty ""; + if !Flags.record_aux_file then + record_aux env Id.Set.empty Id.Set.empty; [], def (* Empty section context: no need to check *) | Some declared -> (* We use the declared set and chain a check of correctness *) @@ -542,7 +535,7 @@ let export_side_effects mb env ce = let { const_entry_body = body } = c in let _, eff = Future.force body in let ce = DefinitionEntry { c with - const_entry_body = Future.chain ~pure:true body + const_entry_body = Future.chain body (fun (b_ctx, _) -> b_ctx, ()) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false @@ -614,19 +607,15 @@ let translate_local_def mb env id centry = let open Cooking in let decl = infer_declaration ~trust:mb env None (DefinitionEntry centry) in let typ = decl.cook_type in - if Option.is_empty decl.cook_context && !Flags.compilation_mode = Flags.BuildVo then begin + if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin match decl.cook_body with | Undef _ -> () | Def _ -> () | OpaqueDef lc -> - let context_ids = List.map NamedDecl.get_id (named_context env) in let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in - let expr = - !suggest_proof_using (Id.to_string id) - env ids_def ids_typ context_ids in - record_aux env ids_typ ids_def expr + record_aux env ids_typ ids_def end; let univs = match decl.cook_universes with | Monomorphic_const ctx -> ctx @@ -639,7 +628,7 @@ let translate_local_def mb env id centry = let translate_mind env kn mie = Indtypes.check_inductive env kn mie let inline_entry_side_effects env ce = { ce with - const_entry_body = Future.chain ~pure:true + const_entry_body = Future.chain ce.const_entry_body (fun ((body, ctx), side_eff) -> let body, ctx',_ = inline_side_effects env body ctx side_eff in (body, ctx'), ()); diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 24153343e7..b16f81c5a6 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -77,6 +77,3 @@ val infer_declaration : trust:'a trust -> env -> constant option -> val build_constant_declaration : constant -> env -> Cooking.result -> constant_body - -val set_suggest_proof_using : - (string -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> string) -> unit diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 044877e82a..b40badd7c8 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -65,6 +65,10 @@ let type_of_type u = let uu = Universe.super u in mkType uu +let type_of_sort = function + | Prop c -> type1 + | Type u -> type_of_type u + (*s Type of a de Bruijn index. *) let type_of_relative env n = @@ -323,11 +327,7 @@ let rec execute env cstr = let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) - | Sort (Prop c) -> - type1 - - | Sort (Type u) -> - type_of_type u + | Sort s -> type_of_sort s | Rel n -> type_of_relative env n diff --git a/kernel/typeops.mli b/kernel/typeops.mli index a8f7fba9a0..96be6c14a4 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -37,15 +37,19 @@ val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment (** {6 Type of sorts. } *) +val type1 : types +val type_of_sort : Sorts.t -> types val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment val judge_of_prop_contents : contents -> unsafe_judgment val judge_of_type : universe -> unsafe_judgment (** {6 Type of a bound variable. } *) +val type_of_relative : env -> int -> types val judge_of_relative : env -> int -> unsafe_judgment (** {6 Type of variables } *) +val type_of_variable : env -> variable -> types val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) @@ -66,9 +70,9 @@ val judge_of_abstraction : env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment -val sort_of_product : env -> sorts -> sorts -> sorts - (** {6 Type of a product. } *) +val sort_of_product : env -> sorts -> sorts -> sorts +val type_of_product : env -> Name.t -> sorts -> sorts -> types val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment diff --git a/kernel/univ.ml b/kernel/univ.ml index bae782f5d4..7fe4f82748 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -121,8 +121,7 @@ module Level = struct (** Hashcons on levels + their hash *) module Self = struct - type _t = t - type t = _t + type nonrec t = t type u = unit let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash @@ -755,8 +754,7 @@ struct module HInstancestruct = struct - type _t = t - type t = _t + type nonrec t = t type u = Level.t -> Level.t let hashcons huniv a = diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index ff71452672..3699b1c614 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -93,8 +93,12 @@ let split_flags s = "all" flag, and reverses the list. *) let rec cut_before_all_rev acc = function | [] -> acc - | (_status,name as w) :: warnings -> - cut_before_all_rev (w :: if is_all_keyword name then [] else acc) warnings + | (status,name as w) :: warnings -> + let acc = + if is_all_keyword name then [w] + else if is_none_keyword name then [(Disabled,"all")] + else w :: acc in + cut_before_all_rev acc warnings let cut_before_all_rev warnings = cut_before_all_rev [] warnings diff --git a/lib/envars.ml b/lib/envars.ml index 68604ae6c9..206d750338 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -213,6 +213,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sCAMLP4BIN=%s/\n" prefix_var_name (camlp4bin ()); fprintf f "%sCAMLP4LIB=%s\n" prefix_var_name (camlp4lib ()); fprintf f "%sCAMLP4OPTIONS=%s\n" prefix_var_name Coq_config.camlp4compat; + fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) diff --git a/lib/feedback.ml b/lib/feedback.ml index 54d16a9be3..7a126363cc 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -15,6 +15,7 @@ type level = | Warning | Error +type doc_id = int type route_id = int type feedback_content = @@ -35,7 +36,8 @@ type feedback_content = | Message of level * Loc.t option * Pp.t type feedback = { - id : Stateid.t; + doc_id : doc_id; (* The document being concerned *) + span_id : Stateid.t; route : route_id; contents : feedback_content; } @@ -52,23 +54,27 @@ let add_feeder = let del_feeder fid = Hashtbl.remove feeders fid let default_route = 0 -let feedback_id = ref Stateid.dummy +let span_id = ref Stateid.dummy +let doc_id = ref 0 let feedback_route = ref default_route -let set_id_for_feedback ?(route=default_route) i = - feedback_id := i; feedback_route := route +let set_id_for_feedback ?(route=default_route) d i = + doc_id := d; + span_id := i; + feedback_route := route -let feedback ?id ?route what = +let feedback ?did ?id ?route what = let m = { contents = what; - route = Option.default !feedback_route route; - id = Option.default !feedback_id id; + route = Option.default !feedback_route route; + doc_id = Option.default !doc_id did; + span_id = Option.default !span_id id; } in Hashtbl.iter (fun _ f -> f m) feeders (* Logging messages *) let feedback_logger ?loc lvl msg = - feedback ~route:!feedback_route ~id:!feedback_id (Message (lvl, loc, msg)) + feedback ~route:!feedback_route ~id:!span_id (Message (lvl, loc, msg)) let msg_info ?loc x = feedback_logger ?loc Info x let msg_notice ?loc x = feedback_logger ?loc Notice x diff --git a/lib/feedback.mli b/lib/feedback.mli index 45a02d384a..73b84614f1 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -17,6 +17,9 @@ type level = | Error +(** Document unique identifier for serialization *) +type doc_id = int + (** Coq "semantic" infos obtained during execution *) type route_id = int @@ -43,7 +46,8 @@ type feedback_content = | Message of level * Loc.t option * Pp.t type feedback = { - id : Stateid.t; (* The document part concerned *) + doc_id : doc_id; (* The document being concerned *) + span_id : Stateid.t; (* The document part concerned *) route : route_id; (* Extra routing info *) contents : feedback_content; (* The payload *) } @@ -60,13 +64,13 @@ val add_feeder : (feedback -> unit) -> int (** [del_feeder fid] removes the feeder with id [fid] *) val del_feeder : int -> unit -(** [feedback ?id ?route fb] produces feedback fb, with [route] and - [id] set appropiatedly, if absent, it will use the defaults set by - [set_id_for_feedback] *) -val feedback : ?id:Stateid.t -> ?route:route_id -> feedback_content -> unit +(** [feedback ?did ?sid ?route fb] produces feedback [fb], with + [route] and [did, sid] set appropiatedly, if absent, it will use + the defaults set by [set_id_for_feedback] *) +val feedback : ?did:doc_id -> ?id:Stateid.t -> ?route:route_id -> feedback_content -> unit (** [set_id_for_feedback route id] Set the defaults for feedback *) -val set_id_for_feedback : ?route:route_id -> Stateid.t -> unit +val set_id_for_feedback : ?route:route_id -> doc_id -> Stateid.t -> unit (** {6 output functions} diff --git a/lib/flags.ml b/lib/flags.ml index d4be81c61a..a53a866aba 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -42,12 +42,8 @@ let with_extra_values o l f x = Exninfo.iraise reraise let boot = ref false -let load_init = ref true -let batch_mode = ref false -type compilation_mode = BuildVo | BuildVio | Vio2Vo -let compilation_mode = ref BuildVo -let compilation_output_name = ref None +let record_aux_file = ref false let test_mode = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 3024c60396..5233e72a25 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -11,14 +11,10 @@ (** Command-line flags *) val boot : bool ref -val load_init : bool ref -(* Will affect STM caching *) -val batch_mode : bool ref - -type compilation_mode = BuildVo | BuildVio | Vio2Vo -val compilation_mode : compilation_mode ref -val compilation_output_name : string option ref +(** Set by coqtop to tell the kernel to output to the aux file; will + be eventually removed by cleanups such as PR#1103 *) +val record_aux_file : bool ref (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) diff --git a/lib/future.ml b/lib/future.ml index d9463aa0f1..09285ea27d 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -6,12 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* To deal with side effects we have to save/restore the system state *) -type freeze -let freeze = ref (fun () -> assert false : unit -> freeze) -let unfreeze = ref (fun _ -> () : freeze -> unit) -let set_freeze f g = freeze := f; unfreeze := g - let not_ready_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^ "Please wait or pass "^ @@ -30,6 +24,7 @@ let customize_not_here_msg f = not_here_msg := f exception NotReady of string exception NotHere of string + let _ = CErrors.register_handler (function | NotReady name -> !not_ready_msg name | NotHere name -> !not_here_msg name @@ -59,7 +54,7 @@ type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computat and 'a comp = | Delegated of (unit -> unit) | Closure of (unit -> 'a) - | Val of 'a * freeze option + | Val of 'a | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = @@ -74,7 +69,7 @@ let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with - | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None)) + | Finished v -> unnamed, UUID.invalid, id, ref (Val v) | Ongoing (name, x) -> try let uuid, fix, c = CEphemeron.get x in name, uuid, fix, c with CEphemeron.InvalidKey -> @@ -95,13 +90,13 @@ let is_exn kx = let _, _, _, x = get kx in match !x with | Val _ | Closure _ | Delegated _ -> false let peek_val kx = let _, _, _, x = get kx in match !x with - | Val (v, _) -> Some v + | Val v -> Some v | Exn _ | Closure _ | Delegated _ -> None let uuid kx = let _, id, _, _ = get kx in id -let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None)) -let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ()))) +let from_val ?(fix_exn=id) v = create fix_exn (Val v) +let from_here ?(fix_exn=id) v = create fix_exn (Val v) let fix_exn_of ck = let _, _, fix_exn, _ = get ck in fix_exn @@ -110,7 +105,7 @@ let create_delegate ?(blocking=true) ~name fix_exn = let _, _, fix_exn, c = get ck in assert (match !c with Delegated _ -> true | _ -> false); begin match v with - | `Val v -> c := Val (v, None) + | `Val v -> c := Val v | `Exn e -> c := Exn (fix_exn e) | `Comp f -> let _, _, _, comp = get f in c := !comp end; signal () in @@ -124,17 +119,16 @@ let create_delegate ?(blocking=true) ~name fix_exn = ck, assignement signal ck (* TODO: get rid of try/catch to be stackless *) -let rec compute ~pure ck : 'a value = +let rec compute ck : 'a value = let _, _, fix_exn, c = get ck in match !c with - | Val (x, _) -> `Val x + | Val x -> `Val x | Exn (e, info) -> `Exn (e, info) - | Delegated wait -> wait (); compute ~pure ck + | Delegated wait -> wait (); compute ck | Closure f -> try let data = f () in - let state = if pure then None else Some (!freeze ()) in - c := Val (data, state); `Val data + c := Val data; `Val data with e -> let e = CErrors.push e in let e = fix_exn e in @@ -142,60 +136,30 @@ let rec compute ~pure ck : 'a value = | (NotReady _, _) -> `Exn e | _ -> c := Exn e; `Exn e -let force ~pure x = match compute ~pure x with +let force x = match compute x with | `Val v -> v | `Exn e -> Exninfo.iraise e -let chain ~pure ck f = +let chain ck f = let name, uuid, fix_exn, c = get ck in create ~uuid ~name fix_exn (match !c with - | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck)) + | Closure _ | Delegated _ -> Closure (fun () -> f (force ck)) | Exn _ as x -> x - | Val (v, None) when pure -> Val (f v, None) - | Val (v, Some _) when pure -> Val (f v, None) - | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v) - | Val (v, None) -> - match !ck with - | Finished _ -> CErrors.anomaly(Pp.str - "Future.chain ~pure:false call on an already joined computation.") - | Ongoing _ -> CErrors.anomaly(Pp.strbrk( - "Future.chain ~pure:false call on a pure computation. "^ - "This can happen if the computation was initial created with "^ - "Future.from_val or if it was Future.chain ~pure:true with a "^ - "function and later forced."))) + | Val v -> Val (f v)) let create fix_exn f = create fix_exn (Closure f) let replace kx y = let _, _, _, x = get kx in match !x with - | Exn _ -> x := Closure (fun () -> force ~pure:false y) + | Exn _ -> x := Closure (fun () -> force y) | _ -> CErrors.anomaly (Pp.str "A computation can be replaced only if is_exn holds.") -let purify f x = - let state = !freeze () in - try - let v = f x in - !unfreeze state; - v - with e -> - let e = CErrors.push e in !unfreeze state; Exninfo.iraise e - -let transactify f x = - let state = !freeze () in - try f x - with e -> - let e = CErrors.push e in !unfreeze state; Exninfo.iraise e - -let purify_future f x = if is_over x then f x else purify f x -let compute x = purify_future (compute ~pure:false) x -let force ~pure x = purify_future (force ~pure) x -let chain ~pure x f = - let y = chain ~pure x f in - if is_over x then ignore(force ~pure y); +let chain x f = + let y = chain x f in + if is_over x then ignore(force y); y -let force x = force ~pure:false x let join kx = let v = force kx in @@ -205,12 +169,11 @@ let join kx = let sink kx = if is_val kx then ignore(join kx) let split2 x = - chain ~pure:true x (fun x -> fst x), - chain ~pure:true x (fun x -> snd x) + chain x (fun x -> fst x), chain x (fun x -> snd x) let map2 f x l = CList.map_i (fun i y -> - let xi = chain ~pure:true x (fun x -> + let xi = chain x (fun x -> try List.nth x i with Failure _ | Invalid_argument _ -> CErrors.anomaly (Pp.str "Future.map2 length mismatch.")) in @@ -226,6 +189,5 @@ let print f kx = match !x with | Delegated _ -> str "Delegated" ++ uid | Closure _ -> str "Closure" ++ uid - | Val (x, None) -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x) - | Val (x, Some _) -> str "StateVal" ++ uid ++ spc () ++ hov 0 (f x) + | Val x -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x) | Exn (e, _) -> str "Exn" ++ uid ++ spc () ++ hov 0 (str (Printexc.to_string e)) diff --git a/lib/future.mli b/lib/future.mli index acfce51a07..853f81cea0 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -6,42 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Futures: asynchronous computations with some purity enforcing +(* Futures: asynchronous computations. * * A Future.computation is like a lazy_t but with some extra bells and whistles - * to deal with imperative code and eventual delegation to a slave process. + * to deal with eventual delegation to a slave process. * - * Example of a simple scenario taken into account: - * - * let f = Future.from_here (number_of_constants (Global.env())) in - * let g = Future.chain ~pure:false f (fun n -> - * n = number_of_constants (Global.env())) in - * ... - * Lemmas.save_named ...; - * ... - * let b = Future.force g in - * - * The Future.computation f holds a (immediate, no lazy here) value. - * We then chain to obtain g that (will) hold false if (when it will be - * run) the global environment has a different number of constants, true - * if nothing changed. - * Before forcing g, we add to the global environment one more constant. - * When finally we force g. Its value is going to be *true*. - * This because Future.from_here stores in the computation not only the initial - * value but the entire system state. When g is forced the state is restored, - * hence Global.env() returns the environment that was actual when f was - * created. - * Last, forcing g is run protecting the system state, hence when g finishes, - * the actual system state is restored. - * - * If you compare this with lazy_t, you see that the value returned is *false*, - * that is counter intuitive and error prone. - * - * Still not all computations are impure and access/alter the system state. - * This class can be optimized by using ~pure:true, but there is no way to - * statically check if this flag is misused, hence use it with care. - * - * Other differences with lazy_t is that a future computation that produces + * One difference with lazy_t is that a future computation that produces * and exception can be substituted for another computation of the same type. * Moreover a future computation can be delegated to another execution entity * that will be allowed to set the result. Finally future computations can @@ -113,27 +83,17 @@ val is_exn : 'a computation -> bool val peek_val : 'a computation -> 'a option val uuid : 'a computation -> UUID.t -(* [chain pure c f] chains computation [c] with [f]. - * [chain] forces immediately the new computation if the old one is_over (Exn or Val). - * The [pure] parameter is tricky: - * [pure]: - * When pure is true, the returned computation will not keep a copy - * of the global state. - * [let c' = chain ~pure:true c f in let c'' = chain ~pure:false c' g in] - * is invalid. It works if one forces [c''] since the whole computation - * will be executed in one go. It will not work, and raise an anomaly, if - * one forces c' and then c''. - * [join c; chain ~pure:false c g] is invalid and fails at runtime. - * [force c; chain ~pure:false c g] is correct. - *) -val chain : pure:bool -> - 'a computation -> ('a -> 'b) -> 'b computation +(* [chain c f] chains computation [c] with [f]. + * [chain] is eager, that is to say, it won't suspend the new computation + * if the old one is_over (Exn or Val). +*) +val chain : 'a computation -> ('a -> 'b) -> 'b computation (* Forcing a computation *) val force : 'a computation -> 'a val compute : 'a computation -> 'a value -(* Final call, no more *inpure* chain allowed since the state is lost. +(* Final call. * Also the fix_exn function is lost, hence error reporting can be incomplete * in a computation obtained by chaining on a joined future. *) val join : 'a computation -> 'a @@ -148,19 +108,8 @@ val map2 : ('a computation -> 'b -> 'c) -> 'a list computation -> 'b list -> 'c list -(* Once set_freeze is called we can purify a computation *) -val purify : ('a -> 'b) -> 'a -> 'b -(* And also let a function alter the state but backtrack if it raises exn *) -val transactify : ('a -> 'b) -> 'a -> 'b - (** Debug: print a computation given an inner printing function. *) val print : ('a -> Pp.t) -> 'a computation -> Pp.t -type freeze -(* These functions are needed to get rid of side effects. - Thy are set for the outermos layer of the system, since they have to - deal with the whole system state. *) -val set_freeze : (unit -> freeze) -> (freeze -> unit) -> unit - val customize_not_ready_msg : (string -> Pp.t) -> unit val customize_not_here_msg : (string -> Pp.t) -> unit diff --git a/lib/minisys.ml b/lib/minisys.ml index 706f0430c3..389b18ad4e 100644 --- a/lib/minisys.ml +++ b/lib/minisys.ml @@ -36,10 +36,15 @@ let skipped_dirnames = ref ["CVS"; "_darcs"] let exclude_directory f = skipped_dirnames := f :: !skipped_dirnames +(* Note: this test is possibly used for Coq module/file names but also for + OCaml filenames, whose syntax as of today is more restrictive for + module names (only initial letter then letter, digits, _ or quote), + but more permissive (though disadvised) for file names *) + let ok_dirname f = not (f = "") && f.[0] != '.' && - not (List.mem f !skipped_dirnames) (*&& - (match Unicode.ident_refutation f with None -> true | _ -> false)*) + not (List.mem f !skipped_dirnames) && + match Unicode.ident_refutation f with None -> true | _ -> false (* Check directory can be opened *) @@ -55,10 +60,11 @@ let exists_dir dir = let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) (* as well as skipped files like CVS, ... *) - if ok_dirname name then + let base = try Filename.chop_extension name with Invalid_argument _ -> name in + if ok_dirname base then let path = if path = "." then name else path//name in match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with - | Unix.S_DIR -> f (FileDir (path,name)) + | Unix.S_DIR when name = base -> f (FileDir (path,name)) | Unix.S_REG -> f (FileRegular name) | _ -> () @@ -82,10 +82,21 @@ let utf8_length s = done ; !cnt -let app s1 s2 = match s1, s2 with - | Ppcmd_empty, s - | s, Ppcmd_empty -> s - | s1, s2 -> Ppcmd_glue [s1; s2] +let rec app d1 d2 = match d1, d2 with + | Ppcmd_empty, d + | d, Ppcmd_empty -> d + + (* Optimizations *) + | Ppcmd_glue [l1;l2], Ppcmd_glue l3 -> Ppcmd_glue (l1 :: l2 :: l3) + | Ppcmd_glue [l1;l2], d2 -> Ppcmd_glue [l1 ; l2 ; d2] + | d1, Ppcmd_glue l2 -> Ppcmd_glue (d1 :: l2) + + | Ppcmd_tag(t1,d1), Ppcmd_tag(t2,d2) + when t1 = t2 -> Ppcmd_tag(t1,app d1 d2) + | d1, d2 -> Ppcmd_glue [d1; d2] + (* Optimizations deemed too costly *) + (* | Ppcmd_glue l1, Ppcmd_glue l2 -> Ppcmd_glue (l1 @ l2) *) + (* | Ppcmd_string s1, Ppcmd_string s2 -> Ppcmd_string (s1 ^ s2) *) let seq s = Ppcmd_glue s diff --git a/lib/segmenttree.ml b/lib/segmenttree.ml index 9ce348a0bd..d0ded4cb59 100644 --- a/lib/segmenttree.ml +++ b/lib/segmenttree.ml @@ -1,3 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + (** This module is a very simple implementation of "segment trees". A segment tree of type ['a t] represents a mapping from a union of diff --git a/lib/segmenttree.mli b/lib/segmenttree.mli index 3258537b99..e274a6fdc8 100644 --- a/lib/segmenttree.mli +++ b/lib/segmenttree.mli @@ -1,3 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + (** This module is a very simple implementation of "segment trees". A segment tree of type ['a t] represents a mapping from a union of diff --git a/lib/system.ml b/lib/system.ml index 12eacf2eaf..4b5066ef41 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -52,7 +52,9 @@ let dirmap = ref StrMap.empty let make_dir_table dir = let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty (readdir dir) + Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + +let trust_file_cache = ref true let exists_in_dir_respecting_case dir bf = let cache_dir dir = @@ -62,10 +64,10 @@ let exists_in_dir_respecting_case dir bf = let contents, fresh = try (* in batch mode, assume the directory content is still fresh *) - StrMap.find dir !dirmap, !Flags.batch_mode + StrMap.find dir !dirmap, !trust_file_cache with Not_found -> (* in batch mode, we are not yet sure the directory exists *) - if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true + if !trust_file_cache && not (exists_dir dir) then StrSet.empty, true else cache_dir dir, true in StrSet.mem bf contents || not fresh && @@ -80,7 +82,7 @@ let file_exists_respecting_case path f = let df = Filename.dirname f in (String.equal df "." || aux df) && exists_in_dir_respecting_case (Filename.concat path df) bf - in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f + in (!trust_file_cache || Sys.file_exists (Filename.concat path f)) && aux f let rec search paths test = match paths with diff --git a/lib/system.mli b/lib/system.mli index 7281de97c9..aa964abebe 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -54,6 +54,12 @@ val where_in_path_rex : val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val trust_file_cache : bool ref +(** [trust_file_cache] indicates whether we trust the underlying + mapped file-system not to change along the execution of Coq. This + assumption greatly speds up file search, but it is often + inconvenient in interactive mode *) + val file_exists_respecting_case : string -> string -> bool (** {6 I/O functions } *) diff --git a/lib/unicode.ml b/lib/unicode.ml index 959ccaf73c..f193c4e0f8 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -8,13 +8,14 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol | Unknown +type status = Letter | IdentPart | Symbol | IdentSep | Unknown (* The following table stores classes of Unicode characters that - are used by the lexer. There are 3 different classes so 2 bits are - allocated for each character. We only use 16 bits over the 31 bits - to simplify the masking process. (This choice seems to be a good - trade-off between speed and space after some benchmarks.) *) + are used by the lexer. There are 5 different classes so 3 bits + are allocated for each character. We encode the masks of 8 + characters per word, thus using 24 bits over the 31 available + bits. (This choice seems to be a good trade-off between speed + and space after some benchmarks.) *) (* A 256 KiB table, initially filled with zeros. *) let table = Array.make (1 lsl 17) 0 @@ -24,14 +25,15 @@ let table = Array.make (1 lsl 17) 0 define the position of the pattern in the word. Notice that pattern "00" means "undefined". *) let mask i = function - | Letter -> 1 lsl ((i land 7) lsl 1) (* 01 *) - | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) - | Symbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) - | Unknown -> 0 lsl ((i land 7) lsl 1) (* 00 *) + | Letter -> 1 lsl ((i land 7) * 3) (* 001 *) + | IdentPart -> 2 lsl ((i land 7) * 3) (* 010 *) + | Symbol -> 3 lsl ((i land 7) * 3) (* 011 *) + | IdentSep -> 4 lsl ((i land 7) * 3) (* 100 *) + | Unknown -> 0 lsl ((i land 7) * 3) (* 000 *) -(* Helper to reset 2 bits in a word. *) +(* Helper to reset 3 bits in a word. *) let reset_mask i = - lnot (3 lsl ((i land 7) lsl 1)) + lnot (7 lsl ((i land 7) * 3)) (* Initialize the lookup table from a list of segments, assigning a status to every character of each segment. The order of these @@ -50,13 +52,14 @@ let mk_lookup_table_from_unicode_tables_for status tables = (* Look up into the table and interpret the found pattern. *) let lookup x = - let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in + let v = (table.(x lsr 3) lsr ((x land 7) * 3)) land 7 in if v = 1 then Letter else if v = 2 then IdentPart else if v = 3 then Symbol + else if v = 4 then IdentSep else Unknown -(* [classify] discriminates between 3 different kinds of +(* [classify] discriminates between 5 different kinds of symbols based on the standard unicode classification (extracted from Camomile). *) let classify = @@ -67,13 +70,13 @@ let classify = Unicodetable.sm; (* Symbol, maths. *) Unicodetable.sc; (* Symbol, currency. *) Unicodetable.so; (* Symbol, modifier. *) - Unicodetable.pd; (* Punctation, dash. *) - Unicodetable.pc; (* Punctation, connector. *) - Unicodetable.pe; (* Punctation, open. *) - Unicodetable.ps; (* Punctation, close. *) - Unicodetable.pi; (* Punctation, initial quote. *) - Unicodetable.pf; (* Punctation, final quote. *) - Unicodetable.po; (* Punctation, other. *) + Unicodetable.pd; (* Punctuation, dash. *) + Unicodetable.pc; (* Punctuation, connector. *) + Unicodetable.pe; (* Punctuation, open. *) + Unicodetable.ps; (* Punctution, close. *) + Unicodetable.pi; (* Punctuation, initial quote. *) + Unicodetable.pf; (* Punctuation, final quote. *) + Unicodetable.po; (* Punctuation, other. *) ]; mk_lookup_table_from_unicode_tables_for Letter [ @@ -107,14 +110,14 @@ let classify = [(0x02074, 0x02079)]; (* Superscript 4-9. *) single 0x0002E; (* Dot. *) ]; - mk_lookup_table_from_unicode_tables_for Letter + mk_lookup_table_from_unicode_tables_for IdentSep [ single 0x005F; (* Underscore. *) single 0x00A0; (* Non breaking space. *) ]; mk_lookup_table_from_unicode_tables_for IdentPart [ - single 0x0027; (* Special space. *) + single 0x0027; (* Single quote. *) ]; (* Lookup *) lookup @@ -163,24 +166,75 @@ let is_utf8 s = in try check 0 with End_of_input -> true | Invalid_argument _ -> false +(* Escape string if it contains non-utf8 characters *) + +let escaped_non_utf8 s = + let mk_escape x = Printf.sprintf "%%%X" x in + let buff = Buffer.create (String.length s * 3) in + let rec process_trailing_aux i j = + if i = j then i else + match String.unsafe_get s i with + | '\128'..'\191' -> process_trailing_aux (i+1) j + | _ -> i in + let process_trailing i n = + let j = if i+n-1 >= String.length s then i+1 else process_trailing_aux (i+1) (i+n) in + (if j = i+n then + Buffer.add_string buff (String.sub s i n) + else + let v = Array.init (j-i) (fun k -> mk_escape (Char.code s.[i+k])) in + Buffer.add_string buff (String.concat "" (Array.to_list v))); + j in + let rec process i = + if i >= String.length s then Buffer.contents buff else + let c = String.unsafe_get s i in + match c with + | '\000'..'\127' -> Buffer.add_char buff c; process (i+1) + | '\128'..'\191' | '\248'..'\255' -> Buffer.add_string buff (mk_escape (Char.code c)); process (i+1) + | '\192'..'\223' -> process (process_trailing i 2) + | '\224'..'\239' -> process (process_trailing i 3) + | '\240'..'\247' -> process (process_trailing i 4) + in + process 0 + +let escaped_if_non_utf8 s = + if is_utf8 s then s else escaped_non_utf8 s + (* Check the well-formedness of an identifier *) +let is_valid_ident_initial = function + | Letter | IdentSep -> true + | IdentPart | Symbol | Unknown -> false + let initial_refutation j n s = - match classify n with - | Letter -> None - | _ -> + if is_valid_ident_initial (classify n) then None + else let c = String.sub s 0 j in Some (false, "Invalid character '"^c^"' at beginning of identifier \""^s^"\".") +let is_valid_ident_trailing = function + | Letter | IdentSep | IdentPart -> true + | Symbol | Unknown -> false + let trailing_refutation i j n s = - match classify n with - | Letter | IdentPart -> None - | _ -> + if is_valid_ident_trailing (classify n) then None + else let c = String.sub s i j in Some (false, "Invalid character '"^c^"' in identifier \""^s^"\".") +let is_unknown = function + | Unknown -> true + | Letter | IdentSep | IdentPart | Symbol -> false + +let is_ident_part = function + | IdentPart -> true + | Letter | IdentSep | Symbol | Unknown -> false + +let is_ident_sep = function + | IdentSep -> true + | Letter | IdentPart | Symbol | Unknown -> false + let ident_refutation s = if s = ".." then None else try let j, n = next_utf8 s 0 in @@ -198,7 +252,7 @@ let ident_refutation s = |x -> x with | End_of_input -> Some (true,"The empty string is not an identifier.") - | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.") + | Invalid_argument _ -> Some (true,escaped_non_utf8 s^": invalid utf8 sequence.") let lowercase_unicode = let tree = Segmenttree.make Unicodetable.to_lower in @@ -214,6 +268,26 @@ let lowercase_first_char s = let j, n = next_utf8 s 0 in utf8_of_unicode (lowercase_unicode n) +let split_at_first_letter s = + let n, v = next_utf8 s 0 in + if ((* optim *) n = 1 && s.[0] != '_') || not (is_ident_sep (classify v)) then None + else begin + let n = ref n in + let p = ref 0 in + while !n < String.length s && + let n', v = next_utf8 s !n in + p := n'; + (* Test if not letter *) + ((* optim *) n' = 1 && (s.[!n] = '_' || s.[!n] = '\'')) + || let st = classify v in + is_ident_sep st || is_ident_part st + do n := !n + !p + done; + let s1 = String.sub s 0 !n in + let s2 = String.sub s !n (String.length s - !n) in + Some (s1,s2) + end + (** For extraction, we need to encode unicode character into ascii ones *) let is_basic_ascii s = @@ -268,9 +342,7 @@ let utf8_length s = | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) + | '\248'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len && !nc > 0 do @@ -299,9 +371,7 @@ let utf8_sub s start_u len_u = | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) + | '\248'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len_b && !nc > 0 do diff --git a/lib/unicode.mli b/lib/unicode.mli index c7d7424801..32ffbb8e94 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -8,7 +8,7 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol | Unknown +type status (** Classify a unicode char into 3 classes or unknown. *) val classify : int -> status @@ -17,10 +17,23 @@ val classify : int -> status Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. *) val ident_refutation : string -> (bool * string) option +(** Tells if a valid initial character for an identifier *) +val is_valid_ident_initial : status -> bool + +(** Tells if a valid non-initial character for an identifier *) +val is_valid_ident_trailing : status -> bool + +(** Tells if a character is unclassified *) +val is_unknown : status -> bool + (** First char of a string, converted to lowercase @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string +(** Split a string supposed to be an ident at the first letter; + as an optimization, return None if the first character is a letter *) +val split_at_first_letter : string -> (string * string) option + (** Return [true] if all UTF-8 characters in the input string are just plain ASCII characters. Returns [false] otherwise. *) val is_basic_ascii : string -> bool @@ -40,3 +53,6 @@ val utf8_length : string -> int (** Variant of {!String.sub} for UTF-8 strings. *) val utf8_sub : string -> int -> int -> string + +(** Return a "%XX"-escaped string if it contains non UTF-8 characters. *) +val escaped_if_non_utf8 : string -> string diff --git a/library/library.ml b/library/library.ml index 28afa054e9..e2832ecdc3 100644 --- a/library/library.ml +++ b/library/library.ml @@ -620,25 +620,6 @@ let check_coq_overwriting p id = (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") -(* Verifies that a string starts by a letter and do not contain - others caracters than letters, digits, or `_` *) - -let check_module_name s = - let msg c = - strbrk "Invalid module name: " ++ str s ++ strbrk " character " ++ - (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ - strbrk " is not allowed in module names\n" - in - let err c = user_err (msg c) in - match String.get s 0 with - | 'a' .. 'z' | 'A' .. 'Z' -> - for i = 1 to (String.length s)-1 do - match String.get s i with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> () - | c -> err c - done - | c -> err c - let start_library fo = let ldir0 = try @@ -648,7 +629,6 @@ let start_library fo = in let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in - check_module_name file; check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; @@ -703,7 +683,8 @@ let error_recursively_dependent_library dir = let save_library_to ?todo dir f otab = let except = match todo with | None -> - assert(!Flags.compilation_mode = Flags.BuildVo); + (* XXX *) + (* assert(!Flags.compilation_mode = Flags.BuildVo); *) assert(Filename.check_suffix f ".vo"); Future.UUIDSet.empty | Some (l,_) -> diff --git a/library/nametab.ml b/library/nametab.ml index 68fdbb4f38..0ec4a37cdb 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -19,10 +19,6 @@ exception GlobalizationError of qualid let error_global_not_found ?loc q = Loc.raise ?loc (GlobalizationError q) -(* Kinds of global names *) - -type ltac_constant = kernel_name - (* The visibility can be registered either - for all suffixes not shorter then a given int - when the object is loaded inside a module @@ -274,19 +270,14 @@ struct end module ExtRefEqual = ExtRefOrdered -module KnEqual = Names.KerName module MPEqual = Names.ModPath module ExtRefTab = Make(FullPath)(ExtRefEqual) -module KnTab = Make(FullPath)(KnEqual) module MPTab = Make(FullPath)(MPEqual) type ccitab = ExtRefTab.t let the_ccitab = ref (ExtRefTab.empty : ccitab) -type kntab = KnTab.t -let the_tactictab = ref (KnTab.empty : kntab) - type mptab = MPTab.t let the_modtypetab = ref (MPTab.empty : mptab) @@ -327,10 +318,6 @@ let the_modrevtab = ref (MPmap.empty : mprevtab) type mptrevtab = full_path MPmap.t let the_modtyperevtab = ref (MPmap.empty : mptrevtab) -type knrevtab = full_path KNmap.t -let the_tacticrevtab = ref (KNmap.empty : knrevtab) - - (* Push functions *********************************************************) (* This is for permanent constructions (never discharged -- but with @@ -368,13 +355,6 @@ let push_modtype vis sp kn = the_modtypetab := MPTab.push vis sp kn !the_modtypetab; the_modtyperevtab := MPmap.add kn sp !the_modtyperevtab -(* This is for tactic definition names *) - -let push_tactic vis sp kn = - the_tactictab := KnTab.push vis sp kn !the_tactictab; - the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab - - (* This is to remember absolute Section/Module names and to avoid redundancy *) let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; @@ -402,8 +382,6 @@ let locate_syndef qid = match locate_extended qid with let locate_modtype qid = MPTab.locate qid !the_modtypetab let full_name_modtype qid = MPTab.user_name qid !the_modtypetab -let locate_tactic qid = KnTab.locate qid !the_tactictab - let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = @@ -428,8 +406,6 @@ let locate_all qid = let locate_extended_all qid = ExtRefTab.find_prefixes qid !the_ccitab -let locate_extended_all_tactic qid = KnTab.find_prefixes qid !the_tactictab - let locate_extended_all_dir qid = DirTab.find_prefixes qid !the_dirtab let locate_extended_all_modtype qid = MPTab.find_prefixes qid !the_modtypetab @@ -471,8 +447,6 @@ let exists_module = exists_dir let exists_modtype sp = MPTab.exists sp !the_modtypetab -let exists_tactic kn = KnTab.exists kn !the_tactictab - (* Reverse locate functions ***********************************************) let path_of_global ref = @@ -492,9 +466,6 @@ let path_of_syndef kn = let dirpath_of_module mp = MPmap.find mp !the_modrevtab -let path_of_tactic kn = - KNmap.find kn !the_tacticrevtab - let path_of_modtype mp = MPmap.find mp !the_modtyperevtab @@ -519,10 +490,6 @@ let shortest_qualid_of_modtype kn = let sp = MPmap.find kn !the_modtyperevtab in MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab -let shortest_qualid_of_tactic kn = - let sp = KNmap.find kn !the_tacticrevtab in - KnTab.shortest_qualid Id.Set.empty sp !the_tactictab - let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> @@ -541,28 +508,24 @@ let global_inductive r = (********************************************************************) (* Registration of tables as a global table and rollback *) -type frozen = ccitab * dirtab * mptab * kntab - * globrevtab * mprevtab * mptrevtab * knrevtab +type frozen = ccitab * dirtab * mptab + * globrevtab * mprevtab * mptrevtab let freeze _ : frozen = !the_ccitab, !the_dirtab, !the_modtypetab, - !the_tactictab, !the_globrevtab, !the_modrevtab, - !the_modtyperevtab, - !the_tacticrevtab + !the_modtyperevtab -let unfreeze (ccit,dirt,mtyt,tact,globr,modr,mtyr,tacr) = +let unfreeze (ccit,dirt,mtyt,globr,modr,mtyr) = the_ccitab := ccit; the_dirtab := dirt; the_modtypetab := mtyt; - the_tactictab := tact; the_globrevtab := globr; the_modrevtab := modr; - the_modtyperevtab := mtyr; - the_tacticrevtab := tacr + the_modtyperevtab := mtyr let _ = Summary.declare_summary "names" diff --git a/library/nametab.mli b/library/nametab.mli index 025a63b1ce..3a380637c2 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -78,10 +78,6 @@ val push_modtype : visibility -> full_path -> module_path -> unit val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit -type ltac_constant = kernel_name -val push_tactic : visibility -> full_path -> ltac_constant -> unit - - (** {6 The following functions perform globalization of qualified names } *) (** These functions globalize a (partially) qualified name or fail with @@ -95,7 +91,6 @@ val locate_modtype : qualid -> module_path val locate_dir : qualid -> global_dir_reference val locate_module : qualid -> module_path val locate_section : qualid -> DirPath.t -val locate_tactic : qualid -> ltac_constant (** These functions globalize user-level references into global references, like [locate] and co, but raise a nice error message @@ -109,7 +104,6 @@ val global_inductive : reference -> inductive val locate_all : qualid -> global_reference list val locate_extended_all : qualid -> extended_global_reference list -val locate_extended_all_tactic : qualid -> ltac_constant list val locate_extended_all_dir : qualid -> global_dir_reference list val locate_extended_all_modtype : qualid -> module_path list @@ -125,7 +119,6 @@ val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) -val exists_tactic : full_path -> bool (** deprecated synonym of [exists_dir] *) (** {6 These functions locate qualids into full user names } *) @@ -144,7 +137,6 @@ val path_of_syndef : syndef_name -> full_path val path_of_global : global_reference -> full_path val dirpath_of_module : module_path -> DirPath.t val path_of_modtype : module_path -> full_path -val path_of_tactic : ltac_constant -> full_path (** Returns in particular the dirpath or the basename of the full path associated to global reference *) @@ -166,7 +158,6 @@ val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : module_path -> qualid val shortest_qualid_of_module : module_path -> qualid -val shortest_qualid_of_tactic : ltac_constant -> qualid (** Deprecated synonyms *) diff --git a/library/states.ml b/library/states.ml index 03e4610a6d..27e0a94f90 100644 --- a/library/states.ml +++ b/library/states.ml @@ -37,5 +37,3 @@ let with_state_protection f x = with reraise -> let reraise = CErrors.push reraise in (unfreeze st; iraise reraise) - -let with_state_protection_on_exception = Future.transactify diff --git a/library/states.mli b/library/states.mli index 780a4e8dc8..accd0e7ea9 100644 --- a/library/states.mli +++ b/library/states.mli @@ -30,10 +30,3 @@ val replace_summary : state -> Summary.frozen -> state val with_state_protection : ('a -> 'b) -> 'a -> 'b -(** [with_state_protection_on_exception f x] applies [f] to [x] and restores the - state of the whole system as it was before applying [f] only if an - exception is raised. Unlike [with_state_protection] it also takes into - account the proof state *) - -val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b - diff --git a/man/coqdep.1 b/man/coqdep.1 index 81f7e1e0df..ed727db7c8 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -82,7 +82,7 @@ Prints the dependencies of Caml modules. \" the standard output. No dependency is computed with this option. .TP .BI \-I/\-Q/\-R \ options -Have the same effects on load path and modules names than for other +Have the same effects on load path and modules names as for other coq commands (coqtop, coqc). .TP .BI \-coqlib \ directory diff --git a/man/coqtop.1 b/man/coqtop.1 index 62d17aa674..b1fbb3262e 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -140,12 +140,6 @@ dump globalizations in file f (to be used by ) .TP -.BI \-with\-geoproof \ (yes|no) -to (de)activate special functions for Geoproof within Coqide (default is -.I yes -) - -.TP .B \-impredicative\-set set sort Set impredicative diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 9c9189ffeb..f26398fa92 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -245,8 +245,8 @@ let check_ident str = loop_id true s | [< s >] -> match unlocated lookup_utf8 Ploc.dummy s with - | Utf8Token (Unicode.Letter, n) -> njunk n s; loop_id true s - | Utf8Token (Unicode.IdentPart, n) when intail -> + | Utf8Token (st, n) when not intail && Unicode.is_valid_ident_initial st -> njunk n s; loop_id true s + | Utf8Token (st, n) when intail && Unicode.is_valid_ident_trailing st -> njunk n s; loop_id true s | EmptyStream -> () @@ -311,9 +311,9 @@ let rec ident_tail loc len = parser ident_tail loc (store len c) s | [< s >] -> match lookup_utf8 loc s with - | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_trailing st -> ident_tail loc (nstore n len s) s - | Utf8Token (Unicode.Unknown, n) -> + | Utf8Token (st, n) when Unicode.is_unknown st -> let id = get_buff len in let u = String.concat "" (List.map (String.make 1) (Stream.npeek n s)) in warn_unrecognized_unicode ~loc:!@loc (u,id); len @@ -539,7 +539,7 @@ let parse_after_dot loc c bp = (try find_keyword loc ("."^field) s with Not_found -> FIELD field) | [< s >] -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_initial st -> let len = ident_tail loc (nstore n 0 s) s in let field = get_buff len in (try find_keyword loc ("."^field) s with Not_found -> FIELD field) @@ -553,7 +553,7 @@ let parse_after_qmark loc bp s = | None -> KEYWORD "?" | _ -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, _) -> LEFTQMARK + | Utf8Token (st, _) when Unicode.is_valid_ident_initial st -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp '?' s) @@ -618,13 +618,13 @@ let rec next_token loc = parser bp comment_stop bp; between_commands := new_between_commands; t | [< s >] -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_initial st -> let len = ident_tail loc (nstore n 0 s) s in let id = get_buff len in let ep = Stream.count s in comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep - | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart | Unicode.Unknown), _) -> + | AsciiChar | Utf8Token _ -> let t = process_chars loc bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index e2c87bbbf6..f10d746770 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -17,12 +17,6 @@ open Pcoq.Vernac_ let thm_token = G_vernac.thm_token -let hint_proof_using e = function - | Some _ as x -> x - | None -> match Proof_using.get_default_proof_using () with - | None -> None - | Some s -> Some (Gram.entry_parse e (Gram.parsable (Stream.of_string s))) - let hint = Gram.entry_create "hint" (* Proof commands *) @@ -35,8 +29,7 @@ GEXTEND Gram ; command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c - | IDENT "Proof" -> - VernacProof (None,hint_proof_using G_vernac.section_subset_expr None) + | IDENT "Proof" -> VernacProof (None,None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; c = lconstr -> VernacExactProof c | IDENT "Abort" -> VernacAbort None diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 819d236cd3..a5b58b8553 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -580,8 +580,8 @@ GEXTEND Gram starredidentref: [ [ i = identref -> SsSingl i | i = identref; "*" -> SsFwdClose(SsSingl i) - | "Type" -> SsSingl (Loc.tag ~loc:!@loc @@ Id.of_string "Type") - | "Type"; "*" -> SsFwdClose (SsSingl (Loc.tag ~loc:!@loc @@ Id.of_string "Type")) ]] + | "Type" -> SsType + | "Type"; "*" -> SsFwdClose SsType ]] ; ssexpr: [ "35" @@ -1020,8 +1020,7 @@ GEXTEND Gram | IDENT "Term"; qid = smart_global -> LocateTerm qid | IDENT "File"; f = ne_string -> LocateFile f | IDENT "Library"; qid = global -> LocateLibrary qid - | IDENT "Module"; qid = global -> LocateModule qid - | IDENT "Ltac"; qid = global -> LocateTactic qid ] ] + | IDENT "Module"; qid = global -> LocateModule qid ] ] ; option_value: [ [ n = integer -> IntValue (Some n) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 1524079f42..6d3d4b7432 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -10,7 +10,7 @@ open Context.Named.Declaration let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body) : Safe_typing.private_constants Entries.const_entry_body = - Future.chain ~pure:true x begin fun ((b,ctx),fx) -> + Future.chain x begin fun ((b,ctx),fx) -> (f b , ctx) , fx end diff --git a/plugins/extraction/CHANGES b/plugins/extraction/CHANGES index cf97ae3ab8..4bc3dba36e 100644 --- a/plugins/extraction/CHANGES +++ b/plugins/extraction/CHANGES @@ -54,7 +54,7 @@ but also a few steps toward a more user-friendly extraction: * bug fixes: - many concerning Records. -- a Stack Overflow with mutual inductive (PR#320) +- a Stack Overflow with mutual inductive (BZ#320) - some optimizations have been removed since they were not type-safe: For example if e has type: type 'x a = A Then: match e with A -> A -----X----> e @@ -125,7 +125,7 @@ but also a few steps toward a more user-friendly extraction: - the dummy constant "__" have changed. see README - - a few bug-fixes (#191 and others) + - a few bug-fixes (BZ#191 and others) 7.2 -> 7.3 diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index f503c572d0..3c46d5c43b 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -342,7 +342,7 @@ let rec extract_structure env mp reso ~all = function and extract_mexpr env mp = function | MEwith _ -> assert false (* no 'with' syntax for modules *) - | me when lang () != Ocaml -> + | me when lang () != Ocaml || Table.is_extrcompute () -> (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) @@ -570,11 +570,12 @@ let print_structure_to_file (fn,si,mo) dry struc = let reset () = Visit.reset (); reset_tables (); reset_renaming_tables Everything -let init modular library = +let init ?(compute=false) modular library = check_inside_section (); check_inside_module (); set_keywords (descr ()).keywords; set_modular modular; set_library library; + set_extrcompute compute; reset (); if modular && lang () == Scheme then error_scheme () @@ -684,8 +685,22 @@ let extraction_library is_rec m = List.iter print struc; reset () +(** For extraction compute, we flatten all the module structure, + getting rid of module types or unapplied functors *) + +let flatten_structure struc = + let rec flatten_elem (lab,elem) = match elem with + |SEdecl d -> [d] + |SEmodtype _ -> [] + |SEmodule m -> match m.ml_mod_expr with + |MEfunctor _ -> [] + |MEident _ | MEapply _ -> assert false (* should be expanded *) + |MEstruct (_,elems) -> flatten_elems elems + and flatten_elems l = List.flatten (List.map flatten_elem l) + in flatten_elems (List.flatten (List.map snd struc)) + let structure_for_compute c = - init false false; + init false false ~compute:true; let env = Global.env () in let ast, mlt = Extraction.extract_constr env c in let ast = Mlutil.normalize ast in @@ -694,8 +709,7 @@ let structure_for_compute c = let () = ast_iter_references add_ref add_ref add_ref ast in let refs = Refset.elements !refs in let struc = optimize_struct (refs,[]) (mono_environment refs []) in - let flatstruc = List.map snd (List.flatten (List.map snd struc)) in - flatstruc, ast, mlt + (flatten_structure struc), ast, mlt (* For the test-suite : extraction to a temporary file + run ocamlc on it *) diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 5769ff1176..7bbb825b10 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -34,5 +34,4 @@ val print_one_decl : (* Used by Extraction Compute *) val structure_for_compute : - Term.constr -> - Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type + Term.constr -> (Miniml.ml_decl list) * Miniml.ml_ast * Miniml.ml_type diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 0f537abece..f708307c38 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -145,7 +145,7 @@ let rec pp_expr par env args = | MLrel n -> let id = get_db_name n env in (* Try to survive to the occurrence of a Dummy rel. - TODO: we should get rid of this hack (cf. #592) *) + TODO: we should get rid of this hack (cf. BZ#592) *) let id = if Id.equal id dummy_name then Id.of_string "__" else id in apply (Id.print id) | MLapp (f,args') -> diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index edebba49df..5e967ef379 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -187,8 +187,6 @@ type ml_structure = (ModPath.t * ml_module_structure) list type ml_signature = (ModPath.t * ml_module_sig) list -type ml_flat_structure = ml_structure_elem list - type unsafe_needs = { mldummy : bool; tdummy : bool; diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index a4c2bcd883..b01b0198d5 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -127,11 +127,15 @@ let rec mgu = function | Taxiom, Taxiom -> () | _ -> raise Impossible -let needs_magic p = try mgu p; false with Impossible -> true +let skip_typing () = lang () == Scheme || is_extrcompute () -let put_magic_if b a = if b && lang () != Scheme then MLmagic a else a +let needs_magic p = + if skip_typing () then false + else try mgu p; false with Impossible -> true -let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a +let put_magic_if b a = if b then MLmagic a else a + +let put_magic p a = if needs_magic p then MLmagic a else a let generalizable a = lang () != Ocaml || @@ -769,6 +773,20 @@ let eta_red e = else e | _ -> e +(* Performs an eta-reduction when the core is atomic, + or otherwise returns None *) + +let atomic_eta_red e = + let ids,t = collect_lams e in + let n = List.length ids in + match t with + | MLapp (f,a) when test_eta_args_lift 0 n a -> + (match f with + | MLrel k when k>n -> Some (MLrel (k-n)) + | MLglob _ | MLexn _ | MLdummy _ -> Some f + | _ -> None) + | _ -> None + (*s Computes all head linear beta-reductions possible in [(t a)]. Non-linear head beta-redex become let-in. *) @@ -1053,6 +1071,10 @@ let rec simpl o = function simpl o (MLcase(typ,e,br')) | MLmagic(MLdummy _ as e) when lang () == Haskell -> e | MLmagic(MLexn _ as e) -> e + | MLlam _ as e -> + (match atomic_eta_red e with + | Some e' -> e' + | None -> ast_map (simpl o) e) | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 30e3b520f9..995d5fd19d 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -250,6 +250,11 @@ let modular () = !modular_ref let set_library b = library_ref := b let library () = !library_ref +let extrcompute = ref false + +let set_extrcompute b = extrcompute := b +let is_extrcompute () = !extrcompute + (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 7e47d0bc81..cc93f294b3 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -165,6 +165,9 @@ val modular : unit -> bool val set_library : bool -> unit val library : unit -> bool +val set_extrcompute : bool -> unit +val is_extrcompute : unit -> bool + (*s Table for custom inlining *) val to_inline : global_reference -> bool diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 1e8854249a..76fcd5ec87 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -549,3 +549,12 @@ type tcc_lemma_value = | Undefined | Value of Term.constr | Not_needed + +(* We only "purify" on exceptions *) +let funind_purify f x = + let st = Vernacentries.freeze_interp_state `No in + try f x + with e -> + let e = CErrors.push e in + Vernacentries.unfreeze_interp_state st; + Exninfo.iraise e diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 2e2ced790e..d41abee87e 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -123,3 +123,5 @@ type tcc_lemma_value = | Undefined | Value of Term.constr | Not_needed + +val funind_purify : ('a -> 'b) -> ('a -> 'b) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 2997537664..93317fce1b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -570,6 +570,11 @@ let rec reflexivity_with_destruct_cases g = with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in + let my_inj_flags = Some { + Equality.keep_proof_equalities = false; + injection_in_context = false; (* for compatibility, necessary *) + injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) + } in let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> @@ -580,8 +585,8 @@ let rec reflexivity_with_destruct_cases g = | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g + else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g ) @@ -759,7 +764,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let funs = Array.of_list funs and graphs = Array.of_list graphs in let map (c, u) = mkConstU (c, EInstance.make u) in let funs_constr = Array.map map funs in - States.with_state_protection_on_exception + (* XXX STATE Why do we need this... why is the toplevel protection not enought *) + funind_purify (fun () -> let env = Global.env () in let evd = ref (Evd.from_env env) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 74c454334e..76f859ed72 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1595,7 +1595,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num spc () ++ str"is defined" ) ) in - States.with_state_protection_on_exception (fun () -> + (* 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 diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index a7aebf9e15..65c186a419 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -91,12 +91,12 @@ let elimOnConstrWithHoles tac with_evars c = (fun c -> tac with_evars (Some (None,ElimOnConstr c))) TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] + [ "simplify_eq" ] -> [ dEq ~keep_proofs:None false None ] +| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) false c ] END TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] +| [ "esimplify_eq" ] -> [ dEq ~keep_proofs:None true None ] +| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) true c ] END let discr_main c = elimOnConstrWithHoles discr_tac false c @@ -117,31 +117,31 @@ let discrHyp id = discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) let injection_main with_evars c = - elimOnConstrWithHoles (injClause None) with_evars c + elimOnConstrWithHoles (injClause None None) with_evars c TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] +| [ "injection" ] -> [ injClause None None false None ] +| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) false c ] END TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] +| [ "einjection" ] -> [ injClause None None true None ] +| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) true c ] END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) false None ] + [ injClause None (Some ipat) false None ] | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) false c ] + [ mytclWithHoles (injClause None (Some ipat)) false c ] END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) true None ] + [ injClause None (Some ipat) true None ] | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause (Some ipat)) true c ] + [ mytclWithHoles (injClause None (Some ipat)) true c ] END TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] +| [ "simple" "injection" ] -> [ simpleInjClause None false None ] +| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles (simpleInjClause None) false c ] END let injHyp id = diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 86c983bdd9..c577cb2198 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -340,7 +340,7 @@ GEXTEND Gram command: [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) + Vernacexpr.VernacProof (Some (in_tac ta), l) | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> Vernacexpr.VernacProof (ta,Some l) ] ] @@ -482,6 +482,11 @@ VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] END +VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY +| [ "Locate" "Ltac" reference(r) ] -> + [ Tacentries.print_located_tactic r ] +END + let pr_ltac_ref = Libnames.pr_reference let pr_tacdef_body tacdef_body = diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index 12b4c81fc4..3972b7aac3 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -1,9 +1,9 @@ Tacarg +Tacsubst +Tacenv Pptactic Pltac Taccoerce -Tacsubst -Tacenv Tactic_debug Tacintern Tacentries diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index d8bd166208..d588c888c4 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -336,7 +336,7 @@ type 'a extra_genarg_printer = let pr_ltac_constant kn = if !Flags.in_debugger then KerName.print kn else try - pr_qualid (Nametab.shortest_qualid_of_tactic kn) + pr_qualid (Tacenv.shortest_qualid_of_tactic kn) with Not_found -> (* local tactic not accessible anymore *) str "<" ++ KerName.print kn ++ str ">" diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index c79d5b389f..d9da954fe6 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -93,7 +93,7 @@ val pr_alias_key : Names.KerName.t -> Pp.t val pr_alias : (Val.t -> Pp.t) -> int -> Names.KerName.t -> Val.t list -> Pp.t -val pr_ltac_constant : Nametab.ltac_constant -> Pp.t +val pr_ltac_constant : ltac_constant -> Pp.t val pr_raw_tactic : raw_tactic_expr -> Pp.t diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 32494a8793..9ae8bfe65b 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -367,18 +367,30 @@ let do_profile s call_trace tac = let get_local_profiling_results () = List.hd Local.(!stack) -module SM = Map.Make(Stateid.Self) +(* We maintain our own cache of document data, given that the + semantics of the STM implies that synchronized state for opaque + proofs will be lost on QED. This provides some complications later + on as we will have to simulate going back on the document on our + own. *) +module DData = struct + type t = Feedback.doc_id * Stateid.t + let compare x y = Pervasives.compare x y +end + +module SM = Map.Make(DData) let data = ref SM.empty let _ = Feedback.(add_feeder (function - | { id = s; contents = Custom (_, "ltacprof_results", xml) } -> + | { doc_id = d; + span_id = s; + contents = Custom (_, "ltacprof_results", xml) } -> let results = to_ltacprof_results xml in let other_results = (* Multi success can cause this *) - try SM.find s !data + try SM.find (d,s) !data with Not_found -> empty_treenode root in - data := SM.add s (merge_roots results other_results) !data + data := SM.add (d,s) (merge_roots results other_results) !data | _ -> ())) let reset_profile () = @@ -388,7 +400,10 @@ let reset_profile () = (* ******************** *) let print_results_filter ~cutoff ~filter = - let valid id _ = Stm.state_of_id id <> `Expired in + (* The STM doesn't provide yet a proper document query and traversal + API, thus we need to re-check if some states are current anymore + (due to backtracking) using the `state_of_id` API. *) + let valid (did,id) _ = Stm.(state_of_id ~doc:(get_doc did) id) <> `Expired in data := SM.filter valid !data; let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index fd791a9101..1809f0fcdb 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1935,7 +1935,12 @@ let default_morphism sign m = let evars, mor = resolve_one_typeclass env (goalevars evars) morph in mor, proper_projection 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 global binders a aeq t n = + warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in @@ -1954,7 +1959,12 @@ let make_tactic name = let tacname = Qualid (Loc.tag tacpath) in TacArg (Loc.tag @@ TacCall (Loc.tag (tacname, []))) +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 glob m n = + warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index a8d518fbd8..0bf6e3d155 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -409,7 +409,7 @@ let create_ltac_quotation name cast (e, l) = type tacdef_kind = | NewTac of Id.t - | UpdateTac of Nametab.ltac_constant + | UpdateTac of Tacexpr.ltac_constant let is_defined_tac kn = try ignore (Tacenv.interp_ltac kn); true with Not_found -> false @@ -441,7 +441,7 @@ let register_ltac local tacl = | Tacexpr.TacticRedefinition (ident, body) -> let loc = loc_of_reference ident in let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) + try Tacenv.locate_tactic (snd (qualid_of_reference ident)) with Not_found -> CErrors.user_err ?loc (str "There is no Ltac named " ++ pr_reference ident ++ str ".") @@ -464,18 +464,20 @@ let register_ltac local tacl = let defs () = (** Register locally the tactic to handle recursivity. This function affects the whole environment, so that we transactify it afterwards. *) - let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let iter_rec (sp, kn) = Tacenv.push_tactic (Nametab.Until 1) sp kn in let () = List.iter iter_rec recvars in List.map map rfun in - let defs = Future.transactify defs () in + (* STATE XXX: Review what is going on here. Why does this needs + protection? Why is not the STM level protection enough? Fishy *) + let defs = States.with_state_protection defs () in let iter (def, tac) = match def with | NewTac id -> Tacenv.register_ltac false local id tac; Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") | UpdateTac kn -> Tacenv.redefine_ltac local kn tac; - let name = Nametab.shortest_qualid_of_tactic kn in + let name = Tacenv.shortest_qualid_of_tactic kn in Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") in List.iter iter defs @@ -488,7 +490,7 @@ let print_ltacs () = let entries = List.sort sort entries in let map (kn, entry) = let qid = - try Some (Nametab.shortest_qualid_of_tactic kn) + try Some (Tacenv.shortest_qualid_of_tactic kn) with Not_found -> None in match qid with @@ -506,6 +508,31 @@ let print_ltacs () = in Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) +let locatable_ltac = "Ltac" + +let () = + let open Prettyp in + let locate qid = try Some (Tacenv.locate_tactic qid) with Not_found -> None in + let locate_all = Tacenv.locate_extended_all_tactic in + let shortest_qualid = Tacenv.shortest_qualid_of_tactic in + let name kn = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in + let print kn = + let qid = qualid_of_path (Tacenv.path_of_tactic kn) in + Tacintern.print_ltac qid + in + let about = name in + register_locatable locatable_ltac { + locate; + locate_all; + shortest_qualid; + name; + print; + about; + } + +let print_located_tactic qid = + Feedback.msg_notice (Prettyp.print_located_other locatable_ltac qid) + (** Grammar *) let () = diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index aa8f4efe65..ab2c6b3073 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -62,3 +62,6 @@ val create_ltac_quotation : string -> val print_ltacs : unit -> unit (** Display the list of ltac definitions currently available. *) + +val print_located_tactic : Libnames.reference -> unit +(** Display the absolute name of a tactic. *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index 13b44f0e2c..8c59a36fa6 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -11,6 +11,42 @@ open Pp open Names open Tacexpr +(** Nametab for tactics *) + +(** TODO: Share me somewhere *) +module FullPath = +struct + open Libnames + type t = full_path + let equal = eq_full_path + let to_string = string_of_path + let repr sp = + let dir,id = repr_path sp in + id, (DirPath.repr dir) +end + +module KnTab = Nametab.Make(FullPath)(KerName) + +let tactic_tab = Summary.ref ~name:"LTAC-NAMETAB" (KnTab.empty, KNmap.empty) + +let push_tactic vis sp kn = + let (tab, revtab) = !tactic_tab in + let tab = KnTab.push vis sp kn tab in + let revtab = KNmap.add kn sp revtab in + tactic_tab := (tab, revtab) + +let locate_tactic qid = KnTab.locate qid (fst !tactic_tab) + +let locate_extended_all_tactic qid = KnTab.find_prefixes qid (fst !tactic_tab) + +let exists_tactic kn = KnTab.exists kn (fst !tactic_tab) + +let path_of_tactic kn = KNmap.find kn (snd !tactic_tab) + +let shortest_qualid_of_tactic kn = + let sp = KNmap.find kn (snd !tactic_tab) in + KnTab.shortest_qualid Id.Set.empty sp (fst !tactic_tab) + (** Tactic notations (TacAlias) *) type alias = KerName.t @@ -103,19 +139,19 @@ let replace kn path t = let load_md i ((sp, kn), (local, id, b, t)) = match id with | None -> - let () = if not local then Nametab.push_tactic (Until i) sp kn in + let () = if not local then push_tactic (Until i) sp kn in add kn b t | Some kn0 -> replace kn0 kn t let open_md i ((sp, kn), (local, id, b, t)) = match id with | None -> - let () = if not local then Nametab.push_tactic (Exactly i) sp kn in + let () = if not local then push_tactic (Exactly i) sp kn in add kn b t | Some kn0 -> replace kn0 kn t let cache_md ((sp, kn), (local, id ,b, t)) = match id with | None -> - let () = Nametab.push_tactic (Until 1) sp kn in + let () = push_tactic (Until 1) sp kn in add kn b t | Some kn0 -> replace kn0 kn t @@ -128,7 +164,7 @@ let subst_md (subst, (local, id, b, t)) = let classify_md (local, _, _, _ as o) = Substitute o -let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = +let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 958109e5a7..4ecc978fea 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -7,11 +7,21 @@ (************************************************************************) open Names +open Libnames open Tacexpr open Geninterp (** This module centralizes the various ways of registering tactics. *) +(** {5 Tactic naming} *) + +val push_tactic : Nametab.visibility -> full_path -> ltac_constant -> unit +val locate_tactic : qualid -> ltac_constant +val locate_extended_all_tactic : qualid -> ltac_constant list +val exists_tactic : full_path -> bool +val path_of_tactic : ltac_constant -> full_path +val shortest_qualid_of_tactic : ltac_constant -> qualid + (** {5 Tactic notations} *) type alias = KerName.t diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 64da097deb..2c36faeff4 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -10,13 +10,14 @@ open Loc open Names open Constrexpr open Libnames -open Nametab open Genredexpr open Genarg open Pattern open Misctypes open Locus +type ltac_constant = KerName.t + type direction_flag = bool (* true = Left-to-right false = right-to-right *) type lazy_flag = | General (* returns all possible successes *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index fc6ee6aab6..99d7684d36 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -118,7 +118,7 @@ let intern_constr_reference strict ist = function let intern_isolated_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in - TacCall (Loc.tag ?loc (ArgArg (loc,locate_tactic qid),[])) + TacCall (Loc.tag ?loc (ArgArg (loc,Tacenv.locate_tactic qid),[])) let intern_isolated_tactic_reference strict ist r = (* An ltac reference *) @@ -137,7 +137,7 @@ let intern_isolated_tactic_reference strict ist r = let intern_applied_global_tactic_reference r = let (loc,qid) = qualid_of_reference r in - ArgArg (loc,locate_tactic qid) + ArgArg (loc,Tacenv.locate_tactic qid) let intern_applied_tactic_reference ist r = (* An ltac reference *) @@ -722,7 +722,7 @@ let pr_ltac_fun_arg n = spc () ++ Name.print n let print_ltac id = try - let kn = Nametab.locate_tactic id in + let kn = Tacenv.locate_tactic id in let entries = Tacenv.ltac_entries () in let tac = KNmap.find kn entries in let filter mp = diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 18348bc113..20f117ff4f 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1394,7 +1394,13 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval else Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) - | _ -> fail + | (VFun(appl,trace,olfun,[],body)) -> + let extra_args = List.length largs in + Tacticals.New.tclZEROMSG (str "Illegal tactic application: got " ++ + str (string_of_int extra_args) ++ + str " extra " ++ str (String.plural extra_args "argument") ++ + str ".") + | VRec(_,_) -> fail else fail (* Gives the tactic corresponding to the tactic value *) diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 63b8cc4824..18bb7d2dbd 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -203,7 +203,7 @@ module PatternMatching (E:StaticEnvironment) = struct let pick l = pick l imatching_error - (** Declares a subsitution, a context substitution and a term substitution. *) + (** Declares a substitution, a context substitution and a term substitution. *) let put subst context terms : unit m = let s = { subst ; context ; terms ; lhs = () } in { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 56b3d480eb..ae4857a77c 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -56,10 +56,18 @@ Section MakeRingPol. Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext. + Proof. exact (Radd_ext Reqe). Qed. + + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. + Proof. exact (Rmul_ext Reqe). Qed. + + Add Morphism ropp with signature (req ==> req) as ropp_ext. + Proof. exact (Ropp_ext Reqe). Qed. + + Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. + Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index ae1a563bee..ff69ddefb8 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -50,6 +50,7 @@ let display_time_flag = ref false let display_system_flag = ref false let display_action_flag = ref false let old_style_flag = ref false +let letin_flag = ref true (* Should we reset all variable labels between two runs of omega ? *) @@ -100,6 +101,14 @@ let _ = optread = read reset_flag; optwrite = write reset_flag } +let _ = + declare_bool_option + { optdepr = false; + optname = "Omega takes advantage of context variables with body"; + optkey = ["Omega";"UseLocalDefs"]; + optread = read letin_flag; + optwrite = write letin_flag } + let intref, reset_all_references = let refs = ref [] in (fun n -> let r = ref n in refs := (r,n) :: !refs; r), @@ -376,16 +385,15 @@ let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_eq t1 t2 = mkApp (Lazy.force coq_eq, - [| Lazy.force coq_Z; t1; t2 |]) +let mk_gen_eq ty t1 t2 = mkApp (Lazy.force coq_eq, [| ty; t1; t2 |]) +let mk_eq t1 t2 = mk_gen_eq (Lazy.force coq_Z) t1 t2 let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (Lazy.force coq_and, [| t1; t2 |]) let mk_or t1 t2 = mkApp (Lazy.force coq_or, [| t1; t2 |]) let mk_not t = mkApp (Lazy.force coq_not, [| t |]) -let mk_eq_rel t1 t2 = mkApp (Lazy.force coq_eq, - [| Lazy.force coq_comparison; t1; t2 |]) +let mk_eq_rel t1 t2 = mk_gen_eq (Lazy.force coq_comparison) t1 t2 let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = @@ -1778,11 +1786,25 @@ let destructure_hyps = let type_of = Tacmach.New.pf_unsafe_type_of gl in let decidability = decidability gl in let pf_nf = pf_nf gl in - let rec loop = function - | [] -> (tclTHEN nat_inject coq_omega) - | decl::lit -> - let i = NamedDecl.get_id decl in - Proofview.tclEVARMAP >>= fun sigma -> + let rec loop = function + | [] -> (tclTHEN nat_inject coq_omega) + | LocalDef (i,body,typ) :: lit when !letin_flag -> + Proofview.tclEVARMAP >>= fun sigma -> + begin + try + match destructurate_type sigma (pf_nf typ) with + | Kapp(Nat,_) | Kapp(Z,_) -> + let hid = fresh_id Id.Set.empty (add_suffix i "_eqn") gl in + let hty = mk_gen_eq typ (mkVar i) body in + tclTHEN + (assert_by (Name hid) hty reflexivity) + (loop (LocalAssum (hid, hty) :: lit)) + | _ -> loop lit + with e when catchable_exception e -> loop lit + end + | decl :: lit -> (* variable without body (or !letin_flag isn't set) *) + let i = NamedDecl.get_id decl in + Proofview.tclEVARMAP >>= fun sigma -> begin try match destructurate_prop sigma (NamedDecl.get_type decl) with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 4ffbd5aa8b..c27ac2ea44 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -221,6 +221,7 @@ let mk_N = function module type Int = sig val typ : Term.constr Lazy.t + val is_int_typ : [ `NF ] Proofview.Goal.t -> Term.constr -> bool val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t val opp : Term.constr Lazy.t @@ -287,12 +288,14 @@ let pf_nf gl c = EConstr.Unsafe.to_constr (Tacmach.New.pf_apply Tacred.simpl gl (EConstr.of_constr c)) +let is_int_typ gl t = + match destructurate (pf_nf gl t) with + | Kapp("Z",[]) -> true + | _ -> false + let parse_rel gl t = match destructurate t with - | Kapp("eq",[typ;t1;t2]) -> - (match destructurate (pf_nf gl typ) with - | Kapp("Z",[]) -> Req (t1,t2) - | _ -> Rother) + | Kapp("eq",[typ;t1;t2]) when is_int_typ gl typ -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index a452b1a917..80e00e4e14 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -103,6 +103,8 @@ module type Int = sig (* the coq type of the numbers *) val typ : Term.constr Lazy.t + (* Is a constr expands to the type of these numbers *) + val is_int_typ : [ `NF ] Proofview.Goal.t -> Term.constr -> bool (* the operations on the numbers *) val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 517df41d93..661485aeeb 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -547,22 +547,33 @@ let display_gl env t_concl t_lhyps = Printf.printf "REIFED PROBLEM\n\n"; Printf.printf " CONCL: %a\n" pprint t_concl; List.iter - (fun (i,t) -> Printf.printf " %s: %a\n" (Id.to_string i) pprint t) + (fun (i,_,t) -> Printf.printf " %s: %a\n" (Id.to_string i) pprint t) t_lhyps; print_env_reification env +type defined = Defined | Assumed + +let reify_hyp env gl i = + let open Context.Named.Declaration in + let ctxt = (false,[],i,[]) in + match Tacmach.New.pf_get_hyp i gl with + | LocalDef (_,d,t) when Z.is_int_typ gl (EConstr.Unsafe.to_constr t) -> + let d = EConstr.Unsafe.to_constr d in + let dummy = Lazy.force coq_True in + let p = mk_equation env ctxt dummy Eq (Term.mkVar i) d in + i,Defined,p + | LocalDef (_,_,t) | LocalAssum (_,t) -> + let t = EConstr.Unsafe.to_constr t in + let p = oproposition_of_constr env ctxt gl t in + i,Assumed,p + let reify_gl env gl = let concl = Tacmach.New.pf_concl gl in let concl = EConstr.Unsafe.to_constr concl in - let hyps = Tacmach.New.pf_hyps_types gl in - let hyps = List.map (fun (i,t) -> (i,EConstr.Unsafe.to_constr t)) hyps in - let t_concl = - oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl in - let t_lhyps = - List.map - (fun (i,t) -> i,oproposition_of_constr env (false,[],i,[]) gl t) - hyps - in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let ctxt_concl = (true,[],id_concl,[O_mono]) in + let t_concl = oproposition_of_constr env ctxt_concl gl concl in + let t_lhyps = List.map (reify_hyp env gl) hyps in let () = if !debug then display_gl env t_concl t_lhyps in t_concl, t_lhyps @@ -602,7 +613,7 @@ and destruct_neg_hyp eqns = function let rec destructurate_hyps = function | [] -> [[]] - | (i,t) :: l -> + | (i,_,t) :: l -> let l_syst1 = destruct_pos_hyp [] t in let l_syst2 = destructurate_hyps l in List.cartesian (@) l_syst1 l_syst2 @@ -673,6 +684,9 @@ let rec stated_in_tree = function | Tree(_,t1,t2) -> StateSet.union (stated_in_tree t1) (stated_in_tree t2) | Leaf s -> stated_in_trace s.s_trace +let mk_refl t = + EConstr.of_constr (app coq_refl_equal [|Lazy.force Z.typ; t|]) + let digest_stated_equations env tree = let do_equation st (vars,gens,eqns,ids) = (** We turn the definition of [v] @@ -684,9 +698,7 @@ let digest_stated_equations env tree = (** We then update the environment *) set_reified_atom st.st_var coq_v env; (** The term we'll introduce *) - let term_to_generalize = - EConstr.of_constr (app coq_refl_equal [|Lazy.force Z.typ; coq_v|]) - in + let term_to_generalize = mk_refl coq_v in (** Its representation as equation (but not reified yet, we lack the proper env to do that). *) let term_to_reify = (v_def,Oatom st.st_var) in @@ -954,18 +966,19 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = display_solution_tree stdout solution_tree; print_newline() end; - (** Collect all hypotheses used in the solution tree *) + (** Collect all hypotheses and variables used in the solution tree *) let useful_equa_ids = equas_of_solution_tree solution_tree in - let equations = List.map (get_equation env) (IntSet.elements useful_equa_ids) - in - let hyps_of_eqns = - List.fold_left (fun s e -> Id.Set.add e.e_origin.o_hyp s) Id.Set.empty in - let hyps = hyps_of_eqns equations in - let useful_hypnames = Id.Set.elements (Id.Set.remove id_concl hyps) in - let useful_hyptypes = - List.map (fun id -> List.assoc_f Id.equal id reified_hyps) useful_hypnames + let useful_hypnames, useful_vars = + IntSet.fold + (fun i (hyps,vars) -> + let e = get_equation env i in + Id.Set.add e.e_origin.o_hyp hyps, + vars_of_equations [e] @@ vars) + useful_equa_ids + (Id.Set.empty, vars_of_prop reified_concl) in - let useful_vars = vars_of_equations equations @@ vars_of_prop reified_concl + let useful_hypnames = + Id.Set.elements (Id.Set.remove id_concl useful_hypnames) in (** Parts coming from equations introduced by omega: *) @@ -996,9 +1009,17 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = let reified_concl = reified_of_proposition env reified_concl in let l_reified_terms = List.map - (fun p -> reified_of_proposition env (maximize_prop useful_equa_ids p)) - useful_hyptypes + (fun id -> + match Id.Map.find id reified_hyps with + | Defined,p -> + reified_of_proposition env p, mk_refl (Term.mkVar id) + | Assumed,p -> + reified_of_proposition env (maximize_prop useful_equa_ids p), + EConstr.mkVar id + | exception Not_found -> assert false) + useful_hypnames in + let l_reified_terms, l_reified_hypnames = List.split l_reified_terms in let env_props_reified = mk_plist env.props in let reified_goal = mk_list (Lazy.force coq_proposition) @@ -1007,14 +1028,14 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = app coq_interp_sequent [| reified_concl;env_props_reified;reduced_term_env;reified_goal|] in + let mk_occ id = {o_hyp=id;o_path=[]} in let initial_context = - List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) useful_hypnames in + List.map (fun id -> CCHyp (mk_occ id)) useful_hypnames in let context = - CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in + CCHyp (mk_occ id_concl) :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in - Tactics.generalize - (l_generalize_arg @ List.map EConstr.mkVar useful_hypnames) >> + Tactics.generalize (l_generalize_arg @ l_reified_hypnames) >> Tactics.convert_concl_no_check (EConstr.of_constr reified) Term.DEFAULTcast >> Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic|])) >> show_goal >> @@ -1034,13 +1055,16 @@ let total_reflexive_omega_tactic unsafe = rst_omega_var (); try let env = new_environment () in - let (concl,hyps) as reified_goal = reify_gl env gl in + let (concl,hyps) = reify_gl env gl in (* Register all atom indexes created during reification as omega vars *) set_omega_maxvar (pred (List.length env.terms)); - let full_reified_goal = (id_concl,Pnot concl) :: hyps in + let full_reified_goal = (id_concl,Assumed,Pnot concl) :: hyps in let systems_list = destructurate_hyps full_reified_goal in + let hyps = + List.fold_left (fun s (id,d,p) -> Id.Map.add id (d,p) s) Id.Map.empty hyps + in if !debug then display_systems systems_list; - resolution unsafe env reified_goal systems_list + resolution unsafe env (concl,hyps) systems_list with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system") end diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 56b985aa34..462ffde313 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -56,11 +56,16 @@ Let rI_neq_rO := AFth.(AF_1_neq_0). Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). -Add Morphism radd : radd_ext. Proof. exact (Radd_ext Reqe). Qed. -Add Morphism rmul : rmul_ext. Proof. exact (Rmul_ext Reqe). Qed. -Add Morphism ropp : ropp_ext. Proof. exact (Ropp_ext Reqe). Qed. -Add Morphism rsub : rsub_ext. Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. -Add Morphism rinv : rinv_ext. Proof. exact SRinv_ext. Qed. +Add Morphism radd with signature (req ==> req ==> req) as radd_ext. +Proof. exact (Radd_ext Reqe). Qed. +Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. +Proof. exact (Rmul_ext Reqe). Qed. +Add Morphism ropp with signature (req ==> req) as ropp_ext. +Proof. exact (Ropp_ext Reqe). Qed. +Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. +Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. +Add Morphism rinv with signature (req ==> req) as rinv_ext. +Proof. exact SRinv_ext. Qed. Let eq_trans := Setoid.Seq_trans _ _ Rsth. Let eq_sym := Setoid.Seq_sym _ _ Rsth. @@ -1607,11 +1612,18 @@ Section Complete. Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). Notation "x == y" := (req x y) (at level 70, no associativity). Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid3. + Add Parametric Relation : R req + reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) + symmetry proved by Rsth.(@Equivalence_Symmetric _ _) + transitivity proved by Rsth.(@Equivalence_Transitive _ _) + as R_setoid3. Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. + Proof. exact (Radd_ext Reqe). Qed. + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext3. + Proof. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp with signature (req ==> req) as ropp_ext3. + Proof. exact (Ropp_ext Reqe). Qed. Section AlmostField. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 98ffff4322..8aa0b1c91f 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -48,12 +48,19 @@ Section ZMORPHISM. Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid3. + Add Parametric Relation : R req + reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) + symmetry proved by Rsth.(@Equivalence_Symmetric _ _) + transitivity proved by Rsth.(@Equivalence_Transitive _ _) + as R_setoid3. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. + Proof. exact (Radd_ext Reqe). Qed. + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext3. + Proof. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp with signature (req ==> req) as ropp_ext3. + Proof. exact (Ropp_ext Reqe). Qed. Fixpoint gen_phiPOS1 (p:positive) : R := match p with @@ -103,7 +110,8 @@ Section ZMORPHISM. Section ALMOST_RING. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext3. + Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. @@ -151,7 +159,8 @@ Section ZMORPHISM. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. Let ARth := Rth_ARth Rsth Reqe Rth. - Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext4. + Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. @@ -255,7 +264,11 @@ Section NMORPHISM. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid4. + Add Parametric Relation : R req + reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) + symmetry proved by Rsth.(@Equivalence_Symmetric _ _) + transitivity proved by Rsth.(@Equivalence_Transitive _ _) + as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. Variable SRth : semi_ring_theory 0 1 radd rmul req. @@ -265,8 +278,10 @@ Section NMORPHISM. Let rsub := (@SRsub R radd). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). - Add Morphism radd : radd_ext4. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext4. + Proof. exact (Radd_ext Reqe). Qed. + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext4. + Proof. exact (Rmul_ext Reqe). Qed. Ltac norm := gen_srewrite_sr Rsth Reqe ARth. Definition gen_phiN1 x := @@ -374,15 +389,23 @@ Section NWORDMORPHISM. Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid5. + Add Parametric Relation : R req + reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) + symmetry proved by Rsth.(@Equivalence_Symmetric _ _) + transitivity proved by Rsth.(@Equivalence_Transitive _ _) + as R_setoid5. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext5. + Proof. exact (Radd_ext Reqe). Qed. + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext5. + Proof. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp with signature (req ==> req) as ropp_ext5. + Proof. exact (Ropp_ext Reqe). Qed. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext7. + Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. @@ -555,12 +578,20 @@ Section GEN_DIV. Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. (* Useful tactics *) - Add Setoid R req Rsth as R_set1. + Add Parametric Relation : R req + reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) + symmetry proved by Rsth.(@Equivalence_Symmetric _ _) + transitivity proved by Rsth.(@Equivalence_Transitive _ _) + as R_set1. Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext. + Proof. exact (Radd_ext Reqe). Qed. + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. + Proof. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp with signature (req ==> req) as ropp_ext. + Proof. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. + Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Definition triv_div x y := @@ -859,8 +890,3 @@ Ltac isZcst t := (* *) | _ => constr:(false) end. - - - - - diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index ac54d862c9..a94f8d8df6 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -59,10 +59,18 @@ Section MakeRingPol. Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext. + Proof. exact (Radd_ext Reqe). Qed. + + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext. + Proof. exact (Rmul_ext Reqe). Qed. + + Add Morphism ropp with signature (req ==> req) as ropp_ext. + Proof. exact (Ropp_ext Reqe). Qed. + + Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext. + Proof. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 8dda5ecd34..776ebd808d 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -254,8 +254,12 @@ Section ALMOST_RING. Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. - Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. - Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. + Add Morphism radd with signature (req ==> req ==> req) as radd_ext1. + Proof. exact (SRadd_ext SReqe). Qed. + + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext1. + Proof. exact (SRmul_ext SReqe). Qed. + Variable SRth : semi_ring_theory 0 1 radd rmul req. (** Every semi ring can be seen as an almost ring, by taking : @@ -323,9 +327,15 @@ Section ALMOST_RING. Notation "- x" := (ropp x). Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. + + Add Morphism radd with signature (req ==> req ==> req) as radd_ext2. + Proof. exact (Radd_ext Reqe). Qed. + + Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext2. + Proof. exact (Rmul_ext Reqe). Qed. + + Add Morphism ropp with signature (req ==> req) as ropp_ext2. + Proof. exact (Ropp_ext Reqe). Qed. Section RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. @@ -393,14 +403,29 @@ Section ALMOST_RING. Notation "?=!" := ceqb. Notation "[ x ]" := (phi x). Variable Csth : Equivalence ceq. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. - Add Setoid C ceq Csth as C_setoid. - Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. - Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed. - Add Morphism copp : copp_ext. exact (Ropp_ext Ceqe). Qed. + + Add Parametric Relation : C ceq + reflexivity proved by Csth.(@Equivalence_Reflexive _ _) + symmetry proved by Csth.(@Equivalence_Symmetric _ _) + transitivity proved by Csth.(@Equivalence_Transitive _ _) + as C_setoid. + + Add Morphism cadd with signature (ceq ==> ceq ==> ceq) as cadd_ext. + Proof. exact (Radd_ext Ceqe). Qed. + + Add Morphism cmul with signature (ceq ==> ceq ==> ceq) as cmul_ext. + Proof. exact (Rmul_ext Ceqe). Qed. + + Add Morphism copp with signature (ceq ==> ceq) as copp_ext. + Proof. exact (Ropp_ext Ceqe). Qed. + Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. Variable phi_ext : forall x y, ceq x y -> [x] == [y]. - Add Morphism phi : phi_ext1. exact phi_ext. Qed. + + Add Morphism phi with signature (ceq ==> req) as phi_ext1. + Proof. exact phi_ext. Qed. + Lemma Smorph_opp x : [-!x] == -[x]. Proof. rewrite <- (Rth.(Radd_0_l) [-!x]). diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cf5fdf3184..d37c676e38 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -814,8 +814,8 @@ let ssr_n_tac seed n gl = let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in let fail msg = CErrors.user_err (Pp.str msg) in let tacname = - try Nametab.locate_tactic (Libnames.qualid_of_ident (Id.of_string name)) - with Not_found -> try Nametab.locate_tactic (ssrqid name) + try Tacenv.locate_tactic (Libnames.qualid_of_ident (Id.of_string name)) + with Not_found -> try Tacenv.locate_tactic (ssrqid name) with Not_found -> if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 832044909c..26b5c57675 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -396,7 +396,7 @@ let revtoptac n0 gl = let equality_inj l b id c gl = let msg = ref "" in - try Proofview.V82.of_tactic (Equality.inj l b None c) gl + try Proofview.V82.of_tactic (Equality.inj None l b None c) gl with | Ploc.Exc(_,CErrors.UserError (_,s)) | CErrors.UserError (_,s) diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 1e1a986daa..7b591feada 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -1554,8 +1554,8 @@ END let ssrautoprop gl = try let tacname = - try Nametab.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) - with Not_found -> Nametab.locate_tactic (ssrqid "ssrautoprop") in + try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) + with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in Proofview.V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl with Not_found -> Proofview.V82.of_tactic (Auto.full_trivial []) gl diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 2e5522b83f..e3e34616bf 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -502,16 +502,16 @@ let ungen_upat lhs (sigma, uc, t) u = let nb_cs_proj_args pc f u = let na k = List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in - try match kind_of_term f with - | Prod _ -> na Prod_cs - | Sort s -> na (Sort_cs (family_of_sort s)) - | Const (c',_) when Constant.equal c' pc -> - begin match kind_of_term u.up_f with + let nargs_of_proj t = match kind_of_term t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be the number of arguments including the projected *) - | _ -> assert false - end + | _ -> assert false in + try match kind_of_term f with + | Prod _ -> na Prod_cs + | Sort s -> na (Sort_cs (family_of_sort s)) + | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) | _ -> -1 with Not_found -> -1 diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index cb76df4e8a..0f1a508c8d 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -176,6 +176,12 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let s = ESorts.kind sigma s in lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] + | Proj (p, c) -> + let c2 = Globnames.ConstRef (Projection.constant p) in + let c = Retyping.expand_projection env sigma p c [] in + let _, args = destApp sigma c in + let sk2 = Stack.append_app args sk2 in + lookup_canonical_conversion (proji, Const_cs c2), sk2 | _ -> let (c2, _) = Termops.global_of_constr sigma t2 in lookup_canonical_conversion (proji, Const_cs c2),sk2 diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 39c2ceeba8..1038945c18 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -5,13 +5,11 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp open CErrors open Term open Vars open Environ open Reduction -open Univ open Declarations open Names open Inductive @@ -20,8 +18,6 @@ open Nativecode open Nativevalues open Context.Rel.Declaration -module RelDecl = Context.Rel.Declaration - (** This module implements normalization by evaluation to OCaml code *) exception Find_at of int @@ -177,44 +173,6 @@ let build_case_type dep p realargs c = if dep then mkApp(mkApp(p, realargs), [|c|]) else mkApp(p, realargs) -(* TODO move this function *) -let type_of_rel env n = - env |> lookup_rel n |> RelDecl.get_type |> lift n - -let type_of_prop = mkSort type1_sort - -let type_of_sort s = - match s with - | Prop _ -> type_of_prop - | Type u -> mkType (Univ.super u) - -let type_of_var env id = - let open Context.Named.Declaration in - try env |> lookup_named id |> get_type - with Not_found -> - anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound.") - -let sort_of_product env domsort rangsort = - match (domsort, rangsort) with - (* Product rule (s,Prop,Prop) *) - | (_, Prop Null) -> rangsort - (* Product rule (Prop/Set,Set,Set) *) - | (Prop _, Prop Pos) -> rangsort - (* Product rule (Type,Set,?) *) - | (Type u1, Prop Pos) -> - if is_impredicative_set env then - (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) - rangsort - else - (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (sup u1 type0_univ) - (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (sup type0_univ u2) - (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Null, Type _) -> rangsort - (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (sup u1 u2) - (* normalisation of values *) let branch_of_switch lvl ans bs = @@ -328,15 +286,15 @@ and nf_atom_type env sigma atom = match atom with | Arel i -> let n = (nb_rel env - i) in - mkRel n, type_of_rel env n + mkRel n, Typeops.type_of_relative env n | Aconstant cst -> mkConstU cst, Typeops.type_of_constant_in env cst | Aind ind -> mkIndU ind, Inductiveops.type_of_inductive env ind | Asort s -> - mkSort s, type_of_sort s + mkSort s, Typeops.type_of_sort s | Avar id -> - mkVar id, type_of_var env id + mkVar id, Typeops.type_of_variable env id | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env sigma accu in let ((mind,_),u as ind),allargs = find_rectype_a env ta in @@ -387,7 +345,7 @@ and nf_atom_type env sigma atom = let vn = mk_rel_accu (nb_rel env) in let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env sigma (codom vn) in - mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2) + mkProd(n,dom,codom), Typeops.type_of_product env n s1 s2 | Aevar(ev,ty) -> let ty = nf_type env sigma ty in mkEvar ev, ty diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index a23579609a..e970a1db90 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -171,7 +171,7 @@ let keep_true_projections projs kinds = let filter (p, (_, b)) = if b then Some p else None in List.map_filter filter (List.combine projs kinds) -let cs_pattern_of_constr t = +let cs_pattern_of_constr env t = match kind_of_term t with App (f,vargs) -> begin @@ -180,6 +180,10 @@ let cs_pattern_of_constr t = end | Rel n -> Default_cs, Some n, [] | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] + | Proj (p, c) -> + let { Environ.uj_type = ty } = Typeops.infer env c in + let _, params = Inductive.find_rectype env ty in + Const_cs (ConstRef (Projection.constant p)), None, params @ [c] | Sort s -> Sort_cs (family_of_sort s), None, [] | _ -> begin @@ -190,7 +194,6 @@ let cs_pattern_of_constr t = let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" (fun (sign,env,t,con,proji_sp) -> - let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let env = Termops.push_rels_assum sign env in let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) in let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in @@ -207,14 +210,16 @@ let compute_canonical_projections warn (con,ind) = let v = (mkConstU (con,u)) in let c = Environ.constant_value_in env (con,u) in let sign,t = Reductionops.splay_lam env Evd.empty (EConstr.of_constr c) in + let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in - let lt = List.rev_map (snd %> EConstr.Unsafe.to_constr) sign in + let lt = List.rev_map snd sign in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in let params, projs = List.chop p args in let lpj = keep_true_projections lpj kl in let lps = List.combine lpj projs in + let nenv = Termops.push_rels_assum sign env in let comp = List.fold_left (fun l (spopt,t) -> (* comp=components *) @@ -222,7 +227,7 @@ let compute_canonical_projections warn (con,ind) = | Some proji_sp -> begin try - let patt, n , args = cs_pattern_of_constr t in + let patt, n , args = cs_pattern_of_constr nenv t in ((ConstRef proji_sp, patt, t, n, args) :: l) with Not_found -> if warn then warn_projection_no_head_constant (sign,env,t,con,proji_sp); @@ -324,15 +329,25 @@ let declare_canonical_structure ref = let lookup_canonical_conversion (proj,pat) = assoc_pat pat (Refmap.find proj !object_table) +let decompose_projection sigma c args = + match EConstr.kind sigma c with + | Const (c, u) -> + let n = find_projection_nparams (ConstRef c) in + (** Check if there is some canonical projection attached to this structure *) + let _ = Refmap.find (ConstRef c) !object_table in + let arg = Stack.nth args n in + arg + | Proj (p, c) -> + let _ = Refmap.find (ConstRef (Projection.constant p)) !object_table in + c + | _ -> raise Not_found + let is_open_canonical_projection env sigma (c,args) = let open EConstr in try - let (ref, _) = Termops.global_of_constr sigma c in - let n = find_projection_nparams ref in - (** Check if there is some canonical projection attached to this structure *) - let _ = Refmap.find ref !object_table in + let arg = decompose_projection sigma c args in try - let arg = whd_all env sigma (Stack.nth args n) in + let arg = whd_all env sigma arg in let hd = match EConstr.kind sigma arg with App (hd, _) -> hd | _ -> arg in not (isConstruct sigma hd) with Failure _ -> false diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 5480b14af0..8e2333b349 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -65,7 +65,7 @@ type obj_typ = { o_TCOMPS : constr list } (** ordered *) (** Return the form of the component of a canonical structure *) -val cs_pattern_of_constr : constr -> cs_pattern * int option * constr list +val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * constr list val pr_cs_pattern : cs_pattern -> Pp.t diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 079524f344..56f8b33e01 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -214,7 +214,6 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = type_of_inductive_knowing_conclusion env sigma (spec, EInstance.kind sigma u) conclty | Const (cst, u) -> let t = constant_type_in env (cst, EInstance.kind sigma u) in - (* TODO *) sigma, EConstr.of_constr t | Var id -> sigma, type_of_var env id | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index d52c3932df..e8f7e2bbaf 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -501,6 +501,10 @@ let expand_key ts env sigma = function in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red | None -> None +let isApp_or_Proj sigma c = + match kind sigma c with + | App _ | Proj _ -> true + | _ -> false type unirec_flags = { at_top: bool; @@ -1020,7 +1024,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = - if isApp sigma cM then + if isApp_or_Proj sigma cM then let f1l1 = whd_nored_state sigma (cM,Stack.empty) in if is_open_canonical_projection curenv sigma f1l1 then let f2l2 = whd_nored_state sigma (cN,Stack.empty) in @@ -1036,7 +1040,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e error_cannot_unify (fst curenvnb) sigma (cM,cN) else try f1 () with e when precatchable_exception e -> - if isApp sigma cN then + if isApp_or_Proj sigma cN then let f2l2 = whd_nored_state sigma (cN, Stack.empty) in if is_open_canonical_projection curenv sigma f2l2 then let f1l1 = whd_nored_state sigma (cM, Stack.empty) in diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 10dd42ea91..d1158b3d6f 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -524,7 +524,16 @@ open Decl_kinds | PrintStrategy (Some qid) -> keyword "Print Strategy" ++ pr_smart_global qid - let pr_using e = str (Proof_using.to_string e) + let pr_using e = + let rec aux = function + | SsEmpty -> "()" + | SsType -> "(Type)" + | SsSingl (_,id) -> "("^Id.to_string id^")" + | SsCompl e -> "-" ^ aux e^"" + | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" + | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" + | SsFwdClose e -> "("^aux e^")*" + in Pp.str (aux e) let rec pr_vernac_body v = let return = tag_vernac v in @@ -1156,7 +1165,7 @@ open Decl_kinds | LocateFile f -> keyword "File" ++ spc() ++ qs f | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid - | LocateTactic qid -> keyword "Ltac" ++ spc () ++ pr_ltac_ref qid + | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid in return (keyword "Locate" ++ spc() ++ pr_locate loc) | VernacRegister (id, RegisterInline) -> diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index b88eed4843..cf27b413c0 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -15,5 +15,8 @@ val pr_rec_definition : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation lis (** Prints a vernac expression *) val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.t +(** Prints a "proof using X" clause. *) +val pr_using : Vernacexpr.section_subset_expr -> Pp.t + (** Prints a vernac expression and closes it with a dot. *) val pr_vernac : Vernacexpr.vernac_expr -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 09859157c3..fdaeded878 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -304,14 +304,33 @@ let print_inductive_argument_scopes = (*********************) (* "Locate" commands *) +type 'a locatable_info = { + locate : qualid -> 'a option; + locate_all : qualid -> 'a list; + shortest_qualid : 'a -> qualid; + name : 'a -> Pp.t; + print : 'a -> Pp.t; + about : 'a -> Pp.t; +} + +type locatable = Locatable : 'a locatable_info -> locatable + type logical_name = | Term of global_reference | Dir of global_dir_reference | Syntactic of kernel_name | ModuleType of module_path - | Tactic of Nametab.ltac_constant + | Other : 'a * 'a locatable_info -> logical_name | Undefined of qualid +(** Generic table for objects that are accessible through a name. *) +let locatable_map : locatable String.Map.t ref = ref String.Map.empty + +let register_locatable name f = + locatable_map := String.Map.add name (Locatable f) !locatable_map + +exception ObjFound of logical_name + let locate_any_name ref = let (loc,qid) = qualid_of_reference ref in try Term (Nametab.locate qid) @@ -321,7 +340,13 @@ let locate_any_name ref = try Dir (Nametab.locate_dir qid) with Not_found -> try ModuleType (Nametab.locate_modtype qid) - with Not_found -> Undefined qid + with Not_found -> + let iter _ (Locatable info) = match info.locate qid with + | None -> () + | Some ans -> raise (ObjFound (Other (ans, info))) + in + try String.Map.iter iter !locatable_map; Undefined qid + with ObjFound obj -> obj let pr_located_qualid = function | Term ref -> @@ -344,8 +369,7 @@ let pr_located_qualid = function str s ++ spc () ++ pr_dirpath dir | ModuleType mp -> str "Module Type" ++ spc () ++ pr_path (Nametab.path_of_modtype mp) - | Tactic kn -> - str "Ltac" ++ spc () ++ pr_path (Nametab.path_of_tactic kn) + | Other (obj, info) -> info.name obj | Undefined qid -> pr_qualid qid ++ spc () ++ str "not a defined object." @@ -383,10 +407,6 @@ let locate_term qid = in List.map expand (Nametab.locate_extended_all qid) -let locate_tactic qid = - let all = Nametab.locate_extended_all_tactic qid in - List.map (fun kn -> (Tactic kn, Nametab.shortest_qualid_of_tactic kn)) all - let locate_module qid = let all = Nametab.locate_extended_all_dir qid in let map dir = match dir with @@ -408,13 +428,30 @@ let locate_modtype qid = in modtypes @ List.map_filter map all +let locate_other s qid = + let Locatable info = String.Map.find s !locatable_map in + let ans = info.locate_all qid in + let map obj = (Other (obj, info), info.shortest_qualid obj) in + List.map map ans + +type locatable_kind = +| LocTerm +| LocModule +| LocOther of string +| LocAny + let print_located_qualid name flags ref = let (loc,qid) = qualid_of_reference ref in - let located = [] in - let located = if List.mem `LTAC flags then locate_tactic qid @ located else located in - let located = if List.mem `MODTYPE flags then locate_modtype qid @ located else located in - let located = if List.mem `MODULE flags then locate_module qid @ located else located in - let located = if List.mem `TERM flags then locate_term qid @ located else located in + let located = match flags with + | LocTerm -> locate_term qid + | LocModule -> locate_modtype qid @ locate_module qid + | LocOther s -> locate_other s qid + | LocAny -> + locate_term qid @ + locate_modtype qid @ + locate_module qid @ + String.Map.fold (fun s _ accu -> locate_other s qid @ accu) !locatable_map [] + in match located with | [] -> let (dir,id) = repr_qualid qid in @@ -432,10 +469,10 @@ let print_located_qualid name flags ref = else mt ()) ++ display_alias o)) l -let print_located_term ref = print_located_qualid "term" [`TERM] ref -let print_located_tactic ref = print_located_qualid "tactic" [`LTAC] ref -let print_located_module ref = print_located_qualid "module" [`MODULE; `MODTYPE] ref -let print_located_qualid ref = print_located_qualid "object" [`TERM; `LTAC; `MODULE; `MODTYPE] ref +let print_located_term ref = print_located_qualid "term" LocTerm ref +let print_located_other s ref = print_located_qualid s (LocOther s) ref +let print_located_module ref = print_located_qualid "module" LocModule ref +let print_located_qualid ref = print_located_qualid "object" LocAny ref (******************************************) (**** Printing declarations and judgments *) @@ -765,12 +802,13 @@ let print_any_name = function | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp - | Tactic kn -> mt () (** TODO *) + | Other (obj, info) -> info.print obj | Undefined qid -> try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - str |> Global.lookup_named |> NamedDecl.set_id str |> print_named_decl + str |> Global.lookup_named |> print_named_decl + with Not_found -> user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") @@ -802,7 +840,7 @@ let print_opaque_name qid = let open EConstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - env |> lookup_named id |> NamedDecl.set_id id |> print_named_decl + env |> lookup_named id |> print_named_decl let print_about_any ?loc k = match k with @@ -822,8 +860,9 @@ let print_about_any ?loc k = v 0 ( print_syntactic_def kn ++ fnl () ++ hov 0 (str "Expands to: " ++ pr_located_qualid k)) - | Dir _ | ModuleType _ | Tactic _ | Undefined _ -> + | Dir _ | ModuleType _ | Undefined _ -> hov 0 (pr_located_qualid k) + | Other (obj, info) -> hov 0 (info.about obj) let print_about = function | ByNotation (loc,(ntn,sc)) -> diff --git a/printing/prettyp.mli b/printing/prettyp.mli index f4277b6c50..dbd1011593 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -50,12 +50,34 @@ val print_all_instances : unit -> Pp.t val inspect : int -> Pp.t -(** Locate *) +(** {5 Locate} *) + +type 'a locatable_info = { + locate : qualid -> 'a option; + (** Locate the most precise object with the provided name if any. *) + locate_all : qualid -> 'a list; + (** Locate all objects whose name is a suffix of the provided name *) + shortest_qualid : 'a -> qualid; + (** Return the shortest name in the current context *) + name : 'a -> Pp.t; + (** Data as printed by the Locate command *) + print : 'a -> Pp.t; + (** Data as printed by the Print command *) + about : 'a -> Pp.t; + (** Data as printed by the About command *) +} +(** Generic data structure representing locatable objects. *) + +val register_locatable : string -> 'a locatable_info -> unit +(** Define a new type of locatable objects that can be reached via the + corresponding generic vernacular commands. The string should be a unique + name describing the kind of objects considered and that is added as a + grammar command prefix for vernacular commands Locate. *) val print_located_qualid : reference -> Pp.t val print_located_term : reference -> Pp.t -val print_located_tactic : reference -> Pp.t val print_located_module : reference -> Pp.t +val print_located_other : string -> reference -> Pp.t type object_pr = { print_inductive : mutual_inductive -> Pp.t; diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 23f96b5a32..469e1a011e 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -156,7 +156,7 @@ let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let ce = if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce else { ce with - const_entry_body = Future.chain ~pure:true ce.const_entry_body + const_entry_body = Future.chain ce.const_entry_body (fun (pt, _) -> pt, ()) } in let (cb, ctx), () = Future.force ce.const_entry_body in let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index f80cb7cc66..4f575ab4be 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -110,10 +110,6 @@ module Strict = struct let push (b:t) pr = focus bullet_cond (b::get_bullets pr) 1 pr - (* Used only in the next function. - TODO: use a recursive function instead? *) - exception SuggestFound of t - let suggest_bullet (prf : proof): suggestion = if is_done prf then ProofFinished else if not (no_focused_goal prf) @@ -122,24 +118,24 @@ module Strict = struct | b::_ -> Unfinished b | _ -> NoBulletInUse else (* There is no goal under focus but some are unfocussed, - let us look at the bullet needed. If no *) - let pcobaye = ref prf in - try - while true do - let pcobaye', b = pop !pcobaye in - (* pop went well, this means that there are no more goals - *under this* bullet b, see if a new b can be pushed. *) - (try let _ = push b pcobaye' in (* push didn't fail so a new b can be pushed. *) - raise (SuggestFound b) - with SuggestFound _ as e -> raise e - | _ -> ()); (* b could not be pushed, so we must look for a outer bullet *) - pcobaye := pcobaye' - done; - assert false - with SuggestFound b -> Suggest b - | _ -> NeedClosingBrace (* No push was possible, but there are still - subgoals somewhere: there must be a "}" to use. *) - + let us look at the bullet needed. *) + let rec loop prf = + match pop prf with + | prf, b -> + (* pop went well, this means that there are no more goals + *under this* bullet b, see if a new b can be pushed. *) + begin + try ignore (push b prf); Suggest b + with _ -> + (* b could not be pushed, so we must look for a outer bullet *) + loop prf + end + | exception _ -> + (* No pop was possible, but there are still + subgoals somewhere: there must be a "}" to use. *) + NeedClosingBrace + in + loop prf let rec pop_until (prf : proof) bul : proof = let prf', b = pop prf in diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index cd4d1dcf64..621178982d 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -373,11 +373,11 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let _, univs = Evd.check_univ_decl (Evd.from_ctx ctx) universe_decl in (univs, typ), ((body, Univ.ContextSet.empty), eff) in - fun t p -> Future.split2 (Future.chain ~pure:true p (make_body t)) + fun t p -> Future.split2 (Future.chain p (make_body t)) else fun t p -> Future.from_val (univctx, nf t), - Future.chain ~pure:true p (fun (pt,eff) -> + Future.chain p (fun (pt,eff) -> (* Deferred proof, we already checked the universe declaration with the initial universes, ensure that the final universes respect the declaration as well. If the declaration is non-extensible, diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index eaf0c693e1..058e839b47 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -1,7 +1,6 @@ Miscprint Goal Evar_refiner -Proof_using Proof_type Logic Refine diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index a4b35ad60f..01b75e4964 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -11,7 +11,7 @@ open Stm module Util : sig val simple_goal : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool -val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ] +val is_focused_goal_simple : doc:Stm.doc -> Stateid.t -> [ `Simple of Goal.goal list | `Not ] type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] @@ -43,10 +43,10 @@ let simple_goal sigma g gs = Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && not (List.exists (Proofview.depends_on sigma g) gs) -let is_focused_goal_simple id = - match state_of_id id with +let is_focused_goal_simple ~doc id = + match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not - | `Valid (Some { proof }) -> + | `Valid (Some { Vernacentries.proof }) -> let proof = Proof_global.proof_of_state proof in let focused, r1, r2, r3, sigma = Proof.proof proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in @@ -88,8 +88,8 @@ let static_bullet ({ entry_point; prev_node } as view) = | _ -> `Stop) entry_point | _ -> assert false -let dynamic_bullet { dynamic_switch = id; carry_on_data = b } = - match is_focused_goal_simple id with +let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = + match is_focused_goal_simple ~doc id with | `Simple focused -> `ValidBlock { base_state = id; @@ -116,8 +116,8 @@ let static_curly_brace ({ entry_point; prev_node } as view) = `Cont (nesting + 1,node) | _ -> `Cont (nesting,node)) (-1, entry_point) -let dynamic_curly_brace { dynamic_switch = id } = - match is_focused_goal_simple id with +let dynamic_curly_brace doc { dynamic_switch = id } = + match is_focused_goal_simple ~doc id with | `Simple focused -> `ValidBlock { base_state = id; @@ -138,8 +138,8 @@ let static_par { entry_point; prev_node } = Some { block_stop = entry_point.id; block_start = pid; dynamic_switch = pid; carry_on_data = unit_val } -let dynamic_par { dynamic_switch = id } = - match is_focused_goal_simple id with +let dynamic_par doc { dynamic_switch = id } = + match is_focused_goal_simple ~doc id with | `Simple focused -> `ValidBlock { base_state = id; @@ -167,9 +167,9 @@ let static_indent ({ entry_point; prev_node } as view) = carry_on_data = of_vernac_expr_val entry_point.ast } ) last_tac -let dynamic_indent { dynamic_switch = id; carry_on_data = e } = +let dynamic_indent doc { dynamic_switch = id; carry_on_data = e } = Printf.eprintf "%s\n" (Stateid.to_string id); - match is_focused_goal_simple id with + match is_focused_goal_simple ~doc id with | `Simple [] -> `Leaks | `Simple focused -> let but_last = List.tl (List.rev focused) in diff --git a/stm/proofBlockDelimiter.mli b/stm/proofBlockDelimiter.mli index e23a1d1c18..5cff0a8a72 100644 --- a/stm/proofBlockDelimiter.mli +++ b/stm/proofBlockDelimiter.mli @@ -21,7 +21,7 @@ type). `Simple carries the list of focused goals. *) val simple_goal : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool -val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ] +val is_focused_goal_simple : doc:Stm.doc -> Stateid.t -> [ `Simple of Goal.goal list | `Not ] type 'a until = [ `Stop | `Found of Stm.static_block_declaration | `Cont of 'a ] diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index 95012d984e..a27c6d6cd2 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -10,5 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout -let () = Coqtop.toploop_run := W.main_loop +let () = Coqtop.toploop_run := (fun _ -> W.main_loop ()) diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml index 85f0e6bfc1..ac7a270ac6 100644 --- a/stm/queryworkertop.ml +++ b/stm/queryworkertop.ml @@ -10,5 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout -let () = Coqtop.toploop_run := W.main_loop +let () = Coqtop.toploop_run := (fun _ -> W.main_loop ()) diff --git a/stm/stm.ml b/stm/stm.ml index 7c44fc86fb..84a4c5cc52 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -22,7 +22,18 @@ open Pp open CErrors open Feedback open Vernacexpr -open Vernac_classifier + +(* Protect against state changes *) +let stm_purify f x = + let st = Vernacentries.freeze_interp_state `No in + try + let res = f x in + Vernacentries.unfreeze_interp_state st; + res + with e -> + let e = CErrors.push e in + Vernacentries.unfreeze_interp_state st; + Exninfo.iraise e let execution_error ?loc state_id msg = feedback ~id:state_id @@ -40,8 +51,8 @@ let state_ready, state_ready_hook = Hook.make let forward_feedback, forward_feedback_hook = let m = Mutex.create () in Hook.make ~default:(function - | { id = id; route; contents } -> - try Mutex.lock m; feedback ~id:id ~route contents; Mutex.unlock m + | { doc_id = did; span_id = id; route; contents } -> + try Mutex.lock m; feedback ~did ~id ~route contents; Mutex.unlock m with e -> Mutex.unlock m; raise e) () let unreachable_state, unreachable_state_hook = Hook.make @@ -64,11 +75,6 @@ let call_process_error_once = end -(* During interactive use we cache more states so that Undoing is fast *) -let interactive () = - if !Flags.ide_slave || not !Flags.batch_mode then `Yes - else `No - let async_proofs_workers_extra_env = ref [||] type aast = { @@ -143,10 +149,12 @@ type step = | `Qed of qed_t * Stateid.t | `Sideff of seff_t * Stateid.t | `Alias of alias_t ] + type visit = { step : step; next : Stateid.t } let mkTransTac cast cblock cqueue = Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false } + let mkTransCmd cast cids ceff cqueue = Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } @@ -157,14 +165,11 @@ let summary_pstate = [ Evarutil.meta_counter_summary_name; type cached_state = | Empty | Error of Exninfo.iexn - | Valid of state -and state = { (* TODO: inline records in OCaml 4.03 *) - system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) -} + | Valid of Vernacentries.interp_state + type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } + type 'vcs state_info = { (* TODO: Make this record private to VCS *) mutable n_reached : int; (* debug cache: how many times was computed *) mutable n_goals : int; (* open goals: indentation *) @@ -253,6 +258,16 @@ end (* }}} *) (*************************** THE DOCUMENT *************************************) (******************************************************************************) +(* The main document type associated to a VCS *) +type stm_doc_type = + | VoDoc of string + | VioDoc of string + | Interactive of Names.DirPath.t + +(* Dummy until we land the functional interp patch + fixed start_library *) +type doc = int +let dummy_doc : doc = 0 + (* Imperative wrap around VCS to obtain _the_ VCS that is the * representation of the document Coq is currently processing *) module VCS : sig @@ -269,7 +284,13 @@ module VCS : sig type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t - val init : id -> unit + val init : stm_doc_type -> id -> doc + (* val get_type : unit -> stm_doc_type *) + val set_ldir : Names.DirPath.t -> unit + val get_ldir : unit -> Names.DirPath.t + + val is_interactive : unit -> [`Yes | `No | `Shallow] + val is_vio_doc : unit -> bool val current_branch : unit -> Branch.t val checkout : Branch.t -> unit @@ -451,9 +472,30 @@ end = struct (* {{{ *) type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) - let init id = + let doc_type = ref (Interactive (Names.DirPath.make [])) + let ldir = ref Names.DirPath.empty + + let init dt id = + doc_type := dt; vcs := empty id; - vcs := set_info !vcs id (default_info ()) + vcs := set_info !vcs id (default_info ()); + dummy_doc + + let set_ldir ld = + ldir := ld + + let get_ldir () = !ldir + (* let get_type () = !doc_type *) + + let is_interactive () = + match !doc_type with + | Interactive _ -> `Yes + | _ -> `No + + let is_vio_doc () = + match !doc_type with + | VioDoc _ -> true + | _ -> false let current_branch () = current_branch !vcs @@ -663,7 +705,7 @@ end = struct (* {{{ *) end (* }}} *) -let state_of_id id = +let state_of_id ~doc id = try match (VCS.get_info id).state with | Valid s -> `Valid (Some s) | Error (e,_) -> `Error e @@ -673,7 +715,7 @@ let state_of_id id = (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig - + (** The function is from unit, so it uses the current state to define a new one. I.e. one may been to install the right state before defining a new one. @@ -683,61 +725,59 @@ module State : sig ?safe_id:Stateid.t -> ?redefine:bool -> ?cache:Summary.marshallable -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit + val fix_exn_ref : (Exninfo.iexn -> Exninfo.iexn) ref val install_cached : Stateid.t -> unit val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool - val exn_on : Stateid.t -> valid:Stateid.t -> Exninfo.iexn -> Exninfo.iexn + (* to send states across worker/master *) - type frozen_state - val get_cached : Stateid.t -> frozen_state - val same_env : frozen_state -> frozen_state -> bool + val get_cached : Stateid.t -> Vernacentries.interp_state + val same_env : Vernacentries.interp_state -> Vernacentries.interp_state -> bool type proof_part + type partial_state = - [ `Full of frozen_state - | `Proof of Stateid.t * proof_part ] - val proof_part_of_frozen : frozen_state -> proof_part + [ `Full of Vernacentries.interp_state + | `ProofOnly of Stateid.t * proof_part ] + + val proof_part_of_frozen : Vernacentries.interp_state -> proof_part val assign : Stateid.t -> partial_state -> unit + (* Handlers for initial state, prior to document creation. *) + val register_root_state : unit -> unit + val restore_root_state : unit -> unit + (* Only for internal use to catch problems in parse_sentence, should be removed in the state handling refactoring. *) val cur_id : Stateid.t ref + end = struct (* {{{ *) + open Vernacentries + (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy let fix_exn_ref = ref (fun x -> x) - (* helpers *) - let freeze_global_state marshallable = - { system = States.freeze ~marshallable; - proof = Proof_global.freeze ~marshallable; - shallow = (marshallable = `Shallow) } - let unfreeze_global_state { system; proof } = - States.unfreeze system; Proof_global.unfreeze proof - - (* hack to make futures functional *) - let () = Future.set_freeze - (fun () -> Obj.magic (freeze_global_state `No, !cur_id)) - (fun t -> let s,i = Obj.magic t in unfreeze_global_state s; cur_id := i) - - type frozen_state = state type proof_part = Proof_global.state * Summary.frozen_bits (* only meta counters *) + type partial_state = - [ `Full of frozen_state - | `Proof of Stateid.t * proof_part ] - let proof_part_of_frozen { proof; system } = + [ `Full of Vernacentries.interp_state + | `ProofOnly of Stateid.t * proof_part ] + + let proof_part_of_frozen { Vernacentries.proof; system } = proof, Summary.project_summary (States.summary_of_state system) summary_pstate let freeze marshallable id = - VCS.set_state id (Valid (freeze_global_state marshallable)) + VCS.set_state id (Valid (Vernacentries.freeze_interp_state marshallable)) + let freeze_invalid id iexn = VCS.set_state id (Error iexn) let is_cached ?(cache=`No) id only_valid = @@ -760,12 +800,16 @@ end = struct (* {{{ *) let install_cached id = match VCS.get_info id with | { state = Valid s } -> - if Stateid.equal id !cur_id then () (* optimization *) - else begin unfreeze_global_state s; cur_id := id end - | { state = Error ie } -> cur_id := id; Exninfo.iraise ie + Vernacentries.unfreeze_interp_state s; + cur_id := id + + | { state = Error ie } -> + cur_id := id; + Exninfo.iraise ie + | _ -> (* coqc has a 1 slot cache and only for valid states *) - if interactive () = `No && Stateid.equal id !cur_id then () + if VCS.is_interactive () = `No && Stateid.equal id !cur_id then () else anomaly Pp.(str "installing a non cached state.") let get_cached id = @@ -782,13 +826,13 @@ end = struct (* {{{ *) try let prev = (VCS.visit id).next in if is_cached_and_valid prev - then { s with proof = + then { s with Vernacentries.proof = Proof_global.copy_terminators ~src:(get_cached prev).proof ~tgt:s.proof } else s with VCS.Expired -> s in VCS.set_state id (Valid s) - | `Proof(ontop,(pstate,counters)) -> + | `ProofOnly(ontop,(pstate,counters)) -> if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = @@ -855,6 +899,15 @@ end = struct (* {{{ *) Hooks.(call unreachable_state id ie); Exninfo.iraise ie + let init_state = ref None + + let register_root_state () = + init_state := Some (Vernacentries.freeze_interp_state `No) + + let restore_root_state () = + cur_id := Stateid.dummy; + Vernacentries.unfreeze_interp_state (Option.get !init_state); + end (* }}} *) (* indentation code for Show Script, initially contributed @@ -948,11 +1001,11 @@ end (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly reduced... *) -let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = +let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacentries.interp_state = (* The Stm will gain the capability to interpret commmads affecting the whole document state, such as backtrack, etc... so we start to design the stm command interpreter now *) - set_id_for_feedback ?route id; + set_id_for_feedback ?route dummy_doc id; Aux_file.record_in_aux_set_at ?loc (); (* We need to check if a command should be filtered from * vernac_entries, as it cannot handle it. This should go away in @@ -965,18 +1018,18 @@ let stm_vernac_interp ?proof id ?route { verbose; loc; expr } = | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> is_filtered_command e | _ -> false in - let aux_interp cmd = + let aux_interp st cmd = if is_filtered_command cmd then - stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr) + (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) else match cmd with - | VernacShow ShowScript -> ShowScript.show_script () + | VernacShow ShowScript -> ShowScript.show_script (); st | expr -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof (Loc.tag ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof st (Loc.tag ?loc expr) with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) - in aux_interp expr + in aux_interp st expr (****************************** CRUFT *****************************************) (******************************************************************************) @@ -990,8 +1043,8 @@ module Backtrack : sig (* we could navigate the dag, but this ways easy *) val branches_of : Stateid.t -> backup - (* To be installed during initialization *) - val undo_vernac_classifier : vernac_expr -> vernac_classification + (* Returns the state that the command should backtract to *) + val undo_vernac_classifier : vernac_expr -> Stateid.t * vernac_when end = struct (* {{{ *) @@ -1044,12 +1097,22 @@ end = struct (* {{{ *) match f acc (id, vcs, ids, tactic, undo) with | `Stop x -> x | `Cont acc -> next acc - + + let undo_costly_in_batch_mode = + CWarnings.create ~name:"undo-batch-mode" ~category:"non-interactive" Pp.(fun v -> + str "Command " ++ Ppvernac.pr_vernac v ++ + str (" is not recommended in batch mode. In particular, going back in the document" ^ + " is not efficient in batch mode due to Coq not caching previous states for memory optimization reasons." ^ + " If your use is intentional, you may want to disable this warning and pass" ^ + " the \"-async-proofs-cache force\" option to Coq.")) + let undo_vernac_classifier v = + if VCS.is_interactive () = `No && !Flags.async_proofs_cache <> Some Flags.Force + then undo_costly_in_batch_mode v; try match v with | VernacResetInitial -> - VtBack (true, Stateid.initial), VtNow + Stateid.initial, VtNow | VernacResetName (_,name) -> let id = VCS.get_branch_pos (VCS.current_branch ()) in (try @@ -1057,20 +1120,20 @@ end = struct (* {{{ *) fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in - VtBack (true, oid), VtNow + oid, VtNow with Not_found -> - VtBack (true, id), VtNow) + id, VtNow) | VernacBack n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in - VtBack (true, oid), VtNow + oid, VtNow | VernacUndo n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,tactic,undo) -> let value = (if tactic then 1 else 0) - undo in if Int.equal n 0 then `Stop id else `Cont (n-value)) n id in - VtBack (true, oid), VtLater + oid, VtLater | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in @@ -1087,17 +1150,17 @@ end = struct (* {{{ *) 0 id in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in - VtBack (true, oid), VtLater + oid, VtLater | VernacAbortAll -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in - VtBack (true, oid), VtLater + oid, VtLater | VernacBacktrack (id,_,_) | VernacBackTo id -> - VtBack (not !Flags.batch_mode, Stateid.of_int id), VtNow - | _ -> VtUnknown, VtNow + Stateid.of_int id, VtNow + | _ -> anomaly Pp.(str "incorrect VtMeta classification") with | Not_found -> CErrors.user_err ~hdr:"undo_vernac_classifier" @@ -1108,18 +1171,15 @@ end (* }}} *) let hints = ref Aux_file.empty_aux_file let set_compilation_hints file = hints := Aux_file.load_aux_file_for file + let get_hint_ctx loc = let s = Aux_file.get ?loc !hints "context_used" in - match Str.split (Str.regexp ";") s with - | ids :: _ -> - let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") ids) in - let ids = List.map (fun id -> Loc.tag id) ids in - begin match ids with - | [] -> SsEmpty - | x :: xs -> - List.fold_left (fun a x -> SsUnion (SsSingl x,a)) (SsSingl x) xs - end - | _ -> raise Not_found + let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") s) in + let ids = List.map (fun id -> Loc.tag id) ids in + match ids with + | [] -> SsEmpty + | x :: xs -> + List.fold_left (fun a x -> SsUnion (SsSingl x,a)) (SsSingl x) xs let get_hint_bp_time proof_name = try float_of_string (Aux_file.get !hints proof_name) @@ -1162,7 +1222,7 @@ type recovery_action = { } type dynamic_block_error_recovery = - static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] + doc -> static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] let proof_block_delimiters = ref [] @@ -1354,7 +1414,7 @@ end = struct (* {{{ *) let build_proof_here ?loc ~drop_pt (id,valid) eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in - if !Flags.batch_mode then Reach.known_state ~cache:`No eop + if VCS.is_interactive () = `No then Reach.known_state ~cache:`No eop else Reach.known_state ~cache:`Shallow eop; let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" @@ -1376,18 +1436,28 @@ end = struct (* {{{ *) * the few errors tactics don't catch, like the "fix" tactic building * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in + (* STATE: We use the current installed imperative state *) + let st = Vernacentries.freeze_interp_state `No in if not drop then begin - let checked_proof = Future.chain ~pure:false future_proof (fun p -> + let checked_proof = Future.chain future_proof (fun p -> + + (* Unfortunately close_future_proof and friends are not pure so we need + to set the state manually here *) + Vernacentries.unfreeze_interp_state st; let pobject, _ = Proof_global.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in + + let st = Vernacentries.freeze_interp_state `No in stm_vernac_interp stop - ~proof:(pobject, terminator) + ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque,None))) }) in ignore(Future.join checked_proof); end; + (* STATE: Restore the state XXX: handle exn *) + Vernacentries.unfreeze_interp_state st; RespBuiltProof(proof,time) with | e when CErrors.noncritical e || e = Stack_overflow -> @@ -1404,7 +1474,7 @@ end = struct (* {{{ *) let perform_states query = if query = [] then [] else - let is_tac e = match classify_vernac e with + let is_tac e = match Vernac_classifier.classify_vernac e with | VtProofStep _, _ -> true | _ -> false in @@ -1427,7 +1497,7 @@ end = struct (* {{{ *) | _, None -> None | Some (prev, o, `Cmd { cast = { expr }}), Some n when is_tac expr && State.same_env o n -> (* A pure tactic *) - Some (id, `Proof (prev, State.proof_part_of_frozen n)) + Some (id, `ProofOnly (prev, State.proof_part_of_frozen n)) | Some _, Some s -> msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) @@ -1491,7 +1561,6 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) let queue = ref None - let init () = if Flags.async_proofs_is_master () then queue := Some (TaskQueue.create !Flags.async_proofs_n_workers) @@ -1523,9 +1592,16 @@ end = struct (* {{{ *) (* 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 ~cache:`No start; - stm_vernac_interp stop ~proof + (* STATE SPEC: + * - start: First non-expired state! [This looks very fishy] + * - end : start + qed + * => takes nothing from the itermediate states. + *) + (* STATE We use the state resulting from reaching start. *) + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque,None))) }; + expr = (VernacEndProof (Proved (Opaque,None))) }); `OK proof end with e -> @@ -1581,10 +1657,9 @@ end = struct (* {{{ *) let pr = Future.from_val (map (Option.get (Global.body_of_constant_body c))) in let uc = - Future.chain - ~pure:true uc Univ.hcons_universe_context_set in - let pr = Future.chain ~pure:true pr discharge in - let pr = Future.chain ~pure:true pr Constr.hcons in + Future.chain uc Univ.hcons_universe_context_set in + let pr = Future.chain pr discharge in + let pr = Future.chain pr Constr.hcons in Future.sink pr; let extra = Future.join uc in u.(bucket) <- uc; @@ -1627,7 +1702,7 @@ end = struct (* {{{ *) let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then - if !Flags.compilation_mode = Flags.BuildVio then begin + if VCS.is_vio_doc () then begin let f,assign = Future.create_delegate ~blocking:true ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in @@ -1760,7 +1835,7 @@ end = struct (* {{{ *) Option.iter VCS.restore vcs; try Reach.known_state ~cache:`No id; - Future.purify (fun () -> + stm_purify (fun () -> let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 (EConstr.of_constr c) in @@ -1774,7 +1849,14 @@ end = struct (* {{{ *) else begin let (i, ast) = r_ast in Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); - stm_vernac_interp r_state_fb ast; + (* STATE SPEC: + * - start : id + * - return: id + * => captures state id in a future closure, which will + discard execution state but for the proof + univs. + *) + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp r_state_fb st ast); let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress @@ -1813,7 +1895,8 @@ end = struct (* {{{ *) | VernacRedirect (_,(_,e)) -> find ~time ~fail e | VernacFail e -> find ~time ~fail:true e | e -> e, time, fail in find ~time:false ~fail:false e in - Vernacentries.with_fail fail (fun () -> + let st = Vernacentries.freeze_interp_state `No in + Vernacentries.with_fail st fail (fun () -> (if time then System.with_time !Flags.time else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> @@ -1905,8 +1988,14 @@ end = struct (* {{{ *) VCS.restore r_doc; VCS.print (); Reach.known_state ~cache:`No r_where; + (* STATE *) + let st = Vernacentries.freeze_interp_state `No in try - stm_vernac_interp r_for { r_what with verbose = true }; + (* STATE SPEC: + * - start: r_where + * - end : after execution of r_what + *) + ignore(stm_vernac_interp r_for st { r_what with verbose = true }); feedback ~id:r_for Processed with e when CErrors.noncritical e -> let e = CErrors.push e in @@ -1952,14 +2041,14 @@ let pstate = summary_pstate let async_policy () = let open Flags in if is_universe_polymorphism () then false - else if interactive () = `Yes then + else if VCS.is_interactive () = `Yes then (async_proofs_is_master () || !async_proofs_mode = APonLazy) else - (!compilation_mode = BuildVio || !async_proofs_mode <> APoff) + (VCS.is_vio_doc () || !async_proofs_mode <> APoff) let delegate name = get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold - || !Flags.compilation_mode = Flags.BuildVio + || VCS.is_vio_doc () || !Flags.async_proofs_full let warn_deprecated_nested_proofs = @@ -2020,7 +2109,7 @@ let collect_proof keep cur hd brkind id = `ASync (parent last,accn,name,delegate name) | `Fork((_, hd', GuaranteesOpacity, ids), _) when has_proof_no_using last && not (State.is_cached_and_valid (parent last)) && - !Flags.compilation_mode = Flags.BuildVio -> + VCS.is_vio_doc () -> assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch); (try let name, hint = name ids, get_hint_ctx loc in @@ -2104,7 +2193,7 @@ let known_state ?(redefine_qed=false) ~cache id = let decl, name = List.hd valid_boxes in try let _, dynamic_check = List.assoc name !proof_block_delimiters in - match dynamic_check decl with + match dynamic_check dummy_doc decl with | `Leaks -> Exninfo.iraise exn | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin let tac = @@ -2114,14 +2203,20 @@ let known_state ?(redefine_qed=false) ~cache id = Proofview.give_up else Proofview.tclUNIT () end in match (VCS.get_info base_state).state with - | Valid { proof } -> + | Valid { Vernacentries.proof } -> Proof_global.unfreeze proof; Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); - Option.iter (fun expr -> stm_vernac_interp id { + (* STATE SPEC: + * - start: Modifies the input state adding a proof. + * - end : maybe after recovery command. + *) + (* STATE: We use an updated state with proof *) + let st = Vernacentries.freeze_interp_state `No in + Option.iter (fun expr -> ignore(stm_vernac_interp id st { verbose = true; loc = None; expr; indentation = 0; - strlen = 0 }) + strlen = 0 } )) recovery_command | _ -> assert false end @@ -2159,10 +2254,12 @@ let known_state ?(redefine_qed=false) ~cache id = let inject_non_pstate (s,l) = Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () in - let rec pure_cherry_pick_non_pstate safe_id id = Future.purify (fun id -> - stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); - reach ~safe_id id; - cherry_pick_non_pstate ()) id + let rec pure_cherry_pick_non_pstate safe_id id = + stm_purify (fun id -> + stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); + reach ~safe_id id; + cherry_pick_non_pstate ()) + id (* traverses the dag backward from nodes being already calculated *) and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id = @@ -2195,7 +2292,10 @@ let known_state ?(redefine_qed=false) ~cache id = | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach view.next; - stm_vernac_interp id x); + (* State resulting from reach *) + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id st x) + ); if eff then update_global_env () ), (if eff then `Yes else cache), true | `Cmd { cast = x; ceff = eff } -> (fun () -> @@ -2203,18 +2303,23 @@ let known_state ?(redefine_qed=false) ~cache id = | Flags.APon | Flags.APonLazy -> resilient_command reach view.next | Flags.APoff -> reach view.next); - stm_vernac_interp id x; + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id st x); if eff then update_global_env () ), (if eff then `Yes else cache), true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; - stm_vernac_interp id x; + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id st x); wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) reach ~cache:`Shallow prev; reach view.next; - (try stm_vernac_interp id x; + + (try + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id st x); with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let info = Stateid.add info ~valid:prev id in @@ -2264,14 +2369,18 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; - stm_vernac_interp id ~proof x; + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id ~proof st x); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true | `Sync (name, `Immediate) -> (fun () -> - reach eop; stm_vernac_interp id x; Proof_global.discard_all () + reach eop; + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id st x); + Proof_global.discard_all () ), `Yes, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; @@ -2292,7 +2401,8 @@ let known_state ?(redefine_qed=false) ~cache id = if keep != VtKeepAsAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in - stm_vernac_interp id ?proof x; + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id ?proof st x); 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)); @@ -2308,7 +2418,10 @@ let known_state ?(redefine_qed=false) ~cache id = in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (ReplayCommand x,_) -> (fun () -> - reach view.next; stm_vernac_interp id x; update_global_env () + reach view.next; + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp id st x); + update_global_env () ), cache, true | `Sideff (CherryPickEnv, origin) -> (fun () -> reach view.next; @@ -2329,10 +2442,56 @@ end (* }}} *) (********************************* STM API ************************************) (******************************************************************************) -let init () = - VCS.init Stateid.initial; - set_undo_classifier Backtrack.undo_vernac_classifier; - State.define ~cache:`Yes (fun () -> ()) Stateid.initial; +type stm_init_options = { + doc_type : stm_doc_type; + require_libs : (string * string option * bool option) list; +(* + fb_handler : Feedback.feedback -> unit; + iload_path : (string list * string * bool) list; + implicit_std : bool; +*) +} + +(* +let doc_type_module_name (std : stm_doc_type) = + match std with + | VoDoc mn | VioDoc mn | Vio2Vo mn -> mn + | Interactive mn -> Names.DirPath.to_string mn +*) + +let init_core () = + State.register_root_state () + +let new_doc { doc_type ; require_libs } = + let load_objs libs = + let rq_file (dir, from, exp) = + let mp = Libnames.(Qualid (Loc.tag @@ qualid_of_string dir)) in + let mfrom = Option.map (fun fr -> Libnames.(Qualid (Loc.tag @@ qualid_of_string fr))) from in + Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in + List.(iter rq_file (rev libs)) + in + + (* We must reset the whole state before creating a document! *) + State.restore_root_state (); + + let doc = VCS.init doc_type Stateid.initial in + + begin match doc_type with + | Interactive ln -> + Declaremods.start_library ln + | VoDoc ln -> + let ldir = Flags.verbosely Library.start_library ln in + VCS.set_ldir ldir; + set_compilation_hints ln + | VioDoc ln -> + let ldir = Flags.verbosely Library.start_library ln in + VCS.set_ldir ldir; + set_compilation_hints ln + end; + load_objs require_libs; + + (* We record the state here! *) + State.define ~cache:`Yes ~redefine:true (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); if Flags.async_proofs_is_master () then begin @@ -2347,35 +2506,39 @@ let init () = async_proofs_workers_extra_env := Array.of_list (Str.split_delim (Str.regexp ";") (Str.replace_first env_opt "" env)) with Not_found -> () end; - end + end; + doc, VCS.cur_tip () -let observe id = +let observe ~doc id = let vcs = VCS.backup () in try - Reach.known_state ~cache:(interactive ()) id; - VCS.print () + Reach.known_state ~cache:(VCS.is_interactive ()) id; + VCS.print (); + doc with e -> let e = CErrors.push e in VCS.print (); VCS.restore vcs; Exninfo.iraise e -let finish () = +let finish ~doc = let head = VCS.current_branch () in - observe (VCS.get_branch_pos head); + let doc =observe ~doc (VCS.get_branch_pos head) in VCS.print (); (* EJGA: Setting here the proof state looks really wrong, and it hides true bugs cf bug #5363. Also, what happens with observe? *) (* Some commands may by side effect change the proof mode *) - match VCS.get_branch head with + (match VCS.get_branch head with | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] | _ -> () + ); doc -let wait () = - finish (); +let wait ~doc = + let doc = finish ~doc in Slaves.wait_all_done (); - VCS.print () + VCS.print (); + doc let rec join_admitted_proofs id = if Stateid.equal id Stateid.initial then () else @@ -2386,32 +2549,33 @@ let rec join_admitted_proofs id = join_admitted_proofs view.next | _ -> join_admitted_proofs view.next -let join () = - wait (); +let join ~doc = + let doc = wait ~doc in stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); stm_prerr_endline (fun () -> "Joining Admitted proofs"); join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); VCS.print (); - VCS.print () + doc let dump_snapshot () = Slaves.dump_snapshot (), RemoteCounter.snapshot () -type document = VCS.vcs + type tasks = int Slaves.tasks * RemoteCounter.remote_counters_status let check_task name (tasks,rcbackup) i = RemoteCounter.restore rcbackup; let vcs = VCS.backup () in try - let rc = Future.purify (Slaves.check_task name tasks) i in + let rc = stm_purify (Slaves.check_task name tasks) i in VCS.restore vcs; rc with e when CErrors.noncritical e -> VCS.restore vcs; false let info_tasks (tasks,_) = Slaves.info_tasks tasks + let finish_tasks name u d p (t,rcbackup as tasks) = RemoteCounter.restore rcbackup; let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = Future.purify (Slaves.finish_task name u d p t) i in + let u = stm_purify (Slaves.finish_task name u d p t) i in VCS.restore vcs; u in try @@ -2441,7 +2605,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.rewrite_merge qed_id ~ours:(Qed (qed ofp)) ~at:master_id brname; VCS.delete_branch brname; VCS.gc (); - Reach.known_state ~redefine_qed:true ~cache:`No qed_id; + let _st = Reach.known_state ~redefine_qed:true ~cache:`No qed_id in VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> @@ -2463,17 +2627,49 @@ let handle_failure (e, info) vcs = VCS.print (); Exninfo.iraise (e, info) -let snapshot_vio ldir long_f_dot_vo = - finish (); +let snapshot_vio ~doc ldir long_f_dot_vo = + let doc = finish ~doc in if List.length (VCS.branches ()) > 1 then CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo - (Global.opaque_tables ()) + (Global.opaque_tables ()); + doc let reset_task_queue = Slaves.reset_task_queue (* Document building *) -let process_transaction ?(newtip=Stateid.fresh ()) +let process_back_meta_command ~part_of_script ~newtip ~head oid aast w = + match part_of_script, w with + | true, w -> + let id = VCS.new_node ~id:newtip () in + let { mine; others } = Backtrack.branches_of oid in + let valid = VCS.get_branch_pos head in + List.iter (fun branch -> + if not (List.mem_assoc branch (mine::others)) then + ignore(merge_proof_branch ~valid aast VtDrop branch)) + (VCS.branches ()); + VCS.checkout_shallowest_proof_branch (); + let head = VCS.current_branch () in + List.iter (fun b -> + if not(VCS.Branch.equal b head) then begin + VCS.checkout b; + VCS.commit (VCS.new_node ()) (Alias (oid,aast)); + end) + (VCS.branches ()); + VCS.checkout_shallowest_proof_branch (); + VCS.commit id (Alias (oid,aast)); + Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + + | false, VtNow -> + stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string oid); + Backtrack.backto oid; + VCS.checkout_shallowest_proof_branch (); + Reach.known_state ~cache:(VCS.is_interactive ()) oid; `Ok + + | false, VtLater -> + anomaly(str"undo classifier: VtMeta + VtLater must imply part_of_script.") + +let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) ({ verbose; loc; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in @@ -2482,57 +2678,32 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.checkout head; let rc = begin stm_prerr_endline (fun () -> - " classified as: " ^ string_of_vernac_classification c); + " classified as: " ^ Vernac_classifier.string_of_vernac_classification c); match c with - (* Back *) - | VtBack (true, oid), w -> - let id = VCS.new_node ~id:newtip () in - let { mine; others } = Backtrack.branches_of oid in - let valid = VCS.get_branch_pos head in - List.iter (fun branch -> - if not (List.mem_assoc branch (mine::others)) then - ignore(merge_proof_branch ~valid x VtDrop branch)) - (VCS.branches ()); - VCS.checkout_shallowest_proof_branch (); - let head = VCS.current_branch () in - List.iter (fun b -> - if not(VCS.Branch.equal b head) then begin - VCS.checkout b; - VCS.commit (VCS.new_node ()) (Alias (oid,x)); - end) - (VCS.branches ()); - VCS.checkout_shallowest_proof_branch (); - VCS.commit id (Alias (oid,x)); - Backtrack.record (); if w == VtNow then finish (); `Ok - | VtBack (false, id), VtNow -> - stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); - Backtrack.backto id; - VCS.checkout_shallowest_proof_branch (); - Reach.known_state ~cache:(interactive ()) id; `Ok - | VtBack (false, id), VtLater -> - anomaly(str"classifier: VtBack + VtLater must imply part_of_script.") - + (* Meta *) + | VtMeta, _ -> + let id, w = Backtrack.undo_vernac_classifier expr in + process_back_meta_command ~part_of_script ~newtip ~head id x w (* Query *) - | VtQuery (false, route), VtNow -> - begin - let query_sid = VCS.cur_tip () in - try stm_vernac_interp ~route (VCS.cur_tip ()) x - with e -> - let e = CErrors.push e in - Exninfo.iraise (State.exn_on ~valid:Stateid.dummy query_sid e) - end; `Ok - (* Part of the script commands don't set the query route *) - | VtQuery (true, _route), w -> + | VtQuery (false,route), VtNow -> + let query_sid = VCS.cur_tip () in + (try + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp ~route query_sid st x) + with e -> + let e = CErrors.push e in + Exninfo.iraise (State.exn_on ~valid:Stateid.dummy query_sid e)); `Ok + | VtQuery (true, route), w -> let id = VCS.new_node ~id:newtip () in let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) - else if Flags.(!compilation_mode = BuildVio) && + else if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && may_pierce_opaque x then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); - Backtrack.record (); if w == VtNow then finish (); `Ok + Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok | VtQuery (false,_), VtLater -> anomaly(str"classifier: VtQuery + VtLater must imply part_of_script.") @@ -2550,7 +2721,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head end; Proof_global.activate_proof_mode mode [@ocaml.warning "-3"]; - Backtrack.record (); if w == VtNow then finish (); `Ok + Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok | VtProofMode _, VtLater -> anomaly(str"VtProofMode must be executed VtNow.") | VtProofMode mode, VtNow -> @@ -2568,7 +2739,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); - finish (); + ignore(finish ~doc:dummy_doc); `Ok | VtProofStep { parallel; proof_block_detection = cblock }, w -> let id = VCS.new_node ~id:newtip () in @@ -2581,17 +2752,19 @@ let process_transaction ?(newtip=Stateid.fresh ()) If/when and UI will make something useful with this piece of info, detection should occur here. detect_proof_block id cblock; *) - Backtrack.record (); if w == VtNow then finish (); `Ok + Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok | VtQed keep, w -> let valid = VCS.get_branch_pos head in let rc = merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); if w == VtNow then finish (); + Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); rc - + (* Side effect on all branches *) | VtUnknown, _ when expr = VernacToplevelControl Drop -> - stm_vernac_interp (VCS.get_branch_pos head) x; `Ok + let st = Vernacentries.freeze_interp_state `No in + ignore(stm_vernac_interp (VCS.get_branch_pos head) st x); + `Ok | VtSideff l, w -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in @@ -2605,19 +2778,20 @@ let process_transaction ?(newtip=Stateid.fresh ()) | _ -> ReplayCommand x in VCS.propagate_sideff ~action; VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); if w == VtNow then finish (); `Ok + Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok (* Unknown: we execute it, check for open goals and propagate sideeff *) | VtUnknown, VtNow -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in let id = VCS.new_node ~id:newtip () in let head_id = VCS.get_branch_pos head in - Reach.known_state ~cache:`Yes head_id; (* ensure it is ok *) + let _st = Reach.known_state ~cache:`Yes head_id in (* ensure it is ok *) let step () = VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in - Reach.known_state ~cache:(interactive ()) mid; - stm_vernac_interp id x; + let _st' = Reach.known_state ~cache:(VCS.is_interactive ()) mid in + let st = Vernacentries.freeze_interp_state `No 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 begin @@ -2654,7 +2828,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) let e = CErrors.push e in handle_failure e vcs -let get_ast id = +let get_ast ~doc id = match VCS.visit id with | { step = `Cmd { cast = { loc; expr } } } | { step = `Fork (({ loc; expr }, _, _, _), _) } @@ -2675,7 +2849,7 @@ let stop_worker n = Slaves.cancel_worker n *) exception End_of_input -let parse_sentence sid pa = +let parse_sentence ~doc sid pa = (* XXX: Should this restore the previous state? Using reach here to try to really get to the proper state makes the error resilience code fail *) @@ -2739,7 +2913,7 @@ let compute_indentation ?loc sid = Option.cata (fun loc -> eff_indent, len ) (0, 0) loc -let add ~ontop ?newtip verb (loc, ast) = +let add ~doc ~ontop ?newtip verb (loc, ast) = let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then user_err ?loc ~hdr:"Stm.add" @@ -2749,13 +2923,13 @@ let add ~ontop ?newtip verb (loc, ast) = let indentation, strlen = compute_indentation ?loc ontop in CWarnings.set_current_loc loc; (* XXX: Classifiy vernac should be moved inside process transaction *) - let clas = classify_vernac ast in + let clas = Vernac_classifier.classify_vernac ast in let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in match process_transaction ?newtip aast clas with - | `Ok -> VCS.cur_tip (), `NewTip - | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ()) + | `Ok -> doc, VCS.cur_tip (), `NewTip + | `Unfocus qed_id -> doc, qed_id, `Unfocus (VCS.cur_tip ()) -let set_perspective id_list = Slaves.set_perspective id_list +let set_perspective ~doc id_list = Slaves.set_perspective id_list type focus = { start : Stateid.t; @@ -2763,23 +2937,23 @@ type focus = { tip : Stateid.t } -let query ~at ~route s = - Future.purify (fun s -> - if Stateid.equal at Stateid.dummy then finish () +let query ~doc ~at ~route s = + stm_purify (fun s -> + if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) else Reach.known_state ~cache:`Yes at; - let loc, ast = parse_sentence at s in + let loc, ast = parse_sentence ~doc at s in let indentation, strlen = compute_indentation ?loc at in CWarnings.set_current_loc loc; - let clas = classify_vernac ast in + let clas = Vernac_classifier.classify_vernac ast in let aast = { verbose = true; indentation; strlen; loc; expr = ast } in match clas with - | VtBack (_,id), _ -> (* TODO: can this still happen ? *) - ignore(process_transaction aast (VtBack (false,id), VtNow)) + | VtMeta , _ -> (* TODO: can this still happen ? *) + ignore(process_transaction ~part_of_script:false aast (VtMeta,VtNow)) | _ -> ignore(process_transaction aast (VtQuery (false, route), VtNow))) s -let edit_at id = +let edit_at ~doc id = if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy.") else let vcs = VCS.backup () in let on_cur_branch id = @@ -2824,7 +2998,7 @@ let edit_at id = VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; cancel_switch := true; - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in let no_edit = function @@ -2847,7 +3021,7 @@ let edit_at id = VCS.gc (); VCS.print (); if not !Flags.async_proofs_full then - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try @@ -2876,7 +3050,7 @@ let edit_at id = | true, None, _ -> if on_cur_branch id then begin VCS.reset_branch (VCS.current_branch ()) id; - Reach.known_state ~cache:(interactive ()) id; + Reach.known_state ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip end else if is_ancestor_of_cur_branch id then begin @@ -2888,7 +3062,7 @@ let edit_at id = | false, None, None -> backto id None in VCS.print (); - rc + doc, rc with e -> let (e, info) = CErrors.push e in match Stateid.get info with @@ -2902,15 +3076,15 @@ let edit_at id = VCS.print (); Exninfo.iraise (e, info) -let backup () = VCS.backup () -let restore d = VCS.restore d +let get_current_state ~doc = VCS.cur_tip () +let get_ldir ~doc = VCS.get_ldir () -let get_current_state () = VCS.cur_tip () +let get_doc did = dummy_doc (*********************** TTY API (PG, coqtop, coqc) ***************************) (******************************************************************************) -let current_proof_depth () = +let current_proof_depth ~doc = let head = VCS.current_branch () in match VCS.get_branch head with | { VCS.kind = `Master } -> 0 @@ -2929,7 +3103,7 @@ let proofname b = match VCS.get_branch b with | { VCS.kind = (`Proof _| `Edit _) } -> Some b | _ -> None -let get_all_proof_names () = +let get_all_proof_names ~doc = List.map unmangle (CList.map_filter proofname (VCS.branches ())) (* Export hooks *) diff --git a/stm/stm.mli b/stm/stm.mli index 3f01fca013..31f4599d36 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -10,9 +10,35 @@ open Names (** state-transaction-machine interface *) +(** The STM doc type determines some properties such as what + uncompleted proofs are allowed and recording of aux files. *) +type stm_doc_type = + | VoDoc of string + | VioDoc of string + | Interactive of DirPath.t + +(* Main initalization routine *) +type stm_init_options = { + doc_type : stm_doc_type; + require_libs : (string * string option * bool option) list; +(* + fb_handler : Feedback.feedback -> unit; + iload_path : (string list * string * bool) list; + implicit_std : bool; +*) +} + +(** The type of a STM document *) +type doc + +val init_core : unit -> unit + +(* Starts a new document *) +val new_doc : stm_init_options -> doc * Stateid.t + (* [parse_sentence sid pa] Reads a sentence from [pa] with parsing state [sid] Returns [End_of_input] if the stream ends *) -val parse_sentence : Stateid.t -> Pcoq.Gram.coq_parsable -> +val parse_sentence : doc:doc -> Stateid.t -> Pcoq.Gram.coq_parsable -> Vernacexpr.vernac_expr Loc.located (* Reminder: A parsable [pa] is constructed using @@ -26,14 +52,14 @@ exception End_of_input sync, but it will eventually call edit_at on the fly if needed. If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) -val add : ontop:Stateid.t -> ?newtip:Stateid.t -> +val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> bool -> Vernacexpr.vernac_expr Loc.located -> - Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] + doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* [query at ?report_with cmd] Executes [cmd] at a given state [at], throwing away side effects except messages. Feedback will be sent with [report_with], which defaults to the dummy state id *) -val query : +val query : doc:doc -> at:Stateid.t -> route:Feedback.route_id -> Pcoq.Gram.coq_parsable -> unit (* [edit_at id] is issued to change the editing zone. [`NewTip] is returned if @@ -46,27 +72,27 @@ val query : If Flags.async_proofs_full is set, then [id] is not [observe]d, else it is. *) type focus = { start : Stateid.t; stop : Stateid.t; tip : Stateid.t } -val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ] +val edit_at : doc:doc -> Stateid.t -> doc * [ `NewTip | `Focus of focus ] (* Evaluates the tip of the current branch *) -val finish : unit -> unit +val finish : doc:doc -> doc (* Internal use (fake_ide) only, do not use *) -val wait : unit -> unit +val wait : doc:doc -> doc -val observe : Stateid.t -> unit +val observe : doc:doc -> Stateid.t -> doc val stop_worker : string -> unit (* Joins the entire document. Implies finish, but also checks proofs *) -val join : unit -> unit +val join : doc:doc -> doc (* Saves on the disk a .vio corresponding to the current status: - if the worker pool is empty, all tasks are saved - if the worker proof is not empty, then it waits until all workers are done with their current jobs and then dumps (or fails if one of the completed tasks is a failure) *) -val snapshot_vio : DirPath.t -> string -> unit +val snapshot_vio : doc:doc -> DirPath.t -> string -> doc (* Empties the task queue, can be used only if the worker pool is empty (E.g. * after having built a .vio in batch mode *) @@ -81,23 +107,17 @@ val finish_tasks : string -> tasks -> Library.seg_univ * Library.seg_proofs (* Id of the tip of the current branch *) -val get_current_state : unit -> Stateid.t - -(* Misc *) -val init : unit -> unit +val get_current_state : doc:doc -> Stateid.t +val get_ldir : doc:doc -> Names.DirPath.t (* This returns the node at that position *) -val get_ast : Stateid.t -> (Vernacexpr.vernac_expr Loc.located) option +val get_ast : doc:doc -> Stateid.t -> (Vernacexpr.vernac_expr Loc.located) option (* Filename *) val set_compilation_hints : string -> unit (* Reorders the task queue putting forward what is in the perspective *) -val set_perspective : Stateid.t list -> unit - -type document -val backup : unit -> document -val restore : document -> unit +val set_perspective : doc:doc -> Stateid.t list -> unit (** workers **************************************************************** **) @@ -112,20 +132,20 @@ module QueryTask : AsyncTaskQueue.Task While checking a proof, if an error occurs in a (valid) block then processing can skip the entire block and go on to give feedback on the rest of the proof. - + static_block_detection and dynamic_block_validation are run when the closing block marker is parsed/executed respectively. - + static_block_detection is for example called when "}" is parsed and declares a block containing all proof steps between it and the matching "{". - + dynamic_block_validation is called when an error "crosses" the "}" statement. Depending on the nature of the goal focused by "{" the block may absorb the error or not. For example if the focused goal occurs in the type of another goal, then the block is leaky. Note that one can design proof commands that need no dynamic validation. - + Example of document: .. { tac1. tac2. } .. @@ -133,7 +153,7 @@ module QueryTask : AsyncTaskQueue.Task Corresponding DAG: .. (3) <-- { -- (4) <-- tac1 -- (5) <-- tac2 -- (6) <-- } -- (7) .. - + Declaration of block [-------------------------------------------] start = 5 the first state_id that could fail in the block @@ -173,7 +193,7 @@ type recovery_action = { } type dynamic_block_error_recovery = - static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] + doc -> static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] val register_proof_block_delimiter : Vernacexpr.proof_block_name -> @@ -197,14 +217,11 @@ val state_ready_hook : (Stateid.t -> unit) Hook.t (* Messages from the workers to the master *) val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t -type state = { - system : States.state; - proof : Proof_global.state; - shallow : bool -} -val state_of_id : - Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] +val get_doc : Feedback.doc_id -> doc + +val state_of_id : doc:doc -> + Stateid.t -> [ `Valid of Vernacentries.interp_state option | `Expired | `Error of exn ] (* Queries for backward compatibility *) -val current_proof_depth : unit -> int -val get_all_proof_names : unit -> Id.t list +val current_proof_depth : doc:doc -> int +val get_all_proof_names : doc:doc -> Id.t list diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml index 186c8f8b7c..1716ac0c61 100644 --- a/stm/tacworkertop.ml +++ b/stm/tacworkertop.ml @@ -10,5 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout -let () = Coqtop.toploop_run := W.main_loop +let () = Coqtop.toploop_run := (fun _ -> W.main_loop ()) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 158ad90846..3aa2cd707e 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -31,7 +31,7 @@ let string_of_vernac_type = function Option.default "" proof_block_detection | VtProofMode s -> "ProofMode " ^ s | VtQuery (b, route) -> "Query " ^ string_of_in_script b ^ " route " ^ string_of_int route - | VtBack (b, _) -> "Stm Back " ^ string_of_in_script b + | VtMeta -> "Meta " let string_of_vernac_when = function | VtLater -> "Later" @@ -53,9 +53,6 @@ let make_polymorphic (a, b as x) = VtStartProof (x, Doesn'tGuaranteeOpacity, ids), b | _ -> x -let undo_classifier = ref (fun _ -> assert false) -let set_undo_classifier f = undo_classifier := f - let rec classify_vernac e = let static_classifier e = match e with (* Univ poly compatibility: we run it now, so that we can just @@ -75,7 +72,7 @@ let rec classify_vernac e = | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ - | VtBack _ | VtProofMode _ ), _ as x -> x + | VtProofMode _ | VtMeta), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtNow @@ -191,7 +188,7 @@ let rec classify_vernac e = | VernacBack _ | VernacAbortAll | VernacUndoTo _ | VernacUndo _ | VernacResetName _ | VernacResetInitial - | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> !undo_classifier e + | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> VtMeta, VtNow (* What are these? *) | VernacToplevelControl _ | VernacRestoreState _ diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index 2fa1e0b8dc..fe42a03a3d 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -18,9 +18,6 @@ val classify_vernac : vernac_expr -> vernac_classification val declare_vernac_classifier : Vernacexpr.extend_name -> (raw_generic_argument list -> unit -> vernac_classification) -> unit -(** Set by Stm *) -val set_undo_classifier : (vernac_expr -> vernac_classification) -> unit - (** Standard constant classifiers *) val classify_as_query : vernac_classification val classify_as_sideeff : vernac_classification diff --git a/tactics/auto.ml b/tactics/auto.ml index 7aa5114a4f..d0424eb892 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -187,35 +187,34 @@ let _ = add_option ["Info";"Trivial"] global_info_trivial; add_option ["Info";"Auto"] global_info_auto -let no_dbg () = (Off,0,ref []) +type debug_kind = ReportForTrivial | ReportForAuto + +let no_dbg (_,whatfor,_,_) = (Off,whatfor,0,ref []) let mk_trivial_dbg debug = let d = if debug == Debug || !global_debug_trivial then Debug else if debug == Info || !global_info_trivial then Info else Off - in (d,0,ref []) - -(** Note : we start the debug depth of auto at 1 to distinguish it - for trivial (whose depth is 0). *) + in (d,ReportForTrivial,0,ref []) let mk_auto_dbg debug = let d = if debug == Debug || !global_debug_auto then Debug else if debug == Info || !global_info_auto then Info else Off - in (d,1,ref []) + in (d,ReportForAuto,0,ref []) -let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace) +let incr_dbg = function (dbg,whatfor,depth,trace) -> (dbg,whatfor,depth+1,trace) (** A tracing tactic for debug/info trivial/auto *) -let tclLOG (dbg,depth,trace) pp tac = +let tclLOG (dbg,_,depth,trace) pp tac = match dbg with | Off -> tac | Debug -> (* For "debug (trivial/auto)", we directly output messages *) - let s = String.make depth '*' in + let s = String.make (depth+1) '*' in Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in @@ -256,23 +255,23 @@ and erase_subtree depth = function | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = - str (String.make (d-1) ' ') ++ pp () ++ str "." + str (String.make d ' ') ++ pp () ++ str "." let pr_info_trace = function - | (Info,_,{contents=(d,Some pp)::l}) -> + | (Info,_,_,{contents=(d,Some pp)::l}) -> Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function - | (Info,_,_) -> Feedback.msg_info (str "idtac.") + | (Info,_,_,_) -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function - | (Off,_,_) -> () - | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") - | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") - | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") - | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") + | (Off,_,_,_) -> () + | (Debug,ReportForTrivial,_,_) -> Feedback.msg_debug (str "(* debug trivial: *)") + | (Debug,ReportForAuto,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") + | (Info,ReportForTrivial,_,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,ReportForAuto,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in @@ -382,7 +381,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= (unify_resolve_gen poly flags (c,cl)) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) - (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) + (trivial_fail_db (no_dbg dbg) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index d912decff4..8764ef085d 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -89,6 +89,12 @@ let mkBranches (eqonleft,mk,c1,c2,typ) = clear_last; intros] +let inj_flags = Some { + Equality.keep_proof_equalities = true; (* necessary *) + Equality.injection_in_context = true; (* does not matter here *) + Equality.injection_pattern_l2r_order = true; (* does not matter here *) + } + let discrHyp id = let c env sigma = (sigma, (mkVar id, NoBindings)) in let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in @@ -136,7 +142,7 @@ let eqCase tac = let injHyp id = let c env sigma = (sigma, (mkVar id, NoBindings)) in - let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in + let tac c = Equality.injClause inj_flags None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac let diseqCase hyps eqonleft = diff --git a/tactics/equality.ml b/tactics/equality.ml index e33dd2e5ed..7c03a3ba6a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -48,6 +48,12 @@ module NamedDecl = Context.Named.Declaration (* Options *) +type inj_flags = { + keep_proof_equalities : bool; + injection_in_context : bool; + injection_pattern_l2r_order : bool; + } + let discriminate_introduction = ref true let discr_do_intro () = !discriminate_introduction @@ -63,7 +69,9 @@ let _ = let injection_pattern_l2r_order = ref true -let use_injection_pattern_l2r_order () = !injection_pattern_l2r_order +let use_injection_pattern_l2r_order = function + | None -> !injection_pattern_l2r_order + | Some flags -> flags.injection_pattern_l2r_order let _ = declare_bool_option @@ -75,9 +83,9 @@ let _ = let injection_in_context = ref false -let use_injection_in_context () = - !injection_in_context - && Flags.version_strictly_greater Flags.V8_5 +let use_injection_in_context = function + | None -> !injection_in_context && Flags.version_strictly_greater Flags.V8_5 + | Some flags -> flags.injection_in_context let _ = declare_bool_option @@ -721,7 +729,14 @@ let _ = optread = (fun () -> !keep_proof_equalities_for_injection) ; optwrite = (fun b -> keep_proof_equalities_for_injection := b) } -let find_positions env sigma ~no_discr t1 t2 = +let keep_proof_equalities = function + | None -> !keep_proof_equalities_for_injection + | Some flags -> flags.keep_proof_equalities + +(* [keep_proofs] is relevant for types in Prop with elimination in Type *) +(* In particular, it is relevant for injection but not for discriminate *) + +let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in let s = get_sort_family_of env sigma ty1 in @@ -768,20 +783,22 @@ let find_positions env sigma ~no_discr t1 t2 = project env sorts posn t1_0 t2_0 in try - let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] - else [InSet;InType] - in + let sorts = if keep_proofs then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) +let use_keep_proofs = function + | None -> !keep_proof_equalities_for_injection + | Some b -> b + let discriminable env sigma t1 t2 = - match find_positions env sigma ~no_discr:false t1 t2 with + match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with | Inl _ -> true | _ -> false -let injectable env sigma t1 t2 = - match find_positions env sigma ~no_discr:true t1 t2 with +let injectable env sigma ~keep_proofs t1 t2 = + match find_positions env sigma ~keep_proofs:(use_keep_proofs keep_proofs) ~no_discr:true t1 t2 with | Inl _ -> assert false | Inr [] | Inr [([],_,_)] -> false | Inr _ -> true @@ -1024,7 +1041,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - match find_positions env sigma ~no_discr:false t1 t2 with + match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> @@ -1069,9 +1086,8 @@ let discr with_evars = onEquality with_evars discrEq let discrClause with_evars = onClause (discrSimpleClause with_evars) let discrEverywhere with_evars = -(* - tclORELSE -*) + tclTHEN (Proofview.tclUNIT ()) + (* Delay the interpretation of side-effect *) (if discr_do_intro () then (tclTHEN (tclREPEAT introf) @@ -1079,9 +1095,7 @@ let discrEverywhere with_evars = (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) -(* (fun gls -> - user_err ~hdr:"DiscrEverywhere" (str"No discriminable equalities.")) -*) + let discr_tac with_evars = function | None -> discrEverywhere with_evars | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c @@ -1403,15 +1417,15 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) -let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = +let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in let env = eq_clause.env in - match find_positions env sigma ~no_discr:true t1 t2 with + match find_positions env sigma ~keep_proofs ~no_discr:true t1 t2 with | Inl _ -> assert false | Inr [] -> let suggestion = - if !keep_proof_equalities_for_injection then + if keep_proofs then "" else " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) @@ -1430,13 +1444,13 @@ let get_previous_hyp_position id gl = in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) -let injEq ?(old=false) with_evars clear_flag ipats = +let injEq flags ?(old=false) with_evars clear_flag ipats = (* Decide which compatibility mode to use *) let ipats_style, l2r, dft_clear_flag, bounded_intro = match ipats with - | None when not old && use_injection_in_context () -> + | None when not old && use_injection_in_context flags -> Some [], true, true, true | None -> None, false, false, false - | _ -> let b = use_injection_pattern_l2r_order () in ipats, b, b, b in + | _ -> let b = use_injection_pattern_l2r_order flags in ipats, b, b, b in (* Built the post tactic depending on compatibility mode *) let post_tac c n = match ipats_style with @@ -1456,26 +1470,26 @@ let injEq ?(old=false) with_evars clear_flag ipats = tclTHEN clear_tac intro_tac end | None -> tclIDTAC in - injEqThen post_tac l2r + injEqThen (keep_proof_equalities flags) post_tac l2r -let inj ipats with_evars clear_flag = onEquality with_evars (injEq with_evars clear_flag ipats) +let inj flags ipats with_evars clear_flag = onEquality with_evars (injEq flags with_evars clear_flag ipats) -let injClause ipats with_evars = function - | None -> onNegatedEquality with_evars (injEq with_evars None ipats) - | Some c -> onInductionArg (inj ipats with_evars) c +let injClause flags ipats with_evars = function + | None -> onNegatedEquality with_evars (injEq flags with_evars None ipats) + | Some c -> onInductionArg (inj flags ipats with_evars) c -let simpleInjClause with_evars = function - | None -> onNegatedEquality with_evars (injEq ~old:true with_evars None None) - | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq ~old:true with_evars clear_flag None)) c +let simpleInjClause flags with_evars = function + | None -> onNegatedEquality with_evars (injEq flags ~old:true with_evars None None) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (injEq flags ~old:true with_evars clear_flag None)) c -let injConcl = injClause None false None -let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) +let injConcl flags = injClause flags None false None +let injHyp flags clear_flag id = injClause flags None false (Some (clear_flag,ElimOnIdent (Loc.tag id))) -let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = +let decompEqThen keep_proofs ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.enter begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in - match find_positions env sigma ~no_discr:false t1 t2 with + match find_positions env sigma ~keep_proofs ~no_discr:false t1 t2 with | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) @@ -1485,18 +1499,18 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = (ntac (clenv_value clause)) end -let dEqThen with_evars ntac = function - | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) - | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c +let dEqThen ~keep_proofs with_evars ntac = function + | None -> onNegatedEquality with_evars (decompEqThen (use_keep_proofs keep_proofs) (ntac None)) + | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (use_keep_proofs keep_proofs) (ntac clear_flag))) c -let dEq with_evars = - dEqThen with_evars (fun clear_flag c x -> +let dEq ~keep_proofs with_evars = + dEqThen ~keep_proofs with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data (c, t) = Proofview.Goal.enter begin fun gl -> let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in - decompEqThen (fun _ -> tac) data cl + decompEqThen !keep_proof_equalities_for_injection (fun _ -> tac) data cl end let _ = declare_intro_decomp_eq intro_decomp_eq diff --git a/tactics/equality.mli b/tactics/equality.mli index a4d1c0f9bd..65da2e7dc0 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -67,23 +67,31 @@ val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.ta val replace : constr -> constr -> unit Proofview.tactic val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic +type inj_flags = { + keep_proof_equalities : bool; (* One may want it or not *) + injection_in_context : bool; (* For regularity; one may want it from ML code but not interactively *) + injection_pattern_l2r_order : bool; (* Compatibility option: no reason not to want it *) + } + val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic val discrConcl : unit Proofview.tactic val discrHyp : Id.t -> unit Proofview.tactic val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val inj : intro_patterns option -> evars_flag -> + +(* Below, if flag is [None], it takes the value from the dynamic value of the option *) +val inj : inj_flags option -> intro_patterns option -> evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic -val injClause : intro_patterns option -> evars_flag -> +val injClause : inj_flags option -> intro_patterns option -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val injHyp : clear_flag -> Id.t -> unit Proofview.tactic -val injConcl : unit Proofview.tactic -val simpleInjClause : evars_flag -> +val injHyp : inj_flags option -> clear_flag -> Id.t -> unit Proofview.tactic +val injConcl : inj_flags option -> unit Proofview.tactic +val simpleInjClause : inj_flags option -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEq : keep_proofs:(bool option) -> evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEqThen : keep_proofs:(bool option) -> evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) @@ -100,7 +108,7 @@ val rewriteInConcl : bool -> constr -> unit Proofview.tactic val discriminable : env -> evar_map -> constr -> constr -> bool (* Tells if tactic "injection" is applicable *) -val injectable : env -> evar_map -> constr -> constr -> bool +val injectable : env -> evar_map -> keep_proofs:(bool option) -> constr -> constr -> bool (* Subst *) diff --git a/tactics/inv.ml b/tactics/inv.ml index f391382bfc..c5aa74ba5c 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -371,7 +371,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (* If no immediate variable in the equation, try to decompose it *) (* and apply a trailer which again try to substitute *) (fun id -> - dEqThen false (deq_trailer id) + dEqThen ~keep_proofs:None false (deq_trailer id) (Some (None,ElimOnConstr (EConstr.mkVar id,NoBindings)))) id diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d6c24e9cc9..e8a78d72d6 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1579,11 +1579,11 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in let hypmv = - try match List.remove Int.equal indmv (clenv_independent elimclause) with - | [a] -> a - | _ -> failwith "" - with Failure _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.") in + match List.remove Int.equal indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.") + in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = Retyping.get_type_of env sigma hyp in @@ -2471,7 +2471,7 @@ let exceed_bound n = function (* We delay thinning until the completion of the whole intros tactic to ensure that dependent hypotheses are cleared in the right - dependency order (see bug #1000); we use fresh names, not used in + dependency order (see BZ#1000); we use fresh names, not used in the tactic, for the hyps to clear *) (* In [intro_patterns_core b avoid ids thin destopt bound n tac patl]: [b]: compatibility flag, if false at toplevel, do not complete incomplete diff --git a/test-suite/Makefile b/test-suite/Makefile index ae426f0daf..61e75fa5d3 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -92,7 +92,7 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ coqdoc # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coq-makefile +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log @@ -156,6 +156,7 @@ summary: $(call summary_dir, "IDE tests", ide); \ $(call summary_dir, "VI tests", vio); \ $(call summary_dir, "Coqchk tests", coqchk); \ + $(call summary_dir, "Coqwc tests", coqwc); \ $(call summary_dir, "Coq makefile", coq-makefile); \ $(call summary_dir, "Coqdoc tests", coqdoc); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ @@ -498,6 +499,26 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) fi; \ } > "$@" +# coqwc : test output + +coqwc : $(patsubst %.v,%.v.log,$(wildcard coqwc/*.v)) + +coqwc/%.v.log : coqwc/%.v + $(HIDE){ \ + echo $(call log_intro,$<); \ + tmpoutput=`mktemp /tmp/coqwc.XXXXXX`; \ + $(BIN)coqwc $< 2>&1 > $$tmpoutput; \ + diff -u --strip-trailing-cr coqwc/$*.out $$tmpoutput 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (unexpected output)"; \ + fi; \ + rm $$tmpoutput; \ + } > "$@" + # coq_makefile coq-makefile: $(patsubst %/run.sh,%.log,$(wildcard coq-makefile/*/run.sh)) diff --git a/test-suite/bugs/closed/38.v b/test-suite/bugs/closed/1238.v index 6b6e83779f..6b6e83779f 100644 --- a/test-suite/bugs/closed/38.v +++ b/test-suite/bugs/closed/1238.v diff --git a/test-suite/bugs/closed/1322.v b/test-suite/bugs/closed/1322.v index 1ec7d452a6..6941ade44c 100644 --- a/test-suite/bugs/closed/1322.v +++ b/test-suite/bugs/closed/1322.v @@ -12,7 +12,11 @@ Variable I_eq_equiv : Setoid_Theory I I_eq. transitivity proved by I_eq_equiv.(Seq_trans I I_eq) as I_eq_relation. *) -Add Setoid I I_eq I_eq_equiv as I_with_eq. +Add Parametric Relation : I I_eq + reflexivity proved by I_eq_equiv.(@Equivalence_Reflexive _ _) + symmetry proved by I_eq_equiv.(@Equivalence_Symmetric _ _) + transitivity proved by I_eq_equiv.(@Equivalence_Transitive _ _) + as I_with_eq. Variable F : I -> Type. Variable F_morphism : forall i j, I_eq i j -> F i = F j. diff --git a/test-suite/bugs/closed/121.v b/test-suite/bugs/closed/1341.v index 8c5a38859f..8c5a38859f 100644 --- a/test-suite/bugs/closed/121.v +++ b/test-suite/bugs/closed/1341.v diff --git a/test-suite/bugs/closed/1362.v b/test-suite/bugs/closed/1362.v new file mode 100644 index 0000000000..6cafb9f0cd --- /dev/null +++ b/test-suite/bugs/closed/1362.v @@ -0,0 +1,26 @@ +(** Omega is now aware of the bodies of context variables + (of type Z or nat). *) + +Require Import ZArith Omega. +Open Scope Z. + +Goal let x := 3 in x = 3. +intros. +omega. +Qed. + +Open Scope nat. + +Goal let x := 2 in x = 2. +intros. +omega. +Qed. + +(** NB: this could be disabled for compatibility reasons *) + +Unset Omega UseLocalDefs. + +Goal let x := 4 in x = 4. +intros. +Fail omega. +Abort. diff --git a/test-suite/bugs/closed/328.v b/test-suite/bugs/closed/1542.v index 52cfbbc496..52cfbbc496 100644 --- a/test-suite/bugs/closed/328.v +++ b/test-suite/bugs/closed/1542.v diff --git a/test-suite/bugs/closed/329.v b/test-suite/bugs/closed/1543.v index def6ed98dd..def6ed98dd 100644 --- a/test-suite/bugs/closed/329.v +++ b/test-suite/bugs/closed/1543.v diff --git a/test-suite/bugs/closed/331.v b/test-suite/bugs/closed/1545.v index 9ef796faf7..9ef796faf7 100644 --- a/test-suite/bugs/closed/331.v +++ b/test-suite/bugs/closed/1545.v diff --git a/test-suite/bugs/closed/335.v b/test-suite/bugs/closed/1547.v index 166fa7a9f2..166fa7a9f2 100644 --- a/test-suite/bugs/closed/335.v +++ b/test-suite/bugs/closed/1547.v diff --git a/test-suite/bugs/closed/348.v b/test-suite/bugs/closed/1551.v index 48f0b55129..48f0b55129 100644 --- a/test-suite/bugs/closed/348.v +++ b/test-suite/bugs/closed/1551.v diff --git a/test-suite/bugs/closed/545.v b/test-suite/bugs/closed/1584.v index 926af7dd1c..926af7dd1c 100644 --- a/test-suite/bugs/closed/545.v +++ b/test-suite/bugs/closed/1584.v diff --git a/test-suite/bugs/closed/4852.v b/test-suite/bugs/closed/4852.v new file mode 100644 index 0000000000..5068ed9b95 --- /dev/null +++ b/test-suite/bugs/closed/4852.v @@ -0,0 +1,54 @@ +(** BZ 4852 : unsatisfactory Extraction Implicit for a fixpoint defined via wf *) + +Require Import Coq.Lists.List. +Import ListNotations. +Require Import Omega. + +Definition wfi_lt := well_founded_induction_type Wf_nat.lt_wf. + +Tactic Notation "wfinduction" constr(term) "on" ne_hyp_list(Hs) "as" ident(H) := + let R := fresh in + let E := fresh in + remember term as R eqn:E; + revert E; revert Hs; + induction R as [R H] using wfi_lt; + intros; subst R. + +Hint Rewrite @app_comm_cons @app_assoc @app_length : app_rws. + +Ltac solve_nat := autorewrite with app_rws in *; cbn in *; omega. + +Notation "| x |" := (length x) (at level 11, no associativity, format "'|' x '|'"). + +Definition split_acc (ls : list nat) : forall acc1 acc2, + (|acc1| = |acc2| \/ |acc1| = S (|acc2|)) -> + { lss : list nat * list nat | + let '(ls1, ls2) := lss in |ls1++ls2| = |ls++acc1++acc2| /\ (|ls1| = |ls2| \/ |ls1| = S (|ls2|))}. +Proof. + induction ls as [|a ls IHls]. all:intros acc1 acc2 H. + { exists (acc1, acc2). cbn. intuition reflexivity. } + destruct (IHls (a::acc2) acc1) as [[ls1 ls2] (H1 & H2)]. 1:solve_nat. + exists (ls1, ls2). cbn. intuition solve_nat. +Defined. + +Definition join(ls : list nat) : { rls : list nat | |rls| = |ls| }. +Proof. + wfinduction (|ls|) on ls as IH. + case (split_acc ls [] []). 1:solve_nat. + intros (ls1 & ls2) (H1 & H2). + destruct ls2 as [|a ls2]. + - exists ls1. solve_nat. + - unshelve eelim (IH _ _ ls1 eq_refl). 1:solve_nat. intros rls1 H3. + unshelve eelim (IH _ _ ls2 eq_refl). 1:solve_nat. intros rls2 H4. + exists (a :: rls1 ++ rls2). solve_nat. +Defined. + +Require Import ExtrOcamlNatInt. +Extract Inlined Constant length => "List.length". +Extract Inlined Constant app => "List.append". + +Extraction Inline wfi_lt. +Extraction Implicit wfi_lt [1 3]. +Recursive Extraction join. (* was: Error: An implicit occurs after extraction *) +Extraction TestCompile join. + diff --git a/test-suite/bugs/closed/5281.v b/test-suite/bugs/closed/5281.v new file mode 100644 index 0000000000..03bafdc9ae --- /dev/null +++ b/test-suite/bugs/closed/5281.v @@ -0,0 +1,6 @@ +Inductive A (T : Prop) := B (_ : T). +Scheme Equality for A. + +Goal forall (T:Prop), (forall x y : T, {x=y}+{x<>y}) -> forall x y : A T, {x=y}+{x<>y}. +decide equality. +Qed. diff --git a/test-suite/bugs/closed/5692.v b/test-suite/bugs/closed/5692.v new file mode 100644 index 0000000000..4c8d464f19 --- /dev/null +++ b/test-suite/bugs/closed/5692.v @@ -0,0 +1,88 @@ +Set Primitive Projections. +Require Import ZArith ssreflect. + +Module Test1. + +Structure semigroup := SemiGroup { + sg_car :> Type; + sg_op : sg_car -> sg_car -> sg_car; +}. + +Structure monoid := Monoid { + monoid_car :> Type; + monoid_op : monoid_car -> monoid_car -> monoid_car; + monoid_unit : monoid_car; +}. + +Coercion monoid_sg (X : monoid) : semigroup := + SemiGroup (monoid_car X) (monoid_op X). +Canonical Structure monoid_sg. + +Parameter X : monoid. +Parameter x y : X. + +Check (sg_op _ x y). + +End Test1. + +Module Test2. + +Structure semigroup := SemiGroup { + sg_car :> Type; + sg_op : sg_car -> sg_car -> sg_car; +}. + +Structure monoid := Monoid { + monoid_car :> Type; + monoid_op : monoid_car -> monoid_car -> monoid_car; + monoid_unit : monoid_car; + monoid_left_id x : monoid_op monoid_unit x = x; +}. + +Coercion monoid_sg (X : monoid) : semigroup := + SemiGroup (monoid_car X) (monoid_op X). +Canonical Structure monoid_sg. + +Canonical Structure nat_sg := SemiGroup nat plus. +Canonical Structure nat_monoid := Monoid nat plus 0 plus_O_n. + +Lemma foo (x : nat) : 0 + x = x. +Proof. +apply monoid_left_id. +Qed. + +End Test2. + +Module Test3. + +Structure semigroup := SemiGroup { + sg_car :> Type; + sg_op : sg_car -> sg_car -> sg_car; +}. + +Structure group := Something { + group_car :> Type; + group_op : group_car -> group_car -> group_car; + group_neg : group_car -> group_car; + group_neg_op' x y : group_neg (group_op x y) = group_op (group_neg x) (group_neg y) +}. + +Coercion group_sg (X : group) : semigroup := + SemiGroup (group_car X) (group_op X). +Canonical Structure group_sg. + +Axiom group_neg_op : forall (X : group) (x y : X), + group_neg X (sg_op (group_sg X) x y) = sg_op (group_sg X) (group_neg X x) (group_neg X y). + +Canonical Structure Z_sg := SemiGroup Z Z.add . +Canonical Structure Z_group := Something Z Z.add Z.opp Z.opp_add_distr. + +Lemma foo (x y : Z) : + sg_op Z_sg (group_neg Z_group x) (group_neg Z_group y) = + group_neg Z_group (sg_op Z_sg x y). +Proof. + rewrite -group_neg_op. + reflexivity. +Qed. + +End Test3. diff --git a/test-suite/bugs/closed/5741.v b/test-suite/bugs/closed/5741.v new file mode 100644 index 0000000000..f6598f192d --- /dev/null +++ b/test-suite/bugs/closed/5741.v @@ -0,0 +1,4 @@ +(* Check no anomaly in info_trivial *) + +Goal True. +info_trivial. diff --git a/test-suite/bugs/closed/5757.v b/test-suite/bugs/closed/5757.v new file mode 100644 index 0000000000..0d0f2eed44 --- /dev/null +++ b/test-suite/bugs/closed/5757.v @@ -0,0 +1,76 @@ +(* Check that resolved status of evars follows "restrict" *) + +Axiom H : forall (v : nat), Some 0 = Some v -> True. +Lemma L : True. +eapply H with _; +match goal with + | |- Some 0 = Some ?v => change (Some (0+0) = Some v) +end. +Abort. + +(* The original example *) + +Set Default Proof Using "Type". + +Module heap_lang. + +Inductive expr := + | InjR (e : expr). + +Inductive val := + | InjRV (v : val). + +Bind Scope val_scope with val. + +Fixpoint of_val (v : val) : expr := + match v with + | InjRV v => InjR (of_val v) + end. + +Fixpoint to_val (e : expr) : option val := None. + +End heap_lang. +Export heap_lang. + +Module W. +Inductive expr := + | Val (v : val) + (* Sums *) + | InjR (e : expr). + +Fixpoint to_expr (e : expr) : heap_lang.expr := + match e with + | Val v => of_val v + | InjR e => heap_lang.InjR (to_expr e) + end. + +End W. + + + +Section Tests. + + Context (iProp: Type). + Context (WPre: expr -> Prop). + + Context (tac_wp_alloc : + forall (e : expr) (v : val), + to_val e = Some v -> WPre e). + + Lemma push_atomic_spec (x: val) : + WPre (InjR (of_val x)). + Proof. +(* This works. *) +eapply tac_wp_alloc with _. +match goal with + | |- to_val ?e = Some ?v => + change (to_val (W.to_expr (W.InjR (W.Val x))) = Some v) +end. +Undo. Undo. +(* This is fixed *) +eapply tac_wp_alloc with _; +match goal with + | |- to_val ?e = Some ?v => + change (to_val (W.to_expr (W.InjR (W.Val x))) = Some v) +end. +Abort. diff --git a/test-suite/bugs/closed/5762.v b/test-suite/bugs/closed/5762.v new file mode 100644 index 0000000000..edd5c8d73d --- /dev/null +++ b/test-suite/bugs/closed/5762.v @@ -0,0 +1,28 @@ +(* Supporting imp. params. in inductive or fixpoints mutually defined with a notation *) + +Reserved Notation "* a" (at level 70). +Inductive P {n : nat} : nat -> Prop := +| c m : *m +where "* m" := (P m). + +Reserved Notation "##". +Inductive I {A:Type} := C : ## where "##" := I. + +(* The following was working in 8.6 *) + +Require Import Vector. + +Reserved Notation "# a" (at level 70). +Fixpoint f {n : nat} (v:Vector.t nat n) : nat := + match v with + | nil _ => 0 + | cons _ _ _ v => S (#v) + end +where "# v" := (f v). + +(* The following was working in 8.6 *) + +Reserved Notation "%% a" (at level 70). +Record R := + {g : forall {A} (a:A), a=a where "%% x" := (g x); + k : %% 0 = eq_refl}. diff --git a/test-suite/bugs/closed/5765.v b/test-suite/bugs/closed/5765.v new file mode 100644 index 0000000000..343ab49357 --- /dev/null +++ b/test-suite/bugs/closed/5765.v @@ -0,0 +1,3 @@ +(* 'pat binder not (yet?) allowed in parameters of inductive types *) + +Fail Inductive X '(a,b) := x. diff --git a/test-suite/bugs/closed/5769.v b/test-suite/bugs/closed/5769.v new file mode 100644 index 0000000000..42573aad87 --- /dev/null +++ b/test-suite/bugs/closed/5769.v @@ -0,0 +1,20 @@ +(* Check a few naming heuristics based on types *) +(* was buggy for types names _something *) + +Inductive _foo :=. +Lemma bob : (sigT (fun x : nat => _foo)) -> _foo. +destruct 1. +exact _f. +Abort. + +Inductive _'Foo :=. +Lemma bob : (sigT (fun x : nat => _'Foo)) -> _'Foo. +destruct 1. +exact _'f. +Abort. + +Inductive ____ :=. +Lemma bob : (sigT (fun x : nat => ____)) -> ____. +destruct 1. +exact x0. +Abort. diff --git a/test-suite/bugs/closed/846.v b/test-suite/bugs/closed/5797.v index ee5ec1fa6a..ee5ec1fa6a 100644 --- a/test-suite/bugs/closed/846.v +++ b/test-suite/bugs/closed/5797.v diff --git a/test-suite/bugs/closed/931.v b/test-suite/bugs/closed/5845.v index ea3347a851..ea3347a851 100644 --- a/test-suite/bugs/closed/931.v +++ b/test-suite/bugs/closed/5845.v diff --git a/test-suite/bugs/closed/1100.v b/test-suite/bugs/closed/5940.v index 32c78b4b9e..32c78b4b9e 100644 --- a/test-suite/bugs/closed/1100.v +++ b/test-suite/bugs/closed/5940.v diff --git a/test-suite/bugs/opened/743.v b/test-suite/bugs/opened/1615.v index 2825701410..2825701410 100644 --- a/test-suite/bugs/opened/743.v +++ b/test-suite/bugs/opened/1615.v diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 9786af10a8..7e0baaa8f2 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -32,9 +32,12 @@ make print-pretty-timed-diff TIME_OF_BUILD_BEFORE_FILE=../before/time-of-build-b cp ../before/time-of-build-before.log ./ make print-pretty-timed-diff || exit $? +INFINITY="∞" +INFINITY_REPLACEMENT="+.%" # assume that if the before time is zero, we expected the time to increase + for ext in "" .desired; do for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do - cat ${file}${ext} | grep -v 'warning: undefined variable' | sed s'/[0-9]//g' | sed s'/ *$//g' | sed s'/^-*$/------/g' | sed s'/ */ /g' | sed s'/\(Total.*\)-\(.*\)-/\1+\2+/g' > ${file}${ext}.processed + cat ${file}${ext} | grep -v 'warning: undefined variable' | sed s"/${INFINITY}/${INFINITY_REPLACEMENT}/g" | sed s'/[0-9]//g' | sed s'/ *$//g' | sed s":|\s*N/A\s*$:| ${INFINITY_REPLACEMENT}:g" | sed s'/^-*$/------/g' | sed s'/ */ /g' | sed s'/\(Total.*\)-\(.*\)-/\1+\2+/g' > ${file}${ext}.processed done done for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do @@ -58,7 +61,7 @@ echo for ext in "" .desired; do for file in A.v.timing.diff; do - cat ${file}${ext} | sed s'/[0-9]*\.[0-9]*//g' | sed s'/0//g' | sed s'/ */ /g' | sed s'/+/-/g' | sort > ${file}${ext}.processed + cat ${file}${ext} | sed s"/${INFINITY}/${INFINITY_REPLACEMENT}/g" | sed s":|\s*N/A\s*$:| ${INFINITY_REPLACEMENT}:g" | sed s'/[0-9]*\.[0-9]*//g' | sed s'/0//g' | sed s'/ */ /g' | sed s'/+/-/g' | sort > ${file}${ext}.processed done done for file in A.v.timing.diff; do diff --git a/test-suite/coqdoc/links.html.out b/test-suite/coqdoc/links.html.out index 7d7d01c1b4..e2928f78d4 100644 --- a/test-suite/coqdoc/links.html.out +++ b/test-suite/coqdoc/links.html.out @@ -76,7 +76,7 @@ Various checks for coqdoc <br/> <span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#d43e996736952df71ebeeae74d10a287"><span class="id" title="notation">-></span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> <br/> -<span class="id" title="keyword">where</span> <a name="8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="variable">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> +<span class="id" title="keyword">where</span> <a name="8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> <br/> <span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out index 844fb3031c..de3182d1a0 100644 --- a/test-suite/coqdoc/links.tex.out +++ b/test-suite/coqdoc/links.tex.out @@ -59,7 +59,7 @@ Various checks for coqdoc \coqdocnoindent \coqdoceol \coqdocnoindent -\coqdockw{where} \coqdef{Coqdoc.links.:type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqdocvariable{eq} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol +\coqdockw{where} \coqdef{Coqdoc.links.:type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvariable{A} \coqdocvariable{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol diff --git a/test-suite/coqwc/BZ5637.out b/test-suite/coqwc/BZ5637.out new file mode 100644 index 0000000000..f0b5e4f7eb --- /dev/null +++ b/test-suite/coqwc/BZ5637.out @@ -0,0 +1,2 @@ + spec proof comments + 5 0 0 coqwc/BZ5637.v diff --git a/test-suite/coqwc/BZ5637.v b/test-suite/coqwc/BZ5637.v new file mode 100644 index 0000000000..6428b10ff8 --- /dev/null +++ b/test-suite/coqwc/BZ5637.v @@ -0,0 +1,5 @@ +Local Obligation Tactic := idtac. +Definition a := 1. +Definition b := 1. +Definition c := 1. +Definition d := 1. diff --git a/test-suite/coqwc/BZ5756.out b/test-suite/coqwc/BZ5756.out new file mode 100644 index 0000000000..039d1e5008 --- /dev/null +++ b/test-suite/coqwc/BZ5756.out @@ -0,0 +1,2 @@ + spec proof comments + 3 0 2 coqwc/BZ5756.v diff --git a/test-suite/coqwc/BZ5756.v b/test-suite/coqwc/BZ5756.v new file mode 100644 index 0000000000..ccb12076a3 --- /dev/null +++ b/test-suite/coqwc/BZ5756.v @@ -0,0 +1,3 @@ +Definition myNextValue := 0. (* OK *) +Definition x := myNextValue. (* not OK *) +Definition y := 0. diff --git a/test-suite/coqwc/false.out b/test-suite/coqwc/false.out new file mode 100644 index 0000000000..14c5713f6d --- /dev/null +++ b/test-suite/coqwc/false.out @@ -0,0 +1,2 @@ + spec proof comments + 3 3 1 coqwc/false.v diff --git a/test-suite/coqwc/false.v b/test-suite/coqwc/false.v new file mode 100644 index 0000000000..640f9ea7f0 --- /dev/null +++ b/test-suite/coqwc/false.v @@ -0,0 +1,8 @@ +Axiom x : nat. + +Definition foo (x : nat) := x + 1. + +Lemma bar : False. + idtac. + idtac. (* truth is overrated *) +Admitted. diff --git a/test-suite/coqwc/next-obligation.out b/test-suite/coqwc/next-obligation.out new file mode 100644 index 0000000000..7a0fd777c1 --- /dev/null +++ b/test-suite/coqwc/next-obligation.out @@ -0,0 +1,2 @@ + spec proof comments + 1 7 0 coqwc/next-obligation.v diff --git a/test-suite/coqwc/next-obligation.v b/test-suite/coqwc/next-obligation.v new file mode 100644 index 0000000000..786df98913 --- /dev/null +++ b/test-suite/coqwc/next-obligation.v @@ -0,0 +1,10 @@ +(* make sure all proof lines are counted *) + +Goal True. + Next Obligation. + idtac. + Next Obligation. + idtac. + Next Obligation. + idtac. +Qed. diff --git a/test-suite/coqwc/theorem.out b/test-suite/coqwc/theorem.out new file mode 100644 index 0000000000..d01507bf78 --- /dev/null +++ b/test-suite/coqwc/theorem.out @@ -0,0 +1,2 @@ + spec proof comments + 1 9 2 coqwc/theorem.v diff --git a/test-suite/coqwc/theorem.v b/test-suite/coqwc/theorem.v new file mode 100644 index 0000000000..901c9074fd --- /dev/null +++ b/test-suite/coqwc/theorem.v @@ -0,0 +1,10 @@ +Theorem foo : True. +Proof. + idtac. (* comment *) + idtac. + idtac. + idtac. (* comment *) + idtac. + idtac. + auto. +Qed. diff --git a/test-suite/ideal-features/complexity/evars_subst.v b/test-suite/ideal-features/complexity/evars_subst.v index b3dfb33cdc..b9c3598887 100644 --- a/test-suite/ideal-features/complexity/evars_subst.v +++ b/test-suite/ideal-features/complexity/evars_subst.v @@ -1,4 +1,4 @@ -(* Bug report #932 *) +(* BZ#932 *) (* Expected time < 1.00s *) (* Let n be the number of let-in. The complexity comes from the fact diff --git a/test-suite/ideal-features/evars_subst.v b/test-suite/ideal-features/evars_subst.v index b3dfb33cdc..b9c3598887 100644 --- a/test-suite/ideal-features/evars_subst.v +++ b/test-suite/ideal-features/evars_subst.v @@ -1,4 +1,4 @@ -(* Bug report #932 *) +(* BZ#932 *) (* Expected time < 1.00s *) (* Let n be the number of let-in. The complexity comes from the fact diff --git a/test-suite/interactive/Back.v b/test-suite/interactive/Back.v index b813a79ab2..22364254dc 100644 --- a/test-suite/interactive/Back.v +++ b/test-suite/interactive/Back.v @@ -1,5 +1,5 @@ (* Check that reset remains synchronised with the compilation unit cache *) -(* See bug #1030 *) +(* See BZ#1030 *) Section multiset_defs. Require Import Plus. diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh new file mode 100755 index 0000000000..13e264c09c --- /dev/null +++ b/test-suite/misc/deps-utf8.sh @@ -0,0 +1,17 @@ +# Check reading directories matching non pure ascii idents +# See bug #5715 (utf-8 working on macos X and linux) +# Windows is still not compliant +a=`uname` +if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then +rm -f misc/deps/théorèmes/*.v +tmpoutput=`mktemp /tmp/coqcheck.XXXXXX` +$coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v +R=$? +$coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v +S=$? +if [ $R = 0 -a $S = 0 ]; then + exit 0 +else + exit 1 +fi +fi diff --git a/test-suite/misc/deps/αβ/γδ.v b/test-suite/misc/deps/αβ/γδ.v new file mode 100644 index 0000000000..f43a2d6571 --- /dev/null +++ b/test-suite/misc/deps/αβ/γδ.v @@ -0,0 +1,4 @@ +Theorem simple : forall A, A -> A. +Proof. +auto. +Qed. diff --git a/test-suite/misc/deps/αβ/εζ.v b/test-suite/misc/deps/αβ/εζ.v new file mode 100644 index 0000000000..e7fd25c0d1 --- /dev/null +++ b/test-suite/misc/deps/αβ/εζ.v @@ -0,0 +1 @@ +Require Import γδ. diff --git a/test-suite/modules/objects2.v b/test-suite/modules/objects2.v index 220e2b3694..0a6b1f06de 100644 --- a/test-suite/modules/objects2.v +++ b/test-suite/modules/objects2.v @@ -2,7 +2,7 @@ the logical objects in the environment *) -(* Bug #1118 (simplified version), submitted by Evelyne Contejean +(* BZ#1118 (simplified version), submitted by Evelyne Contejean (used to failed in pre-V8.1 trunk because of a call to lookup_mind for structure objects) *) diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index fafb478bad..61ae4edbd1 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -7,7 +7,7 @@ Check | a :: l => f a :: F _ _ f l end). -(* V8 printing of this term used to failed in V8.0 and V8.0pl1 (cf bug #860) *) +(* V8 printing of this term used to failed in V8.0 and V8.0pl1 (cf BZ#860) *) Check let fix f (m : nat) : nat := match m with diff --git a/test-suite/output/Implicit.v b/test-suite/output/Implicit.v index 7c9b89f9d2..306532c0df 100644 --- a/test-suite/output/Implicit.v +++ b/test-suite/output/Implicit.v @@ -1,7 +1,7 @@ Set Implicit Arguments. Unset Strict Implicit. -(* Suggested by Pierre Casteran (bug #169) *) +(* Suggested by Pierre Casteran (BZ#169) *) (* Argument 3 is needed to typecheck and should be printed *) Definition compose (A B C : Set) (f : A -> B) (g : B -> C) (x : A) := g (f x). Check (compose (C:=nat) S). diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 65efe228af..6ef75dd135 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -124,3 +124,7 @@ return (1, 2, 3, 4) : nat !!! _ _ : nat, True : (nat -> Prop) * ((nat -> Prop) * Prop) +((*1).2).3 + : nat +*(1.2) + : nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index ea372ad1a3..8c7bbe5917 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -190,3 +190,10 @@ Check 1+1+1. (* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). Check !!! (x y:nat), True. + +(* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) + +Notation "* x" := (id x) (only printing, at level 15, format "* x"). +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). +Check (((id 1) + 2) + 3). +Check (id (1 + 2)). diff --git a/test-suite/output/SuggestProofUsing.out b/test-suite/output/SuggestProofUsing.out new file mode 100644 index 0000000000..8d67a4a4b7 --- /dev/null +++ b/test-suite/output/SuggestProofUsing.out @@ -0,0 +1,7 @@ +The proof of nat should start with one of the following commands: +Proof using . +Proof using Type*. +Proof using Type. +The proof of foo should start with one of the following commands: +Proof using A B. +Proof using All. diff --git a/test-suite/output/SuggestProofUsing.v b/test-suite/output/SuggestProofUsing.v new file mode 100644 index 0000000000..00b6f8e183 --- /dev/null +++ b/test-suite/output/SuggestProofUsing.v @@ -0,0 +1,31 @@ +Set Suggest Proof Using. + +Section Sec. + Variables A B : Type. + + (* Some normal lemma. *) + Lemma nat : Set. + Proof. + exact nat. + Qed. + + (* Make sure All is suggested even though we add an unused variable + to the context. *) + Let foo : Type. + Proof. + exact (A -> B). + Qed. + + (* Having a [Proof using] disables the suggestion message. *) + Definition bar : Type. + Proof using A. + exact A. + Qed. + + (* Transparent definitions don't get a suggestion message. *) + Definition baz : Type. + Proof. + exact A. + Defined. + +End Sec. diff --git a/test-suite/output/Tactics.v b/test-suite/output/Tactics.v index 9a5edb813d..75b66e463a 100644 --- a/test-suite/output/Tactics.v +++ b/test-suite/output/Tactics.v @@ -7,12 +7,12 @@ Ltac f H := split; [a H|e H]. Print Ltac f. (* Test printing of match context *) -(* Used to fail after translator removal (see bug #1070) *) +(* Used to fail after translator removal (see BZ#1070) *) Ltac g := match goal with |- context [if ?X then _ else _ ] => case X end. Print Ltac g. -(* Test an error message (#5390) *) +(* Test an error message (BZ#5390) *) Lemma myid (P : Prop) : P <-> P. Proof. split; auto. Qed. diff --git a/test-suite/output/auto.out b/test-suite/output/auto.out index a5b55a9993..2761b87b02 100644 --- a/test-suite/output/auto.out +++ b/test-suite/output/auto.out @@ -18,3 +18,5 @@ Debug: 1 depth=5 Debug: 1.1 depth=4 simple apply or_intror Debug: 1.1.1 depth=4 intro Debug: 1.1.1.1 depth=4 exact H +(* info trivial: *) +exact I (in core). diff --git a/test-suite/output/auto.v b/test-suite/output/auto.v index a77b7b82e6..92917cdfc7 100644 --- a/test-suite/output/auto.v +++ b/test-suite/output/auto.v @@ -9,3 +9,7 @@ info_eauto. Undo. debug eauto. Qed. + +Goal True. +info_trivial. +Qed. diff --git a/test-suite/output/ltac_extra_args.out b/test-suite/output/ltac_extra_args.out new file mode 100644 index 0000000000..77e799d359 --- /dev/null +++ b/test-suite/output/ltac_extra_args.out @@ -0,0 +1,8 @@ +The command has indeed failed with message: +Illegal tactic application: got 1 extra argument. +The command has indeed failed with message: +Illegal tactic application: got 2 extra arguments. +The command has indeed failed with message: +Illegal tactic application: got 1 extra argument. +The command has indeed failed with message: +Illegal tactic application: got 2 extra arguments. diff --git a/test-suite/output/ltac_extra_args.v b/test-suite/output/ltac_extra_args.v new file mode 100644 index 0000000000..4caf619fee --- /dev/null +++ b/test-suite/output/ltac_extra_args.v @@ -0,0 +1,10 @@ +Ltac foo := idtac. +Ltac bar H := idtac. + +Goal True. +Proof. + Fail foo H. + Fail foo H H'. + Fail bar H H'. + Fail bar H H' H''. +Abort. diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v index 69dc9aca78..d52a853aae 100644 --- a/test-suite/success/Abstract.v +++ b/test-suite/success/Abstract.v @@ -1,4 +1,4 @@ -(* Cf coqbugs #546 *) +(* Cf BZ#546 *) Require Import Omega. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index 06f807f29a..893d75b77f 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -64,7 +64,7 @@ Check (fun x:I1 => end). (* Check implicit parameters of inductive types (submitted by Pierre - Casteran and also implicit in #338) *) + Casteran and also implicit in BZ#338) *) Set Implicit Arguments. Unset Strict Implicit. @@ -80,7 +80,7 @@ Inductive Finite (A : Set) : LList A -> Prop := | Finite_LCons : forall (a : A) (l : LList A), Finite l -> Finite (LCons a l). -(* Check positivity modulo reduction (cf bug #983) *) +(* Check positivity modulo reduction (cf bug BZ#983) *) Record P:Type := {PA:Set; PB:Set}. diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index 850f094348..45c71615fc 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -1,6 +1,6 @@ Axiom magic : False. -(* Submitted by Dachuan Yu (bug #220) *) +(* Submitted by Dachuan Yu (BZ#220) *) Fixpoint T (n : nat) : Type := match n with | O => nat -> Prop @@ -16,7 +16,7 @@ Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l. inversion 1. Abort. -(* Submitted by Pierre Casteran (bug #540) *) +(* Submitted by Pierre Casteran (BZ#540) *) Set Implicit Arguments. Unset Strict Implicit. @@ -64,7 +64,7 @@ elim magic. elim magic. Qed. -(* Submitted by Boris Yakobowski (bug #529) *) +(* Submitted by Boris Yakobowski (BZ#529) *) (* Check that Inversion does not fail due to unnormalized evars *) Set Implicit Arguments. @@ -100,7 +100,7 @@ intros a b H. inversion H. Abort. -(* Check non-regression of bug #1968 *) +(* Check non-regression of BZ#1968 *) Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t). Goal forall o, foo2 o -> 0 = 1. @@ -130,7 +130,7 @@ Proof. intros. inversion H. Abort. -(* Bug #2314 (simplified): check that errors do not show as anomalies *) +(* BZ#2314 (simplified): check that errors do not show as anomalies *) Goal True -> True. intro. @@ -158,7 +158,7 @@ reflexivity. Qed. (* Up to September 2014, Mapp below was called MApp0 because of a bug - in intro_replacing (short version of bug 2164.v) + in intro_replacing (short version of BZ#2164.v) (example taken from CoLoR) *) Parameter Term : Type. diff --git a/test-suite/success/Mod_type.v b/test-suite/success/Mod_type.v index d5e1a38cf5..6c59bf6edb 100644 --- a/test-suite/success/Mod_type.v +++ b/test-suite/success/Mod_type.v @@ -1,4 +1,4 @@ -(* Check bug #1025 submitted by Pierre-Luc Carmel Biron *) +(* Check BZ#1025 submitted by Pierre-Luc Carmel Biron *) Module Type FOO. Parameter A : Type. @@ -18,7 +18,7 @@ Module Bar : BAR. End Bar. -(* Check bug #2809: correct printing of modules with notations *) +(* Check BZ#2809: correct printing of modules with notations *) Module C. Inductive test : Type := diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 4d04f2cf9b..e3f90f6d94 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -1,5 +1,5 @@ (* Check that "where" clause behaves as if given independently of the *) -(* definition (variant of bug #1132 submitted by Assia Mahboubi) *) +(* definition (variant of BZ#1132 submitted by Assia Mahboubi) *) Fixpoint plus1 (n m:nat) {struct n} : nat := match n with diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v index ecbf04e412..470e4f0580 100644 --- a/test-suite/success/Omega.v +++ b/test-suite/success/Omega.v @@ -52,7 +52,7 @@ Lemma lem5 : (H > 0)%Z. Qed. End B. -(* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *) +(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *) Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. @@ -86,7 +86,7 @@ intros; omega. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) -(* Submitted by Hubert Thierry (bug #743) *) +(* Submitted by Hubert Thierry (BZ#743) *) (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). Proof. diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v index b8f8660e9c..6fd936935c 100644 --- a/test-suite/success/Omega0.v +++ b/test-suite/success/Omega0.v @@ -132,7 +132,7 @@ intros. omega. Qed. -(* Magaud #240 *) +(* Magaud BZ#240 *) Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. intros. diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v index c4d086a348..4e726335c9 100644 --- a/test-suite/success/Omega2.v +++ b/test-suite/success/Omega2.v @@ -1,6 +1,6 @@ Require Import ZArith Omega. -(* Submitted by Yegor Bryukhov (#922) *) +(* Submitted by Yegor Bryukhov (BZ#922) *) Open Scope Z_scope. diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v index 801ece9e3d..0df3d5685d 100644 --- a/test-suite/success/ROmega.v +++ b/test-suite/success/ROmega.v @@ -52,7 +52,7 @@ Lemma lem5 : (H > 0)%Z. Qed. End B. -(* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *) +(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *) Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. @@ -88,7 +88,7 @@ romega with nat. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) -(* Submitted by Hubert Thierry (bug #743) *) +(* Submitted by Hubert Thierry (BZ#743) *) (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m : nat, le n (plus n (mult n m)). Proof. diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v index 42730f2e16..3ddf6a40fb 100644 --- a/test-suite/success/ROmega0.v +++ b/test-suite/success/ROmega0.v @@ -132,7 +132,7 @@ intros. romega. Qed. -(* Magaud #240 *) +(* Magaud BZ#240 *) Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. Proof. @@ -146,7 +146,7 @@ intros x y. romega. Qed. -(* Besson #1298 *) +(* Besson BZ#1298 *) Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False. Proof. diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v index 87e8c8e33e..43eda67ea3 100644 --- a/test-suite/success/ROmega2.v +++ b/test-suite/success/ROmega2.v @@ -1,6 +1,6 @@ Require Import ZArith ROmega. -(* Submitted by Yegor Bryukhov (#922) *) +(* Submitted by Yegor Bryukhov (BZ#922) *) Open Scope Z_scope. diff --git a/test-suite/success/ROmega4.v b/test-suite/success/ROmega4.v new file mode 100644 index 0000000000..58ae5b8fb8 --- /dev/null +++ b/test-suite/success/ROmega4.v @@ -0,0 +1,26 @@ +(** ROmega is now aware of the bodies of context variables + (of type Z or nat). + See also #148 for the corresponding improvement in Omega. +*) + +Require Import ZArith ROmega. +Open Scope Z. + +Goal let x := 3 in x = 3. +intros. +romega. +Qed. + +(** Example seen in #4132 + (actually solvable even if b isn't known to be 5) *) + +Lemma foo + (x y x' zxy zxy' z : Z) + (b := 5) + (Ry : - b <= y < b) + (Bx : x' <= b) + (H : - zxy' <= zxy) + (H' : zxy' <= x') : - b <= zxy. +Proof. +romega. +Qed. diff --git a/test-suite/success/Rename.v b/test-suite/success/Rename.v index 0576f3c68f..2789c6c9a6 100644 --- a/test-suite/success/Rename.v +++ b/test-suite/success/Rename.v @@ -4,7 +4,7 @@ rename n into p. induction p; auto. Qed. -(* Submitted by Iris Loeb (#842) *) +(* Submitted by Iris Loeb (BZ#842) *) Section rename. diff --git a/test-suite/success/Try.v b/test-suite/success/Try.v index 361c787e25..76aac39a55 100644 --- a/test-suite/success/Try.v +++ b/test-suite/success/Try.v @@ -1,5 +1,5 @@ (* To shorten interactive scripts, it is better that Try catches - non-existent names in Unfold [cf bug #263] *) + non-existent names in Unfold [cf BZ#263] *) Lemma lem1 : True. try unfold i_dont_exist. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 90a60daa66..0219c3bfdf 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -12,7 +12,7 @@ assumption. assumption. Qed. -(* Simplification of bug 711 *) +(* Simplification of BZ#711 *) Parameter f : true = false. Goal let p := f in True. @@ -37,7 +37,7 @@ Goal True. case Refl || ecase Refl. Abort. -(* Submitted by B. Baydemir (bug #1882) *) +(* Submitted by B. Baydemir (BZ#1882) *) Require Import List. @@ -385,7 +385,7 @@ intros. Fail destruct H. Abort. -(* Check keep option (bug #3791) *) +(* Check keep option (BZ#3791) *) Goal forall b:bool, True. intro b. diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index c36313ec16..627794832d 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -23,7 +23,7 @@ Definition f1 frm0 a1 : B := f frm0 a1. (* Checks that solvable ? in the type part of the definition are harmless *) Definition f2 frm0 a1 : B := f frm0 a1. -(* Checks that sorts that are evars are handled correctly (bug 705) *) +(* Checks that sorts that are evars are handled correctly (BZ#705) *) Require Import List. Fixpoint build (nl : list nat) : @@ -58,7 +58,7 @@ Check (forall y n : nat, {q : nat | y = q * n}) -> forall n : nat, {q : nat | x = q * n}). -(* Check instantiation of nested evars (bug #1089) *) +(* Check instantiation of nested evars (BZ#1089) *) Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))). @@ -188,7 +188,7 @@ Abort. End Additions_while. -(* Two examples from G. Melquiond (bugs #1878 and #1884) *) +(* Two examples from G. Melquiond (BZ#1878 and BZ#1884) *) Parameter F1 G1 : nat -> Prop. Goal forall x : nat, F1 x -> G1 x. @@ -207,7 +207,7 @@ Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := | (existT _ k v)::l' => (existT _ k v):: (filter A l') end. -(* Bug #2000: used to raise Out of memory in 8.2 while it should fail by +(* BZ#2000: used to raise Out of memory in 8.2 while it should fail by lack of information on the conclusion of the type of j *) Goal True. @@ -381,7 +381,7 @@ Section evar_evar_occur. Check match g _ with conj a b => f _ a b end. End evar_evar_occur. -(* Eta expansion (bug #2936) *) +(* Eta expansion (BZ#2936) *) Record iffT (X Y:Type) : Type := mkIff { iffLR : X->Y; iffRL : Y->X }. Record tri (R:Type->Type->Type) (S:Type->Type->Type) (T:Type->Type->Type) := mkTri { tri0 : forall a b c, R a b -> S a c -> T b c diff --git a/test-suite/success/if.v b/test-suite/success/if.v index 9fde95e80d..c81d2b9bf1 100644 --- a/test-suite/success/if.v +++ b/test-suite/success/if.v @@ -3,7 +3,7 @@ Check (fun b : bool => if b then Type else nat). -(* Check correct use of if-then-else predicate annotation (cf bug 690) *) +(* Check correct use of if-then-else predicate annotation (cf BZ#690) *) Check fun b : bool => if b as b0 return (if b0 then b0 = true else b0 = false) diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index ee69df9774..a329894aad 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -1,5 +1,5 @@ (* Thinning introduction hypothesis must be done after all introductions *) -(* Submitted by Guillaume Melquiond (bug #1000) *) +(* Submitted by Guillaume Melquiond (BZ#1000) *) Goal forall A, A -> True. intros _ _. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 29e373eaa5..0f22a1f0a0 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -147,7 +147,7 @@ check_binding ipattern:(H). Abort. (* Check that variables explicitly parsed as ltac variables are not - seen as intro pattern or constr (bug #984) *) + seen as intro pattern or constr (BZ#984) *) Ltac afi tac := intros; tac. Goal 1 = 2. diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 352abb2af5..b8a8ff7561 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -31,7 +31,7 @@ Proof. end). Abort. -(* Submitted by Roland Zumkeller (bug #888) *) +(* Submitted by Roland Zumkeller (BZ#888) *) (* The Fix and CoFix rules expect a subgoal even for closed components of the (co-)fixpoint *) @@ -43,7 +43,7 @@ Goal nat -> nat. exact 0. Qed. -(* Submitted by Roland Zumkeller (bug #889) *) +(* Submitted by Roland Zumkeller (BZ#889) *) (* The types of metas were in metamap and they were not updated when passing through a binder *) @@ -56,7 +56,7 @@ Goal forall n : nat, nat -> n = 0. end). Abort. -(* Submitted by Roland Zumkeller (bug #931) *) +(* Submitted by Roland Zumkeller (BZ#931) *) (* Don't turn dependent evar into metas *) Goal (forall n : nat, n = 0 -> Prop) -> Prop. @@ -65,7 +65,7 @@ intro P. reflexivity. Abort. -(* Submitted by Jacek Chrzaszcz (bug #1102) *) +(* Submitted by Jacek Chrzaszcz (BZ#1102) *) (* le problème a été résolu ici par normalisation des evars présentes dans les types d'evars, mais le problème reste a priori ouvert dans diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 1f24ef2a6b..c8dfcd2cbf 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -33,7 +33,8 @@ Qed. Add Setoid set same setoid_set as setsetoid. -Add Morphism In : In_ext. +Add Morphism In with signature (eq ==> same ==> iff) as In_ext. +Proof. unfold same; intros a s t H; elim (H a); auto. Qed. @@ -50,10 +51,9 @@ simpl; right. apply (H2 H1). Qed. -Add Morphism Add : Add_ext. +Add Morphism Add with signature (eq ==> same ==> same) as Add_ext. split; apply add_aux. assumption. - rewrite H. reflexivity. Qed. @@ -90,7 +90,7 @@ Qed. Parameter P : set -> Prop. Parameter P_ext : forall s t : set, same s t -> P s -> P t. -Add Morphism P : P_extt. +Add Morphism P with signature (same ==> iff) as P_extt. intros; split; apply P_ext; (assumption || apply (Seq_sym _ _ setoid_set); assumption). Qed. @@ -113,7 +113,7 @@ Definition f: forall A : Set, A -> A := fun A x => x. Add Relation (id A) (rel A) as eq_rel. -Add Morphism (@f A) : f_morph. +Add Morphism (@f A) with signature (eq ==> eq) as f_morph. Proof. unfold rel, f. trivial. Qed. diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v index 6baf79701a..79467e549c 100644 --- a/test-suite/success/setoid_test2.v +++ b/test-suite/success/setoid_test2.v @@ -134,8 +134,8 @@ Axiom SetoidS2 : Setoid_Theory S2 eqS2. Add Setoid S2 eqS2 SetoidS2 as S2setoid. Axiom f : S1 -> nat -> S2. -Add Morphism f : f_compat. Admitted. -Add Morphism f : f_compat2. Admitted. +Add Morphism f with signature (eqS1 ==> eq ==> eqS2) as f_compat. Admitted. +Add Morphism f with signature (eqS1 ==> eq ==> eqS2) as f_compat2. Admitted. Theorem test1: forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)). intros. @@ -151,7 +151,7 @@ Theorem test1': forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)). Qed. Axiom g : S1 -> S2 -> nat. -Add Morphism g : g_compat. Admitted. +Add Morphism g with signature (eqS1 ==> eqS2 ==> eq) as g_compat. Admitted. Axiom P : nat -> Prop. Theorem test2: @@ -190,13 +190,13 @@ Theorem test5: Qed. Axiom f_test6 : S2 -> Prop. -Add Morphism f_test6 : f_test6_compat. Admitted. +Add Morphism f_test6 with signature (eqS2 ==> iff) as f_test6_compat. Admitted. Axiom g_test6 : bool -> S2. -Add Morphism g_test6 : g_test6_compat. Admitted. +Add Morphism g_test6 with signature (eq ==> eqS2) as g_test6_compat. Admitted. Axiom h_test6 : S1 -> bool. -Add Morphism h_test6 : h_test6_compat. Admitted. +Add Morphism h_test6 with signature (eqS1 ==> eq) as h_test6_compat. Admitted. Theorem test6: forall E1 E2, (eqS1 E1 E2) -> (f_test6 (g_test6 (h_test6 E2))) -> @@ -223,7 +223,7 @@ Add Setoid S1_test8 eqS1_test8 SetoidS1_test8 as S1_test8setoid. Instance eqS1_test8_default : DefaultRelation eqS1_test8. Axiom f_test8 : S2 -> S1_test8. -Add Morphism f_test8 : f_compat_test8. Admitted. +Add Morphism f_test8 with signature (eqS2 ==> eqS1_test8) as f_compat_test8. Admitted. Axiom eqS1_test8': S1_test8 -> S1_test8 -> Prop. Axiom SetoidS1_test8' : Setoid_Theory S1_test8 eqS1_test8'. @@ -233,7 +233,7 @@ Add Setoid S1_test8 eqS1_test8' SetoidS1_test8' as S1_test8setoid'. (S1_test8, eqS1_test8'). However this does not happen and there is still no syntax for it ;-( *) Axiom g_test8 : S1_test8 -> S2. -Add Morphism g_test8 : g_compat_test8. Admitted. +Add Morphism g_test8 with signature (eqS1_test8 ==> eqS2) as g_compat_test8. Admitted. Theorem test8: forall x x': S2, (eqS2 x x') -> diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index 5b87e877bf..1bfb8580b3 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -1,6 +1,6 @@ Require Import TestSuite.admit. (* Check that inversion of names of mutual inductive fixpoints works *) -(* (cf bug #1031) *) +(* (cf BZ#1031) *) Inductive tree : Set := | node : nat -> forest -> tree diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v index 6f7498d659..1ffc026730 100644 --- a/test-suite/success/unification.v +++ b/test-suite/success/unification.v @@ -43,7 +43,7 @@ Check (fun _h1 => (zenon_notall nat _ (fun _T_0 => (fun _h2 => (zenon_noteq _ _T_0 _h2))) _h1)). -(* Core of an example submitted by Ralph Matthes (#849) +(* Core of an example submitted by Ralph Matthes (BZ#849) It used to fail because of the K-variable x in the type of "sum_rec ..." which was not in the scope of the evar ?B. Solved by a head @@ -131,7 +131,7 @@ try case nonemptyT_intro. (* check that it fails w/o anomaly *) Abort. (* Test handling of return type and when it is decided to make the - predicate dependent or not - see "bug" #1851 *) + predicate dependent or not - see "bug" BZ#1851 *) Goal forall X (a:X) (f':nat -> X), (exists f : nat -> X, True). intros. diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index fc74225d76..2863404590 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -20,8 +20,7 @@ intro P; pattern P. apply lem2. Abort. -(* Check managing of universe constraints in inversion *) -(* Bug report #855 *) +(* Check managing of universe constraints in inversion (BZ#855) *) Inductive dep_eq : forall X : Type, X -> X -> Prop := | intro_eq : forall (X : Type) (f : X), dep_eq X f f @@ -40,7 +39,7 @@ Proof. Abort. -(* Submitted by Bas Spitters (bug report #935) *) +(* Submitted by Bas Spitters (BZ#935) *) (* This is a problem with the status of the type in LetIn: is it a user-provided one or an inferred one? At the current time, the diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v index 672222bdd6..a4fa544cd9 100644 --- a/test-suite/success/unshelve.v +++ b/test-suite/success/unshelve.v @@ -9,3 +9,11 @@ unshelve (refine (F _ _ _ _)). + exact (@eq_refl bool true). + exact (@eq_refl unit tt). Qed. + +(* This was failing in 8.6, because of ?a:nat being wrongly duplicated *) + +Goal (forall a : nat, a = 0 -> True) -> True. +intros F. +unshelve (eapply (F _);clear F). +2:reflexivity. +Qed. diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v index 61e911678a..ef1737bf85 100644 --- a/theories/Compat/Coq87.v +++ b/theories/Compat/Coq87.v @@ -7,3 +7,11 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.7 *) + +(* 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. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 25b042ca98..0041bfa1c4 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -762,7 +762,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. Qed. - Add Morphism cardinal : cardinal_m. + Add Morphism cardinal with signature (Equal ==> Logic.eq) as cardinal_m. Proof. exact Equal_cardinal. Qed. diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index 886533586f..87b7a9a3be 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -27,7 +27,7 @@ Local Ltac simplif flags := | id: ?X1 |- _ => is_disj flags X1; elim id; intro; clear id | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ => (* generalize (id0 id1); intro; clear id0 does not work - (see Marco Maggiesi's bug PR#301) + (see Marco Maggiesi's BZ#301) so we instead use Assert and exact. *) assert X2; [exact (id0 id1) | clear id0] | id: forall (_ : ?X1), ?X2|- _ => diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 88e1298fbe..5d055b5474 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -101,7 +101,7 @@ Proof. - apply Qred_complete. Qed. -Add Morphism Qred : Qred_comp. +Add Morphism Qred with signature (Qeq ==> Qeq) as Qred_comp. Proof. intros. now rewrite !Qred_correct. Qed. @@ -125,19 +125,19 @@ Proof. intros; unfold Qminus'; apply Qred_correct; auto. Qed. -Add Morphism Qplus' : Qplus'_comp. +Add Morphism Qplus' with signature (Qeq ==> Qeq ==> Qeq) as Qplus'_comp. Proof. intros; unfold Qplus'. rewrite H, H0; auto with qarith. Qed. -Add Morphism Qmult' : Qmult'_comp. +Add Morphism Qmult' with signature (Qeq ==> Qeq ==> Qeq) as Qmult'_comp. Proof. intros; unfold Qmult'. rewrite H, H0; auto with qarith. Qed. -Add Morphism Qminus' : Qminus'_comp. +Add Morphism Qminus' with signature (Qeq ==> Qeq ==> Qeq) as Qminus'_comp. Proof. intros; unfold Qminus'. rewrite H, H0; auto with qarith. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index afe8e62ee3..8f79f8a669 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -39,6 +39,7 @@ CAMLP4O := $(COQMF_CAMLP4O) CAMLP4BIN := $(COQMF_CAMLP4BIN) CAMLP4LIB := $(COQMF_CAMLP4LIB) CAMLP4OPTIONS := $(COQMF_CAMLP4OPTIONS) +CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) @CONF_FILE@: @PROJECT_FILE@ @@ -100,11 +101,11 @@ AFTER ?= CAMLDONTLINK=camlp5.gramlib,unix,str # OCaml binaries -CAMLC ?= "$(OCAMLFIND)" ocamlc -c -rectypes -thread -CAMLOPTC ?= "$(OCAMLFIND)" opt -c -rectypes -thread -CAMLLINK ?= "$(OCAMLFIND)" ocamlc -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) -CAMLOPTLINK ?= "$(OCAMLFIND)" opt -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) -CAMLDOC ?= "$(OCAMLFIND)" ocamldoc -rectypes +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack # DESTDIR is prepended to all installation paths @@ -114,8 +115,6 @@ DESTDIR ?= CAMLDEBUG ?= COQDEBUG ?= -# Extra flags to the OCaml compiler -CAMLFLAGS ?= # Extra packages to be linked in (as in findlib -package) CAMLPKGS ?= @@ -180,8 +179,6 @@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) $(OCAML_API_FLAGS) -CAMLLIB:=$(shell "$(OCAMLFIND)" printconf stdlib) - # FIXME This should be generated by Coq GRAMMARS:=grammar.cma ifeq ($(CAMLP4),camlp5) @@ -190,7 +187,12 @@ else CAMLP4EXTEND= endif +CAMLLIB:=$(shell "$(OCAMLFIND)" printconf stdlib 2> /dev/null) +ifeq (,$(CAMLLIB)) +PP=$(error "Cannot find the 'ocamlfind' binary used to build Coq ($(OCAMLFIND)). Pre-compiled binary packages of Coq do not support compiling plugins this way. Please download the sources of Coq and run the Windows build script.") +else PP:=-pp '$(CAMLP4O) -I $(CAMLLIB) -I "$(COQLIB)/grammar" $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl' +endif ifneq (,$(TIMING)) TIMING_ARG=-time @@ -749,7 +751,7 @@ printenv:: # file you can extend the merlin-hook target in @LOCAL_FILE@ .merlin: $(SHOW)'FILL .merlin' - $(HIDE)echo 'FLG -rectypes -thread' > .merlin + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin $(HIDE)echo 'B $(COQLIB)' >> .merlin $(HIDE)echo 'S $(COQLIB)' >> .merlin $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index a207c2171b..7298ef5e8e 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -28,10 +28,10 @@ def get_times(file_name): else: with open(file_name, 'r') as f: lines = f.read() - reg = re.compile(r'^([^\s]+) \([^\)]*?user: ([0-9\.]+)[^\)]*?\)$', re.MULTILINE) + 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): - reg = re.compile(r'^([^\s]*) \([^\)]*?real: ([0-9\.]+)[^\)]*?\)$', re.MULTILINE) + reg = re.compile(r'^([^\s]*) \([^\)]*?real: ([0-9\.]+)[^\)]*?\)\s*$', re.MULTILINE) times = reg.findall(lines) if all(STRIP_REG.search(name.strip()) for name, time in times): times = tuple((STRIP_REG.sub(STRIP_REP, name.strip()), time) for name, time in times) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 4a9d871fd3..2feaaa04cd 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -122,7 +122,8 @@ let generate_makefile oc conf_file local_file args project = Envars.coqlib () ^ template in let s = read_whole_file makefile_template in let s = List.fold_left - (fun s (k,v) -> Str.global_replace (Str.regexp_string k) v s) s + (* We use global_substitute to avoid running into backslash issues due to \1 etc. *) + (fun s (k,v) -> Str.global_substitute (Str.regexp_string k) (fun _ -> v) s) s [ "@CONF_FILE@", conf_file; "@LOCAL_FILE@", local_file; "@COQ_VERSION@", Coq_config.version; diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 8eeb59898f..564e20d0e8 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -25,8 +25,6 @@ exception Fin_fichier exception Syntax_error of int*int - let field_name s = String.sub s 1 (String.length s - 1) - let unquote_string s = String.sub s 1 (String.length s - 2) @@ -40,6 +38,18 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + let check_valid lexbuf s = + match Unicode.ident_refutation s with + | None -> s + | Some _ -> syntax_error lexbuf + + let get_ident lexbuf = + let s = Lexing.lexeme lexbuf in check_valid lexbuf s + + let get_field_name lexbuf = + let s = Lexing.lexeme lexbuf in + check_valid lexbuf (String.sub s 1 (String.length s - 1)) + [@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) let uncapitalize = String.uncapitalize [@@@ocaml.warning "+3"] @@ -52,20 +62,8 @@ let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] let caml_up_ident = uppercase identchar* let caml_low_ident = lowercase identchar* -let coq_firstchar = - (* This is only an approximation, refer to lib/util.ml for correct def *) - ['A'-'Z' 'a'-'z' '_'] | - (* superscript 1 *) - '\194' '\185' | - (* utf-8 latin 1 supplement *) - '\195' ['\128'-'\150'] | '\195' ['\152'-'\182'] | '\195' ['\184'-'\191'] | - (* utf-8 letters *) - '\206' (['\145'-'\161'] | ['\163'-'\187']) - '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) - | '\129' [ '\176'-'\187' ] (* superscripts *) - | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) -let coq_identchar = coq_firstchar | ['\'' '0'-'9'] -let coq_ident = coq_firstchar coq_identchar* +(* This is an overapproximation, we check correctness afterwards *) +let coq_ident = ['A'-'Z' 'a'-'z' '_' '\128'-'\255'] ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9' '\128'-'\255']* let coq_field = '.' coq_ident let dot = '.' ( space+ | eof) @@ -102,7 +100,7 @@ and from_rule = parse | space+ { from_rule lexbuf } | coq_ident - { let from = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let from = coq_qual_id_tail [get_ident lexbuf] lexbuf in consume_require (Some from) lexbuf } | eof { syntax_error lexbuf } @@ -241,7 +239,7 @@ and load_file = parse parse_dot lexbuf; Load (unquote_vfile_string s) } | coq_ident - { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } + { let s = get_ident lexbuf in skip_to_dot lexbuf; Load s } | eof { syntax_error lexbuf } | _ @@ -253,7 +251,7 @@ and require_file from = parse | space+ { require_file from lexbuf } | coq_ident - { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let name = coq_qual_id_tail [get_ident lexbuf] lexbuf in let qid = coq_qual_id_list [name] lexbuf in parse_dot lexbuf; Require (from, qid) } @@ -278,7 +276,7 @@ and coq_qual_id = parse | space+ { coq_qual_id lexbuf } | coq_ident - { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf } + { coq_qual_id_tail [get_ident lexbuf] lexbuf } | _ { syntax_error lexbuf } @@ -288,7 +286,7 @@ and coq_qual_id_tail module_name = parse | space+ { coq_qual_id_tail module_name lexbuf } | coq_field - { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf } + { coq_qual_id_tail (get_field_name lexbuf :: module_name) lexbuf } | eof { syntax_error lexbuf } | _ @@ -301,7 +299,7 @@ and coq_qual_id_list module_names = parse | space+ { coq_qual_id_list module_names lexbuf } | coq_ident - { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let name = coq_qual_id_tail [get_ident lexbuf] lexbuf in coq_qual_id_list (name :: module_names) lexbuf } | eof diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index 28a3c791cb..950ed53ccf 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -32,6 +32,8 @@ let supported_suffix f = match CUnix.get_extension f with | ".ml" | ".cmx" | ".cmo" | ".cmxa" | ".cma" | ".c" -> true | _ -> false +let supported_flambda_option f = List.mem f Coq_config.flambda_flags + (** From bytecode extension to native *) let native_suffix f = match CUnix.get_extension f with @@ -187,6 +189,7 @@ let parse_args () = end | ("-h"|"-help"|"--help") :: _ -> usage () + | f :: rem when supported_flambda_option f -> parse (op,fl) rem | f :: rem when supported_suffix f -> parse (op,f::fl) rem | f :: _ -> prerr_endline ("Don't know what to do with " ^ f); exit 1 in @@ -252,6 +255,17 @@ let create_tmp_main_file modules = with reraise -> clean main_name; raise reraise +(* TODO: remove once OCaml 4.04 is adopted *) +let split_on_char sep s = + let r = ref [] in + let j = ref (String.length s) in + for i = String.length s - 1 downto 0 do + if s.[i] = sep then begin + r := String.sub s (i + 1) (!j - i - 1) :: !r; + j := i + end + done; + String.sub s 0 !j :: !r (** {6 Main } *) @@ -264,15 +278,17 @@ let main () = let prog = if !opt then "opt" else "ocamlc" in (* Which arguments ? *) if !opt && !top then failwith "no custom toplevel in native code!"; - let flags = if !opt then [] else Coq_config.vmbyteflags in + let flags = if !opt then Coq_config.flambda_flags else Coq_config.vmbyteflags in let topstart = if !top then [ "topstart.cmo" ] else [] in let (modules, tolink) = files_to_link userfiles in let main_file = create_tmp_main_file modules in try (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) + let coq_camlflags = + List.filter ((<>) "") (split_on_char ' ' Coq_config.caml_flags) in let args = - "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ + coq_camlflags @ "-linkall" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 5ca8869655..c808992887 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -27,12 +27,12 @@ let set_rcfile s = rcfile := s; rcfile_specified := true let load_rc = ref true let no_load_rc () = load_rc := false -let load_rcfile sid = +let load_rcfile doc sid = if !load_rc then try if !rcfile_specified then if CUnix.file_readable_p !rcfile then - Vernac.load_vernac false sid !rcfile + Vernac.load_vernac ~verbosely:false ~interactive:false ~check:true doc sid !rcfile else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) else try @@ -43,8 +43,8 @@ let load_rcfile sid = Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; Envars.home ~warn / "."^rcdefaultname ] in - Vernac.load_vernac false sid inferedrc - with Not_found -> sid + Vernac.load_vernac ~verbosely:false ~interactive:false ~check:true doc sid inferedrc + with Not_found -> doc, sid (* Flags.if_verbose mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ @@ -56,12 +56,12 @@ let load_rcfile sid = iraise reraise else (Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); - sid) + doc, sid) (* Recursively puts dir in the LoadPath if -nois was not passed *) -let add_stdlib_path ~unix_path ~coq_root ~with_ml = +let add_stdlib_path ~load_init ~unix_path ~coq_root ~with_ml = let add_ml = if with_ml then Mltop.AddRecML else Mltop.AddNoML in - Mltop.add_rec_path add_ml ~unix_path ~coq_root ~implicit:(!Flags.load_init) + Mltop.add_rec_path add_ml ~unix_path ~coq_root ~implicit:load_init let add_userlib_path ~unix_path = Mltop.add_rec_path Mltop.AddRecML ~unix_path @@ -75,7 +75,7 @@ let ml_includes = ref [] let push_ml_include s = ml_includes := s :: !ml_includes (* Initializes the LoadPath *) -let init_load_path () = +let init_load_path ~load_init = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in @@ -93,9 +93,9 @@ let init_load_path () = if System.exists_dir (coqlib/"toploop") then Mltop.add_ml_dir (coqlib/"toploop"); (* then standard library *) - add_stdlib_path ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false; + add_stdlib_path ~load_init ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false; (* then plugins *) - add_stdlib_path ~unix_path:(coqlib/"plugins") ~coq_root ~with_ml:true; + add_stdlib_path ~load_init ~unix_path:(coqlib/"plugins") ~coq_root ~with_ml:true; (* then user-contrib *) if Sys.file_exists user_contrib then add_userlib_path ~unix_path:user_contrib; @@ -114,9 +114,6 @@ let init_load_path () = (* additional ml directories, given with option -I *) List.iter Mltop.add_ml_dir (List.rev !ml_includes) -let init_library_roots () = - includes := [] - (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path () = diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 3432e79cc0..60ed698b87 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -13,14 +13,13 @@ val set_debug : unit -> unit val set_rcfile : string -> unit val no_load_rc : unit -> unit -val load_rcfile : Stateid.t -> Stateid.t +val load_rcfile : Stm.doc -> Stateid.t -> Stm.doc * Stateid.t val push_include : string -> Names.DirPath.t -> bool -> unit (** [push_include phys_path log_path implicit] *) val push_ml_include : string -> unit -val init_load_path : unit -> unit -val init_library_roots : unit -> unit +val init_load_path : load_init:bool -> unit val init_ocaml_path : unit -> unit diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 444bf8a8f7..c16e2751bc 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -17,7 +17,7 @@ let top_stderr x = * entered to be able to report errors without pretty-printing. *) type input_buffer = { - mutable prompt : unit -> string; + mutable prompt : Stm.doc -> string; mutable str : Bytes.t; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) mutable bols : int list; (* offsets in str of beginning of lines *) @@ -52,12 +52,12 @@ let emacs_prompt_endstring () = if !print_emacs then "</prompt>" else "" (* Read a char in an input channel, displaying a prompt at every beginning of line. *) -let prompt_char ic ibuf count = +let prompt_char doc ic ibuf count = let bol = match ibuf.bols with | ll::_ -> Int.equal ibuf.len ll | [] -> Int.equal ibuf.len 0 in - if bol && not !print_emacs then top_stderr (str (ibuf.prompt())); + if bol && not !print_emacs then top_stderr (str (ibuf.prompt doc)); try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; @@ -70,11 +70,11 @@ let prompt_char ic ibuf count = (* Reinitialize the char stream (after a Drop) *) -let reset_input_buffer ic ibuf = +let reset_input_buffer doc ic ibuf = ibuf.str <- Bytes.empty; ibuf.len <- 0; ibuf.bols <- []; - ibuf.tokens <- Pcoq.Gram.parsable (Stream.from (prompt_char ic ibuf)); + ibuf.tokens <- Pcoq.Gram.parsable (Stream.from (prompt_char doc ic ibuf)); ibuf.start <- 0 (* Functions to print underlined locations from an input buffer. *) @@ -201,10 +201,10 @@ let make_prompt () = "n |lem1|lem2|lem3| p < " *) -let make_emacs_prompt() = - let statnum = Stateid.to_string (Stm.get_current_state ()) in - let dpth = Stm.current_proof_depth() in - let pending = Stm.get_all_proof_names() in +let make_emacs_prompt doc = + let statnum = Stateid.to_string (Stm.get_current_state ~doc) in + let dpth = Stm.current_proof_depth ~doc in + let pending = Stm.get_all_proof_names ~doc in let pendingprompt = List.fold_left (fun acc x -> acc ^ (if CString.is_empty acc then "" else "|") ^ Names.Id.to_string x) @@ -217,10 +217,10 @@ let make_emacs_prompt() = * initialized when a vernac command is immediately followed by "\n", * or after a Drop. *) let top_buffer = - let pr() = + let pr doc = emacs_prompt_startstring() ^ make_prompt() - ^ make_emacs_prompt() + ^ make_emacs_prompt doc ^ emacs_prompt_endstring() in { prompt = pr; @@ -232,7 +232,7 @@ let top_buffer = let set_prompt prompt = top_buffer.prompt - <- (fun () -> + <- (fun doc -> emacs_prompt_startstring() ^ prompt () ^ emacs_prompt_endstring()) @@ -258,8 +258,8 @@ let rec discard_to_dot () = | Stm.End_of_input -> raise Stm.End_of_input | e when CErrors.noncritical e -> () -let read_sentence sid input = - try Stm.parse_sentence sid input +let read_sentence ~doc sid input = + try Stm.parse_sentence ~doc sid input with reraise -> let reraise = CErrors.push reraise in discard_to_dot (); @@ -300,19 +300,19 @@ let coqloop_feed (fb : Feedback.feedback) = let open Feedback in is caught and handled (i.e. not re-raised). *) -let do_vernac sid = +let do_vernac doc sid = top_stderr (fnl()); - if !print_emacs then top_stderr (str (top_buffer.prompt())); + if !print_emacs then top_stderr (str (top_buffer.prompt doc)); resynch_buffer top_buffer; try let input = (top_buffer.tokens, None) in - Vernac.process_expr sid (read_sentence sid (fst input)) + Vernac.process_expr doc sid (read_sentence ~doc sid (fst input)) with | Stm.End_of_input | CErrors.Quit -> top_stderr (fnl ()); raise CErrors.Quit | CErrors.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise CErrors.Drop - else (Feedback.msg_error (str "There is no ML toplevel."); sid) + else (Feedback.msg_error (str "There is no ML toplevel."); doc, sid) (* Exception printing should be done by the feedback listener, however this is not yet ready so we rely on the exception for now. *) @@ -321,7 +321,7 @@ let do_vernac sid = let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer; - sid + doc, sid (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -337,18 +337,18 @@ let loop_flush_all () = Format.pp_print_flush !Topfmt.std_ft (); Format.pp_print_flush !Topfmt.err_ft () -let rec loop () = +let rec loop doc = Sys.catch_break true; try - reset_input_buffer stdin top_buffer; + reset_input_buffer doc stdin top_buffer; (* Be careful to keep this loop tail-recursive *) - let rec vernac_loop sid = - let nsid = do_vernac sid in + let rec vernac_loop doc sid = + let ndoc, nsid = do_vernac doc sid in loop_flush_all (); - vernac_loop nsid + vernac_loop ndoc nsid (* We recover the current stateid, threading from the caller is not possible due exceptions. *) - in vernac_loop (Stm.get_current_state ()) + in vernac_loop doc (Stm.get_current_state ~doc) with | CErrors.Drop -> () | CErrors.Quit -> exit 0 @@ -358,4 +358,4 @@ let rec loop () = fnl() ++ str"Please report" ++ strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); - loop () + loop doc diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 8eaa68914e..46dabf995d 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -15,7 +15,7 @@ val print_emacs : bool ref * entered to be able to report errors without pretty-printing. *) type input_buffer = { - mutable prompt : unit -> string; + mutable prompt : Stm.doc -> string; mutable str : Bytes.t; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) mutable bols : int list; (** offsets in str of begining of lines *) @@ -32,8 +32,8 @@ val coqloop_feed : Feedback.feedback -> unit (** Parse and execute one vernac command. *) -val do_vernac : Stateid.t -> Stateid.t +val do_vernac : Stm.doc -> Stateid.t -> Stm.doc * Stateid.t (** Main entry point of Coq: read and execute vernac commands. *) -val loop : unit -> unit +val loop : Stm.doc -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index c1cdaa5a34..19fcd99937 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -9,7 +9,6 @@ open Pp open CErrors open Libnames -open Coqinit let () = at_exit flush_all @@ -82,14 +81,14 @@ let toploop_init = ref begin fun x -> let coqtop_init_feed = Coqloop.coqloop_feed (* Default toplevel loop *) -let console_toploop_run () = +let console_toploop_run doc = (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; - Coqloop.loop(); + Coqloop.loop doc; (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); Mltop.ocaml_toploop(); @@ -121,6 +120,9 @@ let print_memory_stat () = let _ = at_exit print_memory_stat +(******************************************************************************) +(* Engagement *) +(******************************************************************************) let impredicative_set = ref Declarations.PredicativeSet let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet let set_type_in_type () = @@ -129,14 +131,18 @@ let set_type_in_type () = let engage () = Global.set_engagement !impredicative_set -let set_batch_mode () = Flags.batch_mode := true - +(******************************************************************************) +(* Interactive toplevel name *) +(******************************************************************************) let toplevel_default_name = Names.(DirPath.make [Id.of_string "Top"]) let toplevel_name = ref toplevel_default_name let set_toplevel_name dir = if Names.DirPath.is_empty dir then user_err Pp.(str "Need a non empty toplevel module name"); toplevel_name := dir +(******************************************************************************) +(* Input/Output State *) +(******************************************************************************) let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> strbrk "The inputstate option is deprecated and discouraged.") @@ -164,55 +170,71 @@ let outputstate () = let fname = CUnix.make_suffix !outputstate ".coq" in States.extern_state fname -let set_include d p implicit = - let p = dirpath_of_string p in - push_include d p implicit - +(******************************************************************************) +(* Interactive Load File Simulation *) +(******************************************************************************) let load_vernacular_list = ref ([] : (string * bool) list) + let add_load_vernacular verb s = load_vernacular_list := ((CUnix.make_suffix s ".v"),verb) :: !load_vernacular_list -let load_vernacular sid = + +let load_vernacular doc sid = List.fold_left - (fun sid (s,v) -> - let s = Loadpath.locate_file s in + (fun (doc,sid) (f_in, verbosely) -> + let s = Loadpath.locate_file f_in in if !Flags.beautify then - Flags.(with_option beautify_file (Vernac.load_vernac v sid) s) + Flags.with_option Flags.beautify_file (Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid) f_in else - Vernac.load_vernac v sid s) - sid (List.rev !load_vernacular_list) - -let load_vernacular_obj = ref ([] : string list) -let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj -let load_vernac_obj () = - let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in - Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj) - -let require_prelude () = - let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in - let vio = Envars.coqlib () / "theories/Init/Prelude.vio" in - let m = - if Sys.file_exists vo then vo else - if Sys.file_exists vio then vio else vo in - Library.require_library_from_dirpath [Coqlib.prelude_module,m] (Some true) - -let require_list = ref ([] : string list) + Vernac.load_vernac ~verbosely ~interactive:false ~check:true doc sid s) + (doc, sid) (List.rev !load_vernacular_list) + +let load_init_vernaculars doc sid = + let doc, sid = Coqinit.load_rcfile doc sid in + load_vernacular doc sid + +(******************************************************************************) +(* Required Modules *) +(******************************************************************************) +let set_include d p implicit = + let p = dirpath_of_string p in + Coqinit.push_include d p implicit + +(* None = No Import; Some false = Import; Some true = Export *) +let require_list = ref ([] : (string * string option * bool option) list) let add_require s = require_list := s :: !require_list -let require () = - let () = if !Flags.load_init then Flags.silently require_prelude () in - let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in - Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) + +let load_init = ref true + +(* From Coq Require Import Prelude. *) +let prelude_data = "Prelude", Some "Coq", Some true + +let require_libs () = + if !load_init then prelude_data :: !require_list else !require_list let add_compat_require v = match v with - | Flags.V8_5 -> add_require "Coq.Compat.Coq85" - | Flags.V8_6 -> add_require "Coq.Compat.Coq86" - | Flags.V8_7 -> add_require "Coq.Compat.Coq87" + | Flags.V8_5 -> add_require ("Coq.Compat.Coq85", None, Some false) + | Flags.V8_6 -> add_require ("Coq.Compat.Coq86", None, Some false) + | Flags.V8_7 -> add_require ("Coq.Compat.Coq87", None, Some false) | Flags.VOld | Flags.Current -> () -let compile_list = ref ([] : (bool * string) list) +(******************************************************************************) +(* File Compilation *) +(******************************************************************************) let glob_opt = ref false +let compile_list = ref ([] : (bool * string) list) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo +let compilation_mode = ref BuildVo +let compilation_output_name = ref None + +let batch_mode = ref false +let set_batch_mode () = + System.trust_file_cache := false; + batch_mode := true + let add_compile verbose s = set_batch_mode (); Flags.quiet := true; @@ -226,21 +248,186 @@ let add_compile verbose s = in compile_list := (verbose,s) :: !compile_list -let compile_file (v,f) = +let warn_file_no_extension = + CWarnings.create ~name:"file-no-extension" ~category:"filesystem" + (fun (f,ext) -> + str "File \"" ++ str f ++ + strbrk "\" has been implicitly expanded to \"" ++ + str f ++ str ext ++ str "\"") + +let ensure_ext ext f = + if Filename.check_suffix f ext then f + else begin + warn_file_no_extension (f,ext); + f ^ ext + end + +let chop_extension f = + try Filename.chop_extension f with _ -> f + +let compile_error msg = + Topfmt.std_logger Feedback.Error msg; + flush_all (); + exit 1 + +let ensure_bname src tgt = + let src, tgt = Filename.basename src, Filename.basename tgt in + let src, tgt = chop_extension src, chop_extension tgt in + if src <> tgt then + compile_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++ + str "Source: " ++ str src ++ fnl () ++ + str "Target: " ++ str tgt) + +let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt + +let ensure_v v = ensure ".v" v v +let ensure_vo v vo = ensure ".vo" v vo +let ensure_vio v vio = ensure ".vio" v vio + +let ensure_exists f = + if not (Sys.file_exists f) then + compile_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) + +(* Compile a vernac file *) +let compile ~verbosely ~f_in ~f_out = + let check_pending_proofs () = + let pfs = Proof_global.get_all_proof_names () in + if not (CList.is_empty pfs) then + compile_error (str "There are pending proofs: " + ++ (pfs + |> List.rev + |> prlist_with_sep pr_comma Names.Id.print) + ++ str ".") + in + match !compilation_mode with + | BuildVo -> + Flags.record_aux_file := true; + let long_f_dot_v = ensure_v f_in in + ensure_exists long_f_dot_v; + let long_f_dot_vo = + match f_out with + | None -> long_f_dot_v ^ "o" + | Some f -> ensure_vo long_f_dot_v f in + + let doc, sid = Stm.(new_doc + { doc_type = VoDoc long_f_dot_vo; + require_libs = require_libs () + }) in + + let doc, sid = load_init_vernaculars doc sid in + let ldir = Stm.get_ldir ~doc in + Aux_file.(start_aux_file + ~aux_file:(aux_file_name_for long_f_dot_vo) + ~v_file:long_f_dot_v); + Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; + Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); + let wall_clock1 = Unix.gettimeofday () in + let doc, _ = Vernac.load_vernac ~verbosely ~check:true ~interactive:false doc (Stm.get_current_state ~doc) long_f_dot_v in + let _doc = Stm.join ~doc in + let wall_clock2 = Unix.gettimeofday () in + check_pending_proofs (); + Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); + Aux_file.record_in_aux_at "vo_compile_time" + (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); + Aux_file.stop_aux_file (); + Dumpglob.end_dump_glob () + | BuildVio -> + + Flags.record_aux_file := false; + Dumpglob.noglob (); + + let long_f_dot_v = ensure_v f_in in + ensure_exists long_f_dot_v; + + let long_f_dot_vio = + match f_out with + | None -> long_f_dot_v ^ "io" + | Some f -> ensure_vio long_f_dot_v f in + + let doc, sid = Stm.(new_doc + { doc_type = VioDoc long_f_dot_vio; + require_libs = require_libs () + }) in + + let doc, sid = load_init_vernaculars doc sid in + + let ldir = Stm.get_ldir ~doc in + let doc, _ = Vernac.load_vernac ~verbosely ~check:false ~interactive:false doc (Stm.get_current_state ~doc) long_f_dot_v in + let doc = Stm.finish ~doc in + check_pending_proofs (); + let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in + Stm.reset_task_queue () + + | Vio2Vo -> + let open Filename in + Flags.record_aux_file := false; + Dumpglob.noglob (); + let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in + let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in + let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in + Library.save_library_raw lfdv sum lib univs proofs + +let compile ~verbosely ~f_in ~f_out = + ignore(CoqworkmgrApi.get 1); + compile ~verbosely ~f_in ~f_out; + CoqworkmgrApi.giveback 1 + +let compile_file (verbosely,f_in) = if !Flags.beautify then - Flags.(with_option beautify_file (Vernac.compile v) f) + Flags.with_option Flags.beautify_file + (fun f_in -> compile ~verbosely ~f_in ~f_out:None) f_in else - Vernac.compile v f + compile ~verbosely ~f_in ~f_out:None -let compile_files () = +let compile_files doc = if !compile_list == [] then () - else - let init_state = States.freeze ~marshallable:`No in - List.iter (fun vf -> - States.unfreeze init_state; - compile_file vf) - (List.rev !compile_list) + else List.iter compile_file (List.rev !compile_list) + +(******************************************************************************) +(* VIO Dispatching *) +(******************************************************************************) + +let vio_tasks = ref [] +let add_vio_task f = + set_batch_mode (); + Flags.quiet := true; + vio_tasks := f :: !vio_tasks + +let check_vio_tasks () = + let rc = + List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) + true (List.rev !vio_tasks) in + if not rc then exit 1 + +(* vio files *) +let vio_files = ref [] +let vio_files_j = ref 0 +let vio_checking = ref false +let add_vio_file f = + set_batch_mode (); + Flags.quiet := true; + vio_files := f :: !vio_files + +let set_vio_checking_j opt j = + try vio_files_j := int_of_string j + with Failure _ -> + prerr_endline ("The first argument of " ^ opt ^ " must the number"); + prerr_endline "of concurrent workers to be used (a positive integer)."; + prerr_endline "Makefiles generated by coq_makefile should be called"; + prerr_endline "setting the J variable like in 'make vio2vo J=3'"; + exit 1 + +let schedule_vio_checking () = + if !vio_files <> [] && !vio_checking then + Vio_checking.schedule_vio_checking !vio_files_j !vio_files + +let schedule_vio_compilation () = + if !vio_files <> [] && not !vio_checking then + Vio_checking.schedule_vio_compilation !vio_files_j !vio_files +(******************************************************************************) +(* UI Options *) +(******************************************************************************) (** Options for proof general *) let set_emacs () = @@ -296,14 +483,15 @@ let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesy (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned") exception NoCoqLib -let usage () = + +let usage batch = begin try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib); - init_load_path (); + Coqinit.init_load_path ~load_init:!load_init; with NoCoqLib -> usage_no_coqlib () end; - if !Flags.batch_mode then Usage.print_usage_coqc () + if batch then Usage.print_usage_coqc () else begin Mltop.load_ml_objects_raw_rex (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); @@ -389,47 +577,10 @@ let get_error_resilience opt = function let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) -let vio_tasks = ref [] - -let add_vio_task f = - set_batch_mode (); - Flags.quiet := true; - vio_tasks := f :: !vio_tasks - -let check_vio_tasks () = - let rc = - List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) - true (List.rev !vio_tasks) in - if not rc then exit 1 - -let vio_files = ref [] -let vio_files_j = ref 0 -let vio_checking = ref false -let add_vio_file f = - set_batch_mode (); - Flags.quiet := true; - vio_files := f :: !vio_files - -let set_vio_checking_j opt j = - try vio_files_j := int_of_string j - with Failure _ -> - prerr_endline ("The first argument of " ^ opt ^ " must the number"); - prerr_endline "of concurrent workers to be used (a positive integer)."; - prerr_endline "Makefiles generated by coq_makefile should be called"; - prerr_endline "setting the J variable like in 'make vio2vo J=3'"; - exit 1 - let is_not_dash_option = function | Some f when String.length f > 0 && f.[0] <> '-' -> true | _ -> false -let schedule_vio_checking () = - if !vio_files <> [] && !vio_checking then - Vio_checking.schedule_vio_checking !vio_files_j !vio_files -let schedule_vio_compilation () = - if !vio_files <> [] && not !vio_checking then - Vio_checking.schedule_vio_compilation !vio_files_j !vio_files - let get_native_name s = (* We ignore even critical errors because this mode has to be super silent *) try @@ -464,7 +615,7 @@ let parse_args arglist = (* Complex options with many args *) |"-I"|"-include" -> begin match rem with - | d :: rem -> push_ml_include d; args := rem + | d :: rem -> Coqinit.push_ml_include d; args := rem | [] -> error_missing_arg opt end |"-Q" -> @@ -522,25 +673,31 @@ let parse_args arglist = |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true |"-feedback-glob" -> Dumpglob.feedback_glob () |"-exclude-dir" -> System.exclude_directory (next ()) - |"-init-file" -> set_rcfile (next ()) + |"-init-file" -> Coqinit.set_rcfile (next ()) |"-inputstate"|"-is" -> set_inputstate (next ()) |"-load-ml-object" -> Mltop.dir_ml_load (next ()) |"-load-ml-source" -> Mltop.dir_ml_use (next ()) - |"-load-vernac-object" -> add_vernac_obj (next ()) + |"-load-vernac-object" -> add_require (next (), None, None) |"-load-vernac-source"|"-l" -> add_load_vernacular false (next ()) |"-load-vernac-source-verbose"|"-lv" -> add_load_vernacular true (next ()) |"-outputstate" -> set_outputstate (next ()) |"-print-mod-uid" -> let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0 |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; Flags.profile_ltac_cutoff := get_float opt (next ()) - |"-require" -> add_require (next ()) + |"-require" -> add_require (next (), None, Some false) |"-top" -> set_toplevel_name (dirpath_of_string (next ())) - |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ()) |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()) |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) - |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Flags.Vio2Vo + |"-vio2vo" -> + add_compile false (next ()); + compilation_mode := Vio2Vo |"-toploop" -> set_toploop (next ()) - |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ())) - |"-o" -> Flags.compilation_output_name := Some (next()) + |"-w" | "-W" -> + let w = next () in + if w = "none" then CWarnings.set_flags w + else + let w = CWarnings.get_flags () ^ "," ^ w in + CWarnings.set_flags (CWarnings.normalize_flags_string w) + |"-o" -> compilation_output_name := Some (next()) (* Options with zero arg *) |"-async-queries-always-delegate" @@ -552,20 +709,20 @@ let parse_args arglist = |"-batch" -> set_batch_mode () |"-test-mode" -> Flags.test_mode := true |"-beautify" -> Flags.beautify := true - |"-boot" -> Flags.boot := true; no_load_rc () + |"-boot" -> Flags.boot := true; Coqinit.no_load_rc () |"-bt" -> Backtrace.record_backtrace true |"-color" -> set_color (next ()) |"-config"|"--config" -> print_config := true - |"-debug" -> set_debug () + |"-debug" -> Coqinit.set_debug () |"-stm-debug" -> Flags.stm_debug := true |"-emacs" -> set_emacs () |"-filteropts" -> filter_opts := true - |"-h"|"-H"|"-?"|"-help"|"--help" -> usage () + |"-h"|"-H"|"-?"|"-help"|"--help" -> usage !batch_mode |"-ideslave" -> set_ideslave () |"-impredicative-set" -> set_impredicative_set () |"-indices-matter" -> Indtypes.enforce_indices_matter () |"-m"|"--memory" -> memory_stat := true - |"-noinit"|"-nois" -> Flags.load_init := false + |"-noinit"|"-nois" -> load_init := false |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true |"-native-compiler" -> if Coq_config.no_native_compiler then @@ -573,13 +730,15 @@ let parse_args arglist = else Flags.native_compiler := true |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true - |"-q" -> no_load_rc () + |"-q" -> Coqinit.no_load_rc () |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false - |"-quick" -> Flags.compilation_mode := Flags.BuildVio + |"-quick" -> + Safe_typing.allow_delayed_constants := true; + compilation_mode := BuildVio |"-list-tags" -> print_tags := true |"-time" -> Flags.time := true |"-type-in-type" -> set_type_in_type () - |"-unicode" -> add_require "Utf8_core" + |"-unicode" -> add_require ("Utf8_core", None, Some false) |"-v"|"--version" -> Usage.version (exitcode ()) |"-print-version"|"--print-version" -> Usage.machine_readable_version (exitcode ()) |"-where" -> print_where := true @@ -594,12 +753,18 @@ let parse_args arglist = with any -> fatal_error any let init_toplevel arglist = + (* Coq's init process, phase 1: + - OCaml parameters, and basic structures and IO + *) Profile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) let init_feeder = Feedback.add_feeder coqtop_init_feed in Lib.init(); - begin + (* Coq's init process, phase 2: + - Basic Coq environment, load-path, plugins. + *) + let res = begin try let extras = parse_args arglist in (* If we have been spawned by the Spawn module, this has to be done @@ -610,7 +775,7 @@ let init_toplevel arglist = if !print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode ())); if !print_tags then (print_style_tags (); exit (exitcode ())); if !filter_opts then (print_string (String.concat "\n" extras); exit 0); - init_load_path (); + Coqinit.init_load_path ~load_init:!load_init; Option.iter Mltop.load_ml_object_raw !toploop; let extras = !toploop_init extras in if not (CList.is_empty extras) then begin @@ -619,50 +784,67 @@ let init_toplevel arglist = exit 1 end; Flags.if_verbose print_header (); - inputstate (); Mltop.init_known_plugins (); engage (); - if (not !Flags.batch_mode || CList.is_empty !compile_list) - && Global.env_is_initial () - then Declaremods.start_library !toplevel_name; - init_library_roots (); - load_vernac_obj (); - require (); - (* XXX: This is incorrect in batch mode, as we will initialize - the STM before having done Declaremods.start_library, thus - state 1 is invalid. This bug was present in 8.5/8.6. *) - Stm.init (); - let sid = load_rcfile (Stm.get_current_state ()) in - (* XXX: We ignore this for now, but should be threaded to the toplevels *) - let _sid = load_vernacular sid in - compile_files (); - schedule_vio_checking (); - schedule_vio_compilation (); - check_vio_tasks (); - outputstate () + + (* Allow the user to load an arbitrary state here *) + inputstate (); + + (* This state will be shared by all the documents *) + Stm.init_core (); + + (* Coq init process, phase 3: Stm initialization, backtracking state. + + It is essential that the module system is in a consistent + state before we take the first snapshot. This was not + guaranteed in the past. In particular, we want to be sure we + have called start_library before loading the prelude and rest + of required files. + + We split the codepath here depending whether coqtop is called + in interactive mode or not. *) + + if (not !batch_mode || CList.is_empty !compile_list) + (* Interactive *) + then begin + try + let doc, sid = Stm.(new_doc + { doc_type = Interactive !toplevel_name; + require_libs = require_libs () + }) in + Some (load_init_vernaculars doc sid) + with any -> flush_all(); fatal_error any + (* Non interactive *) + end else begin + try + compile_files (); + schedule_vio_checking (); + schedule_vio_compilation (); + check_vio_tasks (); + (* Allow the user to output an arbitrary state *) + outputstate (); + None + with any -> flush_all(); fatal_error any + end; with any -> flush_all(); - let extra = - if !Flags.batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) - then None - else Some (str "Error during initialization: ") - in + let extra = Some (str "Error during initialization: ") in fatal_error ?extra any - end; - if !Flags.batch_mode then begin + end in + Feedback.del_feeder init_feeder; + res + +let start () = + match init_toplevel (List.tl (Array.to_list Sys.argv)) with + (* Batch mode *) + | Some (doc, sid) when not !batch_mode -> + !toploop_run doc; + exit 1 + | _ -> flush_all(); if !output_context then Feedback.msg_notice Flags.(with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 - end; - Feedback.del_feeder init_feeder - -let start () = - let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in - (* In batch mode, Coqtop has already exited at this point. In interactive one, - dump glob is nothing but garbage ... *) - !toploop_run (); - exit 1 (* [Coqtop.start] will be called by the code produced by coqmktop *) diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 892d64d917..1c7c3f944a 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -11,12 +11,11 @@ state, load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [Coqloop.loop]. *) -val init_toplevel : string list -> unit +val init_toplevel : string list -> (Stm.doc * Stateid.t) option val start : unit -> unit - (* For other toploops *) val toploop_init : (string list -> string list) ref -val toploop_run : (unit -> unit) ref +val toploop_run : (Stm.doc -> unit) ref diff --git a/toplevel/usage.ml b/toplevel/usage.ml index d596e36f34..f0215b6783 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -74,7 +74,6 @@ let print_usage_channel co command = \n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ -\n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\ \n -impredicative-set set sort Set impredicative\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 4b97ee0dde..cf63fbdc3d 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -47,35 +47,29 @@ let beautify_suffix = ".beautified" let set_formatter_translator ch = let out s b e = output_substring ch s b e in - Format.set_formatter_output_functions out (fun () -> flush ch); - Format.set_max_boxes max_int + let ft = Format.make_formatter out (fun () -> flush ch) in + Format.pp_set_max_boxes ft max_int; + ft -let pr_new_syntax_in_context ?loc chan_beautify ocom = +let pr_new_syntax_in_context ?loc ft_beautify ocom = let loc = Option.cata Loc.unloc (0,0) loc in - if !Flags.beautify_file then set_formatter_translator chan_beautify; let fs = States.freeze ~marshallable:`No in - (* The content of this is not supposed to fail, but if ever *) - try - (* Side-effect: order matters *) - let before = comment (CLexer.extract_comments (fst loc)) in - let com = match ocom with - | Some com -> Ppvernac.pr_vernac com - | None -> mt() in - let after = comment (CLexer.extract_comments (snd loc)) in - if !Flags.beautify_file then - (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); - Format.pp_print_flush !Topfmt.std_ft ()) - else - Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); - States.unfreeze fs; - Format.set_formatter_out_channel stdout - with any -> - States.unfreeze fs; - Format.set_formatter_out_channel stdout - -let pr_new_syntax ?loc po chan_beautify ocom = + (* Side-effect: order matters *) + let before = comment (CLexer.extract_comments (fst loc)) in + let com = match ocom with + | Some com -> Ppvernac.pr_vernac com + | None -> mt() in + let after = comment (CLexer.extract_comments (snd loc)) in + if !Flags.beautify_file then + (Pp.pp_with ft_beautify (hov 0 (before ++ com ++ after)); + Format.pp_print_flush ft_beautify ()) + else + Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); + States.unfreeze fs + +let pr_new_syntax ?loc po ft_beautify ocom = (* Reinstall the context of parsing which includes the bindings of comments to locations *) - Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc chan_beautify) ocom + Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc ft_beautify) ocom (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) @@ -109,54 +103,54 @@ let pr_open_cur_subgoals () = try Printer.pr_open_subgoals () with Proof_global.NoCurrentProof -> Pp.str "" -let vernac_error msg = - Topfmt.std_logger Feedback.Error msg; - flush_all (); - exit 1 - (* Reenable when we get back to feedback printing *) (* let is_end_of_input any = match any with *) (* Stm.End_of_input -> true *) (* | _ -> false *) -let rec interp_vernac sid (loc,com) = +let rec interp_vernac ~check ~interactive doc sid (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let f = Loadpath.locate_file fname in - load_vernac verbosely sid f + load_vernac ~verbosely ~check ~interactive doc sid f | v -> (* XXX: We need to run this before add as the classification is highly dynamic and depends on the structure of the - document. Hopefully this is fixed when VtBack can be removed + document. Hopefully this is fixed when VtMeta can be removed and Undo etc... are just interpreted regularly. *) + + (* XXX: The classifier can emit warnings so we need to guard + against that... *) + let wflags = CWarnings.get_flags () in + CWarnings.set_flags "none"; let is_proof_step = match fst (Vernac_classifier.classify_vernac v) with - | VtProofStep _ | VtBack (_, _) | VtStartProof _ -> true + | VtProofStep _ | VtMeta | VtStartProof _ -> true | _ -> false in + CWarnings.set_flags wflags; - let nsid, ntip = Stm.add ~ontop:sid (not !Flags.quiet) (loc,v) in + let doc, nsid, ntip = Stm.add ~doc ~ontop:sid (not !Flags.quiet) (loc,v) in (* Main STM interaction *) if ntip <> `NewTip then anomaly (str "vernac.ml: We got an unfocus operation on the toplevel!"); + (* Due to bug #5363 we cannot use observe here as we should, it otherwise reveals bugs *) (* Stm.observe nsid; *) - - let check_proof = Flags.(!compilation_mode = BuildVo || not !batch_mode) in - if check_proof then Stm.finish (); + let ndoc = if check then Stm.finish ~doc else doc in (* We could use a more refined criteria that depends on the vernac. For now we imitate the old approach and rely on the classification. *) - let print_goals = not !Flags.batch_mode && not !Flags.quiet && + let print_goals = interactive && not !Flags.quiet && is_proof_step && Proof_global.there_are_pending_proofs () in if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ()); - nsid + ndoc, nsid in try (* The -time option is only supported from console-based @@ -167,7 +161,7 @@ let rec interp_vernac sid (loc,com) = with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird things, so we better avoid it while we investigate *) - if not !Flags.batch_mode then ignore(Stm.edit_at sid); + if interactive then ignore(Stm.edit_at ~doc sid); let (reraise, info) = CErrors.push reraise in let info = begin match Loc.get_loc info with @@ -176,19 +170,25 @@ let rec interp_vernac sid (loc,com) = end in iraise (reraise, info) (* Load a vernac file. CErrors are annotated with file and location *) -and load_vernac verbosely sid file = - let chan_beautify = - if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in +and load_vernac ~verbosely ~check ~interactive doc sid file = + let ft_beautify, close_beautify = + if !Flags.beautify_file then + let chan_beautify = open_out (file^beautify_suffix) in + set_formatter_translator chan_beautify, fun () -> close_out chan_beautify; + else + !Topfmt.std_ft, fun () -> () + in let in_chan = open_utf8_file_in file in let in_echo = if verbosely then Some (open_utf8_file_in file) else None in let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in let rsid = ref sid in + let rdoc = ref doc in try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) while true do let loc, ast = - Stm.parse_sentence !rsid in_pa + Stm.parse_sentence ~doc:!rdoc !rsid in_pa (* If an error in parsing occurs, we propagate the exception so the caller of load_vernac will take care of it. However, in the future it could be possible that we want to handle @@ -208,14 +208,15 @@ and load_vernac verbosely sid file = *) in (* Printing of vernacs *) - if !Flags.beautify then pr_new_syntax ?loc in_pa chan_beautify (Some ast); + if !Flags.beautify then pr_new_syntax ?loc in_pa ft_beautify (Some ast); Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); - let nsid = Flags.silently (interp_vernac !rsid) (loc, ast) in - rsid := nsid + let ndoc, nsid = Flags.silently (interp_vernac ~check ~interactive !rdoc !rsid) (loc, ast) in + rsid := nsid; + rdoc := ndoc done; - !rsid + !rdoc, !rsid with any -> (* whatever the exception *) let (e, info) = CErrors.push any in close_in in_chan; @@ -224,11 +225,11 @@ and load_vernac verbosely sid file = | Stm.End_of_input -> (* Is this called so comments at EOF are printed? *) if !Flags.beautify then - pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa chan_beautify None; - if !Flags.beautify_file then close_out chan_beautify; - !rsid + pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa ft_beautify None; + if !Flags.beautify_file then close_beautify (); + !rdoc, !rsid | reraise -> - if !Flags.beautify_file then close_out chan_beautify; + if !Flags.beautify_file then close_beautify (); iraise (disable_drop e, info) (** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit] @@ -238,107 +239,6 @@ and load_vernac verbosely sid file = of a new state label). An example of state-preserving command is one coming from the query panel of Coqide. *) -let process_expr sid loc_ast = +let process_expr doc sid loc_ast = checknav_deep loc_ast; - interp_vernac sid loc_ast - -let warn_file_no_extension = - CWarnings.create ~name:"file-no-extension" ~category:"filesystem" - (fun (f,ext) -> - str "File \"" ++ str f ++ - strbrk "\" has been implicitly expanded to \"" ++ - str f ++ str ext ++ str "\"") - -let ensure_ext ext f = - if Filename.check_suffix f ext then f - else begin - warn_file_no_extension (f,ext); - f ^ ext - end - -let chop_extension f = - try Filename.chop_extension f with _ -> f - -let ensure_bname src tgt = - let src, tgt = Filename.basename src, Filename.basename tgt in - let src, tgt = chop_extension src, chop_extension tgt in - if src <> tgt then - vernac_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++ - str "Source: " ++ str src ++ fnl () ++ - str "Target: " ++ str tgt) - -let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt - -let ensure_v v = ensure ".v" v v -let ensure_vo v vo = ensure ".vo" v vo -let ensure_vio v vio = ensure ".vio" v vio - -let ensure_exists f = - if not (Sys.file_exists f) then - vernac_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) - -(* Compile a vernac file *) -let compile verbosely f = - let check_pending_proofs () = - let pfs = Proof_global.get_all_proof_names () in - if not (List.is_empty pfs) then - vernac_error (str "There are pending proofs: " - ++ (pfs - |> List.rev - |> prlist_with_sep pr_comma Names.Id.print) - ++ str ".") - in - match !Flags.compilation_mode with - | Flags.BuildVo -> - let long_f_dot_v = ensure_v f in - ensure_exists long_f_dot_v; - let long_f_dot_vo = - match !Flags.compilation_output_name with - | None -> long_f_dot_v ^ "o" - | Some f -> ensure_vo long_f_dot_v f in - let ldir = Flags.verbosely Library.start_library long_f_dot_vo in - Stm.set_compilation_hints long_f_dot_vo; - Aux_file.(start_aux_file - ~aux_file:(aux_file_name_for long_f_dot_vo) - ~v_file:long_f_dot_v); - Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; - Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); - let wall_clock1 = Unix.gettimeofday () in - let _ = load_vernac verbosely (Stm.get_current_state ()) long_f_dot_v in - Stm.join (); - let wall_clock2 = Unix.gettimeofday () in - check_pending_proofs (); - Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); - Aux_file.record_in_aux_at "vo_compile_time" - (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - Aux_file.stop_aux_file (); - Dumpglob.end_dump_glob () - | Flags.BuildVio -> - let long_f_dot_v = ensure_v f in - ensure_exists long_f_dot_v; - let long_f_dot_vio = - match !Flags.compilation_output_name with - | None -> long_f_dot_v ^ "io" - | Some f -> ensure_vio long_f_dot_v f in - let ldir = Flags.verbosely Library.start_library long_f_dot_vio in - Dumpglob.noglob (); - Stm.set_compilation_hints long_f_dot_vio; - let _ = load_vernac verbosely (Stm.get_current_state ()) long_f_dot_v in - Stm.finish (); - check_pending_proofs (); - Stm.snapshot_vio ldir long_f_dot_vio; - Stm.reset_task_queue () - | Flags.Vio2Vo -> - let open Filename in - let open Library in - Dumpglob.noglob (); - let f = if check_suffix f ".vio" then chop_extension f else f in - let lfdv, sum, lib, univs, disch, tasks, proofs = load_library_todo f in - Stm.set_compilation_hints lfdv; - let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in - Library.save_library_raw lfdv sum lib univs proofs - -let compile v f = - ignore(CoqworkmgrApi.get 1); - compile v f; - CoqworkmgrApi.giveback 1 + interp_vernac ~interactive:true ~check:true doc sid loc_ast diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index bccf560e16..f9a4300267 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -12,12 +12,9 @@ expected to handle and print errors in form of exceptions, however care is taken so the state machine is left in a consistent state. *) -val process_expr : Stateid.t -> Vernacexpr.vernac_expr Loc.located -> Stateid.t +val process_expr : Stm.doc -> Stateid.t -> Vernacexpr.vernac_expr Loc.located -> Stm.doc * Stateid.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle and print errors in form of exceptions. *) -val load_vernac : bool -> Stateid.t -> string -> Stateid.t - -(** Compile a vernac file, (f is assumed without .v suffix) *) -val compile : bool -> string -> unit +val load_vernac : verbosely:bool -> check:bool -> interactive:bool -> Stm.doc -> Stateid.t -> string -> Stm.doc * Stateid.t diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 503508fc04..7af391758d 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -91,6 +91,15 @@ let destruct_on_using c id = let destruct_on_as c l = destruct false None c (Some (Loc.tag l)) None +let inj_flags = Some { + Equality.keep_proof_equalities = true; (* necessary *) + injection_in_context = true; (* does not matter here *) + Equality.injection_pattern_l2r_order = true; (* does not matter here *) + } + +let my_discr_tac = Equality.discr_tac false None +let my_inj_tac x = Equality.inj inj_flags None false None (EConstr.mkVar x,NoBindings) + (* reconstruct the inductive with the correct de Bruijn indexes *) let mkFullInd (ind,u) n = let mib = Global.lookup_mind (fst ind) in @@ -595,7 +604,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = intro_using freshz; intros; Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) + Tacticals.New.tclORELSE reflexivity my_discr_tac ); simpl_in_hyp (freshz,Locus.InHyp); (* @@ -739,9 +748,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = intro_using freshz; intros; Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) + Tacticals.New.tclORELSE reflexivity my_discr_tac ); - Equality.inj None false None (EConstr.mkVar freshz,NoBindings); + my_inj_tac freshz; intros; simpl_in_concl; Auto.default_auto; Tacticals.New.tclREPEAT ( @@ -936,7 +945,7 @@ let compute_dec_tact ind lnamesparrec nparrec = NoBindings ) true; - Equality.discr_tac false None + my_discr_tac ] end ] diff --git a/vernac/command.ml b/vernac/command.ml index 120f9590f2..f58ed065c6 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -79,7 +79,7 @@ let red_constant_entry n ce sigma = function let (_, c) = redfun env sigma c in EConstr.Unsafe.to_constr c in - { ce with const_entry_body = Future.chain ~pure:true proof_out + { ce with const_entry_body = Future.chain proof_out (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } let warn_implicits_in_term = @@ -518,7 +518,8 @@ let check_param = function | CLocalDef (na, _, _) -> check_named na | CLocalAssum (nas, Default _, _) -> List.iter check_named nas | CLocalAssum (nas, Generalized _, _) -> () -| CLocalPattern _ -> assert false +| CLocalPattern (loc,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = check_all_names_different indl; @@ -549,13 +550,12 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in - let implsforntn = compute_internalization_env env0 Variable indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation implsforntn) notations; + List.iter (Metasyntax.set_notation_for_interpretation env_params impls) notations; (* Interpret the constructor types *) List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl) () in @@ -707,7 +707,7 @@ let do_mutual_inductive indl cum poly prv finite = (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) - List.iter Metasyntax.add_notation_interpretation ntns; + List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) List.iter (fun qid -> Class.try_add_new_coercion (locate qid) ~local:false poly) coes; (* If positivity is assumed declares itself as unsafe. *) @@ -1109,7 +1109,7 @@ let interp_recursive isfix fixl notations = (* Interp bodies with rollback because temp use of notations/implicit *) let fixdefs = Metasyntax.with_syntax_protection (fun () -> - List.iter (Metasyntax.set_notation_for_interpretation impls) notations; + List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; List.map4 (fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls)) fixctximpenvs fixctxs fixl fixccls) @@ -1175,7 +1175,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind fixpoint_message (Some indexes) fixnames; end; (* Declare notations *) - List.iter Metasyntax.add_notation_interpretation ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then @@ -1206,7 +1206,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n cofixpoint_message fixnames end; (* Declare notations *) - List.iter Metasyntax.add_notation_interpretation ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns let extract_decreasing_argument limit = function | (na,CStructRec) -> na diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 12b68fe38e..189c47aab9 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -84,7 +84,7 @@ let rec contract3' env sigma a b c = function (** Ad-hoc reductions *) let j_nf_betaiotaevar sigma j = - { uj_val = Evarutil.nf_evar sigma j.uj_val; + { uj_val = j.uj_val; uj_type = Reductionops.nf_betaiota sigma j.uj_type } let jv_nf_betaiotaevar sigma jl = @@ -173,7 +173,6 @@ let explain_unbound_var env v = str "No such section variable or assumption: " ++ var ++ str "." let explain_not_type env sigma j = - let j = Evarutil.j_nf_evar sigma j in let pe = pr_ne_context_of (str "In environment") env sigma in let pc,pt = pr_ljudge_env env sigma j in pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ @@ -241,7 +240,6 @@ let explain_elim_arity env sigma ind sorts c pj okinds = fnl () ++ msg let explain_case_not_inductive env sigma cj = - let cj = Evarutil.j_nf_evar sigma cj in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma cj.uj_val in let pct = pr_leconstr_env env sigma cj.uj_type in @@ -254,7 +252,6 @@ let explain_case_not_inductive env sigma cj = str "which is not a (co-)inductive type." let explain_number_branches env sigma cj expn = - let cj = Evarutil.j_nf_evar sigma cj in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma cj.uj_val in let pct = pr_leconstr_env env sigma cj.uj_type in @@ -263,7 +260,7 @@ let explain_number_branches env sigma cj expn = str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reductionops.nf_betaiota sigma (Evarutil.nf_evar sigma t) in + let simp t = Reductionops.nf_betaiota sigma t in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma c in let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in @@ -300,10 +297,10 @@ let explain_unification_error env sigma p1 p2 = function | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> + let t1 = Reductionops.nf_betaiota sigma t1 in + let t2 = Reductionops.nf_betaiota sigma t2 in if EConstr.eq_constr sigma t1 p1 && EConstr.eq_constr sigma t2 p2 then [] else let env = make_all_name_different env sigma in - let t1 = Evarutil.nf_evar sigma t1 in - let t2 = Evarutil.nf_evar sigma t2 in if not (EConstr.eq_constr sigma t1 p1) || not (EConstr.eq_constr sigma t2 p2) then let t1, t2 = pr_explicit env sigma t1 t2 in [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] @@ -327,8 +324,6 @@ let explain_unification_error env sigma p1 p2 = function | CannotSolveConstraint ((pb,env,t,u),e) -> let t = EConstr.of_constr t in let u = EConstr.of_constr u in - let t = Evarutil.nf_evar sigma t in - let u = Evarutil.nf_evar sigma u in let env = make_all_name_different env sigma in (strbrk "cannot satisfy constraint " ++ pr_leconstr_env env sigma t ++ str " == " ++ pr_leconstr_env env sigma u) @@ -359,9 +354,7 @@ let explain_actual_type env sigma j t reason = let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = let randl = jv_nf_betaiotaevar sigma randl in - let exptyp = Evarutil.nf_evar sigma exptyp in let actualtyp = Reductionops.nf_betaiota sigma actualtyp in - let rator = Evarutil.j_nf_evar sigma rator in let env = make_all_name_different env sigma in let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in let nargs = Array.length randl in @@ -386,8 +379,6 @@ let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = exptyp ++ str "." let explain_cant_apply_not_functional env sigma rator randl = - let randl = Evarutil.jv_nf_evar sigma randl in - let rator = Evarutil.j_nf_evar sigma rator in let env = make_all_name_different env sigma in let nargs = Array.length randl in (* let pe = pr_ne_context_of (str "in environment") env sigma in*) @@ -407,8 +398,6 @@ let explain_cant_apply_not_functional env sigma rator randl = fnl () ++ str " " ++ v 0 appl let explain_unexpected_type env sigma actual_type expected_type = - let actual_type = Evarutil.nf_evar sigma actual_type in - let expected_type = Evarutil.nf_evar sigma expected_type in let pract, prexp = pr_explicit env sigma actual_type expected_type in str "Found type" ++ spc () ++ pract ++ spc () ++ str "where" ++ spc () ++ prexp ++ str " was expected." @@ -510,8 +499,6 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = with e when CErrors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = - let vdefj = Evarutil.jv_nf_evar sigma vdefj in - let vargs = Array.map (Evarutil.nf_evar sigma) vargs in let env = make_all_name_different env sigma in let pvd = pr_leconstr_env env sigma vdefj.(i).uj_val in let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in @@ -575,9 +562,9 @@ let rec explain_evar_kind env sigma evk ty = function | Evar_kinds.SubEvar evk' -> let evi = Evd.find sigma evk' in let pc = match evi.evar_body with - | Evar_defined c -> pr_leconstr_env env sigma (Evarutil.nf_evar sigma (EConstr.of_constr c)) + | Evar_defined c -> pr_leconstr_env env sigma (EConstr.of_constr c) | Evar_empty -> assert false in - let ty' = Evarutil.nf_evar sigma (EConstr.of_constr evi.evar_concl) in + let ty' = EConstr.of_constr evi.evar_concl in pr_existential_key sigma evk ++ str " of type " ++ ty ++ str " in the partial instance " ++ pc ++ str " found for " ++ explain_evar_kind env sigma evk' @@ -628,8 +615,6 @@ let explain_wrong_case_info env (ind,u) ci = let explain_cannot_unify env sigma m n e = let env = make_all_name_different env sigma in - let m = Evarutil.nf_evar sigma m in - let n = Evarutil.nf_evar sigma n in let pm, pn = pr_explicit env sigma m n in let ppreason = explain_unification_error env sigma m n e in let pe = pr_ne_context_of (str "In environment") env sigma in diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 2c8f6ec9d6..9ab89c8832 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -60,7 +60,7 @@ let adjust_guardness_conditions const = function (* Try all combinations... not optimal *) let env = Global.env() in { const with const_entry_body = - Future.chain ~pure:true const.const_entry_body + Future.chain const.const_entry_body (fun ((body, ctx), eff) -> match kind_of_term body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> @@ -180,10 +180,14 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = try let const = adjust_guardness_conditions const do_guard in let k = Kindops.logical_kind_of_goal_kind kind in + let should_suggest = const.const_entry_opaque && Option.is_empty const.const_entry_secctx in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in + let () = if should_suggest + then Proof_using.suggest_variable (Global.env ()) id + in (Local, VarRef id) | Local | Global | Discharge -> let local = match locality with @@ -192,7 +196,11 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = in let kn = declare_constant ?export_seff id ~local (DefinitionEntry const, k) in - (locality, ConstRef kn) in + let () = if should_suggest + then Proof_using.suggest_constant (Global.env ()) kn + in + (locality, ConstRef kn) + in definition_message id; Option.iter (Universes.register_universe_binders r) pl; call_hook (fun exn -> exn) hook l r diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 5298ef2e44..9376afa8cc 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -991,7 +991,7 @@ let is_not_printable onlyparse nonreversible = function (warn_non_reversible_notation (); true) else onlyparse -let find_precedence lev etyps symbols = +let find_precedence lev etyps symbols onlyprint = let first_symbol = let rec aux = function | Break _ :: t -> aux t @@ -1009,8 +1009,13 @@ let find_precedence lev etyps symbols = | None -> [],0 | Some (NonTerminal x) -> (try match List.assoc x etyps with - | ETConstr _ -> - user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") + | ETConstr _ -> + if onlyprint then + if Option.is_empty lev then + user_err Pp.(str "Explicit level needed in only-printing mode when the level of the leftmost non-terminal is given.") + else [],Option.get lev + else + user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") | ETName | ETBigint | ETReference -> begin match lev with | None -> @@ -1134,7 +1139,7 @@ let compute_syntax_data df modifiers = let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in let ntn_for_grammar = if need_squash then make_notation_key symbols_for_grammar else ntn_for_interp in if not onlyprint then check_rule_productivity symbols_for_grammar; - let msgs,n = find_precedence mods.level mods.etyps symbols in + let msgs,n = find_precedence mods.level mods.etyps symbols onlyprint in (* To globalize... *) let etyps = join_auxiliary_recursive_types recvars mods.etyps in let sy_typs, prec = @@ -1313,7 +1318,7 @@ let to_map l = let fold accu (x, v) = Id.Map.add x v accu in List.fold_left fold Id.Map.empty l -let add_notation_in_scope local df c mods scope = +let add_notation_in_scope local df env c mods scope = let open SynData in let sd = compute_syntax_data df mods in (* Prepare the interpretation *) @@ -1324,7 +1329,7 @@ let add_notation_in_scope local df c mods scope = ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map sd.recvars; } in - let (acvars, ac, reversible) = interp_notation_constr nenv c in + let (acvars, ac, reversible) = interp_notation_constr env nenv c in let interp = make_interpretation_vars sd.recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in let onlyparse = is_not_printable sd.only_parsing (not reversible) ac in @@ -1344,7 +1349,7 @@ let add_notation_in_scope local df c mods scope = Lib.add_anonymous_leaf (inNotation notation); sd.info -let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = +let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = let dfs = split_notation_string df in let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint dfs in (* Recover types of variables and pa/pp rules; redeclare them if needed *) @@ -1363,7 +1368,7 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map recvars; } in - let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in + let (acvars, ac, reversible) = interp_notation_constr env ~impls nenv c in let interp = make_interpretation_vars recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in let onlyparse = is_not_printable onlyparse (not reversible) ac in @@ -1390,33 +1395,33 @@ let add_syntax_extension local ((loc,df),mods) = let open SynData in (* Notations with only interpretation *) -let add_notation_interpretation ((loc,df),c,sc) = - let df' = add_notation_interpretation_core false df c sc false false None in +let add_notation_interpretation env ((loc,df),c,sc) = + let df' = add_notation_interpretation_core false df env c sc false false None in Dumpglob.dump_notation (loc,df') sc true -let set_notation_for_interpretation impls ((_,df),c,sc) = +let set_notation_for_interpretation env impls ((_,df),c,sc) = (try ignore - (Flags.silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); + (Flags.silently (fun () -> add_notation_interpretation_core false df env ~impls c sc false false None) ()); with NoSyntaxRule -> user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) -let add_notation local c ((loc,df),modifiers) sc = +let add_notation local env c ((loc,df),modifiers) sc = let df' = if no_syntax_modifiers modifiers then (* No syntax data: try to rely on a previously declared rule *) let onlyparse = is_only_parsing modifiers in let onlyprint = is_only_printing modifiers in let compat = get_compat_version modifiers in - try add_notation_interpretation_core local df c sc onlyparse onlyprint compat + try add_notation_interpretation_core local df env c sc onlyparse onlyprint compat with NoSyntaxRule -> (* Try to determine a default syntax rule *) - add_notation_in_scope local df c modifiers sc + add_notation_in_scope local df env c modifiers sc else (* Declare both syntax and interpretation *) - add_notation_in_scope local df c modifiers sc + add_notation_in_scope local df env c modifiers sc in Dumpglob.dump_notation (loc,df') sc true @@ -1431,13 +1436,13 @@ let add_notation_extra_printing_rule df k v = let inject_var x = CAst.make @@ CRef (Ident (Loc.tag @@ Id.of_string x),None) -let add_infix local ((loc,inf),modifiers) pr sc = +let add_infix local env ((loc,inf),modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) let metas = [inject_var "x"; inject_var "y"] in let c = mkAppC (pr,metas) in let df = "x "^(quote_notation_token inf)^" y" in - add_notation local c ((loc,df),modifiers) sc + add_notation local env c ((loc,df),modifiers) sc (**********************************************************************) (* Delimiters and classes bound to scopes *) @@ -1493,7 +1498,7 @@ let try_interp_name_alias = function | [], { CAst.v = CRef (ref,_) } -> intern_reference ref | _ -> raise Not_found -let add_syntactic_definition ident (vars,c) local onlyparse = +let add_syntactic_definition env ident (vars,c) local onlyparse = let nonprintable = ref false in let vars,pat = try [], NRef (try_interp_name_alias (vars,c)) @@ -1504,7 +1509,7 @@ let add_syntactic_definition ident (vars,c) local onlyparse = ninterp_var_type = i_vars; ninterp_rec_vars = Id.Map.empty; } in - let nvars, pat, reversible = interp_notation_constr nenv c in + let nvars, pat, reversible = interp_notation_constr env nenv c in let () = nonprintable := not reversible in let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in List.map map vars, pat diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 9cd00cbcb4..b3049f1b7a 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -11,15 +11,16 @@ open Vernacexpr open Notation open Constrexpr open Notation_term +open Environ val add_token_obj : string -> unit (** Adding a (constr) notation in the environment*) -val add_infix : locality_flag -> (lstring * syntax_modifier list) -> +val add_infix : locality_flag -> env -> (lstring * syntax_modifier list) -> constr_expr -> scope_name option -> unit -val add_notation : locality_flag -> constr_expr -> +val add_notation : locality_flag -> env -> constr_expr -> (lstring * syntax_modifier list) -> scope_name option -> unit val add_notation_extra_printing_rule : string -> string -> string -> unit @@ -33,11 +34,11 @@ val add_class_scope : scope_name -> scope_class list -> unit (** Add only the interpretation of a notation that already has pa/pp rules *) val add_notation_interpretation : - (lstring * constr_expr * scope_name option) -> unit + env -> (lstring * constr_expr * scope_name option) -> unit (** Add a notation interpretation for supporting the "where" clause *) -val set_notation_for_interpretation : Constrintern.internalization_env -> +val set_notation_for_interpretation : env -> Constrintern.internalization_env -> (lstring * constr_expr * scope_name option) -> unit (** Add only the parsing/printing rule of a notation *) @@ -47,7 +48,7 @@ val add_syntax_extension : (** Add a syntactic definition (as in "Notation f := ...") *) -val add_syntactic_definition : Id.t -> Id.t list * constr_expr -> +val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr -> bool -> Flags.compat_version option -> unit (** Print the Camlp4 state of a grammar *) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 1edbd1a850..d3de10235f 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -174,6 +174,7 @@ let warn_cannot_use_directory = let convert_string d = try Names.Id.of_string d with UserError _ -> + let d = Unicode.escaped_if_non_utf8 d in warn_cannot_use_directory d; raise Exit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 81218308f9..785c842ba1 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -556,7 +556,7 @@ let declare_mutual_definition l = let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) [] ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) - List.iter Metasyntax.add_notation_interpretation first.prg_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 let kn = match gr with ConstRef kn -> kn | _ -> assert false in diff --git a/proofs/proof_using.ml b/vernac/proof_using.ml index 1a321120c6..ffe99cfd81 100644 --- a/proofs/proof_using.ml +++ b/vernac/proof_using.ml @@ -14,16 +14,6 @@ open Context.Named.Declaration module NamedDecl = Context.Named.Declaration -let to_string e = - let rec aux = function - | SsEmpty -> "()" - | SsSingl (_,id) -> "("^Id.to_string id^")" - | SsCompl e -> "-" ^ aux e^"" - | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" - | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" - | SsFwdClose e -> "("^aux e^")*" - in aux e - let known_names = Summary.ref [] ~name:"proofusing-nameset" let in_nameset = @@ -48,12 +38,20 @@ let rec close_fwd e s = s (named_context e) in if Id.Set.equal s s' then s else close_fwd e s' -;; + +let set_of_type env ty = + List.fold_left (fun acc ty -> + Id.Set.union (global_vars_set env ty) acc) + Id.Set.empty ty + +let full_set env = + List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty let rec process_expr env e ty = let rec aux = function | SsEmpty -> Id.Set.empty - | SsSingl (_,id) -> set_of_id env ty id + | SsType -> set_of_type env ty + | SsSingl (_,id) -> set_of_id env id | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) | SsCompl e -> Id.Set.diff (full_set env) (aux e) @@ -61,23 +59,15 @@ let rec process_expr env e ty = in aux e -and set_of_id env ty id = - if Id.to_string id = "Type" then - List.fold_left (fun acc ty -> - Id.Set.union (global_vars_set env ty) acc) - Id.Set.empty ty - else if Id.to_string id = "All" then +and set_of_id env id = + if Id.to_string id = "All" then List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty else if CList.mem_assoc_f Id.equal id !known_names then process_expr env (CList.assoc_f Id.equal id !known_names) [] else Id.Set.singleton id -and full_set env = - List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty - let process_expr env e ty = - let ty_expr = SsSingl(Loc.tag @@ Id.of_string "Type") in - let v_ty = process_expr env ty_expr ty in + let v_ty = set_of_type env ty in let s = Id.Set.union v_ty (process_expr env e ty) in Id.Set.elements s @@ -105,7 +95,13 @@ let remove_ids_and_lets env s ids = (no_body id || Id.Set.exists not_ids (Id.Set.filter no_body (deps id)))) s) -let suggest_Proof_using name env vars ids_typ context_ids = +let record_proof_using expr = + Aux_file.record_in_aux "suggest_proof_using" expr + +(* Variables in [skip] come from after the definition, so don't count + for "All". Used in the variable case since the env contains the + variable itself. *) +let suggest_common env ppid used ids_typ skip = let module S = Id.Set in let open Pp in let print x = Feedback.msg_debug x in @@ -114,10 +110,13 @@ let suggest_Proof_using name env vars ids_typ context_ids = if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" else ppcmds in wrap (prlist_with_sep (fun _ -> str" ") Id.print (S.elements s)) in - let used = S.union vars ids_typ in + let needed = minimize_hyps env (remove_ids_and_lets env used ids_typ) in let all_needed = really_needed env needed in - let all = List.fold_right S.add context_ids S.empty in + let all = List.fold_left (fun all d -> S.add (NamedDecl.get_id d) all) + S.empty (named_context env) + in + let all = S.diff all skip in let fwd_typ = close_fwd env ids_typ in if !Flags.debug then begin print (str "All " ++ pr_set false all); @@ -133,36 +132,59 @@ let suggest_Proof_using name env vars ids_typ context_ids = if S.equal all all_needed then valid(str "All"); valid (pr_set false needed); Feedback.msg_info ( - str"The proof of "++ str name ++ spc() ++ + str"The proof of "++ ppid ++ spc() ++ str "should start with one of the following commands:"++spc()++ v 0 ( prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs)); - string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) -;; + if !Flags.record_aux_file + then + let s = string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) in + record_proof_using s -let value = ref false +let suggest_proof_using = ref false let _ = Goptions.declare_bool_option { Goptions.optdepr = false; Goptions.optname = "suggest Proof using"; Goptions.optkey = ["Suggest";"Proof";"Using"]; - Goptions.optread = (fun () -> !value); - Goptions.optwrite = (fun b -> - value := b; - if b then Term_typing.set_suggest_proof_using suggest_Proof_using - else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> "") - ) } + Goptions.optread = (fun () -> !suggest_proof_using); + Goptions.optwrite = ((:=) suggest_proof_using) } + +let suggest_constant env kn = + if !suggest_proof_using + then begin + let open Declarations in + let body = lookup_constant kn env in + let used = Id.Set.of_list @@ List.map NamedDecl.get_id body.const_hyps in + let ids_typ = global_vars_set env body.const_type in + suggest_common env (Printer.pr_constant env kn) used ids_typ Id.Set.empty + end + +let suggest_variable env id = + if !suggest_proof_using + then begin + match lookup_named id env with + | LocalDef (_,body,typ) -> + let ids_typ = global_vars_set env typ in + let ids_body = global_vars_set env body in + let used = Id.Set.union ids_body ids_typ in + suggest_common env (Id.print id) used ids_typ (Id.Set.singleton id) + | LocalAssum _ -> assert false + end let value = ref None +let using_to_string us = Pp.string_of_ppcmds (Ppvernac.pr_using us) +let using_from_string us = Pcoq.Gram.(entry_parse G_vernac.section_subset_expr (parsable (Stream.of_string us))) + let _ = Goptions.declare_stringopt_option { Goptions.optdepr = false; Goptions.optname = "default value for Proof using"; Goptions.optkey = ["Default";"Proof";"Using"]; - Goptions.optread = (fun () -> !value); - Goptions.optwrite = (fun b -> value := b;) } - + Goptions.optread = (fun () -> Option.map using_to_string !value); + Goptions.optwrite = (fun b -> value := Option.map using_from_string b); + } let get_default_proof_using () = !value diff --git a/proofs/proof_using.mli b/vernac/proof_using.mli index c882b1827a..f63c8e2424 100644 --- a/proofs/proof_using.mli +++ b/vernac/proof_using.mli @@ -14,6 +14,8 @@ val process_expr : val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit -val to_string : Vernacexpr.section_subset_expr -> string +val suggest_constant : Environ.env -> Names.Constant.t -> unit -val get_default_proof_using : unit -> string option +val suggest_variable : Environ.env -> Names.Id.t -> unit + +val get_default_proof_using : unit -> Vernacexpr.section_subset_expr option diff --git a/vernac/record.ml b/vernac/record.ml index 18e7796caf..5533fe5b38 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -72,7 +72,7 @@ let interp_fields_evars env evars impls_env nots l = | None -> LocalAssum (i,t') | Some b' -> LocalDef (i,b',t') in - List.iter (Metasyntax.set_notation_for_interpretation impls) no; + List.iter (Metasyntax.set_notation_for_interpretation env impls) no; (EConstr.push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l @@ -418,7 +418,6 @@ let declare_structure finite univs id idbuild paramimpls params arity template begin let env = Global.env () in let env' = Environ.push_context ctx env in - (* let env'' = Environ.push_rel_context params env' in *) let evd = Evd.from_env env' in Inductiveops.infer_inductive_subtyping env' evd mie end diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index f74073e1f7..850902d6ba 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -1,4 +1,5 @@ Vernacprop +Proof_using Lemmas Himsg ExplainErr diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 83296cf58f..e08cb83871 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -430,11 +430,11 @@ let vernac_arguments_scope locality r scl = let vernac_infix locality local = let local = enforce_module_locality locality local in - Metasyntax.add_infix local + Metasyntax.add_infix local (Global.env()) let vernac_notation locality local = let local = enforce_module_locality locality local in - Metasyntax.add_notation local + Metasyntax.add_notation local (Global.env()) (***********) (* Gallina *) @@ -953,7 +953,7 @@ let vernac_hints locality poly local lb h = let vernac_syntactic_definition locality lid x local y = Dumpglob.dump_definition lid false "syndef"; let local = enforce_module_locality locality local in - Metasyntax.add_syntactic_definition (snd lid) x local y + Metasyntax.add_syntactic_definition (Global.env()) (snd lid) x local y let vernac_declare_implicits locality r l = let local = make_section_locality locality in @@ -1785,7 +1785,7 @@ let vernac_locate = let open Feedback in function (Constrextern.without_symbols pr_lglob_constr) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> msg_notice (print_located_module qid) - | LocateTactic qid -> msg_notice (print_located_tactic qid) + | LocateOther (s, qid) -> msg_notice (print_located_other s qid) | LocateFile f -> msg_notice (locate_file f) let vernac_register id r = @@ -2060,17 +2060,13 @@ let interp ?proof ?loc locality poly c = | VernacEndSubproof -> vernac_end_subproof () | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () - | VernacProof (None, None) -> - Aux_file.record_in_aux_at ?loc "VernacProof" "tac:no using:no" - | VernacProof (Some tac, None) -> - Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:no"; - vernac_set_end_tac tac - | VernacProof (None, Some l) -> - Aux_file.record_in_aux_at ?loc "VernacProof" "tac:no using:yes"; - vernac_set_used_variables l - | VernacProof (Some tac, Some l) -> - Aux_file.record_in_aux_at ?loc "VernacProof" "tac:yes using:yes"; - vernac_set_end_tac tac; vernac_set_used_variables l + | VernacProof (tac, using) -> + let using = Option.append using (Proof_using.get_default_proof_using ()) in + let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in + let usings = if Option.is_empty using then "using:no" else "using:yes" in + Aux_file.record_in_aux_at ?loc "VernacProof" (tacs^" "^usings); + Option.iter vernac_set_end_tac tac; + Option.iter vernac_set_used_variables using | VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"] (* Extensions *) @@ -2152,23 +2148,48 @@ let locate_if_not_already ?loc (e, info) = exception HasNotFailed exception HasFailed of Pp.t -let with_fail b f = - if not b then f () +type interp_state = { (* TODO: inline records in OCaml 4.03 *) + system : States.state; (* summary + libstack *) + proof : Proof_global.state; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) +} + +let s_cache = ref (States.freeze ~marshallable:`No) +let s_proof = ref (Proof_global.freeze ~marshallable:`No) + +let invalidate_cache () = + s_cache := Obj.magic 0; + s_proof := Obj.magic 0 + +let freeze_interp_state marshallable = + { system = (s_cache := States.freeze ~marshallable; !s_cache); + proof = (s_proof := Proof_global.freeze ~marshallable; !s_proof); + shallow = marshallable = `Shallow } + +let unfreeze_interp_state { system; proof } = + if (!s_cache != system) then (s_cache := system; States.unfreeze system); + if (!s_proof != proof) then (s_proof := proof; Proof_global.unfreeze proof) + +(* 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 *) - Future.purify - (fun v -> - try f v; 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)))) - () + 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! *) + invalidate_cache (); + unfreeze_interp_state st; let (e, _) = CErrors.push e in match e with | HasNotFailed -> @@ -2179,7 +2200,7 @@ let with_fail b f = | _ -> assert false end -let interp ?(verbosely=true) ?proof (loc,c) = +let interp ?(verbosely=true) ?proof st (loc,c) = let orig_program_mode = Flags.is_program_mode () in let rec aux ?locality ?polymorphism isprogcmd = function @@ -2192,7 +2213,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = | VernacPolymorphic (b, c) -> user_err Pp.(str "Polymorphism specified twice") | VernacLocal _ -> user_err Pp.(str "Locality specified twice") | VernacFail v -> - with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v) + with_fail st true (fun () -> aux ?locality ?polymorphism isprogcmd v) | VernacTimeout (n,v) -> current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v @@ -2231,3 +2252,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = in if verbosely then Flags.verbosely (aux false) c else aux false c + +let interp ?verbosely ?proof st cmd = + unfreeze_interp_state st; + interp ?verbosely ?proof st cmd; + freeze_interp_state `No diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index a09011d245..56635c8011 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -14,11 +14,21 @@ val dump_global : Libnames.reference or_by_notation -> unit val vernac_require : Libnames.reference option -> bool option -> Libnames.reference list -> unit +type interp_state = { (* TODO: inline records in OCaml 4.03 *) + system : States.state; (* summary + libstack *) + proof : Proof_global.state; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) +} + +val freeze_interp_state : Summary.marshallable -> interp_state +val unfreeze_interp_state : interp_state -> unit + (** The main interpretation function of vernacular expressions *) val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - Vernacexpr.vernac_expr Loc.located -> unit + interp_state -> + Vernacexpr.vernac_expr Loc.located -> interp_state (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name @@ -28,7 +38,9 @@ val interp : val make_cases : string -> string list list -val with_fail : bool -> (unit -> unit) -> unit +(* XXX STATE: this type hints that restoring the state should be the + caller's responsibility *) +val with_fail : interp_state -> bool -> (unit -> unit) -> unit val command_focus : unit Proof.focus_kind |