diff options
190 files changed, 1056 insertions, 2659 deletions
diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 4a8606a38a..73b61ee0d9 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -16,4 +16,4 @@ Fixes / closes #???? <!-- If this is a feature pull request / breaks compatibility: --> <!-- (Otherwise, remove these lines.) --> - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). -- [ ] Entry added in CHANGES. +- [ ] Entry added in CHANGES.md. diff --git a/.gitignore b/.gitignore index 0ab6e25852..39ef20970d 100644 --- a/.gitignore +++ b/.gitignore @@ -113,8 +113,6 @@ doc/stdlib/index-list.html doc/tutorial/Tutorial.v.out doc/RecTutorial/RecTutorial.html doc/RecTutorial/RecTutorial.ps -dev/ocamldoc/*.html -dev/ocamldoc/*.css # .mll files @@ -160,13 +158,6 @@ checker/names.mli checker/esubst.ml checker/esubst.mli -# mlis documentation - -dev/ocamldoc/html/ -dev/ocamldoc/coq.* -dev/ocamldoc/ocamldoc.sty -dev/myinclude - # emacs save files *~ \#*\# diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index dae412923b..da90ebaa98 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2018-09-25-V1" + CACHEKEY: "bionic_coq-V2018-10-04-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -234,12 +234,17 @@ windows32: except: - /^pr-.*$/ -pkg:dune-release: - <<: *dune-template +pkg:opam: stage: test + # OPAM will build out-of-tree so no point in importing artifacts + dependencies: [] + script: + - set -e + - opam pin add coq . + - opam pin add coqide ide + - set +e variables: OPAM_SWITCH: edge - DUNE_TARGET: release pkg:nix: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git @@ -275,18 +280,6 @@ doc:refman: dependencies: - build:base -doc:ml-api:ocamldoc: - stage: test - dependencies: - - build:edge - script: - - ./configure -warn-error yes -prefix "$(pwd)/_install_ci" - - make mli-doc source-doc # ml-doc [broken in 4.07.0] - artifacts: - name: "$CI_JOB_NAME" - paths: - - dev/ocamldoc - doc:ml-api:odoc: stage: test dependencies: @@ -18,6 +18,7 @@ Yves Bertot <yves.bertot@inria.fr> bertot <bertot@85f007b7-540e- Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> +Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> Pierre Boutillier <pierre.boutillier@ens-lyon.org> pboutill <pboutill@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@pps.univ-paris-diderot.fr> @@ -31,6 +32,8 @@ Maxime Dénès <mail@maximedenes.fr> mdenes <mdenes@85f007b7-540 Maxime Dénès <mail@maximedenes.fr> Maxime Denes <maximedenes@gillespie.inria.fr> Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> +Andres Erbsen <andreser@mit.edu> Andres Erbsen <andres@kevix.co> +Jim Fehrle <jfehrle@sbcglobal.net> Jim <jfehrle@sbcglobal.net> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> Jean-Christophe Filliatre <Jean-Christophe.Filliatre@lri.fr> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -43,6 +46,7 @@ Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@ens-lyon.fr> Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@skyskimmer.net> Stéphane Glondu <steph@glondu.net> glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7> Stéphane Glondu <steph@glondu.net> Stephane Glondu <steph@glondu.net> +Matěj Grabovský <mgrabovsky@yahoo.com> Matěj G <mgrabovsky@users.noreply.github.com> Benjamin Grégoire <benjamin.gregoire@inria.fr> Benjamin Gregoire <Benjamin.Gregoire@inria.fr> Benjamin Grégoire <benjamin.gregoire@inria.fr> bgregoir <bgregoir@85f007b7-540e-0410-9357-904b9bb8a0f7> Benjamin Grégoire <benjamin.gregoire@inria.fr> gregoire <gregoire@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -51,6 +55,7 @@ Jason Gross <jgross@mit.edu> Jason Gross <jasongross9@gmai Vincent Gross <vgross@gforge> vgross <vgross@85f007b7-540e-0410-9357-904b9bb8a0f7> Huang Guan-Shieng <huang@gforge> huang <huang@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Jasper Hugunin <jasperh@cs.washington.edu> Jasper Hugunin <jasper@hashplex.com> Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-540e-0410-9357-904b9bb8a0f7> Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> Florent Kirchner <fkirchne@gforge> fkirchne <fkirchne@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -58,6 +63,7 @@ Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-5 Johannes Kloos <jkloos@mpi-sws.org> jkloos <jkloos@mpi-sws.org> Matej Košík <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> Matej Košík <matej.kosik@inria.fr> Matej Kosik <matej.kosik@inria.fr> +Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> William Lawvere <mundungus.corleone@gmail.com> william-lawvere <mundungus.corleone@gmail.com> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -70,6 +76,7 @@ Lionel Elie Mamane <lmamane@gforge> lmamane <lmamane@85f007b7-540 Claude Marché <marche@gforge> marche <marche@85f007b7-540e-0410-9357-904b9bb8a0f7> Micaela Mayero <mayero@gforge> mayero <mayero@85f007b7-540e-0410-9357-904b9bb8a0f7> Guillaume Melquiond <guillaume.melquiond@inria.fr> gmelquio <gmelquio@85f007b7-540e-0410-9357-904b9bb8a0f7> +Guillaume Melquiond <guillaume.melquiond@inria.fr> Guillaume Melquiond <guillaume.melquiond@gmail.com> Alexandre Miquel <miquel@gforge> miquel <miquel@85f007b7-540e-0410-9357-904b9bb8a0f7> Benjamin Monate <monate@gforge> monate <monate@85f007b7-540e-0410-9357-904b9bb8a0f7> Julien Narboux <jnarboux@gforge> jnarboux <jnarboux@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -81,6 +88,7 @@ Russell O'Connor <roconnor@blockstream.io> roconnor-blockstream <roconno Christine Paulin <cpaulin@gforge> cpaulin <cpaulin@85f007b7-540e-0410-9357-904b9bb8a0f7> Christine Paulin <cpaulin@gforge> mohring <mohring@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Clément Pit-Claudel <clement.pitclaudel@live.com> Clément Pit--Claudel <clement.pitclaudel@live.com> Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> Lars Rasmusson <lars.rasmusson@sics.se> larsr <Lars.Rasmusson@sics.se> @@ -91,16 +99,23 @@ Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7- Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> Regis-Gianas <yrg@pps.univ-paris-diderot.fr> Clément Renard <clrenard@gforge> clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7> Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@coins.tsukuba.ac.jp> Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> +Michael Soegtrop <michael.soegtrop@intel.com> Michael Soegtrop <7895506+MSoegtropIMC@users.noreply.github.com> Elie Soubiran <soubiran@gforge> soubiran <soubiran@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthieu Sozeau <mattam@mattam.org> msozeau <msozeau@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <matthieu.sozeau@inria.fr> +Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <mattam@eduroam-prg-sg-1-46-137.net.univ-paris-diderot.fr> Arnaud Spiwack <arnaud@spiwack.net> aspiwack <aspiwack@85f007b7-540e-0410-9357-904b9bb8a0f7> +Paul Steckler <steck@stecksoft.com> Paul Steckler <psteck@mit.edu> Enrico Tassi <Enrico.Tassi@inria.fr> gareuselesinge <gareuselesinge@85f007b7-540e-0410-9357-904b9bb8a0f7> Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <enrico.tassi@inria.fr> Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <gares@fettunta.org> +Enrico Tassi <Enrico.Tassi@inria.fr> Enrico <gares@fettunta.org> Laurent Théry <laurent.thery@inria.fr> thery <thery@85f007b7-540e-0410-9357-904b9bb8a0f7> Laurent Théry <laurent.thery@inria.fr> thery <thery@sophia.inria.fr> +Laurent Théry <laurent.thery@inria.fr> Laurent Théry <thery@sophia.inria.fr> +Anton Trunov <anton.a.trunov@gmail.com> Anton Trunov <anton.trunov@imdea.org> Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e-0410-9357-904b9bb8a0f7> Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Theo Zimmermann <theo.zimmermann@ens.fr> Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Théo Zimmermann <theo.zimmi@gmail.com> @@ -16,6 +16,9 @@ Plugins Tactics - Removed the deprecated `romega` tactics. +- Tactic names are no longer allowed to clash, even if they are not defined in + the same section. For example, the following is no longer accepted: + `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` Changes from 8.8.2 to 8.9+beta1 =============================== @@ -29,34 +32,34 @@ Notations - New support for autonomous grammars of terms, called "custom entries" (see chapter "Syntax extensions" of the reference manual). -- New command "Declare Scope" to explicitly declare a scope name +- New command `Declare Scope` to explicitly declare a scope name before any use of it. Implicit declaration of a scope at the time of - "Bind Scope", "Delimit Scope", "Undelimit Scope", or "Notation" is + `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is deprecated. Tactics -- Added toplevel goal selector ! which expects a single focused goal. - Use with Set Default Goal Selector to force focusing before tactics +- Added toplevel goal selector `!` which expects a single focused goal. + Use with `Set Default Goal Selector` to force focusing before tactics are called. - The undocumented "nameless" forms `fix N`, `cofix` that were - deprecated in 8.8 have been removed from LTAC's syntax; please use + deprecated in 8.8 have been removed from Ltac's syntax; please use `fix ident N/cofix ident` to explicitly name the (co)fixpoint hypothesis to be introduced. -- Introduction tactics "intro"/"intros" on a goal which is an +- Introduction tactics `intro`/`intros` on a goal that is an existential variable now force a refinement of the goal into a dependent product rather than failing. -- Support for fix/cofix added in Ltac "match" and "lazymatch". +- Support for `fix`/`cofix` added in Ltac `match` and `lazymatch`. - Ltac backtraces now include trace information about tactics called by OCaml-defined tactics. -- Option "Ltac Debug" now applies also to terms built using Ltac functions. +- Option `Ltac Debug` now applies also to terms built using Ltac functions. -- Deprecated the Implicit Tactic family of commands. +- Deprecated the `Implicit Tactic` family of commands. - The default program obligation tactic uses a bounded proof search instead of an unbounded and potentially non-terminating one now @@ -79,7 +82,7 @@ Tactics - The `romega` tactics have been deprecated; please use `lia` instead. - Names of existential variables occurring in Ltac functions - (e.g. "?[n]" or "?n" in terms - not in patterns) are now interpreted + (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted the same way as other variable names occurring in Ltac functions. Focusing @@ -92,24 +95,24 @@ Specification language, type inference - A fix to unification (which was sensitive to the ascii name of variables) may occasionally change type inference in incompatible - ways, especially regarding the inference of the return clause of "match". + ways, especially regarding the inference of the return clause of `match`. - Fixing a missing check in interpreting instances of existential - variables which are bound to local definitions might exceptionally + variables that are bound to local definitions might exceptionally induce an overhead if the cost of checking the conversion of the corresponding definitions is additionally high (PR #8215). -- A few improvements in inference of the return clause of "match" can +- A few improvements in inference of the return clause of `match` can exceptionally introduce incompatibilities (PR #262). This can be - solved by writing an explicit "return" clause, sometimes even simply - an explicit "return _" clause. + solved by writing an explicit `return` clause, sometimes even simply + an explicit `return _` clause. Standard Library - Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, and proved some lemmas about them. Note that this might cause - incompatibilities if you have, e.g., string_scope and Z_scope both - open with string_scope on top, and expect `=?` to refer to `Z.eqb`. + incompatibilities if you have, e.g., `string_scope` and `Z_scope` both + open with `string_scope` on top, and expect `=?` to refer to `Z.eqb`. Solution: wrap `_ =? _` in `(_ =? _)%Z` (or whichever scope you want). @@ -149,35 +152,34 @@ Standard Library Tools - Coq_makefile lets one override or extend the following variables from - the command line: COQFLAGS, COQCHKFLAGS, COQDOCFLAGS. - COQFLAGS is now entirely separate from COQLIBS, so in custom Makefiles - $(COQFLAGS) should be replaced by $(COQFLAGS) $(COQLIBS). + the command line: `COQFLAGS`, `COQCHKFLAGS`, `COQDOCFLAGS`. + `COQFLAGS` is now entirely separate from `COQLIBS`, so in custom Makefiles + `$(COQFLAGS)` should be replaced by `$(COQFLAGS) $(COQLIBS)`. -- Removed the gallina utility (extracts specification from Coq vernacular files). +- Removed the `gallina` utility (extracts specification from Coq vernacular files). If you would like to maintain this tool externally, please contact us. - Removed the Emacs modes distributed with Coq. You are advised to - use Proof-General <https://proofgeneral.github.io/> (and optionally - Company-Coq <https://github.com/cpitclaudel/company-coq>) instead. + use [Proof-General](https://proofgeneral.github.io/) (and optionally + [Company-Coq](https://github.com/cpitclaudel/company-coq)) instead. If your use case is not covered by these alternative Emacs modes, please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. - Vernacular Commands -- Removed deprecated commands Arguments Scope and Implicit Arguments - (not the option). Use the Arguments command instead. +- Removed deprecated commands `Arguments Scope` and `Implicit Arguments` + (not the option). Use the `Arguments` command instead. - Nested proofs may be enabled through the option `Nested Proofs Allowed`. By default, they are disabled and produce an error. The deprecation warning which used to occur when using nested proofs has been removed. -- Added option Uniform Inductive Parameters which abstracts over parameters +- Added option `Uniform Inductive Parameters` which abstracts over parameters before typechecking constructors, allowing to write for example `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` -- New Set Hint Variables/Constants Opaque/Transparent commands for setting +- New `Set Hint Variables/Constants Opaque/Transparent` commands for setting globally the opacity flag of variables and constants in hint databases, overwritting the opacity set of the hint database. -- Added generic syntax for “attributes”, as in: +- Added generic syntax for "attributes", as in: `#[local] Lemma foo : bar.` - Added the `Numeral Notation` command for registering decimal numeral notations for custom types @@ -185,8 +187,8 @@ Vernacular Commands scope. If you want the previous behavior, use `Global Set SsrHave NoTCResolution`. - Multiple sections with the same name are allowed. -- Combined Scheme can now work when inductive schemes are generated in sort - Type. It used to be limited to sort Prop. +- `Combined Scheme` can now work when inductive schemes are generated in sort + `Type`. It used to be limited to sort `Prop`. Coq binaries and process model @@ -204,40 +206,41 @@ SSReflect - The implementation of delayed clear switches in intro patterns is now simpler to explain: - 1. The immediate effect of a clear switch like {x} is to rename the - variable x to _x_ (i.e. a reserved identifier that cannot be mentioned + 1. The immediate effect of a clear switch like `{x}` is to rename the + variable `x` to `_x_` (i.e. a reserved identifier that cannot be mentioned explicitly) - 2. The delayed effect of {x} is that _x_ is cleared at the end of the intro + 2. The delayed effect of `{x}` is that `_x_` is cleared at the end of the intro pattern - 3. A clear switch immediately before a view application like {x}/v is - translated to /v{x}. - In particular rule 3 lets one write {x}/v even if v uses the variable x: + 3. A clear switch immediately before a view application like `{x}/v` is + translated to `/v{x}`. + + In particular, the third rule lets one write `{x}/v` even if `v` uses the variable `x`: indeed the view is executed before the renaming. - An empty clear switch is now accepted in intro patterns before a view application whenever the view is a variable. - One can now write {}/v to mean {v}/v. Remark that {}/x is very similar - to the idiom {}e for the rewrite tactic (the equation e is used for + One can now write `{}/v` to mean `{v}/v`. Remark that `{}/x` is very similar + to the idiom `{}e` for the rewrite tactic (the equation `e` is used for rewriting and then discarded). Standard Library -- There are now conversions between [string] and [positive], [Z], - [nat], and [N] in binary, octal, and hex. +- There are now conversions between `string` and `positive`, `Z`, + `nat`, and `N` in binary, octal, and hex. Display diffs between proof steps -- coqtop and coqide can now highlight the differences between proof steps +- `coqtop` and `coqide` can now highlight the differences between proof steps in color. This can be enabled from the command line or the - `Set Diffs "on"|"off"|"removed"` command. Please see the documentation for + `Set Diffs "on"/"off"/"removed"` command. Please see the documentation for details. Showing diffs in Proof General requires small changes to PG (under discussion). Notations - Added `++` infix for `VectorDef.append`. - Note that this might cause incompatibilities if you have, e.g., list_scope - and vector_scope both open with vector_scope on top, and expect `++` to + Note that this might cause incompatibilities if you have, e.g., `list_scope` + and `vector_scope` both open with `vector_scope` on top, and expect `++` to refer to `app`. Solution: wrap `_ ++ _` in `(_ ++ _)%list` (or whichever scope you want). @@ -263,7 +266,7 @@ Kernel Windows installer - The Windows installer now includes many more external packages that can be -individually selected for installation. + individually selected for installation. Many other bug fixes and lots of documentation improvements (for details, see the 8.8.2 milestone at https://github.com/coq/coq/milestone/15?closed=1). @@ -273,10 +276,10 @@ Changes from 8.8.0 to 8.8.1 Kernel -- Fix a critical bug with cofixpoints and vm_compute/native_compute (#7333). +- Fix a critical bug with cofixpoints and `vm_compute`/`native_compute` (#7333). - Fix a critical bug with modules and algebraic universes (#7695) - Fix a critical bug with inlining of polymorphic constants (#7615). -- Fix a critical bug with universe polymorphism and vm_compute (#7723). Was +- Fix a critical bug with universe polymorphism and `vm_compute` (#7723). Was present since 8.5. Notations @@ -300,7 +303,7 @@ Changes from 8.8+beta1 to 8.8.0 Tools - Asynchronous proof delegation policy was fixed. Since version 8.7 - Coq was ignoring previous runs and the -async-proofs-delegation-threshold + Coq was ignoring previous runs and the `-async-proofs-delegation-threshold` option did not have the expected behavior. Tactic language @@ -39,14 +39,14 @@ WHAT DO YOU NEED ? - Findlib (version >= 1.4.1) (available at http://projects.camlcity.org/projects/findlib.html) - - Camlp5 (version >= 7.01) + - Camlp5 (version >= 7.03) (available at https://camlp5.github.io/) - GNU Make version 3.81 or later - a C compiler - - for CoqIDE, the lablgtk development files (version >= 2.18.3), + - for CoqIDE, the lablgtk development files (version >= 2.18.5), and the GTK 2.x libraries including gtksourceview2. Note that num, camlp5 and lablgtk should be properly registered with @@ -193,11 +193,11 @@ META.coq: META.coq.in # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean alienclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean alienclean -clean: objclean cruftclean depclean docclean devdocclean camldevfilesclean +clean: objclean cruftclean depclean docclean camldevfilesclean -cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean devdocclean +cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean objclean: archclean indepclean @@ -276,12 +276,6 @@ timingclean: -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + -devdocclean: - find . \( -name '*.dep.ps' -o -name '*.dot' \) -exec rm -f {} + - rm -f $(OCAMLDOCDIR)/*.log $(OCAMLDOCDIR)/*.aux $(OCAMLDOCDIR)/*.toc - rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex - rm -f $(OCAMLDOCDIR)/html/*.html - # Ensure that every compiled file around has a known source file. # This should help preventing weird compilation failures caused by leftover # compiled files after deleting or moving some source files. diff --git a/Makefile.doc b/Makefile.doc index db52607612..1184cc186b 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -209,85 +209,6 @@ install-doc-sphinx: $(INSTALLLIB) doc/sphinx/_build/$$f $(FULLDOCDIR)/sphinx/$$f;\ done) -########################################################################### -# Documentation of the source code (using ocamldoc) -########################################################################### - -OCAMLDOCDIR=dev/ocamldoc - -DOCMLLIBS= $(CORECMA:.cma=_MLLIB_DEPENDENCIES) $(PLUGINSCMO:.cmo=_MLPACK_DEPENDENCIES) -DOCMLS=$(foreach lib,$(DOCMLLIBS),$(addsuffix .ml, $($(lib)))) - -DOCMLIS=$(wildcard $(addsuffix /*.mli, $(SRCDIRS))) - -# Defining options to generate dependencies graphs -DOT=dot -ODOCDOTOPTS=-dot -dot-reduce - -.PHONY: source-doc mli-doc ml-doc - -source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf - -OCAMLDOC_CAML_FLAGS=-rectypes -I +threads $(MLINCLUDES) - -$(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) - $(SHOW)'OCAMLDOC -latex -o $@' - $(HIDE)$(OCAMLFIND) ocamldoc -latex $(OCAMLDOC_CAML_FLAGS) \ - $(DOCMLIS) -noheader -t "Coq mlis documentation" \ - -intro $(OCAMLDOCDIR)/docintro -o $@.tmp - $(SHOW)'OCAMLDOC utf8 fix' - $(HIDE)$(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp - $(HIDE)cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ - rm $@.tmp - -mli-doc: $(DOCMLIS:.mli=.cmi) - $(SHOW)'OCAMLDOC -html' - $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html $(OCAMLDOC_CAML_FLAGS) \ - $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ - -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ - -css-style style.css - -ml-dot: $(MLFILES) - $(OCAMLFIND) ocamldoc -dot -dot-reduce $(OCAMLDOC_CAML_FLAGS) \ - $(filter $(addsuffix /%.ml,$(CORESRCDIRS)),$(MLFILES)) -o $(OCAMLDOCDIR)/coq.dot - -%_dep.png: %.dot - $(DOT) -Tpng $< -o $@ - -%_types.dot: %.mli - $(OCAMLFIND) ocamldoc $(OCAMLDOC_CAML_FLAGS) $(ODOCDOTOPTS) -dot-types -o $@ $< - -OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc $(OCAMLDOC_CAML_FLAGS) $(ODOCDOTOPTS) -o $@ \ - $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib)))) - -%.dot: | %.mllib.d - $(OCAMLDOC_MLLIBD) - -ml-doc: kernel/copcodes.cmi - $(SHOW)'OCAMLDOC -html' - $(HIDE)mkdir -p $(OCAMLDOCDIR)/html/implementation - $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html $(OCAMLDOC_CAML_FLAGS) \ - $(DOCMLS) -d $(OCAMLDOCDIR)/html/implementation -colorize-code \ - -t "Coq mls documentation" \ - -css-style ../style.css - -parsing/parsing.dot : | parsing/parsing.mllib.d - $(OCAMLDOC_MLLIBD) - -grammar/grammar.dot : | grammar/grammar.mllib.d - $(OCAMLDOC_MLLIBD) - -tactics/tactics.dot: | tactics/tactics.mllib.d ltac/ltac.mllib.d - $(OCAMLDOC_MLLIBD) - -%.dot: %.mli - $(OCAMLFIND) ocamldoc $(OCAMLDOC_CAML_FLAGS) $(ODOCDOTOPTS) -o $@ $< - -$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex - $(SHOW)'PDFLATEX $*.tex' - $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) - $(HIDE)(cd doc/tools/; ./show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) - # For emacs: # Local Variables: # mode: makefile @@ -27,7 +27,7 @@ and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ), for additional user-contributed documentation. ## Changes -There is a file named [`CHANGES`](CHANGES) that explains the differences and the +There is a file named [`CHANGES.md`](CHANGES.md) that explains the differences and the incompatibilities since last versions. If you upgrade Coq, please read it carefully. diff --git a/checker/declarations.ml b/checker/declarations.ml index 03fee1ab51..93d5f8bfa2 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -70,12 +70,12 @@ let solve_delta_kn resolve kn = | Equiv kn1 -> kn1 | Inline _ -> raise Not_found with Not_found -> - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else - KerName.make new_mp dir l + KerName.make new_mp l let gen_of_delta resolve x kn fix_can = let new_kn = solve_delta_kn resolve kn in @@ -129,17 +129,17 @@ let subst_mp sub mp = | Some (mp',_) -> mp' let subst_kn_delta sub kn = - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',resolve) -> - solve_delta_kn resolve (KerName.make mp' dir l) + solve_delta_kn resolve (KerName.make mp' l) | None -> kn let subst_kn sub kn = - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',_) -> - KerName.make mp' dir l + KerName.make mp' l | None -> kn exception No_subst @@ -156,16 +156,16 @@ let gen_subst_mp f sub mp1 mp2 = | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 -let make_mind_equiv mpu mpc dir l = - let knu = KerName.make mpu dir l in +let make_mind_equiv mpu mpc l = + let knu = KerName.make mpu l in if mpu == mpc then MutInd.make1 knu - else MutInd.make knu (KerName.make mpc dir l) + else MutInd.make knu (KerName.make mpc l) let subst_ind sub mind = let kn1,kn2 = MutInd.user mind, MutInd.canonical mind in - let mp1,dir,l = KerName.repr kn1 in - let mp2,_,_ = KerName.repr kn2 in - let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in + let mp1,l = KerName.repr kn1 in + let mp2,_ = KerName.repr kn2 in + let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 l in try let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in match side with @@ -173,16 +173,16 @@ let subst_ind sub mind = | Canonical -> mind_of_delta2 resolve mind' with No_subst -> mind -let make_con_equiv mpu mpc dir l = - let knu = KerName.make mpu dir l in +let make_con_equiv mpu mpc l = + let knu = KerName.make mpu l in if mpu == mpc then Constant.make1 knu - else Constant.make knu (KerName.make mpc dir l) + else Constant.make knu (KerName.make mpc l) let subst_con0 sub con u = let kn1,kn2 = Constant.user con, Constant.canonical con in - let mp1,dir,l = KerName.repr kn1 in - let mp2,_,_ = KerName.repr kn2 in - let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in + let mp1,l = KerName.repr kn1 in + let mp2,_ = KerName.repr kn2 in + let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 l in let dup con = con, Const (con, u) in let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in match constant_of_delta_with_inline resolve con' with diff --git a/checker/dune b/checker/dune index d520171f98..ebb3dd7583 100644 --- a/checker/dune +++ b/checker/dune @@ -19,6 +19,7 @@ (executable (name main) (public_name coqchk) + (package coq) (modules main) (flags :standard -open Checklib) (libraries coq.checklib)) @@ -26,6 +27,7 @@ (executable (name votour) (public_name votour) + (package coq) (modules votour) (flags :standard -open Checklib) (libraries coq.checklib)) diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 1fd86bc368..0478765a81 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -34,7 +34,7 @@ let string_of_mp mp = if !Flags.debug then debug_string_of_mp mp else string_of_mp mp let prkn kn = - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in str(string_of_mp mp ^ "." ^ Label.to_string l) let prcon c = let ck = Constant.canonical c in diff --git a/checker/modops.ml b/checker/modops.ml index b92d7bbf1f..541d009ff9 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -55,7 +55,7 @@ let module_body_of_type mp mtb = let rec add_structure mp sign resolver env = let add_one env (l,elem) = - let kn = KerName.make2 mp l in + let kn = KerName.make mp l in let con = Constant.make1 kn in let mind = mind_of_delta resolver (MutInd.make1 kn) in match elem with diff --git a/checker/values.ml b/checker/values.ml index 35027d5bfb..24f10b7a87 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -98,7 +98,7 @@ let rec v_mp = Sum("module_path",0, [|[|v_dp|]; [|v_uid|]; [|v_mp;v_id|]|]) -let v_kn = v_tuple "kernel_name" [|v_mp;v_dp;v_id;Int|] +let v_kn = v_tuple "kernel_name" [|v_mp;v_id;Int|] let v_cst = v_sum "cst|mind" 0 [|[|v_kn|];[|v_kn;v_kn|]|] let v_ind = v_tuple "inductive" [|v_cst;Int|] let v_cons = v_tuple "constructor" [|v_ind;Int|] diff --git a/clib/cArray.ml b/clib/cArray.ml index d509c55b9a..d3fa4ef65e 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -49,10 +49,6 @@ sig val map_to_list : ('a -> 'b) -> 'a array -> 'b list val map_of_list : ('a -> 'b) -> 'a list -> 'b array val chop : int -> 'a array -> 'a array * 'a array - val smartmap : ('a -> 'a) -> 'a array -> 'a array - [@@ocaml.deprecated "Same as [Smart.map]"] - val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array - [@@ocaml.deprecated "Same as [Smart.fold_left_map]"] val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : @@ -63,14 +59,8 @@ sig val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array + val fold_left2_map_i : (int -> 'a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array - [@@ocaml.deprecated "Same as [fold_left_map]"] - val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c - [@@ocaml.deprecated "Same as [fold_right_map]"] - val fold_map2' : - ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c - [@@ocaml.deprecated "Same as [fold_right2_map]"] val distinct : 'a array -> bool val rev_of_list : 'a list -> 'a array val rev_to_list : 'a array -> 'a list @@ -85,8 +75,6 @@ sig module Fun1 : sig val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array - val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array - [@@ocaml.deprecated "Same as [Fun1.Smart.map]"] val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit val iter2 : ('r -> 'a -> 'b -> unit) -> 'r -> 'a array -> 'b array -> unit module Smart : @@ -428,15 +416,11 @@ else let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in (v',!e') -let fold_map' = fold_right_map - let fold_left_map f e v = let e' = ref e in let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in (!e',v') -let fold_map = fold_left_map - let fold_right2_map f v1 v2 e = let e' = ref e in let v' = @@ -444,13 +428,16 @@ let fold_right2_map f v1 v2 e = in (v',!e') -let fold_map2' = fold_right2_map - let fold_left2_map f e v1 v2 = let e' = ref e in let v' = map2 (fun x1 x2 -> let (e,y) = f !e' x1 x2 in e' := e; y) v1 v2 in (!e',v') +let fold_left2_map_i f e v1 v2 = + let e' = ref e in + let v' = map2_i (fun idx x1 x2 -> let (e,y) = f idx !e' x1 x2 in e' := e; y) v1 v2 in + (!e',v') + let distinct v = let visited = Hashtbl.create 23 in try @@ -611,10 +598,6 @@ struct end -(* Deprecated aliases *) -let smartmap = Smart.map -let smartfoldmap = Smart.fold_left_map - module Fun1 = struct @@ -681,6 +664,4 @@ struct end - let smartmap = Smart.map - end diff --git a/clib/cArray.mli b/clib/cArray.mli index 5c7e09eeac..f5b015b206 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -82,12 +82,6 @@ sig (** [chop i a] returns [(a1, a2)] s.t. [a = a1 + a2] and [length a1 = n]. Raise [Failure "Array.chop"] if [i] is not a valid index. *) - val smartmap : ('a -> 'a) -> 'a array -> 'a array - [@@ocaml.deprecated "Same as [Smart.map]"] - - val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array - [@@ocaml.deprecated "Same as [Smart.fold_left_map]"] - val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array (** See also [Smart.map2] *) @@ -114,19 +108,13 @@ sig val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array (** Same with two arrays, folding on the left; see also [Smart.fold_left2_map] *) + val fold_left2_map_i : + (int -> 'a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array + (** Same than [fold_left2_map] but passing the index of the array *) + val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c (** Same with two arrays, folding on the left *) - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array - [@@ocaml.deprecated "Same as [fold_left_map]"] - - val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c - [@@ocaml.deprecated "Same as [fold_right_map]"] - - val fold_map2' : - ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c - [@@ocaml.deprecated "Same as [fold_right2_map]"] - val distinct : 'a array -> bool (** Return [true] if every element of the array is unique (for default equality). *) @@ -171,9 +159,6 @@ sig val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array (** [Fun1.map f x v = map (f x) v] *) - val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array - [@@ocaml.deprecated "Same as [Fun1.Smart.map]"] - val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit (** [Fun1.iter f x v = iter (f x) v] *) diff --git a/clib/cEphemeron.ml b/clib/cEphemeron.ml index 3136d66e34..d7cc0a4dc2 100644 --- a/clib/cEphemeron.ml +++ b/clib/cEphemeron.ml @@ -8,84 +8,103 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type key_type = int - -type boxed_key = key_type ref ref - -let mk_key : unit -> boxed_key = - (* TODO: take a random value here. Is there a random function in OCaml? *) - let bid = ref 0 in - (* According to OCaml Gc module documentation, Pervasives.ref is one of the - few ways of getting a boxed value the compiler will never alias. *) - fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid) - -(* A phantom type to preserve type safety *) -type 'a key = boxed_key - -(* Comparing keys with == grants that if a key is unmarshalled (in the same - process where it was created or in another one) it is not mistaken for - an already existing one (unmarshal has no right to alias). If the initial - value of bid is taken at random, then one also avoids potential collisions *) -module HT = Hashtbl.Make(struct - type t = key_type ref - let equal k1 k2 = k1 == k2 - let hash id = !id +(* Type-safe implementation by whitequark *) + +(* An extensible variant has an internal representation equivalent + to the following: + + type constr = { + name: string, + id: int + } + type value = (*Object_tag*) constr * v1 * v2... + + and the code generated by the compiler looks like: + + (* type X += Y *) + let constr_Y = alloc { "Y", %caml_fresh_oo_id () } + (* match x with Y -> a | _ -> b *) + if x.0 == constr_Y then a else b + + and the polymorphic comparison function works like: + + let equal = fun (c1, ...) (c2, ...) -> + c1.id == c2.id + + In every new extension constructor, the name field is a constant + string and the id field is filled with an unique[1] value returned + by %caml_fresh_oo_id. Moreover, every value of an extensible variant + type is allocated as a new block. + + [1]: On 64-bit systems. On 32-bit systems, calling %caml_fresh_oo_id + 2**30 times will result in a wraparound. Note that this does + not affect soundness because constructors are compared by + physical equality during matching. See OCaml PR7809 for code + demonstrating this. + + An extensible variant can be marshalled and unmarshalled, and + is guaranteed to not be equal to itself after unmarshalling, + since the id field is filled with another unique value. + + Note that the explanation above is purely informative and we + do not depend on the exact representation of extensible variants, + only on the fact that no two constructor representations ever + alias. In particular, if the definition of constr is replaced with: + + type constr = int + + (where the value is truly unique for every created constructor), + correctness is preserved. + *) +type 'a typ = .. + +(* Erases the contained type so that the key can be put in a hash table. *) +type boxkey = Box : 'a typ -> boxkey [@@unboxed] + +(* Carry the type we just erased with the actual key. *) +type 'a key = 'a typ * boxkey + +module EHashtbl = Ephemeron.K1.Make(struct + type t = boxkey + let equal = (==) + let hash = Hashtbl.hash end) -(* A key is the (unique) value inside a boxed key, hence it does not - keep its corresponding boxed key reachable (replacing key_type by boxed_key - would make the key always reachable) *) -let values : Obj.t HT.t = HT.create 1001 - -(* To avoid a race condition between the finalization function and - get/create on the values hashtable, the finalization function just - enqueues in an imperative list the item to be collected. Being the list - imperative, even if the Gc enqueues an item while run_collection is operating, - the tail of the list is eventually set to Empty on completion. - Kudos to the authors of Why3 that came up with this solution for their - implementation of weak hash tables! *) -type imperative_list = cell ref -and cell = Empty | Item of key_type ref * imperative_list - -let collection_queue : imperative_list ref = ref (ref Empty) - -let enqueue x = collection_queue := ref (Item (!x, !collection_queue)) - -let run_collection () = - let rec aux l = match !l with - | Empty -> () - | Item (k, tl) -> HT.remove values k; aux tl in - let l = !collection_queue in - aux l; - l := Empty - -(* The only reference to the boxed key is the one returned, when the user drops - it the value eventually disappears from the values table above *) -let create (v : 'a) : 'a key = - run_collection (); - let k = mk_key () in - HT.add values !k (Obj.repr v); - Gc.finalise enqueue k; - k +type value = { get : 'k. 'k typ -> 'k } [@@unboxed] + +let values : value EHashtbl.t = + EHashtbl.create 1001 + +let create : type v. v -> v key = + fun value -> + let module M = struct + type _ typ += Typ : v typ + + let get : type k. k typ -> k = + fun typ -> + match typ with + | Typ -> value + | _ -> assert false + + let boxkey = Box Typ + let key = Typ, boxkey + let value = { get } + end in + EHashtbl.add values M.boxkey M.value; + M.key (* Avoid raising Not_found *) exception InvalidKey -let get (k : 'a key) : 'a = - run_collection (); - try Obj.obj (HT.find values !k) +let get (typ, boxkey) = + try (EHashtbl.find values boxkey).get typ with Not_found -> raise InvalidKey -(* Simple utils *) -let default k v = - try get k - with InvalidKey -> v +let default (typ, boxkey) default = + try (EHashtbl.find values boxkey).get typ + with Not_found -> default -let iter_opt k f = - match - try Some (get k) - with InvalidKey -> None - with - | None -> () - | Some v -> f v +let iter_opt (typ, boxkey) f = + try f ((EHashtbl.find values boxkey).get typ) + with Not_found -> () -let clear () = run_collection () +let clean () = EHashtbl.clean values diff --git a/clib/cEphemeron.mli b/clib/cEphemeron.mli index 8e753d0b62..96391e10fa 100644 --- a/clib/cEphemeron.mli +++ b/clib/cEphemeron.mli @@ -33,7 +33,7 @@ An ['a key] can always be marshalled. When marshalled, a key loses its value. The function [get] raises Not_found on unmarshalled keys. - + If a key is garbage collected, the corresponding value is garbage collected too (unless extra references to it exist). In short no memory management hassle, keys can just replace their @@ -48,7 +48,7 @@ exception InvalidKey val get : 'a key -> 'a (* These never fail. *) -val iter_opt : 'a key -> ('a -> unit) -> unit val default : 'a key -> 'a -> 'a +val iter_opt : 'a key -> ('a -> unit) -> unit -val clear : unit -> unit +val clean : unit -> unit diff --git a/clib/cList.ml b/clib/cList.ml index dc59ff2970..aba3e46bd5 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -36,16 +36,12 @@ sig val filteri : (int -> 'a -> bool) -> 'a list -> 'a list val filter_with : bool list -> 'a list -> 'a list - val smartfilter : ('a -> bool) -> 'a list -> 'a list - [@@ocaml.deprecated "Same as [filter]"] val map_filter : ('a -> 'b option) -> 'a list -> 'b list val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list val partitioni : (int -> 'a -> bool) -> 'a list -> 'a list * 'a list val map : ('a -> 'b) -> 'a list -> 'b list val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val smartmap : ('a -> 'a) -> 'a list -> 'a list - [@@ocaml.deprecated "Same as [Smart.map]"] val map_left : ('a -> 'b) -> 'a list -> 'b list val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list val map2_i : @@ -75,10 +71,6 @@ sig val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - [@@ocaml.deprecated "Same as [fold_left_map]"] - val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a - [@@ocaml.deprecated "Same as [fold_right_map]"] val except : 'a eq -> 'a -> 'a list -> 'a list val remove : 'a eq -> 'a -> 'a list -> 'a list val remove_first : ('a -> bool) -> 'a list -> 'a list @@ -116,8 +108,6 @@ sig val unionq : 'a list -> 'a list -> 'a list val subtract : 'a eq -> 'a list -> 'a list -> 'a list val subtractq : 'a list -> 'a list -> 'a list - val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - [@@ocaml.deprecated "Same as [merge_set]"] val distinct : 'a list -> bool val distinct_f : 'a cmp -> 'a list -> bool val duplicates : 'a eq -> 'a list -> 'a list @@ -337,8 +327,6 @@ let filteri p = in filter_i_rec 0 -let smartfilter = filter (* Alias *) - let rec filter_with_loop filter p l = match filter, l with | [], [] -> () | b :: filter, x :: l' -> @@ -618,8 +606,6 @@ let rec fold_left_map f e = function let e'',t' = fold_left_map f e' t in e'',h' :: t' -let fold_map = fold_left_map - (* (* tail-recursive version of the above function *) let fold_left_map f e l = let g (e,b') h = @@ -634,8 +620,6 @@ let fold_left_map f e l = let fold_right_map f l e = List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) -let fold_map' = fold_right_map - let on_snd f (x,y) = (x,f y) let fold_left2_map f e l l' = @@ -905,8 +889,6 @@ let rec merge_set cmp l1 l2 = match l1, l2 with then h1 :: merge_set cmp t1 l2 else h2 :: merge_set cmp l1 t2 -let merge_uniq = merge_set - let intersect cmp l1 l2 = filter (fun x -> mem_f cmp x l2) l1 @@ -1047,8 +1029,6 @@ struct end -let smartmap = Smart.map - module type MonoS = sig type elt val equal : elt list -> elt list -> bool diff --git a/clib/cList.mli b/clib/cList.mli index 39d9a5e535..8582e6cd65 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -91,9 +91,6 @@ sig (** [filter_with bl l] selects elements of [l] whose corresponding element in [bl] is [true]. Raise [Invalid_argument _] if sizes differ. *) - val smartfilter : ('a -> bool) -> 'a list -> 'a list - [@@ocaml.deprecated "Same as [filter]"] - val map_filter : ('a -> 'b option) -> 'a list -> 'b list (** Like [map] but keeping only non-[None] elements *) @@ -111,9 +108,6 @@ sig val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** Like OCaml [List.map2] but tail-recursive *) - val smartmap : ('a -> 'a) -> 'a list -> 'a list - [@@ocaml.deprecated "Same as [Smart.map]"] - val map_left : ('a -> 'b) -> 'a list -> 'b list (** As [map] but ensures the left-to-right order of evaluation. *) @@ -208,12 +202,6 @@ sig val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list (** Same with four lists, folding on the left *) - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - [@@ocaml.deprecated "Same as [fold_left_map]"] - - val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a - [@@ocaml.deprecated "Same as [fold_right_map]"] - (** {6 Splitting} *) val except : 'a eq -> 'a -> 'a list -> 'a list @@ -357,9 +345,6 @@ sig val subtractq : 'a list -> 'a list -> 'a list (** [subtract] specialized to physical equality *) - val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list - [@@ocaml.deprecated "Same as [merge_set]"] - (** {6 Uniqueness and duplication} *) val distinct : 'a list -> bool diff --git a/clib/cMap.ml b/clib/cMap.ml index 54a8b25851..040dede0a2 100644 --- a/clib/cMap.ml +++ b/clib/cMap.ml @@ -34,10 +34,6 @@ sig val bind : (key -> 'a) -> Set.t -> 'a t val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val smartmap : ('a -> 'a) -> 'a t -> 'a t - [@@ocaml.deprecated "Same as [Smart.map]"] - val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t - [@@ocaml.deprecated "Same as [Smart.mapi]"] val height : 'a t -> int module Smart : sig @@ -65,10 +61,6 @@ sig val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b - val smartmap : ('a -> 'a) -> 'a map -> 'a map - [@@ocaml.deprecated "Same as [Smart.map]"] - val smartmapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map - [@@ocaml.deprecated "Same as [Smart.mapi]"] val height : 'a map -> int module Smart : sig @@ -195,9 +187,6 @@ struct end - let smartmap = Smart.map - let smartmapi = Smart.mapi - module Unsafe = struct diff --git a/clib/cMap.mli b/clib/cMap.mli index 127bf23ab6..f5496239f6 100644 --- a/clib/cMap.mli +++ b/clib/cMap.mli @@ -57,12 +57,6 @@ sig val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Folding keys in decreasing order. *) - val smartmap : ('a -> 'a) -> 'a t -> 'a t - [@@ocaml.deprecated "Same as [Smart.map]"] - - val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t - [@@ocaml.deprecated "Same as [Smart.mapi]"] - val height : 'a t -> int (** An indication of the logarithmic size of a map *) diff --git a/clib/cString.ml b/clib/cString.ml index dd33562f16..b178cbbd2c 100644 --- a/clib/cString.ml +++ b/clib/cString.ml @@ -13,9 +13,6 @@ module type S = module type of String module type ExtS = sig include S - [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) - external equal : string -> string -> bool = "caml_string_equal" "noalloc" - [@@@ocaml.warning "+3"] val hash : string -> int val is_empty : string -> bool val explode : string -> string list @@ -37,10 +34,6 @@ end include String -[@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) -external equal : string -> string -> bool = "caml_string_equal" "noalloc" -[@@@ocaml.warning "+3"] - let rec hash len s i accu = if i = len then accu else diff --git a/clib/cString.mli b/clib/cString.mli index 2000dfafb5..df25a3821a 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -16,10 +16,6 @@ sig include S (** We include the standard library *) - [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) - external equal : string -> string -> bool = "caml_string_equal" "noalloc" - [@@@ocaml.warning "+3"] - (** Equality on strings *) val hash : string -> int diff --git a/clib/hMap.ml b/clib/hMap.ml index b2cf474304..33cb6d0131 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -396,9 +396,6 @@ struct end - let smartmap = Smart.map - let smartmapi = Smart.mapi - let height s = Int.Map.height s module Unsafe = diff --git a/clib/hashcons.ml b/clib/hashcons.ml index 39969ebf75..4e5d6212a0 100644 --- a/clib/hashcons.ml +++ b/clib/hashcons.ml @@ -131,9 +131,7 @@ module Hstring = Make( type u = unit let hashcons () s =(* incr accesstr;*) s - [@@@ocaml.warning "-3"] (* [@@noalloc] since 4.03.0 GPR#240 *) - external eq : string -> string -> bool = "caml_string_equal" "noalloc" - [@@@ocaml.warning "+3"] + let eq = String.equal (** Copy from CString *) let rec hash len s i accu = diff --git a/clib/option.ml b/clib/option.ml index 7a3d5f934f..3e57fd5c85 100644 --- a/clib/option.ml +++ b/clib/option.ml @@ -131,8 +131,6 @@ let fold_right_map f x a = | Some y -> let z, a = f y a in Some z, a | _ -> None, a -let fold_map = fold_left_map - (** [cata f a x] is [a] if [x] is [None] and [f y] if [x] is [Some y]. *) let cata f a = function | Some c -> f c @@ -183,8 +181,6 @@ struct end -let smartmap = Smart.map - (** {6 Operations with Lists} *) module List = diff --git a/clib/option.mli b/clib/option.mli index 8f82bf090b..e99c8015c4 100644 --- a/clib/option.mli +++ b/clib/option.mli @@ -75,9 +75,6 @@ val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit (** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) val map : ('a -> 'b) -> 'a option -> 'b option -val smartmap : ('a -> 'a) -> 'a option -> 'a option -[@@ocaml.deprecated "Same as [Smart.map]"] - (** [fold_left f a x] is [f a y] if [x] is [Some y], and [a] otherwise. *) val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b @@ -95,10 +92,6 @@ val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option (** Same as [fold_left_map] on the right *) val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b option -> 'a -> 'c option * 'a -(** @deprecated Same as [fold_left_map] *) -val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option -[@@ocaml.deprecated "Same as [fold_left_map]"] - (** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) val cata : ('a -> 'b) -> 'b -> 'a option -> 'b @@ -6,13 +6,13 @@ bug-reports: "https://github.com/coq/coq/issues" dev-repo: "https://github.com/coq/coq.git" license: "LGPL-2.1" -available: [ ocaml-version >= "4.02.3" ] +available: [ ocaml-version >= "4.05.0" ] depends: [ - "dune" { build } + "dune" { build & >= "1.2.0" } "ocamlfind" { build } "num" - "camlp5" + "camlp5" { >= "7.03" } ] build-env: [ diff --git a/coqpp/dune b/coqpp/dune index 24b9b9184b..a6edf4cf5b 100644 --- a/coqpp/dune +++ b/coqpp/dune @@ -4,5 +4,6 @@ (executable (name coqpp_main) (public_name coqpp) + (package coq) (modules coqpp_ast coqpp_lex coqpp_parse coqpp_main) (modules_without_implementation coqpp_ast)) diff --git a/dev/README.md b/dev/README.md index 4642aaf06d..d9fdd230d3 100644 --- a/dev/README.md +++ b/dev/README.md @@ -34,9 +34,8 @@ | [`dev/doc/release-process.md`](doc/release-process.md) | Process of creating a new Coq release | -## Documentation of ML interfaces using ocamldoc ( `dev/ocamldoc/html`) -`make mli-doc` in coq root directory. - +## Documentation of ML interfaces using `odoc` ( `_build/default/_doc`) +`make -f Makefile.dune apidoc` in coq root directory. ## Other development tools (`dev/tools`) diff --git a/dev/base_include b/dev/base_include index 6f54ecb241..67a7e87d78 100644 --- a/dev/base_include +++ b/dev/base_include @@ -99,7 +99,6 @@ open Evarutil open Evarsolve open Tacred open Evd -open Universes open Termops open Namegen open Indrec diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 5f07aa8fca..b8bea755e0 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1374,7 +1374,7 @@ function copy_coq_license { # FIXME: this is not the micromega license # It only applies to code that was copied into one single file! install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D CHANGES "$PREFIXCOQ/license_readme/coq/Changes.txt" + install -D CHANGES.md "$PREFIXCOQ/license_readme/coq/Changes.md" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi diff --git a/dev/ci/README.md b/dev/ci/README.md index 3a179a9431..7870cbb51d 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -126,7 +126,7 @@ patch (or ask someone to prepare a patch) to fix the project: developer who merges the PR on Coq. There are plans to improve this, cf. [#6724](https://github.com/coq/coq/issues/6724). -Moreover your PR must absolutely update the [`CHANGES`](../../CHANGES) file. +Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) file. Advanced GitLab CI information ------------------------------ @@ -167,10 +167,7 @@ Currently available artifacts are: + Coq's Standard Library Documentation [master branch] https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=doc:refman + Coq's ML API Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/dev/ocamldoc/html/index.html?job=doc:ml-api:ocamldoc - - The dune job also provides its own API documentation using the newer `odoc` tool: - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc ### GitLab and Windows diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 1b1aeafa0d..511eaaba9c 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -49,11 +49,12 @@ ######################################################################## # Iris ######################################################################## -: "${stdpp_CI_REF:=master}" + +# NB: stdpp and Iris refs are gotten from the opam files in the Iris +# and lambdaRust repos respectively. : "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp}" : "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" -: "${Iris_CI_REF:=master}" : "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq}" : "${Iris_CI_ARCHIVEURL:=${Iris_CI_GITURL}/-/archive}" diff --git a/dev/ci/ci-fiat-crypto-legacy.sh b/dev/ci/ci-fiat-crypto-legacy.sh index e0395754e5..6bf3138346 100755 --- a/dev/ci/ci-fiat-crypto-legacy.sh +++ b/dev/ci/ci-fiat-crypto-legacy.sh @@ -10,4 +10,5 @@ fiat_crypto_legacy_CI_TARGETS1="print-old-pipeline-lite old-pipeline-lite lite-d fiat_crypto_legacy_CI_TARGETS2="print-old-pipeline-nobigmem old-pipeline-nobigmem nonautogenerated-specific nonautogenerated-specific-display" ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ + ./etc/ci/remove_autogenerated.sh && \ make ${fiat_crypto_legacy_CI_TARGETS1} && make -j 1 ${fiat_crypto_legacy_CI_TARGETS2} ) diff --git a/dev/ci/ci-iris-lambda-rust.sh b/dev/ci/ci-iris-lambda-rust.sh index 6960a8b98a..95f143bb95 100755 --- a/dev/ci/ci-iris-lambda-rust.sh +++ b/dev/ci/ci-iris-lambda-rust.sh @@ -9,13 +9,13 @@ install_ssreflect git_download lambdaRust # Extract required version of Iris -Iris_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambdaRust/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') +Iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambdaRust/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') # Setup Iris git_download Iris # Extract required version of std++ -stdpp_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/Iris/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') +stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/Iris/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') # Setup std++ git_download stdpp diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index fcfa591ce1..f257c62dd3 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-09-25-V1" +# CACHEKEY: "bionic_coq-V2018-10-04-V2" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -41,7 +41,7 @@ ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.2.1 ounit.2.0.8 odoc.1.2.0" \ CI_OPAM="menhir.20180530 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. -ENV CAMLP5_VER="7.01" \ +ENV CAMLP5_VER="7.03" \ COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" # base switch diff --git a/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh b/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh new file mode 100644 index 0000000000..484ad8f9e6 --- /dev/null +++ b/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh @@ -0,0 +1,11 @@ +if [ "$CI_PULL_REQUEST" = "8554" ] || [ "$CI_BRANCH" = "master+fix8553-change-under-binders" ]; then + + ltac2_CI_BRANCH=master+fix-pr8554-change-takes-env + ltac2_CI_REF=master+fix-pr8554-change-takes-env + ltac2_CI_GITURL=https://github.com/herbelin/ltac2 + + Equations_CI_BRANCH=master+fix-pr8554-change-takes-env + Equations_CI_REF=master+fix-pr8554-change-takes-env + Equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh b/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh new file mode 100644 index 0000000000..41c2ad6fef --- /dev/null +++ b/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "8555" ] || [ "$CI_BRANCH" = "rm-section-path" ]; then + + ltac2_CI_REF=rm-section-path + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + Equations_CI_REF=rm-section-path + Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index c0cd9c8cdd..000f21c254 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -54,7 +54,7 @@ those external projects should have been prepared (cf. the relevant sub-section in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). -Moreover the PR must absolutely update the [`CHANGES`](../../CHANGES) file. +Moreover the PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) file. If overlays are missing, ask the author to prepare them and label the PR with the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. @@ -93,7 +93,7 @@ When the PR has conflicts, the assignee can either: In both cases, CI should be run again. -In some rare cases (e.g. the conflicts are in the CHANGES file), it is ok to fix +In some rare cases (e.g. the conflicts are in the `CHANGES.md` file), it is ok to fix the conflicts in the merge commit (following the same steps as below), and push to `master` directly. Don't use the GitHub interface to fix these conflicts. diff --git a/dev/doc/changes.md b/dev/doc/changes.md index fdeb0abed4..7e64f80ac5 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -2,10 +2,22 @@ ### ML API -Termops: +General deprecation -- Internal printing functions have been placed under the - `Termops.Internal` namespace. +- All functions marked [@@ocaml.deprecated] in 8.8 have been + removed. Please, make sure your plugin is warning-free in 8.8 before + trying to port it over 8.9. + +Names + +- Kernel names no longer contain a section path. They now have only two + components (module path and label), which led to some changes in the API: + + KerName.make takes only 2 components + KerName.repr returns only 2 components + KerName.make2 is now KerName.make + Constant.make3 has been removed, use Constant.make2 + Constant.repr3 has been removed, use Constant.repr2 ## Changes between Coq 8.8 and Coq 8.9 @@ -16,8 +28,8 @@ Names - In `Libnames`, the type `reference` and its two constructors `Qualid` and `Ident` have been removed in favor of `qualid`. `Qualid` is now the identity, `Ident` can be replaced by `qualid_of_ident`. Matching over `reference` can be - replaced by a test using `qualid_is_ident`. Extracting the ident part of a - qualid can be done using `qualid_basename`. + replaced by a test using `qualid_is_ident`. Extracting the `ident` part of a + `qualid` can be done using `qualid_basename`. Misctypes @@ -51,20 +63,20 @@ Proof engine ML Libraries used by Coq -- Introduction of a "Smart" module for collecting "smart*" functions, e.g. - Array.Smart.map. -- Uniformization of some names, e.g. Array.Smart.fold_left_map instead - of Array.smartfoldmap. +- Introduction of a `Smart` module for collecting `smart*` functions, e.g. + `Array.Smart.map`. +- Uniformization of some names, e.g. `Array.Smart.fold_left_map` instead + of `Array.smartfoldmap`. Printer.ml API -- The mechanism in Printer that allowed dynamically overriding pr_subgoals, - pr_subgoal and pr_goal was removed to simplify the code. It was - earlierly used by PCoq. +- The mechanism in `Printer` that allowed dynamically overriding `pr_subgoals`, + `pr_subgoal` and `pr_goal` was removed to simplify the code. It was + earlier used by PCoq. Kernel - The following renamings happened: +- The following renamings happened: - `Context.Rel.t` into `Constr.rel_context` - `Context.Named.t` into `Constr.named_context` - `Context.Compacted.t` into `Constr.compacted_context` @@ -93,19 +105,24 @@ Vernacular commands Primitive number parsers -- For better modularity, the primitive parsers for positive, N and Z - have been split over three files (plugins/syntax/positive_syntax.ml, - plugins/syntax/n_syntax.ml, plugins/syntax/z_syntax.ml). +- For better modularity, the primitive parsers for `positive`, `N` and `Z` + have been split over three files (`plugins/syntax/positive_syntax.ml`, + `plugins/syntax/n_syntax.ml`, `plugins/syntax/z_syntax.ml`). Parsing -- Manual uses of the Pcoq.Gram module have been deprecated. Wrapper modules - Pcoq.Entry and Pcoq.Parsable were introduced to replace it. +- Manual uses of the `Pcoq.Gram` module have been deprecated. Wrapper modules + `Pcoq.Entry` and `Pcoq.Parsable` were introduced to replace it. + +Termops + +- Internal printing functions have been placed under the + `Termops.Internal` namespace. ### Unit testing - The test suite now allows writing unit tests against OCaml code in the Coq - code base. Those unit tests create a dependency on the OUnit test framework. +The test suite now allows writing unit tests against OCaml code in the Coq +code base. Those unit tests create a dependency on the OUnit test framework. ### Transitioning away from Camlp5 @@ -140,7 +157,7 @@ let myval = 0 Steps to perform: - replace the brackets enclosing OCaml code in actions with braces -- if not there yet, add a leading `|̀ to the first rule +- if not there yet, add a leading `|` to the first rule For instance, code of the form: ``` @@ -171,8 +188,8 @@ Most plugin writers do not need this low-level interface, but for the sake of completeness we document it. Steps to perform are: -- replace GEXTEND with GRAMMAR EXTEND -- wrap every occurrence of OCaml code in actions into braces { } +- replace `GEXTEND` with `GRAMMAR EXTEND` +- wrap every occurrence of OCaml code in actions into braces `{ }` For instance, code of the form ``` @@ -222,7 +239,7 @@ All the other bugs kept their number. General deprecation -- All functions marked [@@ocaml.deprecated] in 8.7 have been +- All functions marked `[@@ocaml.deprecated]` in 8.7 have been removed. Please, make sure your plugin is warning-free in 8.7 before trying to port it over 8.8. @@ -250,8 +267,8 @@ We changed the type of the following functions: - `Global.body_of_constant`: same as above. -- `Constrinterp.*` generally, many functions that used to take an - `evar_map ref` have been now switched to functions that will work in +- `Constrinterp.*`: generally, many functions that used to take an + `evar_map ref` have now been switched to functions that will work in a functional way. The old style of passing `evar_map`s as references is not supported anymore. @@ -269,16 +286,16 @@ We have changed the representation of the following types: 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 +- `injectable`, `dEq`, etc. take 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 Declaration of printers for arguments used only in vernac command -- It should now use "declare_extra_vernac_genarg_pprule" rather than - "declare_extra_genarg_pprule", otherwise, a failure at runtime might +- It should now use `declare_extra_vernac_genarg_pprule` rather than + `declare_extra_genarg_pprule`, otherwise, a failure at runtime might happen. An alternative is to register the corresponding argument as - a value, using "Geninterp.register_val0 wit None". + a value, using `Geninterp.register_val0 wit None`. Types Alias deprecation and type relocation. @@ -321,7 +338,7 @@ functions when some given constants are traversed: * `declare_reduction_effect`: to declare a hook to be applied when some constant are visited during the execution of some reduction functions - (primarily cbv). + (primarily `cbv`). * `set_reduction_effect`: to declare a constant on which a given effect hook should be called. diff --git a/dev/ocamldoc/docintro b/dev/ocamldoc/docintro deleted file mode 100644 index 33d20fc818..0000000000 --- a/dev/ocamldoc/docintro +++ /dev/null @@ -1,49 +0,0 @@ -{!indexlist} - -This is Coq, a proof assistant for the Calculus of Inductive Constructions. -This document describes the implementation of Coq. -It has been automatically generated from the source of -Coq using {{:http://caml.inria.fr/}ocamldoc}. -The source files are organized in several directories ordered like that: - -{ol {- Utility libraries : lib - -describes the various utility libraries used in the code -of Coq.} -{- Kernel : kernel - -describes the Coq kernel, which is a type checker for the Calculus -of Inductive Constructions.} -{- Library : library - -describes the Coq library, which is made of two parts: -- a general mechanism to keep a trace of all operations and of - the state of the system, with backtrack capabilities; -- a global environment for the CCI, with functions to export and - import compiled modules. - -} -{- Pretyping : pretyping - -} -{- Front abstract syntax of terms : interp - -describes the translation from Coq context-dependent -front abstract syntax of terms {v constr_expr v} to and from the -context-free, untyped, globalized form of constructions {v glob_constr v}.} -{- Parsers and printers : parsing - -describes the implementation of the Coq parsers and printers.} -{- Proof engine : proofs - -describes the Coq proof engine, which is also called -the ``refiner'', since it provides a way to build terms by successive -refining steps. Those steps are either primitive rules or higher-level -tactics.} -{- Tacticts : tactics - -describes the Coq main tactics.} -{- Toplevel : toplevel - -describes the highest modules of the Coq system.} -} diff --git a/dev/ocamldoc/fix-ocamldoc-utf8 b/dev/ocamldoc/fix-ocamldoc-utf8 deleted file mode 100755 index fe2e0c1155..0000000000 --- a/dev/ocamldoc/fix-ocamldoc-utf8 +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -# This reverts automatic translation of latin1 accentuated letters by ocamldoc -# Usage: fix-ocamldoc-utf8 file - -sed -i -e 's/\\`a/\d224/g' -e "s/\\\^a/\d226/g" -e "s/\\\'e/\d233/g" -e 's/\\`e/\d232/g' -e "s/\\\^e/\d234/g" -e 's/\\\"e/\d235/g' -e "s/\\\^o/\d244/g" -e 's/\\\"o/\d246/g' -e "s/\\\^i/\d238/g" -e 's/\\\"i/\d239/g' -e 's/\\`u/\d249/g' -e "s/\\\^u/\d251/g" -e "s/\\\c{c}/\d231/g" $1 diff --git a/dev/ocamldoc/header.tex b/dev/ocamldoc/header.tex deleted file mode 100644 index 4091f8144f..0000000000 --- a/dev/ocamldoc/header.tex +++ /dev/null @@ -1,14 +0,0 @@ -\documentclass[11pt]{article} -\usepackage[utf8x]{inputenc} -\usepackage[T1]{fontenc} -\usepackage{textcomp} -\usepackage{tipa} -\usepackage{textgreek} -\usepackage{fullpage} -\usepackage{url} -\usepackage{ocamldoc} -\title{Coq mlis documentation} -\begin{document} -\maketitle -\tableofcontents -\vspace{0.2cm} diff --git a/dev/ocamldoc/html/style.css b/dev/ocamldoc/html/style.css deleted file mode 100644 index c2c45b6297..0000000000 --- a/dev/ocamldoc/html/style.css +++ /dev/null @@ -1,220 +0,0 @@ -a:visited {
- color: #416DFF; text-decoration: none;
-}
-
-a:link {
- color: #416DFF; text-decoration: none;
-}
-
-a:hover {
- color: Red; text-decoration: none; background-color: #5FFF88
-}
-
-a:active {
- color: Red; text-decoration: underline;
-}
-
-.keyword {
- font-weight: bold; color: Red
-}
-
-.keywordsign {
- color: #C04600
-}
-
-.superscript {
- font-size: 8
-}
-
-.subscript {
- font-size: 8
-}
-
-.comment {
- color: Green
-}
-
-.constructor {
- color: Blue
-}
-
-.type {
- color: #5C6585
-}
-
-.string {
- color: Maroon
-}
-
-.warning {
- color: Red; font-weight: bold
-}
-
-.info {
- margin-left: 3em; margin-right: 3em
-}
-
-.param_info {
- margin-top: 4px; margin-left: 3em; margin-right: 3em
-}
-
-.code {
- color: #465F91;
-}
-
-h1 {
- font-size: 20pt; text-align: center;
-}
-
-h5, h6, div.h7, div.h8, div.h9 {
- font-size: 20pt;
- border: 1px solid #000000;
- margin-top: 5px;
- margin-bottom: 2px;
- text-align: center;
- padding: 2px;
-}
-
-h5 {
- background-color: #90FDFF;
-}
-
-h6 {
- background-color: #016699;
- color: white;
-}
-
-div.h7 {
- background-color: #E0FFFF;
-}
-
-div.h8 {
- background-color: #F0FFFF;
-}
-
-div.h9 {
- background-color: #FFFFFF;
-}
-
-.typetable, .indextable, .paramstable {
- border-style: hidden;
-}
-
-.paramstable {
- padding: 5pt 5pt;
-}
-
-body {
- background-color: white;
-}
-
-tr {
- background-color: white;
-}
-
-td.typefieldcomment {
- background-color: #FFFFFF;
- font-size: smaller;
-}
-
-pre {
- margin-bottom: 4px;
-}
-
-div.sig_block {
- margin-left: 2em;
-}
-
-
-h2 {
- font-family: Arial, Helvetica, sans-serif;
- font-size: 16pt;
- font-weight: normal;
- border-bottom: 1px solid #dadada;
- border-top: 1px solid #dadada;
- color: #101010;
- background: #eeeeff;
- margin: 25px 0px 10px 0px;
- padding: 1px 1px 1px 1px;
-}
-
-h3 {
- font-family: Arial, Helvetica, sans-serif;
- font-size: 12pt;
- color: #016699;
- font-weight: bold;
- padding: 15px 0 0 0ex;
- margin: 5px 0 0 0;
-}
-
-h4 {
- font-family: Arial, Helvetica, sans-serif;
- font-size: 10pt;
- color: #016699;
- padding: 15px 0 0 0ex;
- margin: 5px 0 0 0;
-}
-
-/* Here starts the overwrite of default rules to give a better look */
-
-body {
- font-family: Calibri, Georgia, Garamond, Baskerville, serif;
- font-size: 12pt;
- background-color: white;
-}
-
-a:link, a {
- color: #6895c3 !important;
-}
-
-a:hover {
- color: #2F4459 !important;
- background-color: white;
-}
-
-hr {
- height: 1px;
- color: #016699;
- background-color: #016699;
- border-width: 0;
-}
-
-h1, h1 a:link, h1 a:visited, h1 a {
- font-family: Cambria, Georgia, Garamond, Baskerville, serif;
- color: #016699;
-}
-
-.navbar {
- float: left;
-}
-
-.navbar a, .navbar a:link, .navbar a:visited {
- color: #016699;
- font-family: Arial, Helvetica, sans-serif;
- font-weight: bold;
- font-size: 80%;
-}
-
-.keyword {
- color: #c13939;
-}
-
-.constructor {
- color: #3c8f7e;
-}
-
-pre, code {
- font-family: "DejaVu Sans Mono", "Bitstream Vera Mono", "Courrier New", monospace;
- white-space: normal;
- font-size: 9pt;
- font-weight: bold;
-}
-
-.type br {
- display: none;
-}
-
-.info {
- margin-left: 1em;
- font-size: 12pt;
-}
diff --git a/dev/top_printers.ml b/dev/top_printers.ml index e15fd776b2..8129a4a867 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -552,23 +552,22 @@ open Libnames let encode_path ?loc prefix mpdir suffix id = let dir = match mpdir with | None -> [] - | Some (mp,dir) -> - (DirPath.repr (dirpath_of_string (ModPath.to_string mp))@ - DirPath.repr dir) in + | Some mp -> DirPath.repr (dirpath_of_string (ModPath.to_string mp)) + in make_qualid ?loc (DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id let raw_string_of_ref ?loc _ = function | ConstRef cst -> - let (mp,dir,id) = Constant.repr3 cst in - encode_path ?loc "CST" (Some (mp,dir)) [] (Label.to_id id) + let (mp,id) = Constant.repr2 cst in + encode_path ?loc "CST" (Some mp) [] (Label.to_id id) | IndRef (kn,i) -> - let (mp,dir,id) = MutInd.repr3 kn in - encode_path ?loc "IND" (Some (mp,dir)) [Label.to_id id] + let (mp,id) = MutInd.repr2 kn in + encode_path ?loc "IND" (Some mp) [Label.to_id id] (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> - let (mp,dir,id) = MutInd.repr3 kn in - encode_path ?loc "CSTR" (Some (mp,dir)) + let (mp,id) = MutInd.repr2 kn in + encode_path ?loc "CSTR" (Some mp) [Label.to_id id;Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) | VarRef id -> @@ -576,14 +575,14 @@ let raw_string_of_ref ?loc _ = function let short_string_of_ref ?loc _ = function | VarRef id -> qualid_of_ident ?loc id - | ConstRef cst -> qualid_of_ident ?loc (Label.to_id (pi3 (Constant.repr3 cst))) - | IndRef (kn,0) -> qualid_of_ident ?loc (Label.to_id (pi3 (MutInd.repr3 kn))) + | ConstRef cst -> qualid_of_ident ?loc (Label.to_id (Constant.label cst)) + | IndRef (kn,0) -> qualid_of_ident ?loc (Label.to_id (MutInd.label kn)) | IndRef (kn,i) -> - encode_path ?loc "IND" None [Label.to_id (pi3 (MutInd.repr3 kn))] + encode_path ?loc "IND" None [Label.to_id (MutInd.label kn)] (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> encode_path ?loc "CSTR" None - [Label.to_id (pi3 (MutInd.repr3 kn));Id.of_string ("_"^string_of_int i)] + [Label.to_id (MutInd.label kn);Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) (* Anticipate that printers can be used from ocamldebug and that diff --git a/doc/sphinx/credits-contents.rst b/doc/sphinx/credits-contents.rst index 212f0a65b0..d1df0657aa 100644 --- a/doc/sphinx/credits-contents.rst +++ b/doc/sphinx/credits-contents.rst @@ -1238,7 +1238,7 @@ of integers and real constants are now represented using `IZR` (work by Guillaume Melquiond). Standard library additions and improvements by Jason Gross, Pierre Letouzey and -others, documented in the `CHANGES` file. +others, documented in the ``CHANGES.md`` file. The mathematical proof language/declarative mode plugin was removed from the archive. @@ -1352,7 +1352,7 @@ version. Version 8.8 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. -Most important ones are documented in the ``CHANGES`` file. +Most important ones are documented in the ``CHANGES.md`` file. The efficiency of the whole system has seen improvements thanks to contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and diff --git a/engine/evarutil.ml b/engine/evarutil.ml index b1d880b0ad..fc2189f870 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -11,7 +11,6 @@ open CErrors open Util open Names -open Term open Constr open Environ open Evd @@ -43,9 +42,6 @@ let evd_comb2 f evdref x y = evdref := evd'; z -let e_new_global evdref x = - evd_comb1 (Evd.fresh_global (Global.env())) evdref x - let new_global evd x = let (evd, c) = Evd.fresh_global (Global.env()) evd x in (evd, c) @@ -87,23 +83,6 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} = let nf_evars_universes evm = UnivSubst.nf_evars_and_universes_opt_subst (safe_evar_value evm) (Evd.universe_subst evm) - -let nf_evars_and_universes evm = - let evm = Evd.minimize_universes evm in - evm, nf_evars_universes evm - -let e_nf_evars_and_universes evdref = - evdref := Evd.minimize_universes !evdref; - nf_evars_universes !evdref, Evd.universe_subst !evdref - -let nf_evar_map_universes evm = - let evm = Evd.minimize_universes evm in - let subst = Evd.universe_subst evm in - if Univ.LMap.is_empty subst then evm, nf_evar0 evm - else - let f = nf_evars_universes evm in - let f' c = EConstr.of_constr (f (EConstr.Unsafe.to_constr c)) in - Evd.raw_map (fun _ -> map_evar_info f') evm, f let nf_named_context_evar sigma ctx = Context.Named.map (nf_evar0 sigma) ctx @@ -490,26 +469,11 @@ let new_type_evar ?src ?filter ?naming ?principal ?hypnaming env evd rigid = let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal ?hypnaming (EConstr.mkSort s) in evd', (e, s) -let e_new_type_evar env evdref ?src ?filter ?naming ?principal ?hypnaming rigid = - let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal ?hypnaming rigid in - evdref := evd; - c - let new_Type ?(rigid=Evd.univ_flexible) evd = let open EConstr in let (evd, s) = new_sort_variable rigid evd in (evd, mkSort s) -let e_new_Type ?(rigid=Evd.univ_flexible) evdref = - let evd', s = new_sort_variable rigid !evdref in - evdref := evd'; EConstr.mkSort s - - (* The same using side-effect *) -let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ?hypnaming ty = - let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ?hypnaming ty in - evdref := evd'; - ev - (* Safe interface to unification problems *) type unification_pb = conv_pb * env * EConstr.constr * EConstr.constr @@ -853,7 +817,7 @@ let occur_evar_upto sigma n c = let judge_of_new_Type evd = let open EConstr in let (evd', s) = new_univ_variable univ_rigid evd in - (evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }) + (evd', { uj_val = mkSort (Sorts.Type s); uj_type = mkSort (Sorts.Type (Univ.super s)) }) let subterm_source evk ?where (loc,k) = let evk = match k with diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 0ad323ac4b..11e07175e3 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -173,14 +173,6 @@ val nf_evar_map_undefined : evar_map -> evar_map val nf_evars_universes : evar_map -> Constr.constr -> Constr.constr -val nf_evars_and_universes : evar_map -> evar_map * (Constr.constr -> Constr.constr) -[@@ocaml.deprecated "Use Evd.minimize_universes and nf_evars_universes"] - -(** Normalize the evar map w.r.t. universes, after simplification of constraints. - Return the substitution function for constrs as well. *) -val nf_evar_map_universes : evar_map -> evar_map * (Constr.constr -> Constr.constr) -[@@ocaml.deprecated "Use Evd.minimize_universes and nf_evar_map and nf_evars_universes"] - (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of Evar.t val flush_and_check_evars : evar_map -> constr -> Constr.constr @@ -266,32 +258,13 @@ val generalize_evar_over_rels : evar_map -> existential -> types * constr list (** Evar combinators *) val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a +[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a +[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a +[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] val subterm_source : Evar.t -> ?where:Evar_kinds.subevar_kind -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located val meta_counter_summary_tag : int Summary.Dyn.tag - -val e_new_evar : - env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> ?store:Store.t -> - ?naming:intro_pattern_naming_expr -> - ?principal:bool -> ?hypnaming:naming_mode -> types -> constr -[@@ocaml.deprecated "Use [Evarutil.new_evar]"] - -val e_new_type_evar : env -> evar_map ref -> - ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?naming:intro_pattern_naming_expr -> - ?principal:bool -> ?hypnaming:naming_mode -> rigid -> constr * Sorts.t -[@@ocaml.deprecated "Use [Evarutil.new_type_evar]"] - -val e_new_Type : ?rigid:rigid -> evar_map ref -> constr -[@@ocaml.deprecated "Use [Evarutil.new_Type]"] - -val e_new_global : evar_map ref -> GlobRef.t -> constr -[@@ocaml.deprecated "Use [Evarutil.new_global]"] - -val e_nf_evars_and_universes : evar_map ref -> (Constr.constr -> Constr.constr) * UnivSubst.universe_opt_subst -[@@ocaml.deprecated "Use Evd.minimize_universes and nf_evars_universes"] diff --git a/engine/namegen.ml b/engine/namegen.ml index 2a59b914db..7ce759a3fb 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -76,9 +76,9 @@ let is_imported_ref = function | VarRef _ -> false | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - let (mp,_,_) = MutInd.repr3 kn in is_imported_modpath mp + let mp = MutInd.modpath kn in is_imported_modpath mp | ConstRef kn -> - let (mp,_,_) = Constant.repr3 kn in is_imported_modpath mp + let mp = Constant.modpath kn in is_imported_modpath mp let is_global id = try diff --git a/engine/termops.mli b/engine/termops.mli index aa0f837938..64e3977d68 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -335,16 +335,4 @@ val pr_rel_decl : env -> Constr.rel_declaration -> Pp.t val print_rel_context : env -> Pp.t val print_env : env -> Pp.t -val print_constr : constr -> Pp.t -[@@deprecated "use print_constr_env"] - end - -val print_constr : constr -> Pp.t -[@@deprecated "use Internal.print_constr_env"] - -val print_constr_env : env -> Evd.evar_map -> constr -> Pp.t -[@@deprecated "use Internal.print_constr_env"] - -val print_rel_context : env -> Pp.t -[@@deprecated "use Internal.print_rel_context"] diff --git a/engine/univNames.ml b/engine/univNames.ml index 70cdd3a2db..e89dcedb9c 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -69,7 +69,7 @@ let discharge_ubinder (_,(ref,l)) = with Not_found -> name_universe lvl in let l = List.map map sec_inst @ l in - Some (Lib.discharge_global ref, l) + Some (ref, l) let ubinder_obj : GlobRef.t * Id.t list -> Libobject.obj = let open Libobject in diff --git a/engine/universes.ml b/engine/universes.ml deleted file mode 100644 index 5d0157b2db..0000000000 --- a/engine/universes.ml +++ /dev/null @@ -1,92 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Univ - -(** Deprecated *) - -(** UnivNames *) -type universe_binders = UnivNames.universe_binders -type univ_name_list = UnivNames.univ_name_list - -let pr_with_global_universes = UnivNames.pr_with_global_universes -let reference_of_level = UnivNames.qualid_of_level - -let empty_binders = UnivNames.empty_binders - -let register_universe_binders = UnivNames.register_universe_binders - -let universe_binders_with_opt_names = UnivNames.universe_binders_with_opt_names - -(** UnivGen *) -type universe_id = UnivGen.universe_id - -let set_remote_new_univ_id = UnivGen.set_remote_new_univ_id -let new_univ_id = UnivGen.new_univ_id -let new_univ_level = UnivGen.new_univ_level -let new_univ = UnivGen.new_univ -let new_Type = UnivGen.new_Type -let new_Type_sort = UnivGen.new_Type_sort -let new_global_univ = UnivGen.new_global_univ -let new_sort_in_family = UnivGen.new_sort_in_family -let fresh_instance_from_context = UnivGen.fresh_instance_from_context -let fresh_instance_from = UnivGen.fresh_instance_from -let fresh_sort_in_family = UnivGen.fresh_sort_in_family -let fresh_constant_instance = UnivGen.fresh_constant_instance -let fresh_inductive_instance = UnivGen.fresh_inductive_instance -let fresh_constructor_instance = UnivGen.fresh_constructor_instance -let fresh_global_instance = UnivGen.fresh_global_instance -let fresh_global_or_constr_instance = UnivGen.fresh_global_or_constr_instance -let fresh_universe_context_set_instance = UnivGen.fresh_universe_context_set_instance -let global_of_constr = UnivGen.global_of_constr -let constr_of_global_univ = UnivGen.constr_of_global_univ -let extend_context = UnivGen.extend_context -let constr_of_global = UnivGen.constr_of_global -let constr_of_reference = UnivGen.constr_of_global -let type_of_global = UnivGen.type_of_global - -(** UnivSubst *) - -let level_subst_of = UnivSubst.level_subst_of -let subst_univs_constraints = UnivSubst.subst_univs_constraints -let subst_univs_constr = UnivSubst.subst_univs_constr -type universe_opt_subst = UnivSubst.universe_opt_subst -let make_opt_subst = UnivSubst.make_opt_subst -let subst_opt_univs_constr = UnivSubst.subst_opt_univs_constr -let normalize_univ_variables = UnivSubst.normalize_univ_variables -let normalize_univ_variable = UnivSubst.normalize_univ_variable -let normalize_univ_variable_opt_subst = UnivSubst.normalize_univ_variable_opt_subst -let normalize_univ_variable_subst = UnivSubst.normalize_univ_variable_subst -let normalize_universe_opt_subst = UnivSubst.normalize_universe_opt_subst -let normalize_universe_subst = UnivSubst.normalize_universe_subst -let nf_evars_and_universes_opt_subst = UnivSubst.nf_evars_and_universes_opt_subst -let pr_universe_opt_subst = UnivSubst.pr_universe_opt_subst - -(** UnivProblem *) - -type universe_constraint = UnivProblem.t = - | ULe of Universe.t * Universe.t - | UEq of Universe.t * Universe.t - | ULub of Level.t * Level.t - | UWeak of Level.t * Level.t - -module Constraints = UnivProblem.Set -type 'a constraint_accumulator = 'a UnivProblem.accumulator -type 'a universe_constrained = 'a UnivProblem.constrained -type 'a universe_constraint_function = 'a UnivProblem.constraint_function -let subst_univs_universe_constraints = UnivProblem.Set.subst_univs -let enforce_eq_instances_univs = UnivProblem.enforce_eq_instances_univs -let to_constraints = UnivProblem.to_constraints -let eq_constr_univs_infer_with = UnivProblem.eq_constr_univs_infer_with - -(** UnivMinim *) -module UPairSet = UnivMinim.UPairSet - -let normalize_context_set = UnivMinim.normalize_context_set diff --git a/engine/universes.mli b/engine/universes.mli deleted file mode 100644 index 0d3bae4c95..0000000000 --- a/engine/universes.mli +++ /dev/null @@ -1,230 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Constr -open Environ -open Univ - -(** ************************************** *) -(** This entire module is deprecated. **** *) -(** ************************************** *) -[@@@ocaml.warning "-3"] - -(** ****** Deprecated: moved to [UnivNames] *) - -val pr_with_global_universes : Level.t -> Pp.t -[@@ocaml.deprecated "Use [UnivNames.pr_with_global_universes]"] -val reference_of_level : Level.t -> Libnames.qualid -[@@ocaml.deprecated "Use [UnivNames.qualid_of_level]"] - -type universe_binders = UnivNames.universe_binders -[@@ocaml.deprecated "Use [UnivNames.universe_binders]"] - -val empty_binders : universe_binders -[@@ocaml.deprecated "Use [UnivNames.empty_binders]"] - -val register_universe_binders : Globnames.global_reference -> universe_binders -> unit -[@@ocaml.deprecated "Use [UnivNames.register_universe_binders]"] - -type univ_name_list = UnivNames.univ_name_list -[@@ocaml.deprecated "Use [UnivNames.univ_name_list]"] - -val universe_binders_with_opt_names : Globnames.global_reference -> - univ_name_list option -> universe_binders -[@@ocaml.deprecated "Use [UnivNames.universe_binders_with_opt_names]"] - -(** ****** Deprecated: moved to [UnivGen] *) - -type universe_id = UnivGen.universe_id -[@@ocaml.deprecated "Use [UnivGen.universe_id]"] - -val set_remote_new_univ_id : universe_id RemoteCounter.installer -[@@ocaml.deprecated "Use [UnivGen.set_remote_new_univ_id]"] - -val new_univ_id : unit -> universe_id -[@@ocaml.deprecated "Use [UnivGen.new_univ_id]"] - -val new_univ_level : unit -> Level.t -[@@ocaml.deprecated "Use [UnivGen.new_univ_level]"] - -val new_univ : unit -> Universe.t -[@@ocaml.deprecated "Use [UnivGen.new_univ]"] - -val new_Type : unit -> types -[@@ocaml.deprecated "Use [UnivGen.new_Type]"] - -val new_Type_sort : unit -> Sorts.t -[@@ocaml.deprecated "Use [UnivGen.new_Type_sort]"] - -val new_global_univ : unit -> Universe.t in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.new_global_univ]"] - -val new_sort_in_family : Sorts.family -> Sorts.t -[@@ocaml.deprecated "Use [UnivGen.new_sort_in_family]"] - -val fresh_instance_from_context : AUContext.t -> - Instance.t constrained -[@@ocaml.deprecated "Use [UnivGen.fresh_instance_from_context]"] - -val fresh_instance_from : AUContext.t -> Instance.t option -> - Instance.t in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_instance_from]"] - -val fresh_sort_in_family : Sorts.family -> - Sorts.t in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_sort_in_family]"] - -val fresh_constant_instance : env -> Constant.t -> - pconstant in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_constant_instance]"] - -val fresh_inductive_instance : env -> inductive -> - pinductive in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_inductive_instance]"] - -val fresh_constructor_instance : env -> constructor -> - pconstructor in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_constructor_instance]"] - -val fresh_global_instance : ?names:Univ.Instance.t -> env -> Globnames.global_reference -> - constr in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_global_instance]"] - -val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> - constr in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.fresh_global_or_constr_instance]"] - -val fresh_universe_context_set_instance : ContextSet.t -> - universe_level_subst * ContextSet.t -[@@ocaml.deprecated "Use [UnivGen.fresh_universe_context_set_instance]"] - -val global_of_constr : constr -> Globnames.global_reference puniverses -[@@ocaml.deprecated "Use [UnivGen.global_of_constr]"] - -val constr_of_global_univ : Globnames.global_reference puniverses -> constr -[@@ocaml.deprecated "Use [UnivGen.constr_of_global_univ]"] - -val extend_context : 'a in_universe_context_set -> ContextSet.t -> - 'a in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.extend_context]"] - -val constr_of_global : Globnames.global_reference -> constr -[@@ocaml.deprecated "Use [UnivGen.constr_of_global]"] - -val constr_of_reference : Globnames.global_reference -> constr -[@@ocaml.deprecated "Use [UnivGen.constr_of_global]"] - -val type_of_global : Globnames.global_reference -> types in_universe_context_set -[@@ocaml.deprecated "Use [UnivGen.type_of_global]"] - -(** ****** Deprecated: moved to [UnivSubst] *) - -val level_subst_of : universe_subst_fn -> universe_level_subst_fn -[@@ocaml.deprecated "Use [UnivSubst.level_subst_of]"] - -val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t -[@@ocaml.deprecated "Use [UnivSubst.subst_univs_constraints]"] - -val subst_univs_constr : universe_subst -> constr -> constr -[@@ocaml.deprecated "Use [UnivSubst.subst_univs_constr]"] - -type universe_opt_subst = UnivSubst.universe_opt_subst -[@@ocaml.deprecated "Use [UnivSubst.universe_opt_subst]"] - -val make_opt_subst : universe_opt_subst -> universe_subst_fn -[@@ocaml.deprecated "Use [UnivSubst.make_opt_subst]"] - -val subst_opt_univs_constr : universe_opt_subst -> constr -> constr -[@@ocaml.deprecated "Use [UnivSubst.subst_opt_univs_constr]"] - -val normalize_univ_variables : universe_opt_subst -> - universe_opt_subst * LSet.t * universe_subst -[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variables]"] - -val normalize_univ_variable : - find:(Level.t -> Universe.t) -> - Level.t -> Universe.t -[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variable]"] - -val normalize_univ_variable_opt_subst : universe_opt_subst -> - (Level.t -> Universe.t) -[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variable_opt_subst]"] - -val normalize_univ_variable_subst : universe_subst -> - (Level.t -> Universe.t) -[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variable_subst]"] - -val normalize_universe_opt_subst : universe_opt_subst -> - (Universe.t -> Universe.t) -[@@ocaml.deprecated "Use [UnivSubst.normalize_universe_opt_subst]"] - -val normalize_universe_subst : universe_subst -> - (Universe.t -> Universe.t) -[@@ocaml.deprecated "Use [UnivSubst.normalize_universe_subst]"] - -val nf_evars_and_universes_opt_subst : (existential -> constr option) -> - universe_opt_subst -> constr -> constr -[@@ocaml.deprecated "Use [UnivSubst.nf_evars_and_universes_opt_subst]"] - -val pr_universe_opt_subst : universe_opt_subst -> Pp.t -[@@ocaml.deprecated "Use [UnivSubst.pr_universe_opt_subst]"] - -(** ****** Deprecated: moved to [UnivProblem] *) - -type universe_constraint = UnivProblem.t = - | ULe of Universe.t * Universe.t [@ocaml.deprecated "Use [UnivProblem.ULe]"] - | UEq of Universe.t * Universe.t [@ocaml.deprecated "Use [UnivProblem.UEq]"] - | ULub of Level.t * Level.t [@ocaml.deprecated "Use [UnivProblem.ULub]"] - | UWeak of Level.t * Level.t [@ocaml.deprecated "Use [UnivProblem.UWeak]"] -[@@ocaml.deprecated "Use [UnivProblem.t]"] - -module Constraints = UnivProblem.Set -[@@ocaml.deprecated "Use [UnivProblem.Set]"] - -type 'a constraint_accumulator = 'a UnivProblem.accumulator -[@@ocaml.deprecated "Use [UnivProblem.accumulator]"] -type 'a universe_constrained = 'a UnivProblem.constrained -[@@ocaml.deprecated "Use [UnivProblem.constrained]"] -type 'a universe_constraint_function = 'a UnivProblem.constraint_function -[@@ocaml.deprecated "Use [UnivProblem.constraint_function]"] - -val subst_univs_universe_constraints : universe_subst_fn -> - Constraints.t -> Constraints.t -[@@ocaml.deprecated "Use [UnivProblem.Set.subst_univs]"] - -val enforce_eq_instances_univs : bool -> Instance.t universe_constraint_function -[@@ocaml.deprecated "Use [UnivProblem.enforce_eq_instances_univs]"] - -(** With [force_weak] UWeak constraints are turned into equalities, - otherwise they're forgotten. *) -val to_constraints : force_weak:bool -> UGraph.t -> Constraints.t -> Constraint.t -[@@ocaml.deprecated "Use [UnivProblem.to_constraints]"] - -(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of - {!eq_constr_univs_infer} taking kind-of-term functions, to expose - subterms of [m] and [n], arguments. *) -val eq_constr_univs_infer_with : - (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> - (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> - UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option -[@@ocaml.deprecated "Use [UnivProblem.eq_constr_univs_infer_with]"] - -(** ****** Deprecated: moved to [UnivMinim] *) - -module UPairSet = UnivMinim.UPairSet -[@@ocaml.deprecated "Use [UnivMinim.UPairSet]"] - -val normalize_context_set : UGraph.t -> ContextSet.t -> - universe_opt_subst (* The defined and undefined variables *) -> - LSet.t (* univ variables that can be substituted by algebraics *) -> - UPairSet.t (* weak equality constraints *) -> - (universe_opt_subst * LSet.t) in_universe_context_set -[@@ocaml.deprecated "Use [UnivMinim.normalize_context_set]"] diff --git a/grammar/dune b/grammar/dune index 90847e7fb6..f03fe07607 100644 --- a/grammar/dune +++ b/grammar/dune @@ -18,6 +18,7 @@ (install (section bin) + (package coq) (files coqp5 coqmlp5)) (rule diff --git a/ide/coqide.opam b/ide/coqide.opam index ba05b9edcf..897177b283 100644 --- a/ide/coqide.opam +++ b/ide/coqide.opam @@ -6,14 +6,16 @@ bug-reports: "https://github.com/coq/coq/issues" dev-repo: "https://github.com/coq/coq.git" license: "LGPL-2.1" -available: [ocaml-version >= "4.02.3"] +available: [ocaml-version >= "4.05.0"] depends: [ - "dune" { build } - "ocamlfind" { build } - "num" - "camlp5" + "dune" { build & >= "1.2.0" } "coq" + "conf-gtksourceview" + "lablgtk" { >= "2.18.5" } ] +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] build: [ [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/ide/dune-workspace b/ide/dune-workspace new file mode 100644 index 0000000000..38875eac2c --- /dev/null +++ b/ide/dune-workspace @@ -0,0 +1,6 @@ +(lang dune 1.2) + +; Add custom flags here. Default developer profile is `dev` +(env + (dev (flags :standard -rectypes -w -9-27-50+60)) + (release (flags :standard -rectypes))) diff --git a/ide/preferences.ml b/ide/preferences.ml index 3f10af04c9..9f04ced1c3 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -688,10 +688,6 @@ let pmodifiers ?(all = false) name p = modifiers name (str_to_mod_list p#get) -[@@@ocaml.warning "-3"] (* String.uppercase_ascii since 4.03.0 GPR#124 *) -let uppercase = String.uppercase -[@@@ocaml.warning "+3"] - let configure ?(apply=(fun () -> ())) () = let cmd_coqtop = string @@ -1018,7 +1014,7 @@ let configure ?(apply=(fun () -> ())) () = let k = if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k else "" in - let k = uppercase k in + let k = String.uppercase_ascii k in [q, k] in diff --git a/ide/protocol/xml_lexer.mll b/ide/protocol/xml_lexer.mll index 4a52147e17..e8bf7e16ae 100644 --- a/ide/protocol/xml_lexer.mll +++ b/ide/protocol/xml_lexer.mll @@ -83,9 +83,6 @@ let error lexbuf e = last_pos := lexeme_start lexbuf; raise (Error e) -[@@@ocaml.warning "-3"] (* String.lowercase_ascii since 4.03.0 GPR#124 *) -let lowercase = String.lowercase -[@@@ocaml.warning "+3"] } let newline = ['\n'] @@ -222,7 +219,7 @@ and entity = parse { let ident = lexeme lexbuf in try - Hashtbl.find idents (lowercase ident) + Hashtbl.find idents (String.lowercase_ascii ident) with Not_found -> "&" ^ ident } diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 23d0536df8..d5f0b7bff6 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -526,6 +526,14 @@ let mkAppC (f,l) = | CApp (g,l') -> CAst.make @@ CApp (g, l' @ l) | _ -> CAst.make @@ CApp ((None, f), l) +let mkProdCN ?loc bll c = + if bll = [] then c else + CAst.make ?loc @@ CProdN (bll,c) + +let mkLambdaCN ?loc bll c = + if bll = [] then c else + CAst.make ?loc @@ CLambdaN (bll,c) + let mkCProdN ?loc bll c = CAst.make ?loc @@ CProdN (bll,c) diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 61e8aa1b51..9e83bde8b2 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -38,22 +38,36 @@ val constr_loc : constr_expr -> Loc.t option val cases_pattern_expr_loc : cases_pattern_expr -> Loc.t option val local_binders_loc : local_binder_expr list -> Loc.t option -(** {6 Constructors}*) +(** {6 Constructors} *) + +(** {7 Term constructors} *) + +(** Basic form of the corresponding constructors *) val mkIdentC : Id.t -> constr_expr val mkRefC : qualid -> constr_expr -val mkAppC : constr_expr * constr_expr list -> constr_expr val mkCastC : constr_expr * constr_expr Glob_term.cast_type -> constr_expr val mkLambdaC : lname list * binder_kind * constr_expr * constr_expr -> constr_expr val mkLetInC : lname * constr_expr * constr_expr option * constr_expr -> constr_expr val mkProdC : lname list * binder_kind * constr_expr * constr_expr -> constr_expr -val mkCLambdaN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr -(** Same as [abstract_constr_expr], with location *) +val mkAppC : constr_expr * constr_expr list -> constr_expr +(** Basic form of application, collapsing nested applications *) +(** Optimized constructors: does not add a constructor for an empty binder list *) + +val mkLambdaCN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr +val mkProdCN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr + +(** Aliases for the corresponding constructors; generally [mkLambdaCN] and + [mkProdCN] should be preferred *) + +val mkCLambdaN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr val mkCProdN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_expr -(** Same as [prod_constr_expr], with location *) +(** {7 Pattern constructors} *) + +(** Interpretation of a list of patterns as a disjunctive pattern (optimized) *) val mkCPatOr : ?loc:Loc.t -> cases_pattern_expr list -> cases_pattern_expr val mkAppPattern : ?loc:Loc.t -> cases_pattern_expr -> cases_pattern_expr list -> cases_pattern_expr diff --git a/interp/declare.ml b/interp/declare.ml index 23c68b5e18..f4e57073cc 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -78,7 +78,6 @@ let check_exists sp = let cache_constant ((sp,kn), obj) = let id = basename sp in - let _,dir,_ = KerName.repr kn in let kn' = match obj.cst_decl with | None -> @@ -87,7 +86,7 @@ let cache_constant ((sp,kn), obj) = else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") | Some decl -> let () = check_exists sp in - Global.add_constant dir id decl + Global.add_constant ~in_section:(Lib.sections_are_opened ()) id decl in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); @@ -136,7 +135,7 @@ let register_side_effect (c, role) = cst_kind = IsProof Theorem; cst_locl = false; } in - let id = Label.to_id (pi3 (Constant.repr3 c)) in + let id = Label.to_id (Constant.label c) in ignore(add_leaf id o); update_tables c; match role with @@ -311,8 +310,7 @@ let cache_inductive ((sp,kn),mie) = let names = inductive_names sp kn mie in List.iter check_exists (List.map fst names); let id = basename sp in - let _,dir,_ = KerName.repr kn in - let kn' = Global.add_mind dir id mie in + let kn' = Global.add_mind id mie in assert (MutInd.equal kn' (MutInd.make1 kn)); let mind = Global.lookup_mind kn' in add_section_kn (Declareops.inductive_is_polymorphic mind) kn' mind.mind_hyps; diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index ccad6b19eb..f5be0ddbae 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -234,7 +234,7 @@ let add_glob ?loc ref = add_glob_gen ?loc sp lib_dp ty let mp_of_kn kn = - let mp,sec,l = Names.KerName.repr kn in + let mp,l = Names.KerName.repr kn in Names.MPdot (mp,l) let add_glob_kn ?loc kn = diff --git a/interp/impargs.ml b/interp/impargs.ml index 3603367cf1..ce33cb8731 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -561,29 +561,27 @@ let discharge_implicits (_,(req,l)) = | ImplInteractive (ref,flags,exp) -> (try let vars = variable_section_segment_of_reference ref in - let ref' = if isVarRef ref then ref else pop_global_reference ref in let extra_impls = impls_of_context vars in - let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in - Some (ImplInteractive (ref',flags,exp),l') + let l' = [ref, List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in + Some (ImplInteractive (ref,flags,exp),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) | ImplConstant (con,flags) -> (try - let con' = pop_con con in let vars = variable_section_segment_of_reference (ConstRef con) in let extra_impls = impls_of_context vars in let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in - let l' = [ConstRef con',newimpls] in - Some (ImplConstant (con',flags),l') + let l' = [ConstRef con,newimpls] in + Some (ImplConstant (con,flags),l') with Not_found -> (* con not defined in this section *) Some (req,l)) | ImplMutualInductive (kn,flags) -> (try let l' = List.map (fun (gr, l) -> let vars = variable_section_segment_of_reference gr in let extra_impls = impls_of_context vars in - ((if isVarRef gr then gr else pop_global_reference gr), + (gr, List.map (add_section_impls vars extra_impls) l)) l in - Some (ImplMutualInductive (pop_kn kn,flags),l') + Some (ImplMutualInductive (kn,flags),l') with Not_found -> (* ref not defined in this section *) Some (req,l)) let rebuild_implicits (req,l) = diff --git a/interp/notation.ml b/interp/notation.ml index 02c7812e21..6104ab16c7 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1304,7 +1304,7 @@ let discharge_arguments_scope (_,(req,r,n,l,_)) = vars |> List.map fst |> List.filter is_local_assum |> List.length with Not_found (* Not a ref defined in this section *) -> 0 in - Some (req,Lib.discharge_global r,n,l,[]) + Some (req,r,n,l,[]) let classify_arguments_scope (req,_,_,_,_ as obj) = if req == ArgsScopeNoDischarge then Dispose else Substitute obj diff --git a/kernel/constr.mli b/kernel/constr.mli index 2efdae007c..3c9cc96a0d 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -13,20 +13,12 @@ open Names -(** {6 Value under universe substitution } *) -type 'a puniverses = 'a Univ.puniverses -[@@ocaml.deprecated "use Univ.puniverses"] - (** {6 Simply type aliases } *) type pconstant = Constant.t Univ.puniverses type pinductive = inductive Univ.puniverses type pconstructor = constructor Univ.puniverses (** {6 Existential variables } *) -type existential_key = Evar.t -[@@ocaml.deprecated "use Evar.t"] - -(** {6 Existential variables } *) type metavariable = int (** {6 Case annotation } *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index b361e36bbf..b39aed01e8 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -15,7 +15,6 @@ (* This module implements kernel-level discharching of local declarations over global constants and inductive types *) -open CErrors open Util open Names open Term @@ -28,18 +27,6 @@ module RelDecl = Context.Rel.Declaration (*s Cooking the constants. *) -let pop_dirpath p = match DirPath.repr p with - | [] -> anomaly ~label:"dirpath_prefix" (Pp.str "empty dirpath.") - | _::l -> DirPath.make l - -let pop_mind kn = - let (mp,dir,l) = MutInd.repr3 kn in - MutInd.make3 mp (pop_dirpath dir) l - -let pop_con con = - let (mp,dir,l) = Constant.repr3 con in - Constant.make3 mp (pop_dirpath dir) l - type my_global_reference = | ConstRef of Constant.t | IndRef of inductive @@ -71,29 +58,26 @@ let instantiate_my_gr gr u = let share cache r (cstl,knl) = try RefTable.find cache r with Not_found -> - let f,(u,l) = + let (u,l) = match r with - | IndRef (kn,i) -> - IndRef (pop_mind kn,i), Mindmap.find kn knl - | ConstructRef ((kn,i),j) -> - ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl + | IndRef (kn,_i) -> + Mindmap.find kn knl + | ConstructRef ((kn,_i),_j) -> + Mindmap.find kn knl | ConstRef cst -> - ConstRef (pop_con cst), Cmap.find cst cstl in - let c = (f, (u, Array.map mkVar l)) in + Cmap.find cst cstl in + let c = (u, Array.map mkVar l) in RefTable.add cache r c; c let share_univs cache r u l = - let r', (u', args) = share cache r l in - mkApp (instantiate_my_gr r' (Instance.append u' u), args) + let (u', args) = share cache r l in + mkApp (instantiate_my_gr r (Instance.append u' u), args) let update_case_info cache ci modlist = try - let ind, n = - match share cache (IndRef ci.ci_ind) modlist with - | (IndRef f,(_u,l)) -> (f, Array.length l) - | _ -> assert false in - { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } + let (_u,l) = share cache (IndRef ci.ci_ind) modlist in + { ci with ci_npar = ci.ci_npar + Array.length l } with Not_found -> ci @@ -129,7 +113,7 @@ let expmod_constr cache modlist c = | Proj (p, c') -> let map cst npars = let _, newpars = Mindmap.find cst (snd modlist) in - pop_mind cst, npars + Array.length newpars + (cst, npars + Array.length newpars) in let p' = try Projection.map_npars map p with Not_found -> p in let c'' = substrec c' in diff --git a/kernel/environ.mli b/kernel/environ.mli index 1343b9029b..55ff7ff162 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -320,8 +320,6 @@ val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declarat open Retroknowledge (** functions manipulating the retroknowledge @author spiwack *) -val retroknowledge : (retroknowledge->'a) -> env -> 'a -[@@ocaml.deprecated "Use the record projection."] val registered : env -> field -> bool diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index bff3092655..2a91c7dab0 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -173,12 +173,12 @@ let solve_delta_kn resolve kn = | Inline (lev, Some c) -> raise (Change_equiv_to_inline (lev,c)) | Inline (_, None) -> raise Not_found with Not_found -> - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else - KerName.make new_mp dir l + KerName.make new_mp l let kn_of_delta resolve kn = try solve_delta_kn resolve kn @@ -245,18 +245,18 @@ let subst_mp sub mp = | Some (mp',_) -> mp' let subst_kn_delta sub kn = - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',resolve) -> - solve_delta_kn resolve (KerName.make mp' dir l) + solve_delta_kn resolve (KerName.make mp' l) | None -> kn let subst_kn sub kn = - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',_) -> - (KerName.make mp' dir l) + (KerName.make mp' l) | None -> kn exception No_subst @@ -275,12 +275,12 @@ let progress f x ~orelse = if y != x then y else orelse let subst_mind sub mind = - let mpu,dir,l = MutInd.repr3 mind in + let mpu,l = MutInd.repr2 mind in let mpc = KerName.modpath (MutInd.canonical mind) in try let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in - let knu = KerName.make mpu dir l in - let knc = if mpu == mpc then knu else KerName.make mpc dir l in + let knu = KerName.make mpu l in + let knc = if mpu == mpc then knu else KerName.make mpc l in let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in @@ -295,11 +295,11 @@ let subst_pind sub (ind,u) = (subst_ind sub ind, u) let subst_con0 sub (cst,u) = - let mpu,dir,l = Constant.repr3 cst in + let mpu,l = Constant.repr2 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in - let knu = KerName.make mpu dir l in - let knc = if mpu == mpc then knu else KerName.make mpc dir l in + let knu = KerName.make mpu l in + let knc = if mpu == mpc then knu else KerName.make mpc l in match search_delta_inline resolve knu knc with | Some (ctx, t) -> (* In case of inlining, discard the canonical part (cf #2608) *) @@ -433,10 +433,10 @@ let rec replace_mp_in_mp mpfrom mpto mp = | _ -> mp let replace_mp_in_kn mpfrom mpto kn = - let mp,dir,l = KerName.repr kn in + let mp,l = KerName.repr kn in let mp'' = replace_mp_in_mp mpfrom mpto mp in if mp==mp'' then kn - else KerName.make mp'' dir l + else KerName.make mp'' l let rec mp_in_mp mp mp1 = match mp1 with diff --git a/kernel/modops.ml b/kernel/modops.ml index 424d329e09..bab2eae3df 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -289,10 +289,10 @@ let add_retroknowledge = let rec add_structure mp sign resolver linkinfo env = let add_one env (l,elem) = match elem with |SFBconst cb -> - let c = constant_of_delta_kn resolver (KerName.make2 mp l) in + let c = constant_of_delta_kn resolver (KerName.make mp l) in Environ.add_constant_key c cb linkinfo env |SFBmind mib -> - let mind = mind_of_delta_kn resolver (KerName.make2 mp l) in + let mind = mind_of_delta_kn resolver (KerName.make mp l) in let mib = if mib.mind_private != None then { mib with mind_private = Some true } @@ -331,7 +331,7 @@ let strengthen_const mp_from l cb resolver = match cb.const_body with |Def _ -> cb |_ -> - let kn = KerName.make2 mp_from l in + let kn = KerName.make mp_from l in let con = constant_of_delta_kn resolver kn in let u = match cb.const_universes with @@ -450,8 +450,8 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = (* If we are performing an inclusion we need to add the fact that the constant mp_to.l is \Delta-equivalent to reso(mp_from.l) *) - let kn_from = KerName.make2 mp_from l in - let kn_to = KerName.make2 mp_to l in + let kn_from = KerName.make mp_from l in + let kn_to = KerName.make mp_to l in let old_name = kn_of_delta reso kn_from in add_kn_delta_resolver kn_to old_name reso', str' else @@ -471,8 +471,8 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = in (* Same as constant *) if incl then - let kn_from = KerName.make2 mp_from l in - let kn_to = KerName.make2 mp_to l in + let kn_from = KerName.make mp_from l in + let kn_to = KerName.make mp_to l in let old_name = kn_of_delta reso kn_from in add_kn_delta_resolver kn_to old_name reso', str' else diff --git a/kernel/names.ml b/kernel/names.ml index 6d33f233e9..7cd749de1d 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -365,7 +365,6 @@ module KerName = struct type t = { modpath : ModPath.t; - dirpath : DirPath.t; knlabel : Label.t; mutable refhash : int; (** Lazily computed hash. If unset, it is set to negative values. *) @@ -373,22 +372,18 @@ module KerName = struct type kernel_name = t - let make modpath dirpath knlabel = - { modpath; dirpath; knlabel; refhash = -1; } - let repr kn = (kn.modpath, kn.dirpath, kn.knlabel) + let make modpath knlabel = + { modpath; knlabel; refhash = -1; } + let repr kn = (kn.modpath, kn.knlabel) - let make2 modpath knlabel = - { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; } + let make2 = make + [@@ocaml.deprecated "Please use [KerName.make]"] let modpath kn = kn.modpath let label kn = kn.knlabel let to_string_gen mp_to_string kn = - let dp = - if DirPath.is_empty kn.dirpath then "." - else "#" ^ DirPath.to_string kn.dirpath ^ "#" - in - mp_to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel + mp_to_string kn.modpath ^ "." ^ Label.to_string kn.knlabel let to_string kn = to_string_gen ModPath.to_string kn @@ -402,9 +397,7 @@ module KerName = struct let c = String.compare kn1.knlabel kn2.knlabel in if not (Int.equal c 0) then c else - let c = DirPath.compare kn1.dirpath kn2.dirpath in - if not (Int.equal c 0) then c - else ModPath.compare kn1.modpath kn2.modpath + ModPath.compare kn1.modpath kn2.modpath let equal kn1 kn2 = let h1 = kn1.refhash in @@ -412,7 +405,6 @@ module KerName = struct if 0 <= h1 && 0 <= h2 && not (Int.equal h1 h2) then false else Label.equal kn1.knlabel kn2.knlabel && - DirPath.equal kn1.dirpath kn2.dirpath && ModPath.equal kn1.modpath kn2.modpath open Hashset.Combine @@ -420,8 +412,8 @@ module KerName = struct let hash kn = let h = kn.refhash in if h < 0 then - let { modpath = mp; dirpath = dp; knlabel = lbl; _ } = kn in - let h = combine3 (ModPath.hash mp) (DirPath.hash dp) (Label.hash lbl) in + let { modpath = mp; knlabel = lbl; _ } = kn in + let h = combine (ModPath.hash mp) (Label.hash lbl) in (* Ensure positivity on all platforms. *) let h = h land 0x3FFFFFFF in let () = kn.refhash <- h in @@ -432,12 +424,11 @@ module KerName = struct type t = kernel_name type u = (ModPath.t -> ModPath.t) * (DirPath.t -> DirPath.t) * (string -> string) - let hashcons (hmod,hdir,hstr) kn = - let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in - { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; } + let hashcons (hmod,_hdir,hstr) kn = + let { modpath = mp; knlabel = l; refhash; } = kn in + { modpath = hmod mp; knlabel = hstr l; refhash; } let eq kn1 kn2 = - kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath && - kn1.knlabel == kn2.knlabel + kn1.modpath == kn2.modpath && kn1.knlabel == kn2.knlabel let hash = hash end @@ -492,21 +483,20 @@ module KerPair = struct let make knu knc = if KerName.equal knu knc then Same knc else Dual (knu,knc) let make1 = same - let make2 mp l = same (KerName.make2 mp l) - let make3 mp dir l = same (KerName.make mp dir l) - let repr3 kp = KerName.repr (user kp) + let make2 mp l = same (KerName.make mp l) + let repr2 kp = KerName.repr (user kp) let label kp = KerName.label (user kp) let modpath kp = KerName.modpath (user kp) let change_label kp lbl = - let (mp1,dp1,l1) = KerName.repr (user kp) - and (mp2,dp2,l2) = KerName.repr (canonical kp) in - assert (String.equal l1 l2 && DirPath.equal dp1 dp2); + let (mp1,l1) = KerName.repr (user kp) + and (mp2,l2) = KerName.repr (canonical kp) in + assert (String.equal l1 l2); if String.equal lbl l1 then kp else - let kn = KerName.make mp1 dp1 lbl in + let kn = KerName.make mp1 lbl in if mp1 == mp2 then same kn - else make kn (KerName.make mp2 dp2 lbl) + else make kn (KerName.make mp2 lbl) let to_string kp = KerName.to_string (user kp) let print kp = str (to_string kp) @@ -749,15 +739,12 @@ let eq_table_key f ik1 ik2 = | RelKey k1, RelKey k2 -> Int.equal k1 k2 | _ -> false -let eq_con_chk = Constant.UserOrd.equal let eq_mind_chk = MutInd.UserOrd.equal let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 - (*******************************************************************) (** Compatibility layers *) -type mod_bound_id = MBId.t let eq_constant_key = Constant.UserOrd.equal (** Compatibility layer for [ModPath] *) @@ -933,8 +920,6 @@ struct end -type projection = Projection.t - module GlobRefInternal = struct type t = @@ -1025,10 +1010,6 @@ module GlobRef = struct end -type global_reference = GlobRef.t -[@@ocaml.deprecated "Alias for [GlobRef.t]"] - - type evaluable_global_reference = | EvalVarRef of Id.t | EvalConstRef of Constant.t diff --git a/kernel/names.mli b/kernel/names.mli index 2ea8108734..37930c12e2 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -274,9 +274,11 @@ sig type t (** Constructor and destructor *) - val make : ModPath.t -> DirPath.t -> Label.t -> t + val make : ModPath.t -> Label.t -> t + val repr : t -> ModPath.t * Label.t + val make2 : ModPath.t -> Label.t -> t - val repr : t -> ModPath.t * DirPath.t * Label.t + [@@ocaml.deprecated "Please use [KerName.make]"] (** Projections *) val modpath : t -> ModPath.t @@ -317,15 +319,12 @@ sig val make2 : ModPath.t -> Label.t -> t (** Shortcut for [(make1 (KerName.make2 ...))] *) - val make3 : ModPath.t -> DirPath.t -> Label.t -> t - (** Shortcut for [(make1 (KerName.make ...))] *) - (** Projections *) val user : t -> KerName.t val canonical : t -> KerName.t - val repr3 : t -> ModPath.t * DirPath.t * Label.t + val repr2 : t -> ModPath.t * Label.t (** Shortcut for [KerName.repr (user ...)] *) val modpath : t -> ModPath.t @@ -403,15 +402,12 @@ sig val make2 : ModPath.t -> Label.t -> t (** Shortcut for [(make1 (KerName.make2 ...))] *) - val make3 : ModPath.t -> DirPath.t -> Label.t -> t - (** Shortcut for [(make1 (KerName.make ...))] *) - (** Projections *) val user : t -> KerName.t val canonical : t -> KerName.t - val repr3 : t -> ModPath.t * DirPath.t * Label.t + val repr2 : t -> ModPath.t * Label.t (** Shortcut for [KerName.repr (user ...)] *) val modpath : t -> ModPath.t @@ -531,15 +527,8 @@ val eq_constant_key : Constant.t -> Constant.t -> bool (** equalities on constant and inductive names (for the checker) *) -val eq_con_chk : Constant.t -> Constant.t -> bool -[@@ocaml.deprecated "Same as [Constant.UserOrd.equal]."] - val eq_ind_chk : inductive -> inductive -> bool -(** {6 Deprecated functions. For backward compatibility.} *) - -type mod_bound_id = MBId.t -[@@ocaml.deprecated "Same as [MBId.t]."] (** {5 Module paths} *) type module_path = ModPath.t = @@ -629,9 +618,6 @@ module Projection : sig end -type projection = Projection.t -[@@ocaml.deprecated "Alias for [Projection.t]"] - (** {6 Global reference is a kernel side type for all references together } *) (* XXX: Should we define GlobRefCan GlobRefUser? *) @@ -669,9 +655,6 @@ module GlobRef : sig end -type global_reference = GlobRef.t -[@@ocaml.deprecated "Alias for [GlobRef.t]"] - (** Better to have it here that in Closure, since required in grammar.cma *) (* XXX: Move to a module *) type evaluable_global_reference = diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 74b075f4a5..482a2f3a3c 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1561,7 +1561,7 @@ let rec list_of_mp acc = function let list_of_mp mp = list_of_mp [] mp let string_of_kn kn = - let (mp,_dp,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in let mp = list_of_mp mp in String.concat "_" mp ^ "_" ^ string_of_label l diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 8ac3538fc5..5d1b882361 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -27,7 +27,7 @@ let rec translate_mod prefix mp env mod_expr acc = and translate_field prefix mp env acc (l,x) = match x with | SFBconst cb -> - let con = Constant.make3 mp DirPath.empty l in + let con = Constant.make2 mp l in (if !Flags.debug then let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in Feedback.msg_debug (Pp.str msg)); diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index b036aa6a67..820c5b3a2b 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -479,10 +479,10 @@ type global_declaration = type exported_private_constant = Constant.t * Entries.side_effect_role -let add_constant_aux no_section senv (kn, cb) = - let l = pi3 (Constant.repr3 kn) in +let add_constant_aux ~in_section senv (kn, cb) = + let l = Constant.label kn in let cb, otab = match cb.const_body with - | OpaqueDef lc when no_section -> + | OpaqueDef lc when not in_section -> (* In coqc, opaque constants outside sections will be stored indirectly in a specific table *) let od, otab = @@ -505,13 +505,11 @@ let export_private_constants ~in_section ce senv = let exported, ce = Term_typing.export_side_effects senv.revstruct senv.env ce in let bodies = List.map (fun (kn, cb, _) -> (kn, cb)) exported in let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in - let no_section = not in_section in - let senv = List.fold_left (add_constant_aux no_section) senv bodies in + let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv -let add_constant dir l decl senv = - let kn = Constant.make3 senv.modpath dir l in - let no_section = DirPath.is_empty dir in +let add_constant ~in_section l decl senv = + let kn = Constant.make2 senv.modpath l in let senv = let cb = match decl with @@ -520,9 +518,9 @@ let add_constant dir l decl senv = | ConstantEntry (PureEntry, ce) -> Term_typing.translate_constant Term_typing.Pure senv.env kn ce | GlobalRecipe r -> - let cb = Term_typing.translate_recipe senv.env kn r in - if no_section then Declareops.hcons_const_body cb else cb in - add_constant_aux no_section senv (kn, cb) in + let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in + if in_section then cb else Declareops.hcons_const_body cb in + add_constant_aux ~in_section senv (kn, cb) in kn, senv (** Insertion of inductive types *) @@ -535,9 +533,9 @@ let check_mind mie lab = (* The label and the first inductive type name should match *) assert (Id.equal (Label.to_id lab) oie.mind_entry_typename) -let add_mind dir l mie senv = +let add_mind l mie senv = let () = check_mind mie l in - let kn = MutInd.make3 senv.modpath dir l in + let kn = MutInd.make2 senv.modpath l in let mib = Term_typing.translate_mind senv.env kn mie in let mib = match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib @@ -770,9 +768,9 @@ let add_include me is_module inl senv = let add senv ((l,elem) as field) = let new_name = match elem with | SFBconst _ -> - C (Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp_sup l)) + C (Mod_subst.constant_of_delta_kn resolver (KerName.make mp_sup l)) | SFBmind _ -> - I (Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp_sup l)) + I (Mod_subst.mind_of_delta_kn resolver (KerName.make mp_sup l)) | SFBmodule _ -> M | SFBmodtype _ -> MT in @@ -885,12 +883,6 @@ let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) -[@@@ocaml.warning "-3"] -(** universal lifting, used for the "get" operations mostly *) -let retroknowledge f senv = - Environ.retroknowledge f (env_of_senv senv) -[@@@ocaml.warning "+3"] - let register field value senv = (* todo : value closed *) (* spiwack : updates the safe_env with the information that the register diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 6e0febaa3f..0f150ea971 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -105,13 +105,13 @@ val export_private_constants : in_section:bool -> (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) val add_constant : - DirPath.t -> Label.t -> global_declaration -> + in_section:bool -> Label.t -> global_declaration -> Constant.t safe_transformer (** Adding an inductive type *) val add_mind : - DirPath.t -> Label.t -> Entries.mutual_inductive_entry -> + Label.t -> Entries.mutual_inductive_entry -> MutInd.t safe_transformer (** Adding a module or a module type *) @@ -208,9 +208,6 @@ val delta_of_senv : open Retroknowledge -val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a -[@@ocaml.deprecated "Use the projection of Environ.env"] - val register : field -> GlobRef.t -> safe_transformer0 diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index bfe68671a2..d64342dbb0 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -103,8 +103,8 @@ let check_polymorphic_instance error env auctx1 auctx2 = (* for now we do not allow reorderings *) let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= - let kn1 = KerName.make2 mp1 l in - let kn2 = KerName.make2 mp2 l in + let kn1 = KerName.make mp1 l in + let kn2 = KerName.make mp2 l in let error why = error_signature_mismatch l spec2 why in let check_conv why cst poly f = check_conv_error error why cst poly f in let mib1 = diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 47247ff25e..5ccc23eefc 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -531,11 +531,7 @@ let translate_local_assum env t = let t = Typeops.assumption_of_judgment env j in t -let translate_recipe env kn r = - (** We only hashcons the term when outside of a section, otherwise this would - be useless. It is detected by the dirpath of the constant being empty. *) - let (_, dir, _) = Constant.repr3 kn in - let hcons = DirPath.is_empty dir in +let translate_recipe ~hcons env kn r = build_constant_declaration kn env (Cooking.cook_constant ~hcons r) let translate_local_def env _id centry = diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index b05e05e4dc..ab25090b00 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -64,7 +64,7 @@ val export_side_effects : val translate_mind : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body -val translate_recipe : env -> Constant.t -> Cooking.recipe -> constant_body +val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 752bf76270..4336a22b8c 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -12,8 +12,6 @@ open Univ (** {6 Graphs of universes. } *) type t -type universes = t -[@@ocaml.deprecated "Use UGraph.t"] type 'a check_function = t -> 'a -> 'a -> bool diff --git a/kernel/univ.ml b/kernel/univ.ml index 61ad1d0a82..fa37834a23 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -574,11 +574,8 @@ struct pp_std ++ prl u1 ++ pr_constraint_type op ++ prl u2 ++ fnl () ) c (str "") - let universes_of c = - fold (fun (u1, _op, u2) unvs -> LSet.add u2 (LSet.add u1 unvs)) c LSet.empty end -let universes_of_constraints = Constraint.universes_of let empty_constraint = Constraint.empty let union_constraint = Constraint.union let eq_constraint = Constraint.equal @@ -897,8 +894,6 @@ let subst_instance_constraints s csts = (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) csts Constraint.empty -type universe_instance = Instance.t - type 'a puniverses = 'a * Instance.t let out_punivs (x, _y) = x let in_punivs x = (x, Instance.empty) @@ -955,7 +950,6 @@ struct end -type abstract_universe_context = AUContext.t let hcons_abstract_universe_context = AUContext.hcons (** Universe info for cumulative inductive types: A context of @@ -997,12 +991,10 @@ struct end -type cumulativity_info = CumulativityInfo.t let hcons_cumulativity_info = CumulativityInfo.hcons module ACumulativityInfo = CumulativityInfo -type abstract_cumulativity_info = ACumulativityInfo.t let hcons_abstract_cumulativity_info = ACumulativityInfo.hcons (** A set of universes with universe constraints. @@ -1238,7 +1230,3 @@ let explain_universe_inconsistency prl (o,u,v,p) = in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ pr_rel o ++ spc() ++ pr_uni v ++ reason - -let compare_levels = Level.compare -let eq_levels = Level.equal -let equal_universes = Universe.equal diff --git a/kernel/univ.mli b/kernel/univ.mli index b68bbdf359..1aa53b8aa8 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -51,9 +51,6 @@ sig val name : t -> (Names.DirPath.t * int) option end -type universe_level = Level.t -[@@ocaml.deprecated "Use Level.t"] - (** Sets of universe levels *) module LSet : sig @@ -63,9 +60,6 @@ sig (** Pretty-printing *) end -type universe_set = LSet.t -[@@ocaml.deprecated "Use LSet.t"] - module Universe : sig type t @@ -130,9 +124,6 @@ sig end -type universe = Universe.t -[@@ocaml.deprecated "Use Universe.t"] - (** Alias name. *) val pr_uni : Universe.t -> Pp.t @@ -171,9 +162,6 @@ module Constraint : sig include Set.S with type elt = univ_constraint end -type constraints = Constraint.t -[@@ocaml.deprecated "Use Constraint.t"] - val empty_constraint : Constraint.t val union_constraint : Constraint.t -> Constraint.t -> Constraint.t val eq_constraint : Constraint.t -> Constraint.t -> bool @@ -301,9 +289,6 @@ sig end -type universe_instance = Instance.t -[@@ocaml.deprecated "Use Instance.t"] - val enforce_eq_instances : Instance.t constraint_function val enforce_eq_variance_instances : Variance.t array -> Instance.t constraint_function @@ -340,9 +325,6 @@ sig end -type universe_context = UContext.t -[@@ocaml.deprecated "Use UContext.t"] - module AUContext : sig type t @@ -367,9 +349,6 @@ sig end -type abstract_universe_context = AUContext.t -[@@ocaml.deprecated "Use AUContext.t"] - (** Universe info for cumulative inductive types: A context of universe levels with universe constraints, representing local universe variables and constraints, together with an array of @@ -398,9 +377,6 @@ sig val eq_constraints : t -> Instance.t constraint_function end -type cumulativity_info = CumulativityInfo.t -[@@ocaml.deprecated "Use CumulativityInfo.t"] - module ACumulativityInfo : sig type t @@ -411,11 +387,13 @@ sig val eq_constraints : t -> Instance.t constraint_function end -type abstract_cumulativity_info = ACumulativityInfo.t -[@@ocaml.deprecated "Use ACumulativityInfo.t"] - (** Universe contexts (as sets) *) +(** A set of universes with universe Constraint.t. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) + module ContextSet : sig type t = LSet.t constrained @@ -451,13 +429,6 @@ sig val size : t -> int end -(** A set of universes with universe Constraint.t. - We linearize the set to a list after typechecking. - Beware, representation could change. -*) -type universe_context_set = ContextSet.t -[@@ocaml.deprecated "Use ContextSet.t"] - (** A value in a universe context (resp. context set). *) type 'a in_universe_context = 'a * UContext.t type 'a in_universe_context_set = 'a * ContextSet.t @@ -532,20 +503,3 @@ val hcons_abstract_universe_context : AUContext.t -> AUContext.t val hcons_universe_context_set : ContextSet.t -> ContextSet.t val hcons_cumulativity_info : CumulativityInfo.t -> CumulativityInfo.t val hcons_abstract_cumulativity_info : ACumulativityInfo.t -> ACumulativityInfo.t - -(******) - -(* deprecated: use qualified names instead *) -val compare_levels : Level.t -> Level.t -> int -[@@ocaml.deprecated "Use Level.compare"] - -val eq_levels : Level.t -> Level.t -> bool -[@@ocaml.deprecated "Use Level.equal"] - -(** deprecated: Equality of formal universe expressions. *) -val equal_universes : Universe.t -> Universe.t -> bool -[@@ocaml.deprecated "Use Universe.equal"] - -(** Universes of Constraint.t *) -val universes_of_constraints : Constraint.t -> LSet.t -[@@ocaml.deprecated "Use Constraint.universes_of"] diff --git a/lib/feedback.ml b/lib/feedback.ml index cb8f8aad1e..9654711ebb 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -84,7 +84,7 @@ let feedback_logger ?loc lvl msg = let msg_info ?loc x = feedback_logger ?loc Info x let msg_notice ?loc x = feedback_logger ?loc Notice x let msg_warning ?loc x = feedback_logger ?loc Warning x -let msg_error ?loc x = feedback_logger ?loc Error x +(* let msg_error ?loc x = feedback_logger ?loc Error x *) let msg_debug ?loc x = feedback_logger ?loc Debug x (* Helper for tools willing to understand only the messages *) diff --git a/lib/feedback.mli b/lib/feedback.mli index 64fdf3724d..f407e2fd5b 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -95,11 +95,6 @@ val msg_warning : ?loc:Loc.t -> Pp.t -> unit (** Message indicating that something went wrong, but without serious consequences. *) -val msg_error : ?loc:Loc.t -> Pp.t -> unit -[@@ocaml.deprecated "msg_error is an internal function and should not be \ - used unless you know what you are doing. Use \ - [CErrors.user_err] instead."] - val msg_debug : ?loc:Loc.t -> Pp.t -> unit (** For debugging purposes *) @@ -42,9 +42,6 @@ type doc_view = internal representation opaque here. *) type t = doc_view -type std_ppcmds = t -[@@ocaml.deprecated "alias of Pp.t"] - let repr x = x let unrepr x = x diff --git a/lib/pp.mli b/lib/pp.mli index ed31daa561..4ce6a535c8 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -42,9 +42,6 @@ type pp_tag = string internal representation opaque here. *) type t -type std_ppcmds = t -[@@ocaml.deprecated "alias of Pp.t"] - type block_type = | Pp_hbox of int | Pp_vbox of int diff --git a/library/coqlib.ml b/library/coqlib.ml index 026b7aa316..e71de4d77e 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -119,29 +119,26 @@ let prelude_module_name = init_dir@["Prelude"] let prelude_module = make_dir prelude_module_name let logic_module_name = init_dir@["Logic"] -let logic_module = make_dir logic_module_name +let logic_module = MPfile (make_dir logic_module_name) let logic_type_module_name = init_dir@["Logic_Type"] let logic_type_module = make_dir logic_type_module_name let datatypes_module_name = init_dir@["Datatypes"] -let datatypes_module = make_dir datatypes_module_name +let datatypes_module = MPfile (make_dir datatypes_module_name) let jmeq_module_name = [coq;"Logic";"JMeq"] -let jmeq_module = make_dir jmeq_module_name - -(* TODO: temporary hack. Works only if the module isn't an alias *) -let make_ind dir id = Globnames.encode_mind dir (Id.of_string id) -let make_con dir id = Globnames.encode_con dir (Id.of_string id) +let jmeq_library_path = make_dir jmeq_module_name +let jmeq_module = MPfile jmeq_library_path (** Identity *) -let id = make_con datatypes_module "idProp" -let type_of_id = make_con datatypes_module "IDProp" +let id = Constant.make2 datatypes_module @@ Label.make "idProp" +let type_of_id = Constant.make2 datatypes_module @@ Label.make "IDProp" (** Natural numbers *) -let nat_kn = make_ind datatypes_module "nat" -let nat_path = Libnames.make_path datatypes_module (Id.of_string "nat") +let nat_kn = MutInd.make2 datatypes_module @@ Label.make "nat" +let nat_path = Libnames.make_path (make_dir datatypes_module_name) (Id.of_string "nat") let glob_nat = IndRef (nat_kn,0) @@ -151,7 +148,7 @@ let glob_O = ConstructRef path_of_O let glob_S = ConstructRef path_of_S (** Booleans *) -let bool_kn = make_ind datatypes_module "bool" +let bool_kn = MutInd.make2 datatypes_module @@ Label.make "bool" let glob_bool = IndRef (bool_kn,0) @@ -161,13 +158,13 @@ let glob_true = ConstructRef path_of_true let glob_false = ConstructRef path_of_false (** Equality *) -let eq_kn = make_ind logic_module "eq" +let eq_kn = MutInd.make2 logic_module @@ Label.make "eq" let glob_eq = IndRef (eq_kn,0) -let identity_kn = make_ind datatypes_module "identity" +let identity_kn = MutInd.make2 datatypes_module @@ Label.make "identity" let glob_identity = IndRef (identity_kn,0) -let jmeq_kn = make_ind jmeq_module "JMeq" +let jmeq_kn = MutInd.make2 jmeq_module @@ Label.make "JMeq" let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { diff --git a/library/coqlib.mli b/library/coqlib.mli index 8844684957..6a3d0953cd 100644 --- a/library/coqlib.mli +++ b/library/coqlib.mli @@ -61,12 +61,13 @@ val init_modules : string list list (** Modules *) val prelude_module : DirPath.t -val logic_module : DirPath.t +val logic_module : ModPath.t val logic_module_name : string list val logic_type_module : DirPath.t -val jmeq_module : DirPath.t +val jmeq_module : ModPath.t +val jmeq_library_path : DirPath.t val jmeq_module_name : string list val datatypes_module_name : string list diff --git a/library/declaremods.ml b/library/declaremods.ml index 0b3b461e6c..e01a99f731 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -164,8 +164,7 @@ module ModObjs : *) let mp_of_kn kn = - let mp,sec,l = KerName.repr kn in - assert (DirPath.is_empty sec); + let mp,l = KerName.repr kn in MPdot (mp,l) let dir_of_sp sp = diff --git a/library/global.ml b/library/global.ml index e872d081d6..0e236e6d34 100644 --- a/library/global.ml +++ b/library/global.ml @@ -91,8 +91,8 @@ let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) let typing_flags () = Environ.typing_flags (env ()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) -let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) -let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) +let add_constant ~in_section id d = globalize (Safe_typing.add_constant ~in_section (i2l id) d) +let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl) diff --git a/library/global.mli b/library/global.mli index 5205968c7b..fd6c9a60d4 100644 --- a/library/global.mli +++ b/library/global.mli @@ -42,9 +42,9 @@ val export_private_constants : in_section:bool -> unit Entries.definition_entry * Safe_typing.exported_private_constant list val add_constant : - DirPath.t -> Id.t -> Safe_typing.global_declaration -> Constant.t + in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t val add_mind : - DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> MutInd.t + Id.t -> Entries.mutual_inductive_entry -> MutInd.t (** Extra universe constraints *) val add_constraints : Univ.Constraint.t -> unit diff --git a/library/globnames.ml b/library/globnames.ml index 6bbdd36489..9aca7788d2 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -8,11 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors open Names open Constr open Mod_subst -open Libnames (*s Global reference is a kernel side type for all references together *) type global_reference = GlobRef.t = @@ -137,53 +135,5 @@ type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr -(** {6 Temporary function to brutally form kernel names from section paths } *) - -let encode_mind dir id = MutInd.make2 (MPfile dir) (Label.of_id id) - -let encode_con dir id = Constant.make2 (MPfile dir) (Label.of_id id) - -let check_empty_section dp = - if not (DirPath.is_empty dp) then - anomaly (Pp.str "Section part should be empty!") - -let decode_mind kn = - let rec dir_of_mp = function - | MPfile dir -> DirPath.repr dir - | MPbound mbid -> - let _,_,dp = MBId.repr mbid in - let id = MBId.to_id mbid in - id::(DirPath.repr dp) - | MPdot(mp,l) -> (Label.to_id l)::(dir_of_mp mp) - in - let mp,sec_dir,l = MutInd.repr3 kn in - check_empty_section sec_dir; - (DirPath.make (dir_of_mp mp)),Label.to_id l - -let decode_con kn = - let mp,sec_dir,l = Constant.repr3 kn in - check_empty_section sec_dir; - match mp with - | MPfile dir -> (dir,Label.to_id l) - | _ -> anomaly (Pp.str "MPfile expected!") - -(** Popping one level of section in global names. - These functions are meant to be used during discharge: - user and canonical kernel names must be equal. *) - -let pop_con con = - let (mp,dir,l) = Constant.repr3 con in - Constant.make3 mp (pop_dirpath dir) l - -let pop_kn kn = - let (mp,dir,l) = MutInd.repr3 kn in - MutInd.make3 mp (pop_dirpath dir) l - -let pop_global_reference = function - | ConstRef con -> ConstRef (pop_con con) - | IndRef (kn,i) -> IndRef (pop_kn kn,i) - | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j) - | VarRef id -> anomaly (Pp.str "VarRef not poppable.") - (* Deprecated *) let eq_gr = GlobRef.equal diff --git a/library/globnames.mli b/library/globnames.mli index 45ee069b06..a96a42ced2 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -82,15 +82,3 @@ end type global_reference_or_constr = | IsGlobal of GlobRef.t | IsConstr of constr - -(** {6 Temporary function to brutally form kernel names from section paths } *) - -val encode_mind : DirPath.t -> Id.t -> MutInd.t -val decode_mind : MutInd.t -> DirPath.t * Id.t -val encode_con : DirPath.t -> Id.t -> Constant.t -val decode_con : Constant.t -> DirPath.t * Id.t - -(** {6 Popping one level of section in global names } *) -val pop_con : Constant.t -> Constant.t -val pop_kn : MutInd.t-> MutInd.t -val pop_global_reference : GlobRef.t -> GlobRef.t diff --git a/library/keys.ml b/library/keys.ml index a74d13c600..53447a679a 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -92,8 +92,7 @@ let subst_keys (subst,(k,k')) = (subst_key subst k, subst_key subst k') let discharge_key = function - | KGlob g when Lib.is_in_section g -> - if isVarRef g then None else Some (KGlob (pop_global_reference g)) + | KGlob (VarRef _ as g) when Lib.is_in_section g -> None | x -> Some x let discharge_keys (_,(k,k')) = diff --git a/library/lib.ml b/library/lib.ml index 07026a9c2a..27c5056a7f 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -135,8 +135,8 @@ let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id let make_kn id = - let mp, dir = current_mp (), current_sections () in - Names.KerName.make mp dir (Names.Label.of_id id) + let mp = current_mp () in + Names.KerName.make mp (Names.Label.of_id id) let make_oname id = Libnames.make_oname !lib_state.path_prefix id @@ -632,44 +632,12 @@ let library_part = function |VarRef id -> library_dp () |ref -> dp_of_mp (mp_of_global ref) -(************************) -(* Discharging names *) - -let con_defined_in_sec kn = - let _,dir,_ = Names.Constant.repr3 kn in - not (Names.DirPath.is_empty dir) && - Names.DirPath.equal (pop_dirpath dir) (current_sections ()) - -let defined_in_sec kn = - let _,dir,_ = Names.MutInd.repr3 kn in - not (Names.DirPath.is_empty dir) && - Names.DirPath.equal (pop_dirpath dir) (current_sections ()) - -let discharge_global = function - | ConstRef kn when con_defined_in_sec kn -> - ConstRef (Globnames.pop_con kn) - | IndRef (kn,i) when defined_in_sec kn -> - IndRef (Globnames.pop_kn kn,i) - | ConstructRef ((kn,i),j) when defined_in_sec kn -> - ConstructRef ((Globnames.pop_kn kn,i),j) - | r -> r - -let discharge_kn kn = - if defined_in_sec kn then Globnames.pop_kn kn else kn - -let discharge_con cst = - if con_defined_in_sec cst then Globnames.pop_con cst else cst - let discharge_proj_repr = Projection.Repr.map_npars (fun mind npars -> - if not (defined_in_sec mind) then mind, npars - else - let modlist = replacement_context () in - let _, newpars = Mindmap.find mind (snd modlist) in - Globnames.pop_kn mind, npars + Array.length newpars) - -let discharge_inductive (kn,i) = - (discharge_kn kn,i) + if not (is_in_section (IndRef (mind,0))) then mind, npars + else let modlist = replacement_context () in + let _, newpars = Mindmap.find mind (snd modlist) in + mind, npars + Array.length newpars) let discharge_abstract_universe_context { abstr_subst = subst; abstr_uctx = abs_ctx } auctx = let open Univ in diff --git a/library/lib.mli b/library/lib.mli index a7d21060e9..686e6a0e2d 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -187,10 +187,8 @@ val is_polymorphic_univ : Univ.Level.t -> bool (** {6 Discharge: decrease the section level if in the current section } *) -val discharge_kn : MutInd.t -> MutInd.t -val discharge_con : Constant.t -> Constant.t +(* XXX Why can't we use the kernel functions ? *) + val discharge_proj_repr : Projection.Repr.t -> Projection.Repr.t -val discharge_global : GlobRef.t -> GlobRef.t -val discharge_inductive : inductive -> inductive val discharge_abstract_universe_context : abstr_info -> Univ.AUContext.t -> Univ.universe_level_subst * Univ.AUContext.t diff --git a/library/libnames.ml b/library/libnames.ml index 23085048a1..bd2ca550b9 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -171,8 +171,8 @@ type object_prefix = { } (* let make_oname (dirpath,(mp,dir)) id = *) -let make_oname { obj_dir; obj_mp; obj_sec } id = - make_path obj_dir id, KerName.make obj_mp obj_sec (Label.of_id id) +let make_oname { obj_dir; obj_mp } id = + make_path obj_dir id, KerName.make obj_mp (Label.of_id id) (* to this type are mapped DirPath.t's in the nametab *) type global_dir_reference = diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index d65b35c462..9c421f5b76 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -398,7 +398,6 @@ let set_lexer_state (o,s,b,c,f) = current_file := f let get_lexer_state () = (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) -let release_lexer_state = get_lexer_state let drop_lexer_state () = set_lexer_state (init_lexer_state Loc.ToplevelInput) diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index a14f08d91f..e4aa8debc1 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -54,7 +54,5 @@ type lexer_state val init_lexer_state : Loc.source -> lexer_state val set_lexer_state : lexer_state -> unit val get_lexer_state : unit -> lexer_state -val release_lexer_state : unit -> lexer_state -[@@ocaml.deprecated "Use get_lexer_state"] val drop_lexer_state : unit -> unit val get_comment_state : lexer_state -> ((int * int) * string) list diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 7cb5af787b..e25f7aa54f 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -249,20 +249,20 @@ GRAMMAR EXTEND Gram record_field_declaration: [ [ id = global; bl = binders; ":="; c = lconstr -> - { (id, if bl = [] then c else mkCLambdaN ~loc bl c) } ] ] + { (id, mkLambdaCN ~loc bl c) } ] ] ; binder_constr: [ [ "forall"; bl = open_binders; ","; c = operconstr LEVEL "200" -> - { mkCProdN ~loc bl c } + { mkProdCN ~loc bl c } | "fun"; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> - { mkCLambdaN ~loc bl c } + { mkLambdaCN ~loc bl c } | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> { let ty,c1 = match ty, c1 with | (_,None), { CAst.v = CCast(c, CastConv t) } -> (Loc.tag ?loc:(constr_loc t) @@ Some t), c (* Tolerance, see G_vernac.def_body *) | _, _ -> ty, c1 in - CAst.make ~loc @@ CLetIn(id,mkCLambdaN ?loc:(constr_loc c1) bl c1, - Option.map (mkCProdN ?loc:(fst ty) bl) (snd ty), c2) } + CAst.make ~loc @@ CLetIn(id,mkLambdaCN ?loc:(constr_loc c1) bl c1, + Option.map (mkProdCN ?loc:(fst ty) bl) (snd ty), c2) } | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> { let fixp = mk_single_fix fx in let { CAst.loc = li; v = id } = match fixp.CAst.v with diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index e12ccaa636..c05229d576 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -23,17 +23,7 @@ module Gram : sig include Grammar.S with type te = Tok.t - type 'a entry = 'a Entry.e - [@@ocaml.deprecated "Use [Pcoq.Entry.t]"] - - [@@@ocaml.warning "-3"] - - val entry_create : string -> 'a entry - [@@ocaml.deprecated "Use [Pcoq.Entry.create]"] - - val gram_extend : 'a entry -> 'a Extend.extend_statement -> unit - - [@@@ocaml.warning "+3"] + val gram_extend : 'a Entry.e -> 'a Extend.extend_statement -> unit end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index f235bb8986..bdeb6fca60 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -112,17 +112,12 @@ let pseudo_qualify = qualify "__" let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false -[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -let uncapitalize = String.uncapitalize -[@@@ocaml.warning "+3"] - -let lowercase_id id = Id.of_string (uncapitalize (ascii_of_id id)) +let lowercase_id id = Id.of_string (String.uncapitalize_ascii (ascii_of_id id)) let uppercase_id id = let s = ascii_of_id id in assert (not (String.is_empty s)); if s.[0] == '_' then Id.of_string ("Coq_"^s) - else Id.of_string (capitalize s) + else Id.of_string (String.capitalize_ascii s) type kind = Term | Type | Cons | Mod @@ -593,7 +588,7 @@ let pp_global k r = let ls = ref_renaming (k,r) in assert (List.length ls > 1); let s = List.hd ls in - let mp,_,l = repr_of_r r in + let mp,l = repr_of_r r in if ModPath.equal mp (top_visible_mp ()) then (* simpliest situation: definition of r (or use in the same context) *) (* we update the visible environment *) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 5d3115d8d7..b0f6301192 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -30,7 +30,7 @@ open Common let toplevel_env () = let get_reference = function | (_,kn), Lib.Leaf o -> - let mp,_,l = KerName.repr kn in + let mp,l = KerName.repr kn in begin match Libobject.object_tag o with | "CONSTANT" -> let constant = Global.lookup_constant (Constant.make1 kn) in @@ -124,7 +124,7 @@ module Visit : VISIT = struct end let add_field_label mp = function - | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make2 mp lab) + | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make mp lab) | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) let rec add_labels mp = function @@ -208,10 +208,10 @@ let env_for_mtb_with_def env mp me reso idl = Modops.add_structure mp before reso env let make_cst resolver mp l = - Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) + Mod_subst.constant_of_delta_kn resolver (KerName.make mp l) let make_mind resolver mp l = - Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp l) + Mod_subst.mind_of_delta_kn resolver (KerName.make mp l) (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index e6234c1452..97fe9f24d5 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -21,10 +21,8 @@ open Mlutil open Common (*s Haskell renaming issues. *) -[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) -let pr_lower_id id = str (String.uncapitalize (Id.to_string id)) -let pr_upper_id id = str (String.capitalize (Id.to_string id)) -[@@@ocaml.warning "+3"] +let pr_lower_id id = str (String.uncapitalize_ascii (Id.to_string id)) +let pr_upper_id id = str (String.capitalize_ascii (Id.to_string id)) let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index e05e82af6f..7b4fd280bd 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -22,11 +22,6 @@ open Util open Pp open Miniml -[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -[@@@ocaml.warning "+3"] - - (** Sets and maps for [global_reference] that use the "user" [kernel_name] instead of the canonical one *) @@ -41,16 +36,16 @@ let occur_kn_in_ref kn = function | ConstRef _ | VarRef _ -> false let repr_of_r = function - | ConstRef kn -> Constant.repr3 kn + | ConstRef kn -> Constant.repr2 kn | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> MutInd.repr3 kn + | ConstructRef ((kn,_),_) -> MutInd.repr2 kn | VarRef v -> KerName.repr (Lib.make_kn v) let modpath_of_r r = - let mp,_,_ = repr_of_r r in mp + let mp,_ = repr_of_r r in mp let label_of_r r = - let _,_,l = repr_of_r r in l + let _,l = repr_of_r r in l let rec base_mp = function | MPdot (mp,l) -> base_mp mp @@ -61,7 +56,7 @@ let is_modfile = function | _ -> false let raw_string_of_modfile = function - | MPfile f -> capitalize (Id.to_string (List.hd (DirPath.repr f))) + | MPfile f -> String.capitalize_ascii (Id.to_string (List.hd (DirPath.repr f))) | _ -> assert false let is_toplevel mp = @@ -100,7 +95,7 @@ let rec parse_labels2 ll mp1 = function let labels_of_ref r = let mp_top = Lib.current_mp () in - let mp,_,l = repr_of_r r in + let mp,l = repr_of_r r in parse_labels2 [l] mp_top mp @@ -194,7 +189,7 @@ let init_recursors () = recursors := KNset.empty let add_recursors env ind = let kn = MutInd.canonical ind in let mk_kn id = - KerName.make (KerName.modpath kn) DirPath.empty (Label.of_id id) + KerName.make (KerName.modpath kn) (Label.of_id id) in let mib = Environ.lookup_mind ind env in Array.iter @@ -292,7 +287,7 @@ let safe_pr_long_global r = try Printer.pr_global r with Not_found -> match r with | ConstRef kn -> - let mp,_,l = Constant.repr3 kn in + let mp,l = Constant.repr2 kn in str ((ModPath.to_string mp)^"."^(Label.to_string l)) | _ -> assert false @@ -658,8 +653,7 @@ let inline_extraction : bool * GlobRef.t list -> obj = cache_function = (fun (_,(b,l)) -> add_inline_entries b l); load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); classify_function = (fun o -> Substitute o); - discharge_function = - (fun (_,(b,l)) -> Some (b, List.map pop_global_reference l)); + discharge_function = (fun (_,x) -> Some x); subst_function = (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) } @@ -784,7 +778,7 @@ let file_of_modfile mp = let add_blacklist_entries l = blacklist_table := - List.fold_right (fun s -> Id.Set.add (Id.of_string (capitalize s))) + List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize_ascii s))) l !blacklist_table (* Registration of operations for rollback. *) diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index a8baeaf1b6..acc1bfee8a 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -46,7 +46,7 @@ val info_file : string -> unit (*s utilities about [module_path] and [kernel_names] and [GlobRef.t] *) val occur_kn_in_ref : MutInd.t -> GlobRef.t -> bool -val repr_of_r : GlobRef.t -> ModPath.t * DirPath.t * Label.t +val repr_of_r : GlobRef.t -> ModPath.t * Label.t val modpath_of_r : GlobRef.t -> ModPath.t val label_of_r : GlobRef.t -> Label.t val base_mp : ModPath.t -> ModPath.t diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index b2a528a1fd..f7094ebe51 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -322,7 +322,8 @@ let generate_functional_principle (evd: Evd.evar_map ref) try let f = funs.(i) in - let type_sort = Evarutil.evd_comb1 Evd.fresh_sort_in_family evd InType in + let sigma, type_sort = Evd.fresh_sort_in_family !evd InType in + evd := sigma; let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -394,7 +395,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) exception Not_Rec -let get_funs_constant mp dp = +let get_funs_constant mp = let get_funs_constant const e : (Names.Constant.t*int) array = match Constr.kind ((strip_lam e)) with | Fix((_,(na,_,_))) -> @@ -402,7 +403,7 @@ let get_funs_constant mp dp = (fun i na -> match na with | Name id -> - let const = Constant.make3 mp dp (Label.of_id id) in + let const = Constant.make2 mp (Label.of_id id) in const,i | Anonymous -> anomaly (Pp.str "Anonymous fix.") @@ -474,13 +475,13 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in - let funs_mp,funs_dp,_ = KerName.repr (Constant.canonical (fst first_fun)) in + let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in let first_fun_kn = try fst (find_Function_infos (fst first_fun)).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp (fst first_fun) in + let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = @@ -507,8 +508,9 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Evarutil.evd_comb1 Evd.fresh_sort_in_family evd x - ) + let sigma, fs = Evd.fresh_sort_in_family !evd x in + evd := sigma; fs + ) fas in (* We create the first priciple by tactic *) @@ -669,9 +671,9 @@ let build_case_scheme fa = user_err ~hdr:"FunInd.build_case_scheme" (str "Cannot find " ++ Libnames.pr_qualid f) in let first_fun,u = destConst funs in - let funs_mp,funs_dp,_ = Constant.repr3 first_fun in + let funs_mp = Constant.modpath first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in + let this_block_funs_indexes = get_funs_constant funs_mp first_fun in let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 9eda19a86b..9a6169d42a 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -898,11 +898,11 @@ let make_graph (f_ref : GlobRef.t) = let id = Label.to_id (Constant.label c) in [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in - let mp,dp,_ = Constant.repr3 c in + let mp = Constant.modpath c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter - (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make3 mp dp (Label.of_id id))) + (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) expr_list) let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 4eee2c7a45..6ed382ca1c 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -297,36 +297,7 @@ let subst_Function (subst,finfos) = let classify_Function infos = Libobject.Substitute infos -let discharge_Function (_,finfos) = - let function_constant' = Lib.discharge_con finfos.function_constant - and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Option.Smart.map Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Option.Smart.map Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Option.Smart.map Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Option.Smart.map Lib.discharge_con finfos.rect_lemma - and rec_lemma' = Option.Smart.map Lib.discharge_con finfos.rec_lemma - and prop_lemma' = Option.Smart.map Lib.discharge_con finfos.prop_lemma - in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then Some finfos - else - Some { function_constant = function_constant' ; - graph_ind = graph_ind' ; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma'; - rect_lemma = rect_lemma'; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma' ; - is_general = finfos.is_general - } +let discharge_Function (_,finfos) = Some finfos let pr_ocst c = let sigma, env = Pfedit.get_current_context () in diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index ad11f853ca..56fe430077 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -450,7 +450,7 @@ let generalize_dependent_of x hyp g = let tauto = let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in let mp = ModPath.MPfile (DirPath.make dp) in - let kn = KerName.make2 mp (Label.make "tauto") in + let kn = KerName.make mp (Label.make "tauto") in Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> let body = Tacenv.interp_ltac kn in Tacinterp.eval_tactic body diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 7298342e1e..633d98a585 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -713,7 +713,7 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> - let changefun patvars sigma = + let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in Proofview.V82.of_tactic (change_in_concl None changefun) g2); diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 11d13d3a2f..8731cbf60d 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -35,41 +35,6 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type goal_selector = Goal_select.t = - | SelectAlreadyFocused - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectNth of int - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectList of (int * int) list - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectId of Id.t - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectAll - [@ocaml.deprecated "Use constructors in [Goal_select]"] -[@@ocaml.deprecated "Use [Goal_select.t]"] - -type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = - | ElimOnConstr of 'a - [@ocaml.deprecated "Use constructors in [Tactics]"] - | ElimOnIdent of lident - [@ocaml.deprecated "Use constructors in [Tactics]"] - | ElimOnAnonHyp of int - [@ocaml.deprecated "Use constructors in [Tactics]"] -[@@ocaml.deprecated "Use Tactics.core_destruction_arg"] - -type 'a destruction_arg = - clear_flag * 'a Tactics.core_destruction_arg -[@@ocaml.deprecated "Use Tactics.destruction_arg"] - -type inversion_kind = Inv.inversion_kind = - | SimpleInversion - [@ocaml.deprecated "Use constructors in [Inv]"] - | FullInversion - [@ocaml.deprecated "Use constructors in [Inv]"] - | FullInversionClear - [@ocaml.deprecated "Use constructors in [Inv]"] -[@@ocaml.deprecated "Use Tactics.inversion_kind"] - type ('c,'d,'id) inversion_strength = | NonDepInversion of Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 6b131edaac..9958d6dcda 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -35,41 +35,6 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type goal_selector = Goal_select.t = - | SelectAlreadyFocused - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectNth of int - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectList of (int * int) list - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectId of Id.t - [@ocaml.deprecated "Use constructors in [Goal_select]"] - | SelectAll - [@ocaml.deprecated "Use constructors in [Goal_select]"] -[@@ocaml.deprecated "Use Vernacexpr.goal_selector"] - -type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = - | ElimOnConstr of 'a - [@ocaml.deprecated "Use constructors in [Tactics]"] - | ElimOnIdent of lident - [@ocaml.deprecated "Use constructors in [Tactics]"] - | ElimOnAnonHyp of int - [@ocaml.deprecated "Use constructors in [Tactics]"] -[@@ocaml.deprecated "Use Tactics.core_destruction_arg"] - -type 'a destruction_arg = - clear_flag * 'a Tactics.core_destruction_arg -[@@ocaml.deprecated "Use Tactics.destruction_arg"] - -type inversion_kind = Inv.inversion_kind = - | SimpleInversion - [@ocaml.deprecated "Use constructors in [Inv]"] - | FullInversion - [@ocaml.deprecated "Use constructors in [Inv]"] - | FullInversionClear - [@ocaml.deprecated "Use constructors in [Inv]"] -[@@ocaml.deprecated "Use Tactics.inversion_kind"] - type ('c,'d,'id) inversion_strength = | NonDepInversion of Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 9f34df4608..f90e889678 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -283,6 +283,12 @@ let debugging_exception_step ist signal_anomaly e pp = debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) +let ensure_freshness env = + (* We anonymize declarations which we know will not be used *) + (* This assumes that the original context had no rels *) + process_rel_context + (fun d e -> EConstr.push_rel (Context.Rel.Declaration.set_name Anonymous d) e) env + (* Raise Not_found if not in interpretation sign *) let try_interp_ltac_var coerce ist env {loc;v=id} = let v = Id.Map.find id ist.lfun in @@ -1740,15 +1746,15 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars sigma = + let c_interp patvars env sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c + then interp_type ist env sigma c + else interp_constr ist env sigma c in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end @@ -1761,11 +1767,12 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma = project gl in let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in - let c_interp patvars sigma = + let c_interp patvars env sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in + let env = ensure_freshness env in let ist = { ist with lfun = lfun' } in try interp_constr ist env sigma c diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg index c3d063cff8..85081b24a3 100644 --- a/plugins/omega/g_omega.mlg +++ b/plugins/omega/g_omega.mlg @@ -27,7 +27,7 @@ open Stdarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in + let kn = KerName.make (ModPath.MPfile dp) (Label.make name) in let tac = Tacenv.interp_ltac kn in Tacinterp.eval_tactic tac diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index b05e1e85b7..0734654abf 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -266,7 +266,7 @@ let my_reference c = let znew_ring_path = DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = - lazy(KerName.make (ModPath.MPfile znew_ring_path) DirPath.empty (Label.make s)) + lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s);; let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; @@ -760,7 +760,7 @@ let new_field_path = DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"]) let field_ltac s = - lazy(KerName.make (ModPath.MPfile new_field_path) DirPath.empty (Label.make s)) + lazy(KerName.make (ModPath.MPfile new_field_path) (Label.make s)) let _ = add_map "field" diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index f23433f2f4..2af917b939 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -337,9 +337,9 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) let elim, _ = destConst elim in - let mp,dp,l = Constant.repr3 (Constant.make1 (Constant.canonical elim)) in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make3 mp dp l')) in + let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in mkConst c1', gl in let elim = EConstr.of_constr elim in let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 53153198f9..8ee6fbf036 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -24,7 +24,6 @@ open Coqlib exception Non_closed_ascii let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with @@ -32,10 +31,12 @@ let is_gr c gr = match DAst.get c with | _ -> false let ascii_module = ["Coq";"Strings";"Ascii"] +let ascii_modpath = MPfile (make_dir ascii_module) let ascii_path = make_path ascii_module "ascii" -let ascii_kn = make_kn ascii_module "ascii" +let ascii_label = Label.make "ascii" +let ascii_kn = MutInd.make2 ascii_modpath ascii_label let path_of_Ascii = ((ascii_kn,0),1) let static_glob_Ascii = ConstructRef path_of_Ascii diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 49497aef54..776d2a2229 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -33,12 +33,10 @@ let is_gr c gr = match DAst.get c with | GRef (r, _) -> GlobRef.equal r gr | _ -> false +let positive_modpath = MPfile (make_dir binnums) let positive_path = make_path binnums "positive" -(* TODO: temporary hack *) -let make_kn dir id = Globnames.encode_mind dir id - -let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") +let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") let glob_positive = IndRef (positive_kn,0) let path_of_xI = ((positive_kn,0),1) let path_of_xO = ((positive_kn,0),2) @@ -74,7 +72,7 @@ let rec bignat_of_pos c = match DAst.get c with (**********************************************************************) let z_path = make_path binnums "Z" -let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") +let z_kn = MutInd.make2 positive_modpath (Label.make "Z") let glob_z = IndRef (z_kn,0) let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) @@ -106,12 +104,10 @@ let bigint_of_z c = match DAst.get c with (**********************************************************************) let rdefinitions = ["Coq";"Reals";"Rdefinitions"] +let r_modpath = MPfile (make_dir rdefinitions) let r_path = make_path rdefinitions "R" -(* TODO: temporary hack *) -let make_path dir id = Globnames.encode_con dir (Id.of_string id) - -let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") +let glob_IZR = ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") let r_of_int ?loc z = DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 7478c1e978..703b40dd3e 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -24,9 +24,10 @@ exception Non_closed_string let string_module = ["Coq";"Strings";"String"] +let string_modpath = MPfile (make_dir string_module) let string_path = make_path string_module "string" -let string_kn = make_kn string_module "string" +let string_kn = MutInd.make2 string_modpath @@ Label.make "string" let static_glob_EmptyString = ConstructRef ((string_kn,0),1) let static_glob_String = ConstructRef ((string_kn,0),2) diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index b8958ca944..3da1ab7439 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -46,10 +46,9 @@ let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try let vars = Lib.variable_section_segment_of_reference c in - let c' = pop_global_reference c in let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in let names' = var_names @ names in - Some (ReqGlobal (c', names), (c', names')) + Some (ReqGlobal (c, names), (c, names')) with Not_found -> Some req) | _ -> None diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 37dd3708b3..9fa8442f8a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -408,7 +408,7 @@ let coerce_to_indtype typing_fun env sigma matx tomatchl = (* Utils *) let mkExistential ?(src=(Loc.tag Evar_kinds.InternalHole)) env sigma = - let sigma, (e, u) = new_type_evar env sigma ~src:src univ_flexible_alg in + let sigma, (e, u) = Evarutil.new_type_evar env sigma ~src:src univ_flexible_alg in sigma, e let adjust_tomatch_to_pattern sigma pb ((current,typ),deps,dep) = @@ -1713,7 +1713,8 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let vl = List.map pi1 good in let ty = let ty = get_type_of !!env sigma t in - Evarutil.evd_comb1 (refresh_universes (Some false) !!env) evdref ty + let sigma, res = refresh_universes (Some false) !!env !evdref ty in + evdref := sigma; res in let dummy_subst = List.init k (fun _ -> mkProp) in let ty = substl dummy_subst (aux x ty) in @@ -1748,7 +1749,7 @@ let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = let n = Context.Rel.length (rel_context !!env) in let n' = Context.Rel.length (rel_context !!tycon_env) in let sigma, (impossible_case_type, u) = - new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) + Evarutil.new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) sigma univ_flexible_alg in (sigma, lift (n'-n) impossible_case_type, mkSort u) @@ -2037,7 +2038,7 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = | None -> (* No type constraint: we first create a generic evar type constraint *) let src = (loc, Evar_kinds.CasesType false) in - let sigma, (t, _) = new_type_evar !!env sigma univ_flexible_alg ~src in + let sigma, (t, _) = Evarutil.new_type_evar !!env sigma univ_flexible_alg ~src in sigma, t in (* First strategy: we build an "inversion" predicate, also replacing the *) (* dependencies with existential variables *) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index b264e31474..b026397abf 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -451,12 +451,6 @@ let subst_coercion (subst, c) = else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt; coercion_is_proj = clp; } -let discharge_cl = function - | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) - | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) - | CL_PROJ p -> CL_PROJ (Lib.discharge_proj_repr p) - | cl -> cl - let discharge_coercion (_, c) = if c.coercion_local then None else @@ -467,9 +461,6 @@ let discharge_coercion (_, c) = with Not_found -> 0 in let nc = { c with - coercion_type = Lib.discharge_global c.coercion_type; - coercion_source = discharge_cl c.coercion_source; - coercion_target = discharge_cl c.coercion_target; coercion_params = n + c.coercion_params; coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; } in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 7d480b8d48..bae13dbba1 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -227,13 +227,23 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) +let join_failures evd1 evd2 e1 e2 = + match e1, e2 with + | _, CannotSolveConstraint (_,ProblemBeyondCapabilities) -> (evd1,e1) + | _ -> (evd2,e2) + let rec ise_try evd = function [] -> assert false | [f] -> f evd | f1::l -> match f1 evd with | Success _ as x -> x - | UnifFailure _ -> ise_try evd l + | UnifFailure (evd1,e1) -> + match ise_try evd l with + | Success _ as x -> x + | UnifFailure (evd2,e2) -> + let evd,e = join_failures evd1 evd2 e1 e2 in + UnifFailure (evd,e) let ise_and evd l = let rec ise_and i = function @@ -1376,8 +1386,6 @@ let solve_unif_constraints_with_heuristics env check_problems_are_solved env heuristic_solved_evd; solve_unconstrained_impossible_cases env heuristic_solved_evd -let consider_remaining_unif_problems = solve_unif_constraints_with_heuristics - (* Main entry points *) exception UnableToUnify of evar_map * unification_error @@ -1404,13 +1412,3 @@ let conv env ?(ts=default_transparent_state env) evd t1 t2 = let cumul env ?(ts=default_transparent_state env) evd t1 t2 = make_opt(evar_conv_x ts env evd CUMUL t1 t2) - -let e_conv env ?(ts=default_transparent_state env) evdref t1 t2 = - match evar_conv_x ts env !evdref CONV t1 t2 with - | Success evd' -> evdref := evd'; true - | _ -> false - -let e_cumul env ?(ts=default_transparent_state env) evdref t1 t2 = - match evar_conv_x ts env !evdref CUMUL t1 t2 with - | Success evd' -> evdref := evd'; true - | _ -> false diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index cdf5dd0e50..20a4f34ec7 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -27,12 +27,6 @@ val the_conv_x_leq : env -> ?ts:transparent_state -> constr -> constr -> evar_ma (** The same function resolving evars by side-effect and catching the exception *) -val e_conv : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -> bool -[@@ocaml.deprecated "Use [Evarconv.conv]"] - -val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -> bool -[@@ocaml.deprecated "Use [Evarconv.cumul]"] - val conv : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option val cumul : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option @@ -43,9 +37,6 @@ val cumul : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map -val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map -[@@ocaml.deprecated "Alias for [solve_unif_constraints_with_heuristics]"] - (** Check all pending unification problems are solved and raise an error otherwise *) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 2dd3721980..44bfe4b6cc 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -46,7 +46,8 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) (* direction: true for fresh universes lower than the existing ones *) let refresh_sort status ~direction s = let s = ESorts.kind !evdref s in - let s' = evd_comb0 (new_sort_variable status) evdref in + let sigma, s' = new_sort_variable status !evdref in + evdref := sigma; let evd = if direction then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' @@ -1690,8 +1691,6 @@ let reconsider_unif_constraints conv_algo evd = (Success evd) pbs -let reconsider_conv_pbs = reconsider_unif_constraints - (* Tries to solve problem t1 = t2. * Precondition: t1 is an uninstantiated evar * Returns an optional list of evars that were instantiated, or None diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 3f05c58c41..4665ed29a2 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -62,9 +62,6 @@ val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result -val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result -[@@ocaml.deprecated "Alias for [reconsider_unif_constraints]"] - val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> constr -> alias list option diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 63a66b471b..49a08afe80 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -94,7 +94,7 @@ let push_rec_types sigma (lna,typarray) env = let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e in (e,d)) env ctxt in Array.map get_name ctx, env -let e_new_evar env evdref ?src ?naming typ = +let new_evar env sigma ?src ?naming typ = let open Context.Named.Declaration in let inst_vars = List.map (get_id %> mkVar) (named_context env.renamed_env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.renamed_env)) in @@ -102,15 +102,11 @@ let e_new_evar env evdref ?src ?naming typ = let typ' = csubst_subst subst typ in let instance = inst_rels @ inst_vars in let sign = val_of_named_context nc in - let sigma = !evdref in - let (sigma, e) = new_evar_instance sign sigma typ' ?src ?naming instance in - evdref := sigma; - e + new_evar_instance sign sigma typ' ?src ?naming instance -let e_new_type_evar env evdref ~src = - let (evd', s) = Evd.new_sort_variable Evd.univ_flexible_alg !evdref in - evdref := evd'; - e_new_evar env evdref ~src (EConstr.mkSort s) +let new_type_evar env sigma ~src = + let sigma, s = Evd.new_sort_variable Evd.univ_flexible_alg sigma in + new_evar env sigma ~src (EConstr.mkSort s) let hide_variable env expansion id = let lvar = env.lvar in @@ -150,13 +146,13 @@ let invert_ltac_bound_name env id0 id = str " depends on pattern variable name " ++ Id.print id ++ str " which is not bound in current context.") -let interp_ltac_variable ?loc typing_fun env sigma id = +let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_judgment = (* Check if [id] is an ltac variable *) try let (ids,c) = Id.Map.find id env.lvar.ltac_constrs in let subst = List.map (invert_ltac_bound_name env id) ids in let c = substl subst c in - { uj_val = c; uj_type = protected_get_type_of env.renamed_env sigma c } + sigma, { uj_val = c; uj_type = protected_get_type_of env.renamed_env sigma c } with Not_found -> try let {closure;term} = Id.Map.find id env.lvar.ltac_uconstrs in diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 70a7ee6e2f..e8a2fbdd16 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -53,10 +53,10 @@ val push_rec_types : evar_map -> Name.t array * constr array -> t -> Name.t arra (** Declare an evar using renaming information *) -val e_new_evar : t -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> - ?naming:Namegen.intro_pattern_naming_expr -> constr -> constr +val new_evar : t -> evar_map -> ?src:Evar_kinds.t Loc.located -> + ?naming:Namegen.intro_pattern_naming_expr -> constr -> evar_map * constr -val e_new_type_evar : t -> evar_map ref -> src:Evar_kinds.t Loc.located -> constr +val new_type_evar : t -> evar_map -> src:Evar_kinds.t Loc.located -> evar_map * constr (** [hide_variable env na id] tells to hide the binding of [id] in the ltac environment part of [env] and to additionally rebind @@ -73,8 +73,8 @@ val hide_variable : t -> Name.t -> Id.t -> t (** In case a variable is not bound by a term binder, look if it has an interpretation as a term in the ltac_var_map *) -val interp_ltac_variable : ?loc:Loc.t -> (t -> Glob_term.glob_constr -> unsafe_judgment) -> - t -> evar_map -> Id.t -> unsafe_judgment +val interp_ltac_variable : ?loc:Loc.t -> (t -> Glob_term.glob_constr -> evar_map * unsafe_judgment) -> + t -> evar_map -> Id.t -> evar_map * unsafe_judgment (** Interp an identifier as an ltac variable bound to an identifier, or as the identifier itself if not bound to an ltac variable *) diff --git a/pretyping/heads.ml b/pretyping/heads.ml index 7d9debce34..a3e4eb8971 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -14,7 +14,6 @@ open Constr open Vars open Mod_subst open Environ -open Globnames open Libobject open Lib open Context.Named.Declaration @@ -171,7 +170,7 @@ let subst_head (subst,(ref,k)) = let discharge_head (_,(ref,k)) = match ref with - | EvalConstRef cst -> Some (EvalConstRef (pop_con cst), k) + | EvalConstRef cst -> Some (ref, k) | EvalVarRef id -> None let rebuild_head (ref,k) = diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 418fdf2a26..e49ba75b3f 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -455,8 +455,8 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = | ((indi,u),_,_,dep,kinds)::rest -> let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list mkRel i lnamesparrec) in let s = - Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg) - evdref kinds + let sigma, res = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg !evdref kinds in + evdref := sigma; res in let typP = make_arity env !evdref dep indf s in let typP = EConstr.Unsafe.to_constr typP in @@ -601,13 +601,13 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s) let lookup_eliminator ind_sp s = let kn,i = ind_sp in - let mp,dp,l = KerName.repr (MutInd.canonical kn) in + let mp,l = KerName.repr (MutInd.canonical kn) in let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in let id = add_suffix ind_id (elimination_suffix s) in (* Try first to get an eliminator defined in the same section as the *) (* inductive type *) try - let cst =Global.constant_of_delta_kn (KerName.make mp dp (Label.of_id id)) in + let cst =Global.constant_of_delta_kn (KerName.make mp (Label.of_id id)) in let _ = Global.lookup_constant cst in ConstRef cst with Not_found -> diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 0fa573b9a6..ea222397a8 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -269,10 +269,6 @@ let allowed_sorts env (kn,i as ind) = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_kelim -let projection_nparams_env _ p = Projection.npars p - -let projection_nparams p = Projection.npars p - let has_dependent_elim mib = match mib.mind_record with | PrimRecord _ -> mib.mind_finite == BiFinite diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index ea34707bfc..b2e205115f 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -129,15 +129,9 @@ val allowed_sorts : env -> inductive -> Sorts.family list val has_dependent_elim : mutual_inductive_body -> bool (** Primitive projections *) -val projection_nparams : Projection.t -> int -[@@ocaml.deprecated "Use [Projection.npars]"] -val projection_nparams_env : env -> Projection.t -> int -[@@ocaml.deprecated "Use [Projection.npars]"] - val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> EConstr.t -> EConstr.types -> types - (** Extract information from an inductive family *) type constructor_summary = { @@ -152,8 +146,6 @@ val get_constructor : pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_constructors : env -> inductive_family -> constructor_summary array -val get_projections : env -> inductive -> Projection.Repr.t array option -[@@ocaml.deprecated "Use [Environ.get_projections]"] (** [get_arity] returns the arity of the inductive family instantiated with the parameters; if recursively non-uniform parameters are not diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 1b7f32bcae..495f5c0660 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -231,24 +231,26 @@ let frozen_and_pending_holes (sigma, sigma') = end in FrozenProgress data -let apply_typeclasses env evdref frozen fail_evar = +let apply_typeclasses env sigma frozen fail_evar = let filter_frozen = match frozen with - | FrozenId map -> fun evk -> Evar.Map.mem evk map - | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen + | FrozenId map -> fun evk -> Evar.Map.mem evk map + | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen in - evdref := Typeclasses.resolve_typeclasses - ~filter:(if Flags.is_program_mode () - then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) - else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) - ~split:true ~fail:fail_evar env !evdref; - if Flags.is_program_mode () then (* Try optionally solving the obligations *) - evdref := Typeclasses.resolve_typeclasses - ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env !evdref - -let apply_inference_hook hook evdref frozen = match frozen with -| FrozenId _ -> () + let sigma = Typeclasses.resolve_typeclasses + ~filter:(if Flags.is_program_mode () + then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) + else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) + ~split:true ~fail:fail_evar env sigma in + let sigma = if Flags.is_program_mode () then (* Try optionally solving the obligations *) + Typeclasses.resolve_typeclasses + ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env sigma + else sigma in + sigma + +let apply_inference_hook hook sigma frozen = match frozen with +| FrozenId _ -> sigma | FrozenProgress (lazy (_, pending)) -> - evdref := Evar.Set.fold (fun evk sigma -> + Evar.Set.fold (fun evk sigma -> if Evd.is_undefined sigma evk (* in particular not defined by side-effect *) then try @@ -257,18 +259,19 @@ let apply_inference_hook hook evdref frozen = match frozen with with Exit -> sigma else - sigma) pending !evdref + sigma) pending sigma -let apply_heuristics env evdref fail_evar = +let apply_heuristics env sigma fail_evar = (* Resolve eagerly, potentially making wrong choices *) - try evdref := solve_unif_constraints_with_heuristics - ~ts:(Typeclasses.classes_transparent_state ()) env !evdref + try solve_unif_constraints_with_heuristics + ~ts:(Typeclasses.classes_transparent_state ()) env sigma with e when CErrors.noncritical e -> - let e = CErrors.push e in if fail_evar then iraise e + let e = CErrors.push e in + if fail_evar then iraise e else sigma let check_typeclasses_instances_are_solved env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses env (ref current_sigma) frozen true + apply_typeclasses env current_sigma frozen true let check_extra_evars_are_solved env current_sigma frozen = match frozen with | FrozenId _ -> () @@ -297,22 +300,30 @@ let check_evars env initial_sigma sigma c = | _ -> EConstr.iter sigma proc_rec c in proc_rec c -let check_evars_are_solved env current_sigma frozen = - check_typeclasses_instances_are_solved env current_sigma frozen; - check_problems_are_solved env current_sigma; - check_extra_evars_are_solved env current_sigma frozen +let check_evars_are_solved env sigma frozen = + let sigma = check_typeclasses_instances_are_solved env sigma frozen in + check_problems_are_solved env sigma; + check_extra_evars_are_solved env sigma frozen (* Try typeclasses, hooks, unification heuristics ... *) -let solve_remaining_evars flags env current_sigma init_sigma = - let frozen = frozen_and_pending_holes (init_sigma, current_sigma) in - let evdref = ref current_sigma in - if flags.use_typeclasses then apply_typeclasses env evdref frozen false; - if Option.has_some flags.use_hook then - apply_inference_hook (Option.get flags.use_hook env) evdref frozen; - if flags.solve_unification_constraints then apply_heuristics env evdref false; - if flags.fail_evar then check_evars_are_solved env !evdref frozen; - !evdref +let solve_remaining_evars flags env sigma init_sigma = + let frozen = frozen_and_pending_holes (init_sigma, sigma) in + let sigma = + if flags.use_typeclasses + then apply_typeclasses env sigma frozen false + else sigma + in + let sigma = if Option.has_some flags.use_hook + then apply_inference_hook (Option.get flags.use_hook env) sigma frozen + else sigma + in + let sigma = if flags.solve_unification_constraints + then apply_heuristics env sigma false + else sigma + in + if flags.fail_evar then check_evars_are_solved env sigma frozen; + sigma let check_evars_are_solved env current_sigma init_sigma = let frozen = frozen_and_pending_holes (init_sigma, current_sigma) in @@ -323,10 +334,10 @@ let process_inference_flags flags env initial_sigma (sigma,c,cty) = let c = if flags.expand_evars then nf_evar sigma c else c in sigma,c,cty -let adjust_evar_source evdref na c = - match na, kind !evdref c with +let adjust_evar_source sigma na c = + match na, kind sigma c with | Name id, Evar (evk,args) -> - let evi = Evd.find !evdref evk in + let evi = Evd.find sigma evk in begin match evi.evar_source with | loc, Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=b; @@ -338,18 +349,17 @@ let adjust_evar_source evdref na c = Evar_kinds.qm_name=na; Evar_kinds.qm_record_field=recfieldname; }) in - let (evd, evk') = restrict_evar !evdref evk (evar_filter evi) ~src None in - evdref := evd; - mkEvar (evk',args) - | _ -> c + let (sigma, evk') = restrict_evar sigma evk (evar_filter evi) ~src None in + sigma, mkEvar (evk',args) + | _ -> sigma, c end - | _, _ -> c + | _, _ -> sigma, c (* coerce to tycon if any *) -let inh_conv_coerce_to_tycon ?loc resolve_tc env evdref j = function - | None -> j +let inh_conv_coerce_to_tycon ?loc resolve_tc env sigma j = function + | None -> sigma, j | Some t -> - evd_comb2 (Coercion.inh_conv_coerce_to ?loc resolve_tc !!env) evdref j t + Coercion.inh_conv_coerce_to ?loc resolve_tc !!env sigma j t let check_instance loc subst = function | [] -> () @@ -366,18 +376,18 @@ let orelse_name name name' = match name with | Anonymous -> name' | _ -> name -let pretype_id pretype k0 loc env evdref id = +let pretype_id pretype k0 loc env sigma id = (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context !!env) in - { uj_val = mkRel n; uj_type = lift n typ } + sigma, { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> try - GlobEnv.interp_ltac_variable ?loc (fun env -> pretype env evdref) env !evdref id + GlobEnv.interp_ltac_variable ?loc (fun env -> pretype env sigma) env sigma id with Not_found -> (* Check if [id] is a section or goal variable *) try - { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id !!env) } + sigma, { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id !!env) } with Not_found -> (* [id] not found, standard error message *) error_var_not_found ?loc id @@ -422,24 +432,22 @@ let pretype_global ?loc rigid env evd gr us = let len = Univ.AUContext.size ctx in interp_instance ?loc evd ~len l in - let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance !!env evd gr in - (sigma, c) + Evd.fresh_global ?loc ~rigid ?names:instance !!env evd gr -let pretype_ref ?loc evdref env ref us = +let pretype_ref ?loc sigma env ref us = match ref with | VarRef id -> (* Section variable *) - (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) + (try sigma, make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) Pretype_errors.error_var_not_found ?loc id) | ref -> - let evd, c = pretype_global ?loc univ_flexible env !evdref ref us in - let () = evdref := evd in - let ty = unsafe_type_of !!env evd c in - make_judge c ty + let sigma, c = pretype_global ?loc univ_flexible env sigma ref us in + let ty = unsafe_type_of !!env sigma c in + sigma, make_judge c ty let judge_of_Type ?loc evd s = let evd, s = interp_universe ?loc evd s in @@ -448,19 +456,19 @@ let judge_of_Type ?loc evd s = in evd, judge -let pretype_sort ?loc evdref = function - | GProp -> judge_of_prop - | GSet -> judge_of_set - | GType s -> evd_comb1 (judge_of_Type ?loc) evdref s +let pretype_sort ?loc sigma = function + | GProp -> sigma, judge_of_prop + | GSet -> sigma, judge_of_set + | GType s -> judge_of_Type ?loc sigma s -let new_type_evar env evdref loc = - e_new_type_evar env evdref ~src:(Loc.tag ?loc Evar_kinds.InternalHole) +let new_type_evar env sigma loc = + new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) -(* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) -(* in environment [env], with existential variables [evdref] and *) +(* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) +(* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref t = +let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc resolve_tc in let pretype_type = pretype_type k0 resolve_tc in let pretype = pretype k0 resolve_tc in @@ -468,36 +476,35 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref let loc = t.CAst.loc in match DAst.get t with | GRef (ref,u) -> - inh_conv_coerce_to_tycon ?loc env evdref - (pretype_ref ?loc evdref env ref u) - tycon + let sigma, t_ref = pretype_ref ?loc sigma env ref u in + inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - inh_conv_coerce_to_tycon ?loc env evdref - (pretype_id (fun e r t -> pretype tycon e r t) k0 loc env evdref id) - tycon + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in + inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> (* Ne faudrait-il pas s'assurer que hyps est bien un - sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) + sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) let id = interp_ltac_id env id in let evk = - try Evd.evar_key id !evdref + try Evd.evar_key id sigma with Not_found -> user_err ?loc (str "Unknown existential variable.") in - let hyps = evar_filtered_context (Evd.find !evdref evk) in - let args = pretype_instance k0 resolve_tc env evdref loc hyps evk inst in + let hyps = evar_filtered_context (Evd.find sigma evk) in + let sigma, args = pretype_instance k0 resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in - let j = (Retyping.get_judgment_of !!env !evdref c) in - inh_conv_coerce_to_tycon ?loc env evdref j tycon + let j = Retyping.get_judgment_of !!env sigma c in + inh_conv_coerce_to_tycon ?loc env sigma j tycon | GPatVar kind -> - let ty = + let sigma, ty = match tycon with - | Some ty -> ty - | None -> new_type_evar env evdref loc in + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in let k = Evar_kinds.MatchingVar kind in - { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } + let sigma, uj_val = new_evar env sigma ~src:(loc,k) ty in + sigma, { uj_val; uj_type = ty } | GHole (k, naming, None) -> let open Namegen in @@ -505,75 +512,75 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref | IntroIdentifier id -> IntroIdentifier (interp_ltac_id env id) | IntroAnonymous -> IntroAnonymous | IntroFresh id -> IntroFresh (interp_ltac_id env id) in - let ty = + let sigma, ty = match tycon with - | Some ty -> ty - | None -> new_type_evar env evdref loc in - { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in + let sigma, uj_val = new_evar env sigma ~src:(loc,k) ~naming ty in + sigma, { uj_val; uj_type = ty } | GHole (k, _naming, Some arg) -> - let ty = + let sigma, ty = match tycon with - | Some ty -> ty - | None -> new_type_evar env evdref loc in - let (c, sigma) = GlobEnv.interp_glob_genarg env !evdref ty arg in - let () = evdref := sigma in - { uj_val = c; uj_type = ty } + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in + let c, sigma = GlobEnv.interp_glob_genarg env sigma ty arg in + sigma, { uj_val = c; uj_type = ty } | GRec (fixkind,names,bl,lar,vdef) -> - let rec type_bl env ctxt = function - | [] -> ctxt + let rec type_bl env sigma ctxt = function + | [] -> sigma, ctxt | (na,bk,None,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref ty in + let sigma, ty' = pretype_type empty_valcon env sigma ty in let dcl = LocalAssum (na, ty'.utj_val) in - let dcl', env = push_rel !evdref dcl env in - type_bl env (Context.Rel.add dcl' ctxt) bl + let dcl', env = push_rel sigma dcl env in + type_bl env sigma (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref bd in + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let sigma, bd' = pretype (mk_tycon ty'.utj_val) env sigma bd in let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in - let dcl', env = push_rel !evdref dcl env in - type_bl env (Context.Rel.add dcl' ctxt) bl in - let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in - let larj = - Array.map2 - (fun e ar -> - pretype_type empty_valcon (snd (push_rel_context !evdref e env)) evdref ar) - ctxtv lar in + let dcl', env = push_rel sigma dcl env in + type_bl env sigma (Context.Rel.add dcl' ctxt) bl in + let sigma, ctxtv = Array.fold_left_map (fun sigma -> type_bl env sigma Context.Rel.empty) sigma bl in + let sigma, larj = + Array.fold_left2_map + (fun sigma e ar -> + pretype_type empty_valcon (snd (push_rel_context sigma e env)) sigma ar) + sigma ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in - let () = + let sigma = match tycon with - | Some t -> + | Some t -> let fixi = match fixkind with | GFix (vn,i) -> i | GCoFix i -> i in - begin match conv !!env !evdref ftys.(fixi) t with - | None -> () - | Some sigma -> evdref := sigma + begin match conv !!env sigma ftys.(fixi) t with + | None -> sigma + | Some sigma -> sigma end - | None -> () + | None -> sigma in (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let names,newenv = push_rec_types !evdref (names,ftys) env in - let vdefj = - Array.map2_i - (fun i ctxt def -> - (* we lift nbfix times the type in tycon, because of - * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum !evdref (Context.Rel.length ctxt) - (lift nbfix ftys.(i)) in - let ctxt,nenv = push_rel_context !evdref ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) - ctxtv vdef in - evdref := Typing.check_type_fixpoint ?loc !!env !evdref names ftys vdefj; - let nf c = nf_evar !evdref c in + let names,newenv = push_rec_types sigma (names,ftys) env in + let sigma, vdefj = + Array.fold_left2_map_i + (fun i sigma ctxt def -> + (* we lift nbfix times the type in tycon, because of + * the nbfix variables pushed to newenv *) + let (ctxt,ty) = + decompose_prod_n_assum sigma (Context.Rel.length ctxt) + (lift nbfix ftys.(i)) in + let ctxt,nenv = push_rel_context sigma ctxt newenv in + let sigma, j = pretype (mk_tycon ty) nenv sigma def in + sigma, { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + sigma ctxtv vdef in + let sigma = Typing.check_type_fixpoint ?loc !!env sigma names ftys vdefj in + let nf c = nf_evar sigma c in let ftys = Array.map nf ftys in (** FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in let fixj = match fixkind with @@ -594,43 +601,43 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref let fixdecls = (names,ftys,fdefs) in let indexes = search_guard - ?loc !!env possible_indexes (nf_fix !evdref fixdecls) + ?loc !!env possible_indexes (nf_fix sigma fixdecls) in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let fixdecls = (names,ftys,fdefs) in let cofix = (i, fixdecls) in - (try check_cofix !!env (i, nf_fix !evdref fixdecls) + (try check_cofix !!env (i, nf_fix sigma fixdecls) with reraise -> let (e, info) = CErrors.push reraise in let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info)); make_judge (mkCoFix cofix) ftys.(i) in - inh_conv_coerce_to_tycon ?loc env evdref fixj tycon + inh_conv_coerce_to_tycon ?loc env sigma fixj tycon | GSort s -> - let j = pretype_sort ?loc evdref s in - inh_conv_coerce_to_tycon ?loc env evdref j tycon + let sigma, j = pretype_sort ?loc sigma s in + inh_conv_coerce_to_tycon ?loc env sigma j tycon | GApp (f,args) -> - let fj = pretype empty_tycon env evdref f in + let sigma, fj = pretype empty_tycon env sigma f in let floc = loc_of_glob_constr f in let length = List.length args in let candargs = (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct !evdref fj.uj_val then + if Flags.is_program_mode () && length > 0 && isConstruct sigma fj.uj_val then match tycon with | None -> [] | Some ty -> - let ((ind, i), u) = destConstruct !evdref fj.uj_val in + let ((ind, i), u) = destConstruct sigma fj.uj_val in let npars = inductive_nparams ind in if Int.equal npars 0 then [] else try - let IndType (indf, args) = find_rectype !!env !evdref ty in + let IndType (indf, args) = find_rectype !!env sigma ty in let ((ind',u'),pars) = dest_ind_family indf in if eq_ind ind ind' then List.map EConstr.of_constr pars else (* Let the usual code throw an error *) [] @@ -638,94 +645,91 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref else [] in let app_f = - match EConstr.kind !evdref fj.uj_val with + match EConstr.kind sigma fj.uj_val with | Const (p, u) when Recordops.is_primitive_projection p -> let p = Option.get @@ Recordops.find_primitive_projection p in - let p = Projection.make p false in + let p = Projection.make p false in let npars = Projection.npars p in - fun n -> - if n == npars + 1 then fun _ v -> mkProj (p, v) - else fun f v -> applist (f, [v]) + fun n -> + if n == npars + 1 then fun _ v -> mkProj (p, v) + else fun f v -> applist (f, [v]) | _ -> fun _ f v -> applist (f, [v]) in - let rec apply_rec env n resj candargs = function - | [] -> resj + let rec apply_rec env sigma n resj candargs = function + | [] -> sigma, resj | c::rest -> - let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc !!env) evdref resj in - let resty = whd_all !!env !evdref resj.uj_type in - match EConstr.kind !evdref resty with - | Prod (na,c1,c2) -> - let tycon = Some c1 in - let hj = pretype tycon env evdref c in - let candargs, ujval = - match candargs with - | [] -> [], j_val hj - | arg :: args -> - begin match conv !!env !evdref (j_val hj) arg with - | Some sigma -> evdref := sigma; - args, nf_evar !evdref (j_val hj) - | None -> - [], j_val hj - end - in - let ujval = adjust_evar_source evdref na ujval in + let argloc = loc_of_glob_constr c in + let sigma, resj = Coercion.inh_app_fun resolve_tc !!env sigma resj in + let resty = whd_all !!env sigma resj.uj_type in + match EConstr.kind sigma resty with + | Prod (na,c1,c2) -> + let tycon = Some c1 in + let sigma, hj = pretype tycon env sigma c in + let sigma, candargs, ujval = + match candargs with + | [] -> sigma, [], j_val hj + | arg :: args -> + begin match conv !!env sigma (j_val hj) arg with + | Some sigma -> + sigma, args, nf_evar sigma (j_val hj) + | None -> + sigma, [], j_val hj + end + in + let sigma, ujval = adjust_evar_source sigma na ujval in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in let j = { uj_val = value; uj_type = typ } in - apply_rec env (n+1) j candargs rest - + apply_rec env sigma (n+1) j candargs rest | _ -> - let hj = pretype empty_tycon env evdref c in + let sigma, hj = pretype empty_tycon env sigma c in error_cant_apply_not_functional - ?loc:(Loc.merge_opt floc argloc) !!env !evdref - resj [|hj|] + ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in - let resj = apply_rec env 1 fj candargs args in - let resj = - match EConstr.kind !evdref resj.uj_val with + let sigma, resj = apply_rec env sigma 1 fj candargs args in + let sigma, resj = + match EConstr.kind sigma resj.uj_val with | App (f,args) -> - if is_template_polymorphic !!env !evdref f then + if is_template_polymorphic !!env sigma f then (* Special case for inductive type applications that must be refreshed right away. *) - let c = mkApp (f, args) in - let c = evd_comb1 (Evarsolve.refresh_universes (Some true) !!env) evdref c in - let t = Retyping.get_type_of !!env !evdref c in - make_judge c (* use this for keeping evars: resj.uj_val *) t - else resj - | _ -> resj + let c = mkApp (f, args) in + let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in + let t = Retyping.get_type_of !!env sigma c in + sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t + else sigma, resj + | _ -> sigma, resj in - inh_conv_coerce_to_tycon ?loc env evdref resj tycon + inh_conv_coerce_to_tycon ?loc env sigma resj tycon | GLambda(name,bk,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod ?loc !!env evd ty in - evd, Some ty') - evdref tycon + let sigma, tycon' = + match tycon with + | None -> sigma, tycon + | Some ty -> + let sigma, ty' = Coercion.inh_coerce_to_prod ?loc !!env sigma ty in + sigma, Some ty' in - let (name',dom,rng) = evd_comb1 (split_tycon ?loc !!env) evdref tycon' in + let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env evdref c1 in + let sigma, j = pretype_type dom_valcon env sigma c1 in let var = LocalAssum (name, j.utj_val) in - let var',env' = push_rel !evdref var env in - let j' = pretype rng env' evdref c2 in + let var',env' = push_rel sigma var env in + let sigma, j' = pretype rng env' sigma c2 in let name = get_name var' in let resj = judge_of_abstraction !!env (orelse_name name name') j j' in - inh_conv_coerce_to_tycon ?loc env evdref resj tycon + inh_conv_coerce_to_tycon ?loc env sigma resj tycon | GProd(name,bk,c1,c2) -> - let j = pretype_type empty_valcon env evdref c1 in - let name, j' = match name with + let sigma, j = pretype_type empty_valcon env sigma c1 in + let sigma, name, j' = match name with | Anonymous -> - let j = pretype_type empty_valcon env evdref c2 in - name, { j with utj_val = lift 1 j.utj_val } + let sigma, j = pretype_type empty_valcon env sigma c2 in + sigma, name, { j with utj_val = lift 1 j.utj_val } | Name _ -> let var = LocalAssum (name, j.utj_val) in - let var, env' = push_rel !evdref var env in - get_name var, pretype_type empty_valcon env' evdref c2 + let var, env' = push_rel sigma var env in + let sigma, c2_j = pretype_type empty_valcon env' sigma c2 in + sigma, get_name var, c2_j in let resj = try @@ -734,34 +738,34 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref let (e, info) = CErrors.push e in let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info) in - inh_conv_coerce_to_tycon ?loc env evdref resj tycon + inh_conv_coerce_to_tycon ?loc env sigma resj tycon | GLetIn(name,c1,t,c2) -> - let tycon1 = + let sigma, tycon1 = match t with | Some t -> - mk_tycon (pretype_type empty_valcon env evdref t).utj_val + let sigma, t_j = pretype_type empty_valcon env sigma t in + sigma, mk_tycon t_j.utj_val | None -> - empty_tycon in - let j = pretype tycon1 env evdref c1 in - let t = evd_comb1 (Evarsolve.refresh_universes - ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env) - evdref j.uj_type in + sigma, empty_tycon in + let sigma, j = pretype tycon1 env sigma c1 in + let sigma, t = Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma j.uj_type in let var = LocalDef (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in - let var, env = push_rel !evdref var env in - let j' = pretype tycon env evdref c2 in + let var, env = push_rel sigma var env in + let sigma, j' = pretype tycon env sigma c2 in let name = get_name var in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } + sigma, { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (nal,(na,po),c,d) -> - let cj = pretype empty_tycon env evdref c in + let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = - try find_rectype !!env !evdref cj.uj_type + try find_rectype !!env sigma cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive ?loc:cloc !!env !evdref cj + error_case_not_inductive ?loc:cloc !!env sigma cj in let ind = fst (fst (dest_ind_family indf)) in let cstrs = get_constructors !!env indf in @@ -790,8 +794,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref | [], [] -> [] | _ -> assert false in aux 1 1 (List.rev nal) cs.cs_args, true in - let fsign = Context.Rel.map (whd_betaiota !evdref) fsign in - let fsign,env_f = push_rel_context !evdref fsign env in + let fsign = Context.Rel.map (whd_betaiota sigma) fsign in + let fsign,env_f = push_rel_context sigma fsign env in let obj ind p v f = if not record then let f = it_mkLambda_or_LetIn f fsign in @@ -807,52 +811,52 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref let indt = build_dependent_inductive !!env indf in let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in - let predenv = Cases.make_return_predicate_ltac_lvar env !evdref na c cj.uj_val in + let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let nar = List.length arsgn in - let psign',env_p = push_rel_context ~force_names:true !evdref psign predenv in + let psign',env_p = push_rel_context ~force_names:true sigma psign predenv in (match po with | Some p -> - let pj = pretype_type empty_valcon env_p evdref p in - let ccl = nf_evar !evdref pj.utj_val in + let sigma, pj = pretype_type empty_valcon env_p sigma p in + let ccl = nf_evar sigma pj.utj_val in let p = it_mkLambda_or_LetIn ccl psign' in let inst = (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist !!env !evdref lp inst in - let fj = pretype (mk_tycon fty) env_f evdref d in + let fty = hnf_lam_applist !!env sigma lp inst in + let sigma, fj = pretype (mk_tycon fty) env_f sigma d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort !!env !evdref ind cj.uj_val p; + Typing.check_allowed_sort !!env sigma ind cj.uj_val p; obj ind p cj.uj_val fj.uj_val in - { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } + sigma, { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } | None -> let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref d in - let ccl = nf_evar !evdref fj.uj_type in + let sigma, fj = pretype tycon env_f sigma d in + let ccl = nf_evar sigma fj.uj_type in let ccl = - if noccur_between !evdref 1 cs.cs_nargs ccl then + if noccur_between sigma 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type ?loc !!env !evdref + error_cant_find_case_type ?loc !!env sigma cj.uj_val in (* let ccl = refresh_universes ccl in *) let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort !!env !evdref ind cj.uj_val p; + Typing.check_allowed_sort !!env sigma ind cj.uj_val p; obj ind p cj.uj_val fj.uj_val - in { uj_val = v; uj_type = ccl }) + in sigma, { uj_val = v; uj_type = ccl }) | GIf (c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env evdref c in + let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = - try find_rectype !!env !evdref cj.uj_type + try find_rectype !!env sigma cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive ?loc:cloc !!env !evdref cj in + error_case_not_inductive ?loc:cloc !!env sigma cj in let cstrs = get_constructors !!env indf in if not (Int.equal (Array.length cstrs) 2) then user_err ?loc @@ -867,212 +871,202 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref let indt = build_dependent_inductive !!env indf in let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in - let predenv = Cases.make_return_predicate_ltac_lvar env !evdref na c cj.uj_val in - let psign,env_p = push_rel_context !evdref psign predenv in - let pred,p = match po with + let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in + let psign,env_p = push_rel_context sigma psign predenv in + let sigma, pred, p = match po with | Some p -> - let pj = pretype_type empty_valcon env_p evdref p in - let ccl = nf_evar !evdref pj.utj_val in + let sigma, pj = pretype_type empty_valcon env_p sigma p in + let ccl = nf_evar sigma pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist !evdref (pred,[cj.uj_val])) in - pred, typ + let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in + sigma, pred, typ | None -> - let p = match tycon with - | Some ty -> ty - | None -> new_type_evar env evdref loc + let sigma, p = match tycon with + | Some ty -> sigma, ty + | None -> new_type_evar env sigma loc in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar !evdref pred in - let p = nf_evar !evdref p in - let f cs b = + sigma, it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar sigma pred in + let p = nf_evar sigma p in + let f sigma cs b = let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in + let pi = beta_applist sigma (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in - let cs_args = Context.Rel.map (whd_betaiota !evdref) cs_args in + let cs_args = Context.Rel.map (whd_betaiota sigma) cs_args in let csgn = List.map (set_name Anonymous) cs_args in - let _,env_c = push_rel_context !evdref csgn env in - let bj = pretype (mk_tycon pi) env_c evdref b in - it_mkLambda_or_LetIn bj.uj_val cs_args in - let b1 = f cstrs.(0) b1 in - let b2 = f cstrs.(1) b2 in + let _,env_c = push_rel_context sigma csgn env in + let sigma, bj = pretype (mk_tycon pi) env_c sigma b in + sigma, it_mkLambda_or_LetIn bj.uj_val cs_args in + let sigma, b1 = f sigma cstrs.(0) b1 in + let sigma, b2 = f sigma cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in let ci = make_case_info !!env (fst ind) IfStyle in - let pred = nf_evar !evdref pred in - Typing.check_allowed_sort !!env !evdref ind cj.uj_val pred; + let pred = nf_evar sigma pred in + Typing.check_allowed_sort !!env sigma ind cj.uj_val pred; mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in - inh_conv_coerce_to_tycon ?loc env evdref cj tycon + inh_conv_coerce_to_tycon ?loc env sigma cj tycon | GCases (sty,po,tml,eqns) -> - let pretype tycon env sigma c = - let evdref = ref sigma in - let t = pretype tycon env evdref c in - !evdref, t - in - let sigma = !evdref in - let sigma, j = Cases.compile_cases ?loc sty (pretype, sigma) tycon env (po,tml,eqns) in - let () = evdref := sigma in - j + Cases.compile_cases ?loc sty (pretype, sigma) tycon env (po,tml,eqns) | GCast (c,k) -> - let cj = + let sigma, cj = match k with | CastCoerce -> - let cj = pretype empty_tycon env evdref c in - evd_comb1 (Coercion.inh_coerce_to_base ?loc !!env) evdref cj + let sigma, cj = pretype empty_tycon env sigma c in + Coercion.inh_coerce_to_base ?loc !!env sigma cj | CastConv t | CastVM t | CastNative t -> - let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let tj = pretype_type empty_valcon env evdref t in - let tval = evd_comb1 (Evarsolve.refresh_universes - ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env) - evdref tj.utj_val in - let tval = nf_evar !evdref tval in - let cj, tval = match k with + let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in + let sigma, tj = pretype_type empty_valcon env sigma t in + let sigma, tval = Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in + let tval = nf_evar sigma tval in + let (sigma, cj), tval = match k with | VMcast -> - let cj = pretype empty_tycon env evdref c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in - if not (occur_existential !evdref cty || occur_existential !evdref tval) then - match Reductionops.vm_infer_conv !!env !evdref cty tval with - | Some evd -> (evdref := evd; cj, tval) + let sigma, cj = pretype empty_tycon env sigma c in + let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in + if not (occur_existential sigma cty || occur_existential sigma tval) then + match Reductionops.vm_infer_conv !!env sigma cty tval with + | Some sigma -> (sigma, cj), tval | None -> - error_actual_type ?loc !!env !evdref cj tval + error_actual_type ?loc !!env sigma cj tval (ConversionFailed (!!env,cty,tval)) else user_err ?loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> - let cj = pretype empty_tycon env evdref c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in + let sigma, cj = pretype empty_tycon env sigma c in + let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in begin - match Nativenorm.native_infer_conv !!env !evdref cty tval with - | Some evd -> (evdref := evd; cj, tval) + match Nativenorm.native_infer_conv !!env sigma cty tval with + | Some sigma -> (sigma, cj), tval | None -> - error_actual_type ?loc !!env !evdref cj tval + error_actual_type ?loc !!env sigma cj tval (ConversionFailed (!!env,cty,tval)) end - | _ -> - pretype (mk_tycon tval) env evdref c, tval - in - let v = mkCast (cj.uj_val, k, tval) in - { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon ?loc env evdref cj tycon - -and pretype_instance k0 resolve_tc env evdref loc hyps evk update = - let f decl (subst,update) = + | _ -> + pretype (mk_tycon tval) env sigma c, tval + in + let v = mkCast (cj.uj_val, k, tval) in + sigma, { uj_val = v; uj_type = tval } + in inh_conv_coerce_to_tycon ?loc env sigma cj tycon + +and pretype_instance k0 resolve_tc env sigma loc hyps evk update = + let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in let t = replace_vars subst (NamedDecl.get_type decl) in - let check_body id c = + let check_body sigma id c = match b, c with | Some b, Some c -> - if not (is_conv !!env !evdref b c) then + if not (is_conv !!env sigma b c) then user_err ?loc (str "Cannot interpret " ++ - pr_existential_key !evdref evk ++ + pr_existential_key sigma evk ++ strbrk " in current context: binding for " ++ Id.print id ++ strbrk " is not convertible to its expected definition (cannot unify " ++ - quote (Termops.Internal.print_constr_env !!env !evdref b) ++ + quote (Termops.Internal.print_constr_env !!env sigma b) ++ strbrk " and " ++ - quote (Termops.Internal.print_constr_env !!env !evdref c) ++ + quote (Termops.Internal.print_constr_env !!env sigma c) ++ str ").") | Some b, None -> user_err ?loc (str "Cannot interpret " ++ - pr_existential_key !evdref evk ++ + pr_existential_key sigma evk ++ strbrk " in current context: " ++ Id.print id ++ strbrk " should be bound to a local definition.") | None, _ -> () in - let check_type id t' = - if not (is_conv !!env !evdref t t') then + let check_type sigma id t' = + if not (is_conv !!env sigma t t') then user_err ?loc (str "Cannot interpret " ++ - pr_existential_key !evdref evk ++ + pr_existential_key sigma evk ++ strbrk " in current context: binding for " ++ Id.print id ++ strbrk " is not well-typed.") in - let c, update = + let sigma, c, update = try let c = List.assoc id update in - let c = pretype k0 resolve_tc (mk_tycon t) env evdref c in - check_body id (Some c.uj_val); - c.uj_val, List.remove_assoc id update + let sigma, c = pretype k0 resolve_tc (mk_tycon t) env sigma c in + check_body sigma id (Some c.uj_val); + sigma, c.uj_val, List.remove_assoc id update with Not_found -> try let (n,b',t') = lookup_rel_id id (rel_context !!env) in - check_type id (lift n t'); - check_body id (Option.map (lift n) b'); - mkRel n, update + check_type sigma id (lift n t'); + check_body sigma id (Option.map (lift n) b'); + sigma, mkRel n, update with Not_found -> try let decl = lookup_named id !!env in - check_type id (NamedDecl.get_type decl); - check_body id (NamedDecl.get_value decl); - mkVar id, update + check_type sigma id (NamedDecl.get_type decl); + check_body sigma id (NamedDecl.get_value decl); + sigma, mkVar id, update with Not_found -> user_err ?loc (str "Cannot interpret " ++ - pr_existential_key !evdref evk ++ + pr_existential_key sigma evk ++ str " in current context: no binding for " ++ Id.print id ++ str ".") in - ((id,c)::subst, update) in - let subst,inst = List.fold_right f hyps ([],update) in + ((id,c)::subst, update, sigma) in + let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in check_instance loc subst inst; - Array.map_of_list snd subst + sigma, Array.map_of_list snd subst -(* [pretype_type valcon env evdref c] coerces [c] into a type *) -and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) evdref c = match DAst.get c with +(* [pretype_type valcon env sigma c] coerces [c] into a type *) +and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with | Some v -> - let s = - let sigma = !evdref in + let sigma, s = let t = Retyping.get_type_of !!env sigma v in match EConstr.kind sigma (whd_all !!env sigma t) with - | Sort s -> ESorts.kind sigma s + | Sort s -> + sigma, ESorts.kind sigma s | Evar ev when is_Type sigma (existential_type sigma ev) -> - evd_comb1 (define_evar_as_sort !!env) evdref ev + define_evar_as_sort !!env sigma ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") in (* Correction of bug #5315 : we need to define an evar for *all* holes *) - let evkt = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s) in - let ev,_ = destEvar !evdref evkt in - evdref := Evd.define ev (nf_evar !evdref v) !evdref; + let sigma, evkt = new_evar env sigma ~src:(loc, knd) ~naming (mkSort s) in + let ev,_ = destEvar sigma evkt in + let sigma = Evd.define ev (nf_evar sigma v) sigma in (* End of correction of bug #5315 *) - { utj_val = v; - utj_type = s } + sigma, { utj_val = v; + utj_type = s } | None -> - let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in - { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s); - utj_type = s}) + let sigma, s = new_sort_variable univ_flexible_alg sigma in + let sigma, utj_val = new_evar env sigma ~src:(loc, knd) ~naming (mkSort s) in + sigma, { utj_val; utj_type = s}) | _ -> - let j = pretype k0 resolve_tc empty_tycon env evdref c in + let sigma, j = pretype k0 resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in - let tj = evd_comb1 (Coercion.inh_coerce_to_sort ?loc !!env) evdref j in + let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with - | None -> tj + | None -> sigma, tj | Some v -> - begin match cumul !!env !evdref v tj.utj_val with - | Some sigma -> evdref := sigma; tj + begin match cumul !!env sigma v tj.utj_val with + | Some sigma -> sigma, tj | None -> error_unexpected_type - ?loc:(loc_of_glob_constr c) !!env !evdref tj.utj_val v + ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v end let ise_pretype_gen flags env sigma lvar kind c = let env = GlobEnv.make env sigma lvar in - let evdref = ref sigma in let k0 = Context.Rel.length (rel_context !!env) in - let c', c'_ty = match kind with + let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let j = pretype k0 flags.use_typeclasses empty_tycon env evdref c in - j.uj_val, j.uj_type + let sigma, j = pretype k0 flags.use_typeclasses empty_tycon env sigma c in + sigma, j.uj_val, j.uj_type | OfType exptyp -> - let j = pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref c in - j.uj_val, j.uj_type + let sigma, j = pretype k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + sigma, j.uj_val, j.uj_type | IsType -> - let tj = pretype_type k0 flags.use_typeclasses empty_valcon env evdref c in - tj.utj_val, mkSort tj.utj_type + let sigma, tj = pretype_type k0 flags.use_typeclasses empty_valcon env sigma c in + sigma, tj.utj_val, mkSort tj.utj_type in - process_inference_flags flags !!env sigma (!evdref,c',c'_ty) + process_inference_flags flags !!env sigma (sigma',c',c'_ty) let default_inference_flags fail = { use_typeclasses = true; @@ -1092,8 +1086,8 @@ let all_and_fail_flags = default_inference_flags true let all_no_fail_flags = default_inference_flags false let ise_pretype_gen_ctx flags env sigma lvar kind c = - let evd, c, _ = ise_pretype_gen flags env sigma lvar kind c in - c, Evd.evar_universe_context evd + let sigma, c, _ = ise_pretype_gen flags env sigma lvar kind c in + c, Evd.evar_universe_context sigma (** Entry points of the high-level type synthesis algorithm *) @@ -1113,9 +1107,3 @@ let understand_tcc ?flags env sigma ?expected_type c = let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) - -let pretype k0 resolve_tc typcon env evdref lvar t = - pretype k0 resolve_tc typcon (GlobEnv.make env !evdref lvar) evdref t - -let pretype_type k0 resolve_tc valcon env evdref lvar t = - pretype_type k0 resolve_tc valcon (GlobEnv.make env !evdref lvar) evdref t diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index fcc361b16b..0f95d27528 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -19,7 +19,6 @@ open Evd open EConstr open Glob_term open Ltac_pretype -open Evardefine val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> glob_level -> Univ.Level.t @@ -111,14 +110,6 @@ val check_evars : env -> evar_map -> evar_map -> constr -> unit (**/**) (** Internal of Pretyping... *) -val pretype : - int -> bool -> type_constraint -> env -> evar_map ref -> - ltac_var_map -> glob_constr -> unsafe_judgment - -val pretype_type : - int -> bool -> val_constraint -> env -> evar_map ref -> - ltac_var_map -> glob_constr -> unsafe_type_judgment - val ise_pretype_gen : inference_flags -> env -> evar_map -> ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr * types diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index c25416405e..3719f9302a 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -79,12 +79,7 @@ let subst_structure (subst,((kn,i),id,kl,projs as obj)) = if projs' == projs && kn' == kn && id' == id then obj else ((kn',i),id',kl,projs') -let discharge_constructor (ind, n) = - (Lib.discharge_inductive ind, n) - -let discharge_structure (_,(ind,id,kl,projs)) = - Some (Lib.discharge_inductive ind, discharge_constructor id, kl, - List.map (Option.map Lib.discharge_con) projs) +let discharge_structure (_,x) = Some x let inStruc : struc_tuple -> obj = declare_object {(default_object "STRUCTURE") with @@ -319,8 +314,7 @@ let subst_canonical_structure (subst,(cst,ind as obj)) = let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') -let discharge_canonical_structure (_,(cst,ind)) = - Some (Lib.discharge_con cst,Lib.discharge_inductive ind) +let discharge_canonical_structure (_,x) = Some x let inCanonStruc : Constant.t * inductive -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index e8c3b3e2b3..5dbe95a471 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -132,8 +132,7 @@ module ReductionBehaviour = struct { b with b_nargs = nargs'; b_recargs = recargs' } else b in - let c = Lib.discharge_con c in - Some (ReqGlobal (ConstRef c, req), (ConstRef c, b)) + Some (ReqGlobal (gr, req), (ConstRef c, b)) | _ -> None let rebuild = function @@ -713,8 +712,8 @@ let magicaly_constant_of_fixbody env sigma reference bd = function | Name.Name id -> let open UnivProblem in try - let (cst_mod,cst_sect,_) = Constant.repr3 reference in - let cst = Constant.make3 cst_mod cst_sect (Label.of_id id) in + let (cst_mod,_) = Constant.repr2 reference in + let cst = Constant.make2 cst_mod (Label.of_id id) in let (cst, u), ctx = UnivGen.fresh_constant_instance env cst in match constant_opt_value_in env (cst,u) with | None -> bd diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 67c5643459..7e5815acd1 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -222,26 +222,26 @@ let discharge_class (_,cl) = | Some (_, ((tc,_), _)) -> Some tc.cl_impl) ctx' in - List.Smart.map (Option.Smart.map Lib.discharge_global) grs - @ newgrs + grs @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in - let cl_impl' = Lib.discharge_global cl.cl_impl in - if cl_impl' == cl.cl_impl then cl else + try let info = abs_context cl in let ctx = info.Lib.abstr_ctx in let ctx, subst = rel_of_variable_context ctx in let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in let context = discharge_context ctx (subst, usubst) cl.cl_context in let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in - let discharge_proj (x, y, z) = x, y, Option.Smart.map Lib.discharge_con z in - { cl_univs = cl_univs'; - cl_impl = cl_impl'; - cl_context = context; - cl_props = props; - cl_projs = List.Smart.map discharge_proj cl.cl_projs; - cl_strict = cl.cl_strict; - cl_unique = cl.cl_unique - } + let discharge_proj x = x in + { cl_univs = cl_univs'; + cl_impl = cl.cl_impl; + cl_context = context; + cl_props = props; + cl_projs = List.Smart.map discharge_proj cl.cl_projs; + cl_strict = cl.cl_strict; + cl_unique = cl.cl_unique + } + with Not_found -> (* not defined in the current section *) + cl let rebuild_class cl = try @@ -365,8 +365,8 @@ let discharge_instance (_, (action, inst)) = Some (action, { inst with is_global = Some (pred n); - is_class = Lib.discharge_global inst.is_class; - is_impl = Lib.discharge_global inst.is_impl }) + is_class = inst.is_class; + is_impl = inst.is_impl }) let is_local i = (i.is_global == None) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 4ba715f0d5..dc3f042431 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -398,9 +398,6 @@ let check env sigma c t = error_actual_type_core env sigma j t | Some sigma -> sigma -let e_check env evdref c t = - evdref := check env !evdref c t - (* Type of a constr *) let unsafe_type_of env sigma c = @@ -416,9 +413,6 @@ let sort_of env sigma c = let sigma, a = type_judgment env sigma j in sigma, a.utj_type -let e_sort_of env evdref c = - Evarutil.evd_comb1 (sort_of env) evdref c - (* Try to solve the existential variables by typing *) let type_of ?(refresh=false) env sigma c = @@ -429,16 +423,10 @@ let type_of ?(refresh=false) env sigma c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma j.uj_type else sigma, j.uj_type -let e_type_of ?refresh env evdref c = - Evarutil.evd_comb1 (type_of ?refresh env) evdref c - let solve_evars env sigma c = let env = enrich_env env sigma in let sigma, j = execute env sigma c in (* side-effect on evdref *) sigma, nf_evar sigma j.uj_val -let e_solve_evars env evdref c = - Evarutil.evd_comb1 (solve_evars env) evdref c - let _ = Evarconv.set_solve_evars (fun env sigma c -> solve_evars env sigma c) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 3cf43ace01..b8830ff4a2 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -24,27 +24,17 @@ val unsafe_type_of : env -> evar_map -> constr -> types universes *) val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types -(** Variant of [type_of] using references instead of state-passing. *) -val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types -[@@ocaml.deprecated "Use [Typing.type_of]"] - (** Typecheck a type and return its sort *) val sort_of : env -> evar_map -> types -> evar_map * Sorts.t -val e_sort_of : env -> evar_map ref -> types -> Sorts.t -[@@ocaml.deprecated "Use [Typing.sort_of]"] (** Typecheck a term has a given type (assuming the type is OK) *) val check : env -> evar_map -> constr -> types -> evar_map -val e_check : env -> evar_map ref -> constr -> types -> unit -[@@ocaml.deprecated "Use [Typing.check]"] (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) val solve_evars : env -> evar_map -> constr -> evar_map * constr -val e_solve_evars : env -> evar_map ref -> constr -> constr -[@@ocaml.deprecated "Use [Typing.solve_evars]"] (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 90d2b7abaf..e7f995c84e 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -194,7 +194,6 @@ let tag_var = tag Tag.variable sl ++ id let pr_id = Id.print - let pr_name = Name.print let pr_qualid = pr_qualid let pr_patvar = pr_id diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index bca419c9ac..e7f71849a5 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -34,8 +34,6 @@ val pr_sep_com : constr_expr -> Pp.t val pr_id : Id.t -> Pp.t -val pr_name : Name.t -> Pp.t -[@@ocaml.deprecated "alias of Names.Name.print"] val pr_qualid : qualid -> Pp.t val pr_patvar : Pattern.patvar -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 66f748454d..e6f82c60ee 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -617,10 +617,10 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = | (_,"INDUCTIVE") -> Some (gallina_print_inductive (MutInd.make1 kn) None) | (_,"MODULE") -> - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in Some (print_module with_values (MPdot (mp,l))) | (_,"MODULE TYPE") -> - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in Some (print_modtype (MPdot (mp,l))) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None @@ -734,12 +734,12 @@ let print_full_pure_context env sigma = str "." ++ fnl () ++ fnl () | "MODULE" -> (* TODO: make it reparsable *) - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | "MODULE TYPE" -> (* TODO: make it reparsable *) (* TODO: make it reparsable *) - let (mp,_,l) = KerName.repr kn in + let (mp,l) = KerName.repr kn in print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _ -> mt () in prec rest ++ pp diff --git a/printing/printer.ml b/printing/printer.ml index cfa3e8b6e9..990bdaad7d 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -17,7 +17,6 @@ open Environ open Globnames open Nametab open Evd -open Proof_type open Refiner open Constrextern open Ppconstr @@ -98,20 +97,6 @@ let pr_econstr_env env sigma c = pr_econstr_core false env sigma c let pr_open_lconstr_env env sigma (_,c) = pr_leconstr_env env sigma c let pr_open_constr_env env sigma (_,c) = pr_econstr_env env sigma c -(* NB do not remove the eta-redexes! Global.env() has side-effects... *) -let pr_lconstr t = - let (sigma, env) = Pfedit.get_current_context () in - pr_lconstr_env env sigma t -let pr_constr t = - let (sigma, env) = Pfedit.get_current_context () in - pr_constr_env env sigma t - -let pr_leconstr c = pr_lconstr (EConstr.Unsafe.to_constr c) -let pr_econstr c = pr_constr (EConstr.Unsafe.to_constr c) - -let pr_open_lconstr (_,c) = pr_leconstr c -let pr_open_constr (_,c) = pr_econstr c - let pr_constr_under_binders_env_gen pr env sigma (ids,c) = (* Warning: clashes can occur with variables of same name in env but *) (* we also need to preserve the actual names of the patterns *) @@ -122,13 +107,6 @@ let pr_constr_under_binders_env_gen pr env sigma (ids,c) = let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env -let pr_constr_under_binders c = - let (sigma, env) = Pfedit.get_current_context () in - pr_constr_under_binders_env env sigma c -let pr_lconstr_under_binders c = - let (sigma, env) = Pfedit.get_current_context () in - pr_lconstr_under_binders_env env sigma c - let pr_etype_core goal_concl_style env sigma t = pr_constr_expr (extern_type goal_concl_style env sigma t) let pr_letype_core = Proof_diffs.pr_letype_core @@ -136,13 +114,6 @@ let pr_letype_core = Proof_diffs.pr_letype_core let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) -let pr_ltype t = - let (sigma, env) = Pfedit.get_current_context () in - pr_ltype_env env sigma t -let pr_type t = - let (sigma, env) = Pfedit.get_current_context () in - pr_type_env env sigma t - let pr_etype_env env sigma c = pr_etype_core false env sigma c let pr_letype_env env sigma c = pr_letype_core false env sigma c let pr_goal_concl_style_env env sigma c = pr_letype_core true env sigma c @@ -150,29 +121,15 @@ let pr_goal_concl_style_env env sigma c = pr_letype_core true env sigma c let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) -let pr_ljudge j = - let (sigma, env) = Pfedit.get_current_context () in - pr_ljudge_env env sigma j - let pr_lglob_constr_env env c = pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c) let pr_glob_constr_env env c = pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) -let pr_lglob_constr c = - let (sigma, env) = Pfedit.get_current_context () in - pr_lglob_constr_env env c -let pr_glob_constr c = - let (sigma, env) = Pfedit.get_current_context () in - pr_glob_constr_env env c - let pr_closed_glob_n_env env sigma n c = pr_constr_expr_n n (extern_closed_glob false env sigma c) let pr_closed_glob_env env sigma c = pr_constr_expr (extern_closed_glob false env sigma c) -let pr_closed_glob c = - let (sigma, env) = Pfedit.get_current_context () in - pr_closed_glob_env env sigma c let pr_lconstr_pattern_env env sigma c = pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) @@ -182,13 +139,6 @@ let pr_constr_pattern_env env sigma c = let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) -let pr_lconstr_pattern t = - let (sigma, env) = Pfedit.get_current_context () in - pr_lconstr_pattern_env env sigma t -let pr_constr_pattern t = - let (sigma, env) = Pfedit.get_current_context () in - pr_constr_pattern_env env sigma t - let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) let _ = Termops.Internal.set_print_constr @@ -247,13 +197,6 @@ let safe_gen f env sigma c = let safe_pr_lconstr_env = safe_gen pr_lconstr_env let safe_pr_constr_env = safe_gen pr_constr_env -let safe_pr_lconstr t = - let (sigma, env) = Pfedit.get_current_context () in - safe_pr_lconstr_env env sigma t - -let safe_pr_constr t = - let (sigma, env) = Pfedit.get_current_context () in - safe_pr_constr_env env sigma t let pr_universe_ctx_set sigma c = if !Detyping.print_universes && not (Univ.ContextSet.is_empty c) then @@ -889,19 +832,6 @@ let pr_goal_by_id ~proof id = pr_selected_subgoal (pr_id id) sigma g) with Not_found -> user_err Pp.(str "No such goal.") -(* Elementary tactics *) - -let pr_prim_rule = function - | Refine c -> - (** FIXME *) - str(if Termops.occur_meta Evd.empty (EConstr.of_constr c) then "refine " else "exact ") ++ - Constrextern.with_meta_as_hole pr_constr c - -(* Backwards compatibility *) - -let prterm = pr_lconstr - - (* Printer function for sets of Assumptions.assumptions. It is used primarily by the Print Assumptions command. *) @@ -959,7 +889,7 @@ let pr_assumptionset env sigma s = try pr_constant env kn with Not_found -> (* FIXME? *) - let mp,_,lab = Constant.repr3 kn in + let mp,lab = Constant.repr2 kn in str (ModPath.to_string mp) ++ str "." ++ Label.print lab in let safe_pr_inductive env kn = diff --git a/printing/printer.mli b/printing/printer.mli index 96db7091a6..f9d1a62895 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -27,13 +27,9 @@ val enable_goal_names_printing : bool ref (** Terms *) val pr_lconstr_env : env -> evar_map -> constr -> Pp.t -val pr_lconstr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_env : env -> evar_map -> constr -> Pp.t -val pr_constr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_n_env : env -> evar_map -> Notation_gram.tolerability -> constr -> Pp.t @@ -43,19 +39,11 @@ val pr_constr_n_env : env -> evar_map -> Notation_gram.tolerability -> co in case of remaining issues (such as reference not in env). *) val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t -val safe_pr_lconstr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t -val safe_pr_constr : constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_env : env -> evar_map -> EConstr.t -> Pp.t -val pr_econstr : EConstr.t -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t -val pr_leconstr : EConstr.t -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_n_env : env -> evar_map -> Notation_gram.tolerability -> EConstr.t -> Pp.t @@ -63,54 +51,30 @@ val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_open_constr_env : env -> evar_map -> open_constr -> Pp.t -val pr_open_constr : open_constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_open_lconstr_env : env -> evar_map -> open_constr -> Pp.t -val pr_open_lconstr : open_constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t -val pr_constr_under_binders : constr_under_binders -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t -val pr_lconstr_under_binders : constr_under_binders -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_goal_concl_style_env : env -> evar_map -> EConstr.types -> Pp.t val pr_ltype_env : env -> evar_map -> types -> Pp.t -val pr_ltype : types -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_type_env : env -> evar_map -> types -> Pp.t -val pr_type : types -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_closed_glob_n_env : env -> evar_map -> Notation_gram.tolerability -> closed_glob_constr -> Pp.t val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t -val pr_closed_glob : closed_glob_constr -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t -val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lglob_constr_env : env -> 'a glob_constr_g -> Pp.t -val pr_lglob_constr : 'a glob_constr_g -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_glob_constr_env : env -> 'a glob_constr_g -> Pp.t -val pr_glob_constr : 'a glob_constr_g -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t -val pr_lconstr_pattern : constr_pattern -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t -val pr_constr_pattern : constr_pattern -> Pp.t -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_cases_pattern : cases_pattern -> Pp.t @@ -222,16 +186,8 @@ val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> Evar.Set.t -> Pp.t -val pr_prim_rule : prim_rule -> Pp.t -[@@ocaml.deprecated "[pr_prim_rule] is scheduled to be removed along with the legacy proof engine"] - val print_and_diff : Proof.t option -> Proof.t option -> unit -(** Backwards compatibility *) - -val prterm : constr -> Pp.t (** = pr_lconstr *) -[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] - (** Declarations for the "Print Assumption" command *) type axiom = | Constant of Constant.t (* An axiom or a constant. *) diff --git a/proofs/proof.ml b/proofs/proof.ml index 8bbd82bb0a..70a08e4966 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -122,8 +122,6 @@ type t = { initial_euctx : UState.t } -type proof = t - (*** General proof functions ***) let proof p = @@ -435,9 +433,6 @@ let pr_proof p = (*** Compatibility layer with <=v8.2 ***) module V82 = struct - let subgoals p = - let it, sigma = Proofview.proofview p.proofview in - Evd.{ it; sigma } let background_subgoals p = let it, sigma = Proofview.proofview (unroll_focus p.proofview p.focus_stack) in diff --git a/proofs/proof.mli b/proofs/proof.mli index 511dcc2e00..8cf543557b 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -33,8 +33,6 @@ (* Type of a proof. *) type t -type proof = t -[@@ocaml.deprecated "please use [Proof.t]"] (* Returns a stylised view of a proof for use by, for instance, ide-s. *) @@ -192,8 +190,6 @@ val pr_proof : t -> Pp.t (*** Compatibility layer with <=v8.2 ***) module V82 : sig - val subgoals : t -> Goal.goal list Evd.sigma - [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] (* All the subgoals of the proof, including those which are not focused. *) val background_subgoals : t -> Goal.goal list Evd.sigma diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index cc3e79f858..ed8df29d7b 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -197,6 +197,3 @@ let put p b = let suggest p = (!current_behavior).suggest p - -let pr_goal_selector = Goal_select.pr_goal_selector -let get_default_goal_selector = Goal_select.get_default_goal_selector diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index a09a7ec1d2..0fcc647a6f 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -44,9 +44,3 @@ val register_behavior : behavior -> unit *) val put : Proof.t -> t -> Proof.t val suggest : Proof.t -> Pp.t - -(** Deprecated *) -val pr_goal_selector : Goal_select.t -> Pp.t -[@@ocaml.deprecated "Please use [Goal_select.pr_goal_selector]"] -val get_default_goal_selector : unit -> Goal_select.t -[@@ocaml.deprecated "Please use [Goal_select.get_default_goal_selector]"] diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 7e250faa86..de151fb6e5 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -101,7 +101,6 @@ type pstate = { } type t = pstate list -type state = t let make_terminator f = f let apply_terminator f = f diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 854ceaa41a..2b04bfab57 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,8 +13,6 @@ environment. *) type t -type state = t -[@@ocaml.deprecated "please use [Proof_global.t]"] val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 44685d2bbd..56ce744bc1 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -15,7 +15,6 @@ open Names open Constr open EConstr open Declarations -open Globnames open Genredexpr open Pattern open Reductionops @@ -79,7 +78,7 @@ let set_strategy_one ref l = | OpaqueDef _ -> user_err ~hdr:"set_transparent_const" (str "Cannot make" ++ spc () ++ - Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++ + Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); | _ -> Csymtable.set_transparent_const sp) | _ -> () @@ -114,10 +113,8 @@ let classify_strategy (local,_ as obj) = let disch_ref ref = match ref with - EvalConstRef c -> - let c' = Lib.discharge_con c in - if c==c' then Some ref else Some (EvalConstRef c') - | EvalVarRef id -> if Lib.is_in_section (VarRef id) then None else Some ref + EvalConstRef c -> Some ref + | EvalVarRef id -> if Lib.is_in_section (GlobRef.VarRef id) then None else Some ref let discharge_strategy (_,(local,obj)) = if local then None else diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 0f83e16ec8..30af6d8e1a 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -22,14 +22,6 @@ val project : 'a sigma -> evar_map val pf_env : goal sigma -> Environ.env val pf_hyps : goal sigma -> named_context -val unpackage : 'a sigma -> evar_map ref * 'a -[@@ocaml.deprecated "Do not use [evar_map ref]"] -val repackage : evar_map ref -> 'a -> 'a sigma -[@@ocaml.deprecated "Do not use [evar_map ref]"] -val apply_sig_tac : - evar_map ref -> (goal sigma -> goal list sigma) -> goal -> goal list -[@@ocaml.deprecated "Do not use [evar_map ref]"] - val refiner : rule -> tactic (** {6 Tacticals. } *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 9e42a71ea8..5d1faf1465 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -30,14 +30,7 @@ let re_sig it gc = { it = it; sigma = gc; } (* Operations for handling terms under a local typing context *) (**************************************************************) -type 'a sigma = 'a Evd.sigma;; -type tactic = Proof_type.tactic;; - -[@@@ocaml.warning "-3"] -let unpackage = Refiner.unpackage -let repackage = Refiner.repackage -let apply_sig_tac = Refiner.apply_sig_tac -[@@@ocaml.warning "+3"] +type tactic = Proof_type.tactic let sig_it = Refiner.sig_it let project = Refiner.project diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index b4cb2be2b8..3432ad4afa 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -18,9 +18,6 @@ open Locus (** Operations for handling terms under a local typing context. *) -type 'a sigma = 'a Evd.sigma -[@@ocaml.deprecated "alias of Evd.sigma"] - open Evd type tactic = Proof_type.tactic;; @@ -29,14 +26,6 @@ val project : goal sigma -> evar_map val re_sig : 'a -> evar_map -> 'a sigma -val unpackage : 'a sigma -> evar_map ref * 'a -[@@ocaml.deprecated "Do not use [evar_map ref]"] -val repackage : evar_map ref -> 'a -> 'a sigma -[@@ocaml.deprecated "Do not use [evar_map ref]"] -val apply_sig_tac : - evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list) -[@@ocaml.deprecated "Do not use [evar_map ref]"] - val pf_concl : goal sigma -> types val pf_env : goal sigma -> env val pf_hyps : goal sigma -> named_context diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 768d94d305..94e04d1842 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -325,7 +325,7 @@ module Make(T : Task) () = struct let response = slave_respond request in report_status "Idle"; marshal_response (Option.get !slave_oc) response; - CEphemeron.clear () + CEphemeron.clean () with | MarshalError s -> stm_pr_err Pp.(prlist str ["Fatal marshal error: "; s]); flush_all (); exit 2 diff --git a/tactics/equality.ml b/tactics/equality.ml index d0f4b2c680..510f119229 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -356,9 +356,9 @@ let find_elim hdcncl lft2rgt dep cls ot = | Some true, None | Some false, Some _ -> let c1 = destConstRef pr1 in - let mp,dp,l = Constant.repr3 (Constant.make1 (Constant.canonical c1)) in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (KerName.make mp dp l') in + let c1' = Global.constant_of_delta_kn (KerName.make mp l') in begin try let _ = Global.lookup_constant c1' in diff --git a/tactics/hints.ml b/tactics/hints.ml index c0ba363360..af6d1c472f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -209,14 +209,14 @@ let fresh_key = let cur = incr id; !id in let lbl = Id.of_string ("_" ^ string_of_int cur) in let kn = Lib.make_kn lbl in - let (mp, dir, _) = KerName.repr kn in + let (mp, _) = KerName.repr kn in (** We embed the full path of the kernel name in the label so that the identifier should be unique. This ensures that including two modules together won't confuse the corresponding labels. *) - let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" - (ModPath.to_string mp) (DirPath.to_string dir) cur) + let lbl = Id.of_string_soft (Printf.sprintf "%s#%i" + (ModPath.to_string mp) cur) in - KerName.make mp dir (Label.of_id lbl) + KerName.make mp (Label.of_id lbl) let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = let d = pri1 - pri2 in @@ -1552,11 +1552,6 @@ let pr_hint_db_env env sigma db = hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ content -(* Deprecated in the mli *) -let pr_hint_db db = - let sigma, env = Pfedit.get_current_context () in - pr_hint_db_env env sigma db - let pr_hint_db_by_name env sigma dbname = try let db = searchtable_map dbname in pr_hint_db_env env sigma db @@ -1601,7 +1596,7 @@ let warn_non_imported_hint = let warn env sigma h = let hint = pr_hint env sigma h in - let (mp, _, _) = KerName.repr h.uid in + let mp = KerName.modpath h.uid in warn_non_imported_hint (hint,mp) let wrap_hint_warning t = diff --git a/tactics/hints.mli b/tactics/hints.mli index d63efea27d..6db8feccd0 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -298,9 +298,4 @@ val pr_applicable_hint : unit -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t -val pr_hint_db : Hint_db.t -> Pp.t -[@@ocaml.deprecated "please used pr_hint_db_env"] val pr_hint : env -> evar_map -> hint -> Pp.t - -type nonrec hint_info = hint_info -[@@ocaml.deprecated "Use [Typeclasses.hint_info]"] diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 7da059ae35..a1bb0a7401 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -438,7 +438,7 @@ let match_eq sigma eqn (ref, hetero) = | _ -> raise PatternMatchingFailure let no_check () = true -let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module +let check_jmeq_loaded () = Library.library_is_loaded @@ Coqlib.jmeq_library_path let equalities = [(coq_eq_ref, false), no_check, build_coq_eq_data; diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e4013152e6..b81967c781 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -56,8 +56,7 @@ let subst_scheme (subst,(kind,l)) = (kind,Array.Smart.map (subst_one_scheme subst) l) let discharge_scheme (_,(kind,l)) = - Some (kind,Array.map (fun (ind,const) -> - (Lib.discharge_inductive ind,Lib.discharge_con const)) l) + Some (kind, l) let inScheme : string * (inductive * Constant.t) array -> obj = declare_object {(default_object "SCHEME") with diff --git a/tactics/inv.ml b/tactics/inv.ml index f718b13a63..5ac4284b43 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -70,6 +70,11 @@ type inversion_kind = | FullInversion | FullInversionClear +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + let compute_eqn env sigma n i ai = (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) @@ -94,7 +99,7 @@ let make_inv_predicate env evd indf realargs id status concl = | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> let sort = get_sort_family_of env !evd concl in - let sort = Evarutil.evd_comb1 Evd.fresh_sort_in_family evd sort in + let sort = evd_comb1 Evd.fresh_sort_in_family evd sort in let p = make_arity env !evd true indf sort in let evd',(p,ptyp) = Unification.abstract_list_all env !evd p concl (realargs@[mkVar id]) @@ -124,19 +129,19 @@ let make_inv_predicate env evd indf realargs id status concl = evd := sigma; res in let eq_term = eqdata.Coqlib.eq in - let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in + let eq = evd_comb1 (Evd.fresh_global env) evd eq_term in let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in let refl_term = eqdata.Coqlib.refl in - let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in + let refl_term = evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in - let _ = Evarutil.evd_comb1 (Typing.type_of env) evd refl in + let _ = evd_comb1 (Typing.type_of env) evd refl in let args = refl :: args in build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in let predicate = it_mkLambda_or_LetIn newconcl (name_context env !evd hyps) in - let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in + let _ = evd_comb1 (Typing.type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) predicate, args diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 596feeec8b..f2cf915fe3 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -60,10 +60,6 @@ let tclIFTHENSELSE = Refiner.tclIFTHENSELSE let tclIFTHENSVELSE = Refiner.tclIFTHENSVELSE let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST -(* Synonyms *) - -let tclTHENSEQ = tclTHENLIST - (************************************************************************) (* Tacticals applying on hypotheses *) (************************************************************************) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 1e66c2b0b1..cc15469d0e 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -23,8 +23,6 @@ val tclIDTAC_MESSAGE : Pp.t -> tactic val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclTHEN : tactic -> tactic -> tactic -val tclTHENSEQ : tactic list -> tactic -[@@ocaml.deprecated "alias of Tacticals.tclTHENLIST"] val tclTHENLIST : tactic list -> tactic val tclTHEN_i : tactic -> (int -> tactic) -> tactic val tclTHENFIRST : tactic -> tactic -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 6999b17d8e..f3f81ff616 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -791,9 +791,9 @@ let e_change_in_hyp redfun (id,where) = (convert_hyp c) end -type change_arg = Ltac_pretype.patvar_map -> evar_map -> evar_map * EConstr.constr +type change_arg = Ltac_pretype.patvar_map -> env -> evar_map -> evar_map * EConstr.constr -let make_change_arg c pats sigma = (sigma, replace_vars (Id.Map.bindings pats) c) +let make_change_arg c pats env sigma = (sigma, replace_vars (Id.Map.bindings pats) c) let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in @@ -818,7 +818,7 @@ let check_types env sigma mayneedglobalcheck deep newc origc = (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = - let (sigma, t') = t sigma in + let (sigma, t') = t env sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in match infer_conv ~pb:cv_pb env sigma t' c with | None -> user_err ~hdr:"convert-check-hyp" (str "Not convertible."); diff --git a/tactics/tactics.mli b/tactics/tactics.mli index c088e404b0..24c12ffd82 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -145,7 +145,7 @@ val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic type tactic_reduction = Reductionops.reduction_function type e_tactic_reduction = Reductionops.e_reduction_function -type change_arg = patvar_map -> evar_map -> evar_map * constr +type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic diff --git a/test-suite/bugs/closed/8553.v b/test-suite/bugs/closed/8553.v new file mode 100644 index 0000000000..4a1afabe89 --- /dev/null +++ b/test-suite/bugs/closed/8553.v @@ -0,0 +1,7 @@ +(* Using tactic "change" under binders *) + +Definition add2 n := n +2. +Goal (fun n => n) = (fun n => n+2). +change (?n + 2) with (add2 n). +match goal with |- _ = (fun n => add2 n) => idtac end. (* To test the presence of add2 *) +Abort. diff --git a/test-suite/output/unifconstraints.out b/test-suite/output/unifconstraints.out index ae84603622..2fadd747b7 100644 --- a/test-suite/output/unifconstraints.out +++ b/test-suite/output/unifconstraints.out @@ -63,3 +63,11 @@ unification constraint: True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier +The command has indeed failed with message: +In environment +P : nat -> Type +x : nat +h : P x +Unable to unify "P x" with "?P x" +(unable to find a well-typed instantiation for "?P": cannot ensure that +"nat -> Type" is a subtype of "nat -> Prop"). diff --git a/test-suite/output/unifconstraints.v b/test-suite/output/unifconstraints.v index b9413a4ac2..179dec3fb0 100644 --- a/test-suite/output/unifconstraints.v +++ b/test-suite/output/unifconstraints.v @@ -20,3 +20,9 @@ Goal forall n m : nat, True /\ True /\ True \/ 3:clear m. Show. Admitted. +Unset Printing Existential Instances. + +(* Check non regression of error message (the example can eventually + improve though and succeed) *) + +Fail Check fun P (x:nat) (h:P x) => exist _ x (h : P x). diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 448febed25..5d53fd2f09 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -225,9 +225,9 @@ Qed. (* Illegal application used to make Ltac loop. *) Section LtacLoopTest. - Ltac f x := idtac. + Ltac g x := idtac. Goal True. - Timeout 1 try f()(). + Timeout 1 try g()(). Abort. End LtacLoopTest. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 691f37b414..ff6cefdf24 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -194,7 +194,7 @@ let out_install fmt dir ff = let itarget = String.concat "/" dir in let ff = pmap (function | VO vo -> Some vo.target | _ -> None) ff in let pp_ispec fmt tg = fprintf fmt "(%s as %s)" tg (itarget^"/"^tg) in - fprintf fmt "(install@\n @[(section lib)@\n(files @[%a@])@])@\n" + fprintf fmt "(install@\n @[(section lib)@\n(package coq)@\n(files @[%a@])@])@\n" (pp_list pp_ispec sep) ff (* For each directory, we must record two things, the build rules and diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 23b8bc112e..6a913ea894 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -41,10 +41,6 @@ let norec_dirs = ref StrSet.empty let suffixe = ref ".vo" -[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -[@@@ocaml.warning "+3"] - type dir = string option (** [get_extension f l] checks whether [f] has one of the extensions @@ -473,7 +469,7 @@ let mL_dependencies () = printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname (String.concat " " dep); printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; - let efullname_capital = capitalize (Filename.basename efullname) in + let efullname_capital = String.capitalize_ascii (Filename.basename efullname) in List.iter (fun dep -> printf "%s.cmx : FOR_PACK=-for-pack %s\n" dep efullname_capital) dep; diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index ade5e5be6f..5533ab106d 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -52,9 +52,6 @@ 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"] } let space = [' ' '\t' '\n' '\r'] @@ -159,7 +156,7 @@ and caml_action = parse | space + { caml_action lexbuf } | "open" space* (caml_up_ident as id) - { Use_module (uncapitalize id) } + { Use_module (String.uncapitalize_ascii id) } | "module" space+ caml_up_ident { caml_action lexbuf } | caml_low_ident { caml_action lexbuf } @@ -326,12 +323,12 @@ and modules mllist = parse and qual_id ml_module_name = parse | '.' [^ '.' '(' '['] - { Use_module (uncapitalize ml_module_name) } + { Use_module (String.uncapitalize_ascii ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } and mllib_list = parse - | caml_up_ident { let s = uncapitalize (Lexing.lexeme lexbuf) + | caml_up_ident { let s = String.uncapitalize_ascii (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index 269c1a1d50..36ce405fe6 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -10,11 +10,7 @@ open Cdglobals -[@@@ocaml.warning "-3"] (* Char.uppercase_ascii since 4.03.0 GPR#124 *) -let uppercase = Char.uppercase -[@@@ocaml.warning "+3"] - -let norm_char_latin1 c = match uppercase c with +let norm_char_latin1 c = match Char.uppercase_ascii c with | '\192'..'\198' -> 'A' | '\199' -> 'C' | '\200'..'\203' -> 'E' @@ -25,12 +21,12 @@ let norm_char_latin1 c = match uppercase c with | '\221' -> 'Y' | c -> c -let norm_char_utf8 c = uppercase c +let norm_char_utf8 c = Char.uppercase_ascii c let norm_char c = if !utf8 then norm_char_utf8 c else if !latin1 then norm_char_latin1 c else - uppercase c + Char.uppercase_ascii c let norm_string = String.map (fun s -> norm_char s) diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune index b20d9f9b2e..9c0a6ccffe 100644 --- a/tools/coqdoc/dune +++ b/tools/coqdoc/dune @@ -1,5 +1,6 @@ (install (section lib) + (package coq) (files (coqdoc.css as tools/coqdoc/coqdoc.css) (coqdoc.sty as tools/coqdoc/coqdoc.sty))) @@ -7,6 +8,7 @@ (executable (name main) (public_name coqdoc) + (package coq) (libraries str coq.config)) (ocamllex cpretty) diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 724d3838b0..8d395b418f 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -157,14 +157,10 @@ let sort_entries el = let display_letter c = if c = '*' then "other" else String.make 1 c -[@@@ocaml.warning "-3"] (* String.lowercase_ascii since 4.03.0 GPR#124 *) -let lowercase = String.lowercase -[@@@ocaml.warning "+3"] - let type_name = function | Library -> let ln = !lib_name in - if ln <> "" then lowercase ln else "library" + if ln <> "" then String.lowercase_ascii ln else "library" | Module -> "module" | Definition -> "definition" | Inductive -> "inductive" diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 05bc6aea9b..8ec8927abd 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -21,11 +21,6 @@ let printf s = Printf.fprintf !out_channel s let sprintf = Printf.sprintf -[@@@ocaml.warning "-3"] (* String.{capitalize,lowercase}_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -let lowercase = String.lowercase -[@@@ocaml.warning "+3"] - (*s Coq keywords *) let build_table l = @@ -848,7 +843,7 @@ module Html = struct if t = Library then let ln = !lib_name in if ln <> "" then - "[" ^ lowercase ln ^ "]", m ^ ".html", t + "[" ^ String.lowercase_ascii ln ^ "]", m ^ ".html", t else "[library]", m ^ ".html", t else @@ -866,7 +861,7 @@ module Html = struct (* Impression de la table d'index *) let print_index_table_item i = - printf "<tr>\n<td>%s Index</td>\n" (capitalize i.idx_name); + printf "<tr>\n<td>%s Index</td>\n" (String.capitalize_ascii i.idx_name); List.iter (fun (c,l) -> if l <> [] then @@ -914,7 +909,7 @@ module Html = struct let print_table () = print_index_table all_index in let print_one_index i = if i.idx_size > 0 then begin - printf "<hr/>\n<h1>%s Index</h1>\n" (capitalize i.idx_name); + printf "<hr/>\n<h1>%s Index</h1>\n" (String.capitalize_ascii i.idx_name); all_letters i end in diff --git a/tools/dune b/tools/dune index 20048fde52..3358d1a4e2 100644 --- a/tools/dune +++ b/tools/dune @@ -1,5 +1,6 @@ (install (section lib) + (package coq) (files (CoqMakefile.in as tools/CoqMakefile.in) (TimeFileMaker.py as tools/TimeFileMaker.py) @@ -10,18 +11,21 @@ (executable (name coq_makefile) (public_name coq_makefile) + (package coq) (modules coq_makefile) (libraries coq.lib)) (executable (name coqc) (public_name coqc) + (package coq) (modules coqc) (libraries coq.toplevel)) (executable (name coqdep) (public_name coqdep) + (package coq) (modules coqdep_lexer coqdep_common coqdep) (libraries coq.lib)) @@ -30,6 +34,7 @@ (executable (name coqwc) (public_name coqwc) + (package coq) (modules coqwc) (libraries)) @@ -38,11 +43,13 @@ (executable (name coq_tex) (public_name coq_tex) + (package coq) (modules coq_tex) (libraries str)) (executable (name coq_dune) (public_name coq_dune) + (package coq) (modules coq_dune) (libraries str)) diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 382c39d3f2..053a0435ce 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -14,11 +14,6 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) - [@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) - let uncapitalize = String.uncapitalize - - let capitalize = String.capitalize - [@@@ocaml.warning "+3"] } let space = [' ' '\t' '\n' '\r'] @@ -31,7 +26,7 @@ let caml_low_ident = lowercase identchar* rule mllib_list = parse | uppercase+ { let s = Lexing.lexeme lexbuf in s :: mllib_list lexbuf } - | caml_up_ident { let s = uncapitalize (Lexing.lexeme lexbuf) + | caml_up_ident { let s = String.uncapitalize_ascii (Lexing.lexeme lexbuf) in s :: mllib_list lexbuf } | "*predef*" { mllib_list lexbuf } | space+ { mllib_list lexbuf } @@ -204,7 +199,7 @@ let mlpack_dependencies () = List.iter (fun (name,dirname) -> let fullname = file_name name dirname in - let modname = capitalize name in + let modname = String.capitalize_ascii name in let deps = traite_fichier_modules fullname ".mlpack" in let sdeps = String.concat " " deps in let efullname = escape fullname in diff --git a/topbin/dune b/topbin/dune index 5f07492a10..52f472d149 100644 --- a/topbin/dune +++ b/topbin/dune @@ -1,5 +1,6 @@ (install (section bin) + (package coq) (files (coqtop_bin.exe as coqtop))) (executable diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index b000745961..15c0278f47 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -119,7 +119,7 @@ and fields_of_expression x = fields_of_functor fields_of_expr x let lookup_constant_in_impl cst fallback = try - let mp,dp,lab = KerName.repr (Constant.canonical cst) in + let mp,lab = KerName.repr (Constant.canonical cst) in let fields = memoize_fields_of_mp mp in (* A module found this way is necessarily closed, in particular our constant cannot be in an opened section : *) @@ -143,7 +143,7 @@ let lookup_constant cst = let lookup_mind_in_impl mind = try - let mp,dp,lab = KerName.repr (MutInd.canonical mind) in + let mp,lab = KerName.repr (MutInd.canonical mind) in let fields = memoize_fields_of_mp mp in search_mind_label lab fields with Not_found -> @@ -157,9 +157,9 @@ let lookup_mind mind = traversed objects *) let label_of = function - | ConstRef kn -> pi3 (Constant.repr3 kn) + | ConstRef kn -> Constant.label kn | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> pi3 (MutInd.repr3 kn) + | ConstructRef ((kn,_),_) -> MutInd.label kn | VarRef id -> Label.of_id id let fold_constr_with_full_binders g f n acc c = diff --git a/vernac/classes.ml b/vernac/classes.ml index c738d14af9..37ee33b19f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -99,7 +99,7 @@ let type_ctx_instance env sigma ctx inst subst = let id_of_class cl = match cl.cl_impl with - | ConstRef kn -> let _,_,l = Constant.repr3 kn in Label.to_id l + | ConstRef kn -> Label.to_id @@ Constant.label kn | IndRef (kn,i) -> let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in mip.(0).Declarations.mind_typename diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 750ed35cbc..9497f2fb03 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -84,8 +84,7 @@ match local with in (gr,inst,Lib.is_modtype_strict ()) -let interp_assumption sigma env impls bl c = - let c = mkCProdN ?loc:(local_binders_loc bl) bl c in +let interp_assumption sigma env impls c = let sigma, (ty, impls) = interp_type_evars_impls env sigma ~impls c in sigma, (ty, impls) @@ -148,7 +147,7 @@ let do_assumptions kind nl l = in (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> - let sigma,(t,imps) = interp_assumption sigma env ienv [] c in + let sigma,(t,imps) = interp_assumption sigma env ienv c in let env = EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (id,t)) idl) env in let ienv = List.fold_right (fun {CAst.v=id} ienv -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index cf69a84b8b..895737b538 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -296,7 +296,7 @@ GRAMMAR EXTEND Gram { if List.exists (function CLocalPattern _ -> true | _ -> false) bl then (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkCLambdaN ~loc bl c in + let c = mkLambdaCN ~loc bl c in DefineBody ([], red, c, None) else (match c with @@ -308,7 +308,7 @@ GRAMMAR EXTEND Gram then (* FIXME: "red" will be applied to types in bl and Cast with remain *) let c = CAst.make ~loc @@ CCast (c, CastConv t) in - (([],mkCLambdaN ~loc bl c), None) + (([],mkLambdaCN ~loc bl c), None) else ((bl, c), Some t) in DefineBody (bl, red, c, tyo) } @@ -419,16 +419,16 @@ GRAMMAR EXTEND Gram ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; - t = lconstr -> { fun id -> (oc,AssumExpr (id,mkCProdN ~loc l t)) } + t = lconstr -> { fun id -> (oc,AssumExpr (id,mkProdCN ~loc l t)) } | l = binders; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> { fun id -> - (oc,DefExpr (id,mkCLambdaN ~loc l b,Some (mkCProdN ~loc l t))) } + (oc,DefExpr (id,mkLambdaCN ~loc l b,Some (mkProdCN ~loc l t))) } | l = binders; ":="; b = lconstr -> { fun id -> match b.CAst.v with | CCast(b', (CastConv t|CastVM t|CastNative t)) -> - (None,DefExpr(id,mkCLambdaN ~loc l b',Some (mkCProdN ~loc l t))) + (None,DefExpr(id,mkLambdaCN ~loc l b',Some (mkProdCN ~loc l t))) | _ -> - (None,DefExpr(id,mkCLambdaN ~loc l b,None)) } ] ] + (None,DefExpr(id,mkLambdaCN ~loc l b,None)) } ] ] ; record_binder: [ [ id = name -> { (None,AssumExpr(id, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) } @@ -448,9 +448,9 @@ GRAMMAR EXTEND Gram constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> - { fun l id -> (not (Option.is_empty coe),(id,mkCProdN ~loc l c)) } + { fun l id -> (not (Option.is_empty coe),(id,mkProdCN ~loc l c)) } | -> - { fun l id -> (false,(id,mkCProdN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ] + { fun l id -> (false,(id,mkProdCN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ] -> { t l } ]] ; diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index aa9bd20bf3..4f0bf1b5d2 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -533,7 +533,3 @@ let save_proof ?proof = function (* if the proof is given explicitly, nothing has to be deleted *) if Option.is_empty proof then Proof_global.discard_current (); Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) - -(* Miscellaneous *) -let get_current_context () = Pfedit.get_current_context () - diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 38683ed6b2..62b25946d9 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -67,10 +67,3 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val val set_save_hook : (Proof.t -> unit) -> unit val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit - -(** [get_current_context ()] returns the evar context and env of the - current open proof if any, otherwise returns the empty evar context - and the current global env *) - -val get_current_context : unit -> Evd.evar_map * Environ.env -[@@ocaml.deprecated "please use [Pfedit.get_current_context]"] diff --git a/vernac/misctypes.ml b/vernac/misctypes.ml deleted file mode 100644 index ef9cd3c351..0000000000 --- a/vernac/misctypes.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* Compat module, to be removed in 8.10 *) -open Names - -type lident = Names.lident -[@@ocaml.deprecated "use [Names.lident"] -type lname = Names.lname -[@@ocaml.deprecated "use [Names.lname]"] -type lstring = Names.lstring -[@@ocaml.deprecated "use [Names.lstring]"] - -type 'a or_by_notation_r = 'a Constrexpr.or_by_notation_r = - | AN of 'a [@ocaml.deprecated "use version in [Constrexpr]"] - | ByNotation of (string * string option) [@ocaml.deprecated "use version in [Constrexpr]"] -[@@ocaml.deprecated "use [Constrexpr.or_by_notation_r]"] - -type 'a or_by_notation = 'a Constrexpr.or_by_notation -[@@ocaml.deprecated "use [Constrexpr.or_by_notation]"] - -type intro_pattern_naming_expr = Namegen.intro_pattern_naming_expr = - | IntroIdentifier of Id.t [@ocaml.deprecated "Use version in [Namegen]"] - | IntroFresh of Id.t [@ocaml.deprecated "Use version in [Namegen]"] - | IntroAnonymous [@ocaml.deprecated "Use version in [Namegen]"] -[@@ocaml.deprecated "use [Namegen.intro_pattern_naming_expr]"] - -type 'a or_var = 'a Locus.or_var = - | ArgArg of 'a [@ocaml.deprecated "Use version in [Locus]"] - | ArgVar of Names.lident [@ocaml.deprecated "Use version in [Locus]"] -[@@ocaml.deprecated "use [Locus.or_var]"] - -type quantified_hypothesis = Tactypes.quantified_hypothesis = - AnonHyp of int [@ocaml.deprecated "Use version in [Tactypes]"] - | NamedHyp of Id.t [@ocaml.deprecated "Use version in [Tactypes]"] -[@@ocaml.deprecated "use [Tactypes.quantified_hypothesis]"] - -type multi = Equality.multi = - | Precisely of int [@ocaml.deprecated "use version in [Equality]"] - | UpTo of int [@ocaml.deprecated "use version in [Equality]"] - | RepeatStar [@ocaml.deprecated "use version in [Equality]"] - | RepeatPlus [@ocaml.deprecated "use version in [Equality]"] -[@@ocaml.deprecated "use [Equality.multi]"] - -type 'a bindings = 'a Tactypes.bindings = - | ImplicitBindings of 'a list [@ocaml.deprecated "use version in [Tactypes]"] - | ExplicitBindings of 'a Tactypes.explicit_bindings [@ocaml.deprecated "use version in [Tactypes]"] - | NoBindings [@ocaml.deprecated "use version in [Tactypes]"] -[@@ocaml.deprecated "use [Tactypes.bindings]"] - -type 'constr intro_pattern_expr = 'constr Tactypes.intro_pattern_expr = - | IntroForthcoming of bool [@ocaml.deprecated "use version in [Tactypes]"] - | IntroNaming of Namegen.intro_pattern_naming_expr [@ocaml.deprecated "use version in [Tactypes]"] - | IntroAction of 'constr Tactypes.intro_pattern_action_expr [@ocaml.deprecated "use version in [Tactypes]"] -and 'constr intro_pattern_action_expr = 'constr Tactypes.intro_pattern_action_expr = - | IntroWildcard [@ocaml.deprecated "use [Tactypes]"] - | IntroOrAndPattern of 'constr Tactypes.or_and_intro_pattern_expr [@ocaml.deprecated "use [Tactypes]"] - | IntroInjection of ('constr intro_pattern_expr) CAst.t list [@ocaml.deprecated "use [Tactypes]"] - | IntroApplyOn of 'constr CAst.t * 'constr intro_pattern_expr CAst.t [@ocaml.deprecated "use [Tactypes]"] - | IntroRewrite of bool [@ocaml.deprecated "use [Tactypes]"] -and 'constr or_and_intro_pattern_expr = 'constr Tactypes.or_and_intro_pattern_expr = - | IntroOrPattern of ('constr intro_pattern_expr) CAst.t list list [@ocaml.deprecated "use [Tactypes]"] - | IntroAndPattern of ('constr intro_pattern_expr) CAst.t list [@ocaml.deprecated "use [Tactypes]"] -[@@ocaml.deprecated "use version in [Tactypes]"] - -type 'id move_location = 'id Logic.move_location = - | MoveAfter of 'id [@ocaml.deprecated "use version in [Logic]"] - | MoveBefore of 'id [@ocaml.deprecated "use version in [Logic]"] - | MoveFirst [@ocaml.deprecated "use version in [Logic]"] - | MoveLast [@ocaml.deprecated "use version in [Logic]"] -[@@ocaml.deprecated "use version in [Logic]"] - -type 'a cast_type = 'a Glob_term.cast_type = - | CastConv of 'a [@ocaml.deprecated "use version in [Glob_term]"] - | CastVM of 'a [@ocaml.deprecated "use version in [Glob_term]"] - | CastCoerce [@ocaml.deprecated "use version in [Glob_term]"] - | CastNative of 'a [@ocaml.deprecated "use version in [Glob_term]"] -[@@ocaml.deprecated "use version in [Glob_term]"] diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 015d5fabef..cf2fecb9c1 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -249,8 +249,7 @@ let print_namespace ns = in let print_list pr l = prlist_with_sep (fun () -> str".") pr l in let print_kn kn = - (* spiwack: I'm ignoring the dirpath, is that bad? *) - let (mp,_,lbl) = Names.KerName.repr kn in + let (mp,lbl) = Names.KerName.repr kn in let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in print_list Id.print qn in diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index a5601d8c85..a2ea706b75 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -15,14 +15,6 @@ open Libnames (** Vernac expressions, produced by the parser *) type class_rawexpr = FunClass | SortClass | RefClass of qualid or_by_notation -type goal_selector = Goal_select.t = - | SelectAlreadyFocused [@ocaml.deprecated "Use Goal_select.SelectAlreadyFocused"] - | SelectNth of int [@ocaml.deprecated "Use Goal_select.SelectNth"] - | SelectList of (int * int) list [@ocaml.deprecated "Use Goal_select.SelectList"] - | SelectId of Id.t [@ocaml.deprecated "Use Goal_select.SelectId"] - | SelectAll [@ocaml.deprecated "Use Goal_select.SelectAll"] -[@@ocaml.deprecated "Use Goal_select.t"] - type goal_identifier = string type scope_name = string @@ -31,9 +23,6 @@ type goal_reference = | NthGoal of int | GoalId of Id.t -type univ_name_list = UnivNames.univ_name_list -[@@ocaml.deprecated "Use [UnivNames.univ_name_list]"] - type printable = | PrintTables | PrintFullContext @@ -102,54 +91,12 @@ type comment = | CommentString of string | CommentInt of int -type reference_or_constr = Hints.reference_or_constr = - | HintsReference of qualid [@ocaml.deprecated "Use Hints.HintsReference"] - | HintsConstr of constr_expr [@ocaml.deprecated "Use Hints.HintsConstr"] -[@@ocaml.deprecated "Please use [Hints.reference_or_constr]"] - -type hint_mode = Hints.hint_mode = - | ModeInput [@ocaml.deprecated "Use Hints.ModeInput"] - | ModeNoHeadEvar [@ocaml.deprecated "Use Hints.ModeNoHeadEvar"] - | ModeOutput [@ocaml.deprecated "Use Hints.ModeOutput"] -[@@ocaml.deprecated "Please use [Hints.hint_mode]"] - -type 'a hint_info_gen = 'a Typeclasses.hint_info_gen = - { hint_priority : int option; [@ocaml.deprecated "Use Typeclasses.hint_priority"] - hint_pattern : 'a option [@ocaml.deprecated "Use Typeclasses.hint_pattern"] } -[@@ocaml.deprecated "Please use [Typeclasses.hint_info_gen]"] - -type hint_info_expr = Hints.hint_info_expr -[@@ocaml.deprecated "Please use [Hints.hint_info_expr]"] - -type hints_expr = Hints.hints_expr = - | HintsResolve of (Hints.hint_info_expr * bool * Hints.reference_or_constr) list - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsResolveIFF of bool * qualid list * int option - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsImmediate of Hints.reference_or_constr list - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsUnfold of qualid list - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsTransparency of qualid Hints.hints_transparency_target * bool - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsMode of qualid * Hints.hint_mode list - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsConstructors of qualid list - [@ocaml.deprecated "Use the constructor in module [Hints]"] - | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument - [@ocaml.deprecated "Use the constructor in module [Hints]"] -[@@ocaml.deprecated "Please use [Hints.hints_expr]"] - type search_restriction = | SearchInside of qualid list | SearchOutside of qualid list type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) -type opacity_flag = Proof_global.opacity_flag = - Opaque [@ocaml.deprecated "Use Proof_global.Opaque"] - | Transparent [@ocaml.deprecated "Use Proof_global.Transparent"] - [@ocaml.deprecated "Please use [Proof_global.opacity_flag]"] type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) @@ -285,33 +232,8 @@ type register_kind = | RegisterInline | RegisterRetroknowledge of qualid -type bullet = Proof_bullet.t -[@@ocaml.deprecated "Alias type, please use [Proof_bullet.t]"] - (** {6 Types concerning the module layer} *) -(** Rigid / flexible module signature *) - -type 'a module_signature = 'a Declaremods.module_signature = - | Enforce of 'a (** ... : T *) - [@ocaml.deprecated "Use the constructor in module [Declaremods]"] - | Check of 'a list (** ... <: T1 <: T2, possibly empty *) - [@ocaml.deprecated "Use the constructor in module [Declaremods]"] -[@@ocaml.deprecated "please use [Declaremods.module_signature]."] - -(** Which module inline annotations should we honor, - either None or the ones whose level is less or equal - to the given integer *) - -type inline = Declaremods.inline = - | NoInline - [@ocaml.deprecated "Use the constructor in module [Declaremods]"] - | DefaultInline - [@ocaml.deprecated "Use the constructor in module [Declaremods]"] - | InlineAt of int - [@ocaml.deprecated "Use the constructor in module [Declaremods]"] -[@@ocaml.deprecated "please use [Declaremods.inline]."] - type module_ast_inl = module_ast * Declaremods.inline type module_binder = bool option * lident list * module_ast_inl |