diff options
172 files changed, 2088 insertions, 1819 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ec3702b360..3c24ec28c4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-03-12-V1" + CACHEKEY: "bionic_coq-V2019-04-20-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -47,9 +47,6 @@ before_script: - opam list - opam config list -after_script: - - echo "The build completed normally (not a runner failure)." - ################ GITLAB CACHING ###################### # - use artifacts between jobs # ###################################################### @@ -662,5 +659,5 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda -plugin:ci-relation-algebra: +plugin:ci-relation_algebra: extends: .ci-template @@ -45,7 +45,8 @@ Julien Forest <julien.forest@ensiie.fr> forest <jforest@mourvedre.ens Julien Forest <julien.forest@ensiie.fr> jforest <jforest@thune> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@daneel.lan.home> Julien Forest <julien.forest@ensiie.fr> Julien Forest <forest@ensiie.fr> -Emilio Jesus Gallego Arias <e+git@x80.org> Emilio Jesús Gallego Arias <e+git@x80.org> +Emilio Jesús Gallego Arias <e@x80.org> Emilio Jesus Gallego Arias <e+git@x80.org> +Emilio Jesús Gallego Arias <e@x80.org> Emilio Jesús Gallego Arias <e+git@x80.org> Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@ens-lyon.fr> Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@skyskimmer.net> Stéphane Glondu <steph@glondu.net> glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7> diff --git a/CHANGES.md b/CHANGES.md index ce8a787cd1..9a292562ed 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -22,6 +22,9 @@ Coqide - CoqIDE now properly sets the module name for a given file based on its path, see -topfile change entry for more details. +- Preferences from coqide.keys are no longer overridden by modifiers + preferences in coqiderc. + Coqtop - the use of `coqtop` as a compiler has been deprecated, in favor of @@ -227,6 +230,10 @@ Tools `coqc`/`make` as well as printing to stdout, on both python2 and python3. +- Coq options can be set on the command line, eg `-set "Universe Polymorphism=true"` + +- coq_makefile's install target now errors if any file to install is missing. + Standard Library - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about diff --git a/META.coq.in b/META.coq.in index ab142ccc43..ef5de8da2b 100644 --- a/META.coq.in +++ b/META.coq.in @@ -315,7 +315,7 @@ package "plugins" ( archive(native) = "micromega_plugin.cmx" ) - package "newring" ( + package "setoid_ring" ( description = "Coq newring plugin" version = "8.10" @@ -351,7 +351,7 @@ package "plugins" ( archive(native) = "cc_plugin.cmx" ) - package "ground" ( + package "firstorder" ( description = "Coq ground plugin" version = "8.10" @@ -387,7 +387,7 @@ package "plugins" ( archive(native) = "btauto_plugin.cmx" ) - package "recdef" ( + package "funind" ( description = "Coq recdef plugin" version = "8.10" diff --git a/Makefile.ci b/Makefile.ci index 000725b6b1..a244c17ef3 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -38,7 +38,7 @@ CI_TARGETS= \ ci-mtac2 \ ci-paramcoq \ ci-quickchick \ - ci-relation-algebra \ + ci-relation_algebra \ ci-sf \ ci-simple-io \ ci-stdlib2 \ diff --git a/Makefile.doc b/Makefile.doc index e89a20393c..23aa66a1b8 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -31,8 +31,8 @@ DVIPS:=dvips HTMLSTYLE:=coqremote # Sphinx-related variables -OSNAME:=$(shell uname -o) -ifeq ($(OSNAME),Cygwin) +OSNAME:=$(shell uname -s) +ifeq ($(findstring CYGWIN,$(OSNAME)),CYGWIN) WIN_CURDIR:=$(shell cygpath -w $(CURDIR)) SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(WIN_CURDIR)" else diff --git a/Makefile.ide b/Makefile.ide index 908f5f6648..4cec7aa443 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -66,8 +66,9 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ GTKSHARE=$(shell pkg-config --variable=prefix gtk+-3.0)/share GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) -PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-3.0)/bin +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share +ADWAITASHARE=$(shell ls -d /usr/local/Cellar/adwaita-icon-theme/*)/share ########################################################################### # CoqIde special targets @@ -244,17 +245,20 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk3.sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents $(MKDIR) $@/coq/ $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(IDEBINDINGS) $@/coq/ - $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ + $(MKDIR) $@/gtksourceview-3.0/{language-specs,styles} + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-3.0/language-specs/ + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/styles/{styles.rng,classic.xml} $@/gtksourceview-3.0/styles/ cp -R "$(GTKSHARE)/"locale $@ cp -R "$(GTKSHARE)/"themes $@ + $(MKDIR) $@/glib-2.0/schemas + glib-compile-schemas --targetdir=$@/glib-2.0/schemas "$(GTKSHARE)/"glib-2.0/schemas/ + cp -R "$(ADWAITASHARE)/"icons $@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(MKDIR) $@ @@ -262,20 +266,20 @@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-2.0/2.10.0/immodules/"*.so $@ + $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.so $@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(MKDIR) $@/xdg/coq $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys - $(MKDIR) $@/gtk-2.0 + $(MKDIR) $@/gtk-3.0 { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\ + > $@/gtk-3.0/gdk-pixbuf.loaders + { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.so |\ sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gtk-immodules.loaders + > $@/gtk-3.0/gtk-immodules.loaders $(MKDIR) $@/pango echo "[Pango]" > $@/pango/pangorc diff --git a/azure-pipelines.yml b/azure-pipelines.yml index a8b42cc722..f09087b172 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -42,6 +42,9 @@ jobs: pool: vmImage: 'macOS-10.13' + variables: + MACOSX_DEPLOYMENT_TARGET: '10.12' + steps: - checkout: self fetchDepth: 10 @@ -49,16 +52,20 @@ jobs: - script: | set -e brew update - brew unlink python - brew install gnu-time opam + brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme + pip3 install macpack + displayName: 'Install system dependencies' + - script: | + set -e + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig opam init -a -j "$NJOBS" --compiler=$COMPILER opam switch set $COMPILER eval $(opam env) opam update - opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit + opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 opam list - displayName: 'Install dependencies' + displayName: 'Install OCaml dependencies' env: COMPILER: "4.07.1" FINDLIB_VER: ".1.8.0" @@ -68,11 +75,30 @@ jobs: set -e eval $(opam env) - ./configure -local -warn-error yes -native-compiler no + ./configure -prefix '$(Build.BinariesDirectory)' -warn-error yes -native-compiler no -coqide opt make -j "$NJOBS" displayName: 'Build Coq' - script: | eval $(opam env) - make -j "$NJOBS" test-suite + make -j "$NJOBS" test-suite PRINT_LOGS=1 displayName: 'Run Coq Test Suite' + + - script: | + make install + displayName: 'Install Coq' + + - script: | + set -e + eval $(opam env) + export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig + ./dev/build/osx/make-macos-dmg.sh + mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" + displayName: 'Create the dmg bundle' + env: + OUTDIR: '$(Build.BinariesDirectory)' + + - task: PublishBuildArtifacts@1 + inputs: + pathtoPublish: '$(Build.ArtifactStagingDirectory)' + artifactName: coq-macOS-installer diff --git a/coq-refman.opam b/coq-refman.opam index b9500243a3..16be422c27 100644 --- a/coq-refman.opam +++ b/coq-refman.opam @@ -17,7 +17,7 @@ license: "Open Publication License" depends: [ "dune" { build } - "coq" { build } + "coq" { build & = version } ] build-env: [ @@ -20,7 +20,8 @@ license: "LGPL-2.1" depends: [ "ocaml" { >= "4.05.0" } - "dune" { build & >= "1.4.0" } + "dune" { build & >= "1.6.0" } + "ocamlfind" { build } "num" ] diff --git a/coqide-server.opam b/coqide-server.opam index ed6f3d98d8..0325d2549c 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -19,8 +19,8 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } - "coq" + "dune" { build & >= "1.6.0" } + "coq" { = version } ] build: [ [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/coqide.opam b/coqide.opam index c82fa72564..2507acbb26 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,8 +17,8 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } - "coqide-server" + "dune" { build & >= "1.6.0" } + "coqide-server" { = version } "lablgtk3" { >= "3.0.beta5" } "lablgtk3-sourceview3" { >= "3.0.beta5" } ] diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index c450e8157a..3a096fec06 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -4,7 +4,6 @@ set -e # Configuration setup -OUTDIR=$PWD/_install DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app @@ -13,7 +12,7 @@ APP=bin/CoqIDE_${VERSION}.app make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" # Add Coq to the .app file -make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources/" install-coq install-ide-toploop +make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop # Create the dmg bundle mkdir -p "$DMGDIR" diff --git a/dev/ci/README-users.md b/dev/ci/README-users.md index 01769aeddb..06b617d4c1 100644 --- a/dev/ci/README-users.md +++ b/dev/ci/README-users.md @@ -45,6 +45,26 @@ using [coqbot](https://github.com/coq/bot); meanwhile, a workaround is to give merge permissions to someone from the Coq team as to help with these kind of merges. +### OCaml and plugin-specific considerations + +Developments that link against Coq's OCaml API [most of them are known +as "plugins"] do have some special requirements: + +- Coq's OCaml API is not stable. We hope to improve this in the future + but as of today you should expect to have to merge a fair amount of + "overlays", usually in the form of Pull Requests from Coq developers + in order to keep your plugin compatible with Coq master. + + In order to alleviate the load, you can delegate the merging of such + compatibility pull requests to Coq developers themselves, by + granting access to the plugin repository or by using `bots` such as + [Bors](https://github.com/apps/bors) that allow for automatic + management of Pull Requests. + +- Plugins in the CI should compile with the OCaml flags that Coq + uses. In particular, warnings that are considered fatal by the Coq + developers _must_ be also fatal for plugin CI code. + ### Add your development by submitting a pull request Add a new `ci-mydev.sh` script to [`dev/ci`](.); set the corresponding diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 0c89809ee9..4f5988c59c 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -254,7 +254,7 @@ : "${paramcoq_CI_ARCHIVEURL:=${paramcoq_CI_GITURL}/archive}" ######################################################################## -# relation-algebra +# relation_algebra ######################################################################## : "${relation_algebra_CI_REF:=master}" : "${relation_algebra_CI_GITURL:=https://github.com/damien-pous/relation-algebra}" diff --git a/dev/ci/ci-relation-algebra.sh b/dev/ci/ci-relation_algebra.sh index 84bed5bdfe..84bed5bdfe 100755 --- a/dev/ci/ci-relation-algebra.sh +++ b/dev/ci/ci-relation_algebra.sh diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index e553cbed1b..8eebb3af64 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-03-12-V1" +# CACHEKEY: "bionic_coq-V2019-04-20-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -38,7 +38,7 @@ ENV COMPILER="4.05.0" # `num` does not have a version number as the right version to install varies # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ - CI_OPAM="menhir.20181113 elpi.1.1.0 ocamlgraph.1.8.8" + CI_OPAM="menhir.20181113 elpi.1.2.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" diff --git a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh new file mode 100644 index 0000000000..1e1d36d54a --- /dev/null +++ b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9165" ] || [ "$CI_BRANCH" = "recarg-cleanup" ]; then + + elpi_CI_REF=recarg-cleanup + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + quickchick_CI_REF=recarg-cleanup + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh b/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh new file mode 100644 index 0000000000..01d3068591 --- /dev/null +++ b/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh @@ -0,0 +1,21 @@ +if [ "$CI_PULL_REQUEST" = "9909" ] || [ "$CI_BRANCH" = "pretyping-rm-global" ]; then + + elpi_CI_REF=pretyping-rm-global + elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi + + coqhammer_CI_REF=pretyping-rm-global + coqhammer_CI_GITURL=https://github.com/maximedenes/coqhammer + + equations_CI_REF=pretyping-rm-global + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + + ltac2_CI_REF=pretyping-rm-global + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + paramcoq_CI_REF=pretyping-rm-global + paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq + + mtac2_CI_REF=pretyping-rm-global + mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09973-gares-elpi-2.1.sh b/dev/ci/user-overlays/09973-gares-elpi-2.1.sh new file mode 100644 index 0000000000..9a6e25d893 --- /dev/null +++ b/dev/ci/user-overlays/09973-gares-elpi-2.1.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9973" ] || [ "$CI_BRANCH" = "elpi-1.2" ]; then + + elpi_CI_REF=overlay-elpi1.2-coq-master + elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 416253fad1..4533a4dc01 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -20,6 +20,15 @@ General deprecation removed. Please, make sure your plugin is warning-free in 8.8 before trying to port it over 8.9. +Warnings + +- Coq now builds plugins with `-warn-error` enabled by default. The + amount of dangerous warnings in plugin code was very high, so we now + require plugins in the CI to adhere to the Coq warning policy. We + _strongly_ recommend against disabling the default set of warnings. + If you have special needs, see the documentation of your build + system and/or OCaml for further help. + Names - Kernel names no longer contain a section path. They now have only two @@ -83,6 +92,11 @@ Libobject * `Libobject.superglobal_object` * `Libobject.superglobal_object_nodischarge` +AST + +- Minor changes in the AST have been performed, for example + https://github.com/coq/coq/pull/9165 + Implicit Arguments - `Impargs.declare_manual_implicits` is restricted to only support declaration diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index c23d2fb528..01c2b574a2 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -219,6 +219,15 @@ Conversion machines GH issue number: ? risk: + component: primitive projections, native_compute + summary: stuck primitive projections computed incorrectly by native_compute + introduced: 1 Jun 2018, e1e7888a, ppedrot + impacted released versions: 8.9.0 + impacted coqchk versions: none + found by: maximedenes exploiting bug #9684 + exploit: test-suite/bugs/closed/bug_9684.v + GH issue number: #9684 + Conflicts with axioms in library component: library of real numbers diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 56f84d0ff0..b410833d25 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -194,14 +194,14 @@ Program Fixpoint The optional order annotation follows the grammar: .. productionlist:: orderannot - order : measure `term` (`term`)? | wf `term` `term` + order : measure `term` [ `term` ] | wf `term` `ident` - + :g:`measure f ( R )` where :g:`f` is a value of type :g:`X` computed on - any subset of the arguments and the optional (parenthesised) term - ``(R)`` is a relation on ``X``. By default ``X`` defaults to ``nat`` and ``R`` - to ``lt``. + + :g:`measure f R` where :g:`f` is a value of type :g:`X` computed on + any subset of the arguments and the optional term + :g:`R` is a relation on :g:`X`. :g:`X` defaults to :g:`nat` and :g:`R` + to :g:`lt`. - + :g:`wf R x` which is equivalent to :g:`measure x (R)`. + + :g:`wf R x` which is equivalent to :g:`measure x R`. The structural fixpoint operator behaves just like the one of |Coq| (see :cmd:`Fixpoint`), except it may also generate obligations. It works diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 015b84c530..c0c8c2d79c 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -19,6 +19,9 @@ known as strict propositions). To use :math:`\SProp` you must pass initial value depends on whether you used the command line ``-allow-sprop``. +.. exn:: SProp not allowed, you need to Set Allow StrictProp or to use the -allow-sprop command-line-flag. + :undocumented: + .. coqtop:: none Set Allow StrictProp. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index b069cf27f4..a5e9023732 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -433,22 +433,26 @@ few other commands related to typeclasses. .. _TypeclassesTransparent: -Typeclasses Transparent, Typclasses Opaque -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Typeclasses Transparent, Typeclasses Opaque +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Typeclasses Transparent {+ @ident} This command makes the identifiers transparent during typeclass resolution. + Shortcut for :n:`Hint Transparent {+ @ident } : typeclass_instances`. .. cmd:: Typeclasses Opaque {+ @ident} - Make the identifiers opaque for typeclass search. It is useful when some - constants prevent some unifications and make resolution fail. It is also - useful to declare constants which should never be unfolded during - proof-search, like fixpoints or anything which does not look like an - abbreviation. This can additionally speed up proof search as the typeclass - map can be indexed by such rigid constants (see + Make the identifiers opaque for typeclass search. + Shortcut for :n:`Hint Opaque {+ @ident } : typeclass_instances`. + + It is useful when some constants prevent some unifications and make + resolution fail. It is also useful to declare constants which + should never be unfolded during proof-search, like fixpoints or + anything which does not look like an abbreviation. This can + additionally speed up proof search as the typeclass map can be + indexed by such rigid constants (see :ref:`thehintsdatabasesforautoandeauto`). By default, all constants and local variables are considered transparent. One @@ -458,8 +462,6 @@ type, like: .. coqdoc:: Definition relation A := A -> A -> Prop. -This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. - Settings ~~~~~~~~ diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index eebf1f11e1..bdda35fcc0 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -210,6 +210,13 @@ and ``coqtop``, unless stated otherwise: is intended to be used as a linter for developments that want to be robust to changes in the auto-generated name scheme. The options are provided to facilitate tracking down problems. +:-set *string*: Enable flags and set options. *string* should be + ``Option Name=value``, the value is interpreted according to the + type of the option. For flags ``Option Name`` is equivalent to + ``Option Name=true``. For instance ``-set "Universe Polymorphism"`` + will enable :flag:`Universe Polymorphism`. Note that the quotes are + shell syntax, Coq does not see them. +:-unset *string*: As ``-set`` but used to disable options and flags. :-compat *version*: Attempt to maintain some backward-compatibility with a previous version. :-dump-glob *file*: Dump references for global names in file *file* diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 8346b72cb9..35231610fe 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -144,6 +144,10 @@ Here we describe only few of them. :CAMLFLAGS: can be used to specify additional flags to the |OCaml| compiler, like ``-bin-annot`` or ``-w``.... +:OCAMLWARN: + it contains a default of ``-warn-error +a-3``, useful to modify + this setting; beware this is not recommended for projects in + Coq's CI. :COQC, COQDEP, COQDOC: can be set in order to use alternative binaries (e.g. wrappers) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index afb0239be4..8d9e99b9d5 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3830,25 +3830,25 @@ The general command to add a hint to some databases :n:`{+ @ident}` is check with :cmd:`Print HintDb` to verify the current cut expression: .. productionlist:: regexp - e : `ident` hint or instance identifier - : _ any hint - : `e` | `e` disjunction - : `e` `e` sequence - : `e` * Kleene star - : emp empty - : eps epsilon - : ( `e` ) + regexp : `ident` (hint or instance identifier) + : _ (any hint) + : `regexp` | `regexp` (disjunction) + : `regexp` `regexp` (sequence) + : `regexp` * (Kleene star) + : emp (empty) + : eps (epsilon) + : ( `regexp` ) The `emp` regexp does not match any search path while `eps` matches the empty path. During proof search, the path of successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note that Hint Extern’s do not have + list of identifiers for the hints (note that :cmd:`Hint Extern`\’s do not have an associated identifier). Before applying any hint :n:`@ident` the current path `p` extended with :n:`@ident` is matched against the current cut expression `c` associated to the hint database. If matching succeeds, the hint is *not* applied. The - semantics of ``Hint Cut e`` is to set the cut expression to ``c | e``, the - initial cut expression being `emp`. + semantics of :n:`Hint Cut @regexp` is to set the cut expression + to :n:`c | regexp`, the initial cut expression being `emp`. .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} : @ident :name: Hint Mode @@ -3875,7 +3875,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. note:: One can use an ``Extern`` hint with no pattern to do pattern matching on - hypotheses using ``match goal`` with inside the tactic. + hypotheses using ``match goal with`` inside the tactic. Hint databases defined in the Coq standard library @@ -4724,6 +4724,12 @@ Non-logical tactics from the shelf into focus, by appending them to the end of the current list of focused goals. +.. tacn:: unshelve @tactic + :name: unshelve + + Performs :n:`@tactic`, then unshelves existential variables added to the + shelf by the execution of :n:`@tactic`, prepending them to the current goal. + .. tacn:: give_up :name: give_up diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index eaf1b2c2ad..0ade9fdbf5 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -149,13 +149,6 @@ class CoqObject(ObjectDescription): msg = MSG.format(name, self.env.doc2path(objects[name][0])) self.state_machine.reporter.warning(msg, line=self.lineno) - def _warn_if_duplicate_name(self, objects, name): - """Check that two objects in the same domain don't have the same name.""" - if name in objects: - MSG = 'Duplicate object: {}; other is at {}' - msg = MSG.format(name, self.env.doc2path(objects[name][0])) - self.state_machine.reporter.warning(msg, line=self.lineno) - def _record_name(self, name, target_id): """Record a name, mapping it to target_id diff --git a/ide/.merlin.in b/ide/.merlin.in index 4dc6f45550..b8d7953833 100644 --- a/ide/.merlin.in +++ b/ide/.merlin.in @@ -1,4 +1,4 @@ -PKG unix laglgtk2 lablgtk2.sourceview2 +PKG unix laglgtk3 lablgtk3-sourceview3 S utils B utils diff --git a/ide/idetop.ml b/ide/idetop.ml index 10b8a2cdc5..543ff924bd 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -57,9 +57,9 @@ let coqide_known_option table = List.mem table [ ["Diffs"]] let is_known_option cmd = match Vernacprop.under_control cmd with - | VernacSetOption (_, o, BoolValue true) - | VernacSetOption (_, o, StringValue _) - | VernacUnsetOption (_, o) -> coqide_known_option o + | VernacSetOption (_, o, OptionSetTrue) + | VernacSetOption (_, o, OptionSetString _) + | VernacSetOption (_, o, OptionUnset) -> coqide_known_option o | _ -> false (** Check whether a command is forbidden in the IDE *) @@ -366,12 +366,13 @@ let get_options () = Goptions.OptionMap.fold fold table [] let set_options options = + let open Goptions in let iter (name, value) = match import_option_value value with - | BoolValue b -> Goptions.set_bool_option_value name b - | IntValue i -> Goptions.set_int_option_value name i - | StringValue s -> Goptions.set_string_option_value name s - | StringOptValue (Some s) -> Goptions.set_string_option_value name s - | StringOptValue None -> Goptions.unset_option_value_gen name + | BoolValue b -> set_bool_option_value name b + | IntValue i -> set_int_option_value name i + | StringValue s -> set_string_option_value name s + | StringOptValue (Some s) -> set_string_option_value name s + | StringOptValue None -> unset_option_value_gen name in List.iter iter options diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml index d668788954..dc8fd0e85d 100644 --- a/ide/macos_prehook.ml +++ b/ide/macos_prehook.ml @@ -24,13 +24,13 @@ let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir let () = Unix.putenv "GTK_PATH" resources_dir let () = - Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc") + Unix.putenv "GTK3_RC_FILES" (Filename.concat etc_dir "gtk-3.0/gtkrc") let () = Unix.putenv "GTK_IM_MODULE_FILE" - (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders") + (Filename.concat etc_dir "gtk-3.0/gtk-immodules.loaders") let () = Unix.putenv "GDK_PIXBUF_MODULE_FILE" - (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders") + (Filename.concat etc_dir "gtk-3.0/gdk-pixbuf.loaders") let () = Unix.putenv "PANGO_LIBDIR" lib_dir let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir let () = Unix.putenv "CHARSETALIASDIR" lib_dir diff --git a/ide/preferences.ml b/ide/preferences.ml index e04001974e..3893d023bd 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -263,8 +263,6 @@ let get_unicode_bindings_default_file () = (** Hooks *) -(** New style preferences *) - let cmd_coqtop = new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string) @@ -410,8 +408,8 @@ let vertical_tabs = let opposite_tabs = new preference ~name:["opposite_tabs"] ~init:false ~repr:Repr.(bool) -let background_color = - new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string) +(* let background_color = *) +(* new preference ~name:["background_color"] ~init:"cornsilk" ~repr:Repr.(string) *) let attach_tag (pref : string preference) (tag : GText.tag) f = tag#set_property (f pref#get); @@ -645,8 +643,6 @@ let tag_button () = let box = GPack.hbox () in new tag_button (Gobject.unsafe_cast box#as_widget) -(** Old style preferences *) - let save_pref () = if not (Sys.file_exists (Minilib.coqide_config_home ())) then Unix.mkdir (Minilib.coqide_config_home ()) 0o700; @@ -658,15 +654,18 @@ let save_pref () = Config_lexer.print_file pref_file prefs let load_pref () = + (* Load main preference file *) + let () = + let m = Config_lexer.load_file loaded_pref_file in + let iter name v = + if Util.String.Map.mem name !preferences then + try (Util.String.Map.find name !preferences).set v with _ -> () + else unknown_preferences := Util.String.Map.add name v !unknown_preferences + in + Util.String.Map.iter iter m in + (* Load file for bindings *) let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in - - let m = Config_lexer.load_file loaded_pref_file in - let iter name v = - if Util.String.Map.mem name !preferences then - try (Util.String.Map.find name !preferences).set v with _ -> () - else unknown_preferences := Util.String.Map.add name v !unknown_preferences - in - Util.String.Map.iter iter m + () let pstring name p = string ~f:p#set name p#get let pbool name p = bool ~f:p#set name p#get @@ -737,7 +736,7 @@ let configure ?(apply=(fun () -> ())) parent = () in let () = Util.List.iteri iter [ - ("Background color", background_color); +(* ("Background color", background_color); *) ("Background color of processed text", processed_color); ("Background color of text being processed", processing_color); ("Background color of incompletely processed Qed", incompletely_processed_color); diff --git a/ide/preferences.mli b/ide/preferences.mli index d2f1b5ba29..785c191b46 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -88,7 +88,7 @@ val reset_on_tab_switch : bool preference val line_ending : line_ending preference val vertical_tabs : bool preference val opposite_tabs : bool preference -val background_color : string preference +(* val background_color : string preference *) val processing_color : string preference val processed_color : string preference val error_color : string preference diff --git a/ide/session.ml b/ide/session.ml index fd21515ca5..90412f53f0 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -257,9 +257,10 @@ let make_table_widget ?sort cd cb = ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in let () = data#set_headers_clickable true in - let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:refresh in - let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in +(* FIXME: handle this using CSS *) +(* let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:refresh in *) +(* let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in *) let mk_rend c = GTree.cell_renderer_text [], ["text",c] in let cols = List.map2 (fun (_,c) (_,n,v) -> diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index be400a5f2d..2cadd7ffbf 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,9 +100,10 @@ object(self) router#register_route route_id result; r_bin#add_with_viewport (result :> GObj.widget); views <- (frame#coerce, result, combo#entry) :: views; - let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) @@ -171,8 +172,9 @@ object(self) self#new_page_maker; self#new_query_aux ~grab_now:false (); frame#misc#hide (); - let _ = background_color#connect#changed ~callback:self#refresh_color in - self#refresh_color background_color#get; +(* FIXME: handle this using CSS *) +(* let _ = background_color#connect#changed ~callback:self#refresh_color in *) +(* self#refresh_color background_color#get; *) ignore(notebook#event#connect#key_press ~callback:(fun ev -> if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true) else false diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 7943b099fc..53e004c4e3 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -59,9 +59,10 @@ let message_view () : message_view = let _ = buffer#add_selection_clipboard default_clipboard in let () = view#set_left_margin 2 in view#misc#show (); - let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 596df227b7..7bf73b5ebe 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -204,9 +204,10 @@ let proof_view () = let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in - let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 8802eb0f1c..c1ed9b7506 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -506,9 +506,10 @@ object (self) in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in (* Plug on preferences *) - let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in - let _ = background_color#connect#changed ~callback:cb in - let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in +(* FIXME: handle this using CSS *) +(* let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in *) +(* let _ = background_color#connect#changed ~callback:cb in *) +(* let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in *) let cb b = self#set_wrap_mode (if b then `WORD else `NONE) in stick dynamic_word_wrap self cb; diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 7a14a4e708..9f778d99e9 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -134,16 +134,17 @@ and branch_expr = (cases_pattern_expr list list * constr_expr) CAst.t and fix_expr = - lident * (lident option * recursion_order_expr) * + lident * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr and cofix_expr = lident * local_binder_expr list * constr_expr * constr_expr -and recursion_order_expr = - | CStructRec - | CWfRec of constr_expr - | CMeasureRec of constr_expr * constr_expr option (** measure, relation *) +and recursion_order_expr_r = + | CStructRec of lident + | CWfRec of lident * constr_expr + | CMeasureRec of lident option * constr_expr * constr_expr option (** argument, measure, relation *) +and recursion_order_expr = recursion_order_expr_r CAst.t (* Anonymous defs allowed ?? *) and local_binder_expr = diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 60610b92b8..443473d5b6 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -196,10 +196,9 @@ and branch_expr_eq {CAst.v=(p1, e1)} {CAst.v=(p2, e2)} = List.equal (List.equal cases_pattern_expr_eq) p1 p2 && constr_expr_eq e1 e2 -and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) = +and fix_expr_eq (id1,r1,bl1,a1,b1) (id2,r2,bl2,a2,b2) = (eq_ast Id.equal id1 id2) && - Option.equal (eq_ast Id.equal) j1 j2 && - recursion_order_expr_eq r1 r2 && + Option.equal recursion_order_expr_eq r1 r2 && List.equal local_binder_eq bl1 bl2 && constr_expr_eq a1 a2 && constr_expr_eq b1 b2 @@ -210,13 +209,17 @@ and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = constr_expr_eq a1 a2 && constr_expr_eq b1 b2 -and recursion_order_expr_eq r1 r2 = match r1, r2 with - | CStructRec, CStructRec -> true - | CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 - | CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> +and recursion_order_expr_eq_r r1 r2 = match r1, r2 with + | CStructRec i1, CStructRec i2 -> eq_ast Id.equal i1 i2 + | CWfRec (i1,e1), CWfRec (i2,e2) -> + constr_expr_eq e1 e2 + | CMeasureRec (i1, e1, o1), CMeasureRec (i2, e2, o2) -> + Option.equal (eq_ast Id.equal) i1 i2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 | _ -> false +and recursion_order_expr_eq r1 r2 = eq_ast recursion_order_expr_eq_r r1 r2 + and local_binder_eq l1 l2 = match l1, l2 with | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 @@ -349,7 +352,7 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function (f (Option.fold_right (CAst.with_val (Name.fold_right g)) ona n)) acc po | CFix (_,l) -> let n' = List.fold_right (fun ( { CAst.v = id },_,_,_,_) -> g id) l n in - List.fold_right (fun (_,(_,o),lb,t,c) acc -> + List.fold_right (fun (_,ro,lb,t,c) acc -> fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (_,_) -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 24b1362e6d..488c9a740f 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -212,7 +212,7 @@ let encode_record r = module PrintingRecordRecord = PrintingInductiveMake (struct - let encode = encode_record + let encode _env = encode_record let field = "Record" let title = "Types leading to pretty-printing using record notation: " let member_message s b = @@ -224,7 +224,7 @@ module PrintingRecordRecord = module PrintingRecordConstructor = PrintingInductiveMake (struct - let encode = encode_record + let encode _env = encode_record let field = "Constructor" let title = "Types leading to pretty-printing using constructor form: " let member_message s b = @@ -289,11 +289,11 @@ let extern_reference ?loc vars l = !my_extern_reference vars l let add_patt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CAst.make @@ CPatAtom None) l + Util.List.addn (Inductiveops.inductive_nparamdecls (Global.env()) ind) (CAst.make @@ CPatAtom None) l let add_cpatt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (DAst.make @@ PatVar Anonymous) l + Util.List.addn (Inductiveops.inductive_nparamdecls (Global.env()) ind) (DAst.make @@ PatVar Anonymous) l let drop_implicits_in_patt cst nb_expl args = let impl_st = (implicits_of_global cst) in @@ -364,7 +364,7 @@ let mkPat ?loc qid l = CAst.make ?loc @@ let pattern_printable_in_both_syntax (ind,_ as c) = let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in - let nb_params = Inductiveops.inductive_nparams ind in + let nb_params = Inductiveops.inductive_nparams (Global.env()) ind in List.exists (fun (_,impls) -> (List.length impls >= nb_params) && let params,args = Util.List.chop nb_params impls in @@ -526,7 +526,7 @@ let rec extern_notation_ind_pattern allscopes lonely_seen vars ind args = functi let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and not explicit application. *) - if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then + if !Flags.in_debugger||Inductiveops.inductive_has_local_defs (Global.env()) ind then let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in CAst.make @@ CPatCstr (c, Some (add_patt_for_params ind args), []) @@ -738,6 +738,14 @@ let extern_optimal extern r r' = | Some n, (Some ({ CAst.v = CDelimiters _}) | None) | _, Some n -> n | _ -> raise No_match +(* Helper function for safe and optimal printing of primitive tokens *) +(* such as those for Int63 *) +let extern_prim_token_delimiter_if_required n key_n scope_n scopes = + match availability_of_prim_token n scope_n scopes with + | Some None -> CPrim n + | None -> CDelimiters(key_n, CAst.make (CPrim n)) + | Some (Some key) -> CDelimiters(key, CAst.make (CPrim n)) + (**********************************************************************) (* mapping decl *) @@ -938,13 +946,12 @@ let rec extern inctx (custom,scopes as allscopes) vars r = let (assums,ids,bl) = extern_local_binder scopes vars bl in let vars0 = List.fold_right (Name.fold_right Id.Set.add) ids vars in let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in - let n = - match fst nv.(i) with - | None -> None - | Some x -> Some (CAst.make @@ Name.get_id (List.nth assums x)) - in - let ro = extern_recursion_order scopes vars (snd nv.(i)) in - ((CAst.make fi), (n, ro), bl, extern_typ scopes vars0 ty, + let n = + match nv.(i) with + | None -> None + | Some x -> Some (CAst.make @@ CStructRec (CAst.make @@ Name.get_id (List.nth assums x))) + in + ((CAst.make fi), n, bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv in CFix (CAst.(make ?loc idv.(n)), Array.to_list listdecl) @@ -967,8 +974,11 @@ let rec extern inctx (custom,scopes as allscopes) vars r = | GCast (c, c') -> CCast (sub_extern true scopes vars c, map_cast_type (extern_typ scopes vars) c') + | GInt i -> - CPrim(Numeral (SPlus, NumTok.int (Uint63.to_string i))) + extern_prim_token_delimiter_if_required + (Numeral (SPlus, NumTok.int (Uint63.to_string i))) + "int63" "int63_scope" (snd scopes) in insert_coercion coercion (CAst.make ?loc c) @@ -1159,13 +1169,6 @@ and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function let lonely_seen = add_lonely keyrule lonely_seen in extern_notation allscopes lonely_seen vars t rules -and extern_recursion_order scopes vars = function - GStructRec -> CStructRec - | GWfRec c -> CWfRec (extern true scopes vars c) - | GMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m, - Option.map (extern true scopes vars) r) - - let extern_glob_constr vars c = extern false (InConstrEntrySomeLevel,(None,[])) vars c @@ -1294,7 +1297,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with let v = Array.map3 (fun c t i -> Detyping.share_pattern_names glob_of_pat (i+1) [] def_avoid def_env sigma c (Patternops.lift_pattern n t)) bl tl ln in - GRec(GFix (Array.map (fun i -> Some i, GStructRec) ln,i),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i) ln,i),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 59feb46dc1..c0801067ce 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -96,21 +96,6 @@ let is_global id = with Not_found -> false -let global_reference_of_reference qid = - locate_reference qid - -let global_reference id = - locate_reference (qualid_of_ident id) - -let construct_reference ctx id = - try - VarRef (let _ = Context.Named.lookup id ctx in id) - with Not_found -> - global_reference id - -let global_reference_in_absolute_module dir id = - Nametab.global_of_path (Libnames.make_path dir id) - (**********************************************************************) (* Internalization errors *) @@ -658,7 +643,7 @@ let terms_of_binders bl = | PatCstr (c,l,_) -> let qid = qualid_of_path ?loc (Nametab.path_of_global (ConstructRef c)) in let hole = CAst.make ?loc @@ CHole (None,IntroAnonymous,None) in - let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in + let params = List.make (Inductiveops.inductive_nparams (Global.env()) (fst c)) hole in CAppExpl ((None,qid,None),params @ List.map term_of_pat l)) pt in let rec extract_variables l = match l with | bnd :: l -> @@ -753,7 +738,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = else let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in match disjpat with - | [pat] -> (glob_constr_of_cases_pattern pat, None) + | [pat] -> (glob_constr_of_cases_pattern (Global.env()) pat, None) | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () in let terms = Id.Map.fold mk_env terms Id.Map.empty in @@ -815,7 +800,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = else let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in match disjpat with - | [pat] -> glob_constr_of_cases_pattern pat + | [pat] -> glob_constr_of_cases_pattern (Global.env()) pat | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") with Not_found -> try @@ -1212,10 +1197,10 @@ let check_or_pat_variables loc ids idsl = @return if letin are included *) let check_constructor_length env loc cstr len_pl pl0 = let n = len_pl + List.length pl0 in - if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else - (Int.equal n (Inductiveops.constructor_nalldecls cstr) || + if Int.equal n (Inductiveops.constructor_nallargs env cstr) then false else + (Int.equal n (Inductiveops.constructor_nalldecls env cstr) || (error_wrong_numarg_constructor ?loc env cstr - (Inductiveops.constructor_nrealargs cstr))) + (Inductiveops.constructor_nrealargs env cstr))) open Declarations @@ -1241,9 +1226,9 @@ let add_local_defs_and_check_length loc env g pl args = match g with have been given in the "explicit" arguments, which come from a "@C args" notation or from a custom user notation *) let pl' = insert_local_defs_in_pattern cstr pl in - let maxargs = Inductiveops.constructor_nalldecls cstr in + let maxargs = Inductiveops.constructor_nalldecls env cstr in if List.length pl' + List.length args > maxargs then - error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs cstr); + error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs env cstr); (* Two possibilities: either the args are given with explict variables for local definitions, then we give the explicit args extended with local defs, so that there is nothing more to be @@ -1273,15 +1258,15 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 in aux 0 (impl_list,pl2) let add_implicits_check_constructor_length env loc c len_pl1 pl2 = - let nargs = Inductiveops.constructor_nallargs c in - let nargs' = Inductiveops.constructor_nalldecls c in + let nargs = Inductiveops.constructor_nallargs env c in + let nargs' = Inductiveops.constructor_nalldecls env c in let impls_st = implicits_of_global (ConstructRef c) in add_implicits_check_length (error_wrong_numarg_constructor ?loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = - let nallargs = inductive_nallargs_env env c in - let nalldecls = inductive_nalldecls_env env c in + let nallargs = inductive_nallargs env c in + let nalldecls = inductive_nalldecls env c in let impls_st = implicits_of_global (IndRef c) in add_implicits_check_length (error_wrong_numarg_inductive ?loc env c) nallargs nalldecls impls_st len_pl1 pl2 @@ -1289,8 +1274,8 @@ let add_implicits_check_ind_length env loc c len_pl1 pl2 = (** Do not raise NotEnoughArguments thanks to preconditions*) let chop_params_pattern loc ind args with_letin = let nparams = if with_letin - then Inductiveops.inductive_nparamdecls ind - else Inductiveops.inductive_nparams ind in + then Inductiveops.inductive_nparamdecls (Global.env()) ind + else Inductiveops.inductive_nparams (Global.env()) ind in assert (nparams <= List.length args); let params,args = List.chop nparams args in List.iter (fun c -> match DAst.get c with @@ -1310,10 +1295,11 @@ let find_constructor loc add_params ref = in cstr, match add_params with | Some nb_args -> + let env = Global.env () in let nb = - if Int.equal nb_args (Inductiveops.constructor_nrealdecls cstr) - then Inductiveops.inductive_nparamdecls ind - else Inductiveops.inductive_nparams ind + if Int.equal nb_args (Inductiveops.constructor_nrealdecls env cstr) + then Inductiveops.inductive_nparamdecls env ind + else Inductiveops.inductive_nparams env ind in List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) | None -> [] @@ -1354,7 +1340,7 @@ let sort_fields ~complete loc fields completer = | (first_field_ref, first_field_value):: other_fields -> let (first_field_glob_ref, record) = try - let gr = global_reference_of_reference first_field_ref in + let gr = locate_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> raise (InternalizationError(loc, NotAProjection first_field_ref)) @@ -1412,7 +1398,7 @@ let sort_fields ~complete loc fields completer = let rec index_fields fields remaining_projs acc = match fields with | (field_ref, field_value) :: fields -> - let field_glob_ref = try global_reference_of_reference field_ref + let field_glob_ref = try locate_reference field_ref with Not_found -> user_err ?loc ~hdr:"intern" (str "The field \"" ++ pr_qualid field_ref ++ str "\" does not exist.") in @@ -1859,51 +1845,44 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = in apply_impargs c env imp subscopes l loc - | CFix ({ CAst.loc = locid; v = iddef}, dl) -> + | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in let dl = Array.of_list dl in - let n = - try List.index0 Id.equal iddef lf + let n = + try List.index0 Id.equal iddef lf with Not_found -> - raise (InternalizationError (locid,UnboundFixName (false,iddef))) - in - let idl_temp = Array.map - (fun (id,(n,order),bl,ty,_) -> - let intern_ro_arg f = - let before, after = split_at_annot bl n in - let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in - let ro = f (intern env') in - let n' = Option.map (fun _ -> List.count (fun c -> match DAst.get c with - | GLocalAssum _ -> true - | _ -> false (* remove let-ins *)) - rbefore) n in - n', ro, List.fold_left intern_local_binder (env',rbefore) after - in - let n, ro, (env',rbl) = - match order with - | CStructRec -> - intern_ro_arg (fun _ -> GStructRec) - | CWfRec c -> - intern_ro_arg (fun f -> GWfRec (f c)) - | CMeasureRec (m,r) -> - intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r)) - in - let bl = List.rev (List.map glob_local_binder_of_extended rbl) in - ((n, ro), bl, intern_type env' ty, env')) dl in + raise (InternalizationError (locid,UnboundFixName (false,iddef))) + in + let idl_temp = Array.map + (fun (id,recarg,bl,ty,_) -> + let recarg = Option.map (function { CAst.v = v } -> match v with + | CStructRec i -> i + | _ -> anomaly Pp.(str "Non-structural recursive argument in non-program fixpoint")) recarg + in + let before, after = split_at_annot bl recarg in + let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in + let n = Option.map (fun _ -> List.count (fun c -> match DAst.get c with + | GLocalAssum _ -> true + | _ -> false (* remove let-ins *)) + rbefore) recarg in + let (env',rbl) = List.fold_left intern_local_binder (env',rbefore) after in + let bl = List.rev (List.map glob_local_binder_of_extended rbl) in + (n, bl, intern_type env' ty, env')) dl in let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') -> - let env'' = List.fold_left_i (fun i en name -> - let (_,bli,tyi,_) = idl_temp.(i) in - let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in - push_name_env ntnvars (impls_type_list ~args:fix_args tyi) - en (CAst.make @@ Name name)) 0 env' lf in - (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in - DAst.make ?loc @@ - GRec (GFix - (Array.map (fun (ro,_,_,_) -> ro) idl,n), + let env'' = List.fold_left_i (fun i en name -> + let (_,bli,tyi,_) = idl_temp.(i) in + let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in + push_name_env ntnvars (impls_type_list ~args:fix_args tyi) + en (CAst.make @@ Name name)) 0 env' lf in + (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in + DAst.make ?loc @@ + GRec (GFix + (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, Array.map (fun (_,bl,_,_) -> bl) idl, Array.map (fun (_,_,ty,_) -> ty) idl, Array.map (fun (_,_,_,bd) -> bd) idl) + | CCoFix ({ CAst.loc = locid; v = iddef }, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_) -> id) dl in let dl = Array.of_list dl in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2d14a0d0a7..0d4bc91f57 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -162,24 +162,11 @@ val interp_context_evars : env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) -(* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) -(* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) -(* ?global_level:bool -> ?impl_env:internalization_env -> *) -(* env -> evar_map -> local_binder_expr list -> internalization_env * ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) - -(* val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> *) -(* env -> evar_map -> local_binder_expr list -> *) -(* internalization_env * *) -(* ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *) - (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) val locate_reference : Libnames.qualid -> GlobRef.t val is_global : Id.t -> bool -val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> GlobRef.t -val global_reference : Id.t -> GlobRef.t -val global_reference_in_absolute_module : DirPath.t -> Id.t -> GlobRef.t (** Interprets a term as the left-hand side of a notation. The returned map is guaranteed to have the same domain as the input one. *) diff --git a/interp/declare.ml b/interp/declare.ml index 08a6ac5f7b..76b4bab2ce 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -119,7 +119,6 @@ let set_declare_scheme f = declare_scheme := f let update_tables c = declare_constant_implicits c; - Heads.declare_head (EvalConstRef c); Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) let register_side_effect (c, role) = @@ -257,7 +256,6 @@ let declare_variable id obj = let oname = add_leaf id (inVariable (Inr (id,obj))) in declare_var_implicits id; Notation.declare_ref_arguments_scope Evd.empty (VarRef id); - Heads.declare_head (EvalVarRef id); oname (** Declaration of inductive blocks *) @@ -348,6 +346,25 @@ let inInductive : mutual_inductive_entry -> obj = discharge_function = discharge_inductive; rebuild_function = rebuild_inductive } +let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c + +let load_prim _ p = cache_prim p + +let subst_prim (subst,(p,c)) = Mod_subst.subst_proj_repr subst p, Mod_subst.subst_constant subst c + +let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) + +let inPrim : (Projection.Repr.t * Constant.t) -> obj = + declare_object { + (default_object "PRIMPROJS") with + cache_function = cache_prim ; + load_function = load_prim; + subst_function = subst_prim; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_prim } + +let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) + let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = let id = Label.to_id label in let univs, u = match univs with @@ -362,7 +379,7 @@ let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (ter let entry = definition_entry ~types ~univs term in let cst = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in - Recordops.declare_primitive_projection p cst + declare_primitive_projection p cst let declare_projections univs mind = diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 854651e7b7..dffccf02fc 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -231,23 +231,25 @@ let implicit_application env ?(allow_partial=true) f ty = | Some ({CAst.loc;v=(id, par, inst)}, gr) -> let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = - let c = class_info gr in - let (ci, rd) = c.cl_context in - if not allow_partial then - begin - let opt_succ x n = match x with - | None -> succ n - | Some _ -> n - in - let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in - let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in - if not (Int.equal needlen applen) then - mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd - end; - let pars = List.rev (List.combine ci rd) in - let args, avoid = combine_params avoid f par pars in - CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid - in c, avoid + let env = Global.env () in + let sigma = Evd.from_env env in + let c = class_info env sigma gr in + let (ci, rd) = c.cl_context in + if not allow_partial then + begin + let opt_succ x n = match x with + | None -> succ n + | Some _ -> n + in + let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in + let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in + if not (Int.equal needlen applen) then + mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd + end; + let pars = List.rev (List.combine ci rd) in + let args, avoid = combine_params avoid f par pars in + CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid + in c, avoid let warn_ignoring_implicit_status = CWarnings.create ~name:"ignoring_implicit_status" ~category:"implicits" diff --git a/interp/notation.ml b/interp/notation.ml index b9aca82cf4..56504db04e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1516,7 +1516,7 @@ let uninterp_prim_token c = with Not_found -> raise Notation_ops.No_match let uninterp_prim_token_cases_pattern c = - match glob_constr_of_closed_cases_pattern c with + match glob_constr_of_closed_cases_pattern (Global.env()) c with | exception Not_found -> raise Notation_ops.No_match | na,c -> let (sc,n) = uninterp_prim_token c in (na,sc,n) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7d7e10a05b..7f084fffdd 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -782,7 +782,7 @@ let rec pat_binder_of_term t = DAst.map (function | GApp (t, l) -> begin match DAst.get t with | GRef (ConstructRef cstr,_) -> - let nparams = Inductiveops.inductive_nparams (fst cstr) in + let nparams = Inductiveops.inductive_nparams (Global.env()) (fst cstr) in let _,l = List.chop nparams l in PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) | _ -> raise No_match @@ -909,7 +909,8 @@ let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) alp, add_env alp sigma var (DAst.make @@ GVar id) let bind_binding_as_term_env alp (terms,termlists,binders,binderlists as sigma) var c = - let pat = try cases_pattern_of_glob_constr Anonymous c with Not_found -> raise No_match in + let env = Global.env () in + let pat = try cases_pattern_of_glob_constr env Anonymous c with Not_found -> raise No_match in try (* If already bound to a binder, unify the term and the binder *) let patl' = Id.List.assoc var binders in @@ -956,7 +957,7 @@ let match_fix_kind fk1 fk2 = match (fk1,fk2) with | GCoFix n1, GCoFix n2 -> Int.equal n1 n2 | GFix (nl1,n1), GFix (nl2,n2) -> - let test (n1, _) (n2, _) = match n1, n2 with + let test n1 n2 = match n1, n2 with | _, None -> true | Some id1, Some id2 -> Int.equal id1 id2 | _ -> false @@ -1292,7 +1293,7 @@ let match_notation_constr u c (metas,pat) = | NtnTypeBinder (NtnBinderParsedAsConstr _) -> (match Id.List.assoc x binders with | [pat] -> - let v = glob_constr_of_cases_pattern pat in + let v = glob_constr_of_cases_pattern (Global.env()) pat in ((v,scl)::terms',termlists',binders',binderlists') | _ -> raise No_match) | NtnTypeBinder (NtnParsedAsIdent | NtnParsedAsPattern _) -> @@ -1333,11 +1334,11 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (ConstructRef r2) when eq_constructor r1 r2 -> - let l = try add_patterns_for_params_remove_local_defs r1 largs with Not_found -> raise No_match in + let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(0,l) | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (ConstructRef r2),l2) when eq_constructor r1 r2 -> - let l1 = try add_patterns_for_params_remove_local_defs r1 args1 with Not_found -> raise No_match in + let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length l1 then diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 6fe20486dc..5024f5c26f 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -38,7 +38,7 @@ type notation_constr = notation_constr * notation_constr | NIf of notation_constr * (Name.t * notation_constr option) * notation_constr * notation_constr - | NRec of fix_kind * Id.t array * + | NRec of glob_fix_kind * Id.t array * (Name.t * notation_constr option * notation_constr) list array * notation_constr array * notation_constr array | NSort of glob_sort diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 2dab14e732..3f791dfc22 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -51,7 +51,6 @@ let fresh_lname n = (** Global names **) type gname = | Gind of string * inductive (* prefix, inductive name *) - | Gconstruct of string * constructor (* prefix, constructor name *) | Gconstant of string * Constant.t (* prefix, constant name *) | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *) | Gcase of Label.t option * int @@ -67,8 +66,6 @@ let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> String.equal s1 s2 && eq_ind ind1 ind2 - | Gconstruct (s1, c1), Gconstruct (s2, c2) -> - String.equal s1 s2 && eq_constructor c1 c2 | Gconstant (s1, c1), Gconstant (s2, c2) -> String.equal s1 s2 && Constant.equal c1 c2 | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) -> @@ -88,7 +85,7 @@ let eq_gname gn1 gn2 = | Ginternal s1, Ginternal s2 -> String.equal s1 s2 | Grel i1, Grel i2 -> Int.equal i1 i2 | Gnamed id1, Gnamed id2 -> Id.equal id1 id2 - | (Gind _| Gconstruct _ | Gconstant _ | Gproj _ | Gcase _ | Gpred _ + | (Gind _| Gconstant _ | Gproj _ | Gcase _ | Gpred _ | Gfixtype _ | Gnorm _ | Gnormtbl _ | Ginternal _ | Grel _ | Gnamed _), _ -> false @@ -100,19 +97,17 @@ open Hashset.Combine let gname_hash gn = match gn with | Gind (s, ind) -> combinesmall 1 (combine (String.hash s) (ind_hash ind)) -| Gconstruct (s, c) -> - combinesmall 2 (combine (String.hash s) (constructor_hash c)) | Gconstant (s, c) -> - combinesmall 3 (combine (String.hash s) (Constant.hash c)) -| Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gnorm (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) -| Gnormtbl (l, i) -> combinesmall 8 (combine (Option.hash Label.hash l) (Int.hash i)) -| Ginternal s -> combinesmall 9 (String.hash s) -| Grel i -> combinesmall 10 (Int.hash i) -| Gnamed id -> combinesmall 11 (Id.hash id) -| Gproj (s, p, i) -> combinesmall 12 (combine (String.hash s) (combine (ind_hash p) i)) + combinesmall 2 (combine (String.hash s) (Constant.hash c)) +| Gcase (l, i) -> combinesmall 3 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gpred (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gfixtype (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gnorm (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) +| Gnormtbl (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i)) +| Ginternal s -> combinesmall 8 (String.hash s) +| Grel i -> combinesmall 9 (Int.hash i) +| Gnamed id -> combinesmall 10 (Id.hash id) +| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (ind_hash p) i)) let case_ctr = ref (-1) @@ -382,8 +377,8 @@ type mllambda = | MLif of mllambda * mllambda * mllambda | MLmatch of annot_sw * mllambda * mllambda * mllam_branches (* argument, prefix, accu branch, branches *) - | MLconstruct of string * constructor * mllambda array - (* prefix, constructor name, arguments *) + | MLconstruct of string * inductive * int * mllambda array + (* prefix, inductive name, tag, arguments *) | MLint of int | MLuint of Uint63.t | MLsetref of string * mllambda @@ -391,7 +386,11 @@ type mllambda = | MLarray of mllambda array | MLisaccu of string * inductive * mllambda -and mllam_branches = ((constructor * lname option array) list * mllambda) array +and 'a mllam_pattern = + | ConstPattern of int + | NonConstPattern of tag * 'a array + +and mllam_branches = (lname option mllam_pattern list * mllambda) array let push_lnames n env lns = snd (Array.fold_left (fun (i,r) x -> (i+1, LNmap.add x i r)) (n,env) lns) @@ -444,9 +443,10 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = eq_mllambda gn1 gn2 n env1 env2 c1 c2 && eq_mllambda gn1 gn2 n env1 env2 accu1 accu2 && eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 - | MLconstruct (pf1, cs1, args1), MLconstruct (pf2, cs2, args2) -> + | MLconstruct (pf1, ind1, tag1, args1), MLconstruct (pf2, ind2, tag2, args2) -> String.equal pf1 pf2 && - eq_constructor cs1 cs2 && + eq_ind ind1 ind2 && + Int.equal tag1 tag2 && Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2 | MLint i1, MLint i2 -> Int.equal i1 i2 @@ -479,15 +479,22 @@ and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 = (* we require here that patterns have the same order, which may be too strong *) and eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 = - let eq_cargs (cs1, args1) (cs2, args2) body1 body2 = + let eq_cargs args1 args2 body1 body2 = Int.equal (Array.length args1) (Array.length args2) && - eq_constructor cs1 cs2 && let env1 = opush_lnames n env1 args1 in let env2 = opush_lnames n env2 args2 in eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 body1 body2 in - let eq_branch (ptl1,body1) (ptl2,body2) = - List.equal (fun pt1 pt2 -> eq_cargs pt1 pt2 body1 body2) ptl1 ptl2 + let eq_pattern pat1 pat2 body1 body2 = + match pat1, pat2 with + | ConstPattern tag1, ConstPattern tag2 -> + Int.equal tag1 tag2 && eq_mllambda gn1 gn2 n env1 env2 body1 body2 + | NonConstPattern (tag1,args1), NonConstPattern (tag2,args2) -> + Int.equal tag1 tag2 && eq_cargs args1 args2 body1 body2 + | (ConstPattern _ | NonConstPattern _), _ -> false + in + let eq_branch (patl1,body1) (patl2,body2) = + List.equal (fun pt1 pt2 -> eq_pattern pt1 pt2 body1 body2) patl1 patl2 in Array.equal eq_branch br1 br2 @@ -523,10 +530,11 @@ let rec hash_mllambda gn n env t = let hc = hash_mllambda gn n env c in let haccu = hash_mllambda gn n env accu in combinesmall 9 (hash_mllam_branches gn n env (combine3 hannot hc haccu) br) - | MLconstruct (pf, cs, args) -> + | MLconstruct (pf, ind, tag, args) -> let hpf = String.hash pf in - let hcs = constructor_hash cs in - combinesmall 10 (hash_mllambda_array gn n env (combine hpf hcs) args) + let hcs = ind_hash ind in + let htag = Int.hash tag in + combinesmall 10 (hash_mllambda_array gn n env (combine3 hpf hcs htag) args) | MLint i -> combinesmall 11 i | MLuint i -> @@ -556,15 +564,18 @@ and hash_mllambda_array gn n env init arr = Array.fold_left (fun acc t -> combine (hash_mllambda gn n env t) acc) init arr and hash_mllam_branches gn n env init br = - let hash_cargs (cs, args) body = + let hash_cargs args body = let nargs = Array.length args in - let hcs = constructor_hash cs in let env = opush_lnames n env args in let hbody = hash_mllambda gn (n + nargs) env body in - combine3 nargs hcs hbody + combine nargs hbody + in + let hash_pattern pat body = match pat with + | ConstPattern i -> combinesmall 1 (Int.hash i) + | NonConstPattern (tag,args) -> combinesmall 2 (combine (Int.hash tag) (hash_cargs args body)) in let hash_branch acc (ptl,body) = - List.fold_left (fun acc t -> combine (hash_cargs t body) acc) acc ptl + List.fold_left (fun acc t -> combine (hash_pattern t body) acc) acc ptl in Array.fold_left hash_branch init br @@ -594,17 +605,20 @@ let fv_lam l = | MLmatch(_,a,p,bs) -> let fv = aux a bind (aux p bind fv) in let fv_bs (cargs, body) fv = - let bind = - List.fold_right (fun (_,args) bind -> - Array.fold_right - (fun o bind -> match o with - | Some l -> LNset.add l bind - | _ -> bind) args bind) - cargs bind in - aux body bind fv in + let bind = + List.fold_right (fun pat bind -> + match pat with + | ConstPattern _ -> bind + | NonConstPattern(_,args) -> + Array.fold_right + (fun o bind -> match o with + | Some l -> LNset.add l bind + | _ -> bind) args bind) + cargs bind in + aux body bind fv in Array.fold_right fv_bs bs fv - (* argument, accu branch, branches *) - | MLconstruct (_,_,p) -> + (* argument, accu branch, branches *) + | MLconstruct (_,_,_,p) -> Array.fold_right (fun a fv -> aux a bind fv) p fv | MLsetref(_,l) -> aux l bind fv | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv) @@ -652,8 +666,8 @@ type global = | Gletcase of gname * lname array * annot_sw * mllambda * mllambda * mllam_branches | Gopen of string - | Gtype of inductive * int array - (* ind name, arities of constructors *) + | Gtype of inductive * (tag * int) array + (* ind name, tag and arities of constructors *) | Gcomment of string (* Alpha-equivalence on globals *) @@ -678,7 +692,8 @@ let eq_global g1 g2 = eq_mllambda gn1 gn2 (Array.length lns1) env1 env2 t1 t2 | Gopen s1, Gopen s2 -> String.equal s1 s2 | Gtype (ind1, arr1), Gtype (ind2, arr2) -> - eq_ind ind1 ind2 && Array.equal Int.equal arr1 arr2 + eq_ind ind1 ind2 && + Array.equal (fun (tag1,ar1) (tag2,ar2) -> Int.equal tag1 tag2 && Int.equal ar1 ar2) arr1 arr2 | Gcomment s1, Gcomment s2 -> String.equal s1 s2 | _, _ -> false @@ -705,7 +720,10 @@ let hash_global g = combinesmall 4 (combine nlns (hash_mllambda gn nlns env t)) | Gopen s -> combinesmall 5 (String.hash s) | Gtype (ind, arr) -> - combinesmall 6 (combine (ind_hash ind) (Array.fold_left combine 0 arr)) + let hash_aux acc (tag,ar) = + combine3 acc (Int.hash tag) (Int.hash ar) + in + combinesmall 6 (combine (ind_hash ind) (Array.fold_left hash_aux 0 arr)) | Gcomment s -> combinesmall 7 (String.hash s) let global_stack = ref ([] : global list) @@ -912,26 +930,33 @@ let get_proj_code i = [|MLglobal symbols_tbl_name; MLint i|]) type rlist = - | Rnil - | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' + | Rnil + | Rcons of lname option mllam_pattern list ref * LNset.t * mllambda * rlist' and rlist' = rlist ref -let rm_params fv params = - Array.map (fun l -> if LNset.mem l fv then Some l else None) params +let rm_params fv params = + Array.map (fun l -> if LNset.mem l fv then Some l else None) params -let rec insert cargs body rl = +let rec insert pat body rl = match !rl with | Rnil -> let fv = fv_lam body in - let (c,params) = cargs in - let params = rm_params fv params in - rl:= Rcons(ref [(c,params)], fv, body, ref Rnil) + begin match pat with + | ConstPattern _ as p -> + rl:= Rcons(ref [p], fv, body, ref Rnil) + | NonConstPattern (tag,args) -> + let args = rm_params fv args in + rl:= Rcons(ref [NonConstPattern (tag,args)], fv, body, ref Rnil) + end | Rcons(l,fv,body',rl) -> - if eq_mllambda body body' then - let (c,params) = cargs in - let params = rm_params fv params in - l := (c,params)::!l - else insert cargs body rl + if eq_mllambda body body' then + match pat with + | ConstPattern _ as p -> + l := p::!l + | NonConstPattern (tag,args) -> + let args = rm_params fv args in + l := NonConstPattern (tag,args)::!l + else insert pat body rl let rec to_list rl = match !rl with @@ -940,7 +965,7 @@ let rec to_list rl = let merge_branches t = let newt = ref Rnil in - Array.iter (fun (c,args,body) -> insert (c,args) body newt) t; + Array.iter (fun (pat,body) -> insert pat body newt) t; Array.of_list (to_list newt) let app_prim p args = MLapp(MLprimitive p, args) @@ -1097,14 +1122,19 @@ let ml_of_instance instance u = let a_uid = fresh_lname Anonymous in let la_uid = MLlocal a_uid in (* compilation of branches *) - let ml_br (c,params, body) = - let lnames, env_c = push_rels env_c params in - (c, lnames, ml_of_lam env_c l body) + let nbconst = Array.length bs.constant_branches in + let nbtotal = nbconst + Array.length bs.nonconstant_branches in + let br = Array.init nbtotal (fun i -> if i < Array.length bs.constant_branches then + (ConstPattern i, ml_of_lam env_c l bs.constant_branches.(i)) + else + let (params, body) = bs.nonconstant_branches.(i-nbconst) in + let lnames, env_c = push_rels env_c params in + (NonConstPattern (i-nbconst+1,lnames), ml_of_lam env_c l body) + ) in - let bs = Array.map ml_br bs in let cn = fresh_gcase l in (* Compilation of accu branch *) - let pred = MLapp(MLglobal pn, fv_args env_c pfvn pfvr) in + let pred = MLapp(MLglobal pn, fv_args env_c pfvn pfvr) in let (fvn, fvr) = !(env_c.env_named), !(env_c.env_urel) in let cn_fv = mkMLapp (MLglobal cn) (fv_args env_c fvn fvr) in (* remark : the call to fv_args does not add free variables in env_c *) @@ -1117,7 +1147,7 @@ let ml_of_instance instance u = (* let body = MLlam([|a_uid|], MLmatch(annot, la_uid, accu, bs)) in let case = generalize_fv env_c body in *) let cn = push_global_case cn (Array.append (fv_params env_c) [|a_uid|]) - annot la_uid accu (merge_branches bs) + annot la_uid accu (merge_branches br) in (* Final result *) let arg = ml_of_lam env l a in @@ -1277,12 +1307,11 @@ let ml_of_instance instance u = (lname, paramsi, body) in MLletrec(Array.mapi mkrec lf, lf_args.(start)) *) - | Lmakeblock (prefix,(cn,_u),_,args) -> + | Lint tag -> MLapp(MLprimitive Mk_int, [|MLint tag|]) + + | Lmakeblock (prefix,cn,tag,args) -> let args = Array.map (ml_of_lam env l) args in - MLconstruct(prefix,cn,args) - | Lconstruct (prefix, (cn,u)) -> - let uargs = ml_of_instance env.env_univ u in - mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs + MLconstruct(prefix,cn,tag,args) | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i @@ -1345,7 +1374,7 @@ let subst s l = | MLmatch(annot,a,accu,bs) -> let auxb (cargs,body) = (cargs,aux body) in MLmatch(annot,a,aux accu, Array.map auxb bs) - | MLconstruct(prefix,c,args) -> MLconstruct(prefix,c,Array.map aux args) + | MLconstruct(prefix,c,tag,args) -> MLconstruct(prefix,c,tag,Array.map aux args) | MLsetref(s,l1) -> MLsetref(s,aux l1) | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2) | MLarray arr -> MLarray (Array.map aux arr) @@ -1454,8 +1483,8 @@ let optimize gdef l = | MLmatch(annot,a,accu,bs) -> let opt_b (cargs,body) = (cargs,optimize s body) in MLmatch(annot, optimize s a, subst s accu, Array.map opt_b bs) - | MLconstruct(prefix,c,args) -> - MLconstruct(prefix,c,Array.map (optimize s) args) + | MLconstruct(prefix,c,tag,args) -> + MLconstruct(prefix,c,tag,Array.map (optimize s) args) | MLsetref(r,l) -> MLsetref(r, optimize s l) | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2) | MLarray arr -> MLarray (Array.map (optimize s) arr) @@ -1528,13 +1557,12 @@ let string_of_kn kn = let string_of_con c = string_of_kn (Constant.user c) let string_of_mind mind = string_of_kn (MutInd.user mind) +let string_of_ind (mind,i) = string_of_kn (MutInd.user mind) ^ "_" ^ string_of_int i let string_of_gname g = match g with | Gind (prefix, (mind, i)) -> Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i - | Gconstruct (prefix, ((mind, i), j)) -> - Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) | Gproj (prefix, (mind, n), i) -> @@ -1567,10 +1595,13 @@ let pp_ldecls fmt ids = Format.fprintf fmt " (%a : Nativevalues.t)" pp_lname ids.(i) done -let string_of_construct prefix ((mind,i),j) = - let id = Format.sprintf "Construct_%s_%i_%i" (string_of_mind mind) i (j-1) in - prefix ^ id - +let string_of_construct prefix ~constant ind tag = + let base = if constant then "Int" else "Construct" in + Format.sprintf "%s%s_%s_%i" prefix base (string_of_ind ind) tag + +let string_of_accu_construct prefix ind = + Format.sprintf "%sAccu_%s" prefix (string_of_ind ind) + let pp_int fmt i = if i < 0 then Format.fprintf fmt "(%i)" i else Format.fprintf fmt "%i" i @@ -1596,16 +1627,16 @@ let pp_mllam fmt l = Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" pp_mllam t pp_mllam l1 pp_mllam l2 | MLmatch (annot, c, accu_br, br) -> - let mind,i = annot.asw_ind in + let ind = annot.asw_ind in let prefix = annot.asw_prefix in - let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in - Format.fprintf fmt - "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" - pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br - - | MLconstruct(prefix,c,args) -> + let accu = string_of_accu_construct prefix ind in + Format.fprintf fmt + "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" + pp_mllam c accu pp_mllam accu_br (pp_branches prefix ind) br + + | MLconstruct(prefix,ind,tag,args) -> Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" - (string_of_construct prefix c) pp_cargs args + (string_of_construct prefix ~constant:false ind tag) pp_cargs args | MLint i -> pp_int fmt i | MLuint i -> Format.fprintf fmt "(%s)" (Uint63.compile i) | MLsetref (s, body) -> @@ -1622,8 +1653,8 @@ let pp_mllam fmt l = pp_mllam fmt arr.(len-1) end; Format.fprintf fmt "|]@]" - | MLisaccu (prefix, (mind, i), c) -> - let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in + | MLisaccu (prefix, ind, c) -> + let accu = string_of_accu_construct prefix ind in Format.fprintf fmt "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n true@\n| _ ->@\n false@\nend@]" pp_mllam c accu @@ -1646,7 +1677,7 @@ let pp_mllam fmt l = | MLprimitive (Mk_prod | Mk_sort) (* FIXME: why this special case? *) | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ -> Format.fprintf fmt "(%a)" pp_mllam l - | MLconstruct(_,_,args) when Array.length args > 0 -> + | MLconstruct(_,_,_,args) when Array.length args > 0 -> Format.fprintf fmt "(%a)" pp_mllam l | _ -> pp_mllam fmt l @@ -1685,19 +1716,23 @@ let pp_mllam fmt l = done in Format.fprintf fmt "(%a)" aux params - and pp_branches prefix fmt bs = + and pp_branches prefix ind fmt bs = let pp_branch (cargs,body) = - let pp_c fmt (cn,args) = - Format.fprintf fmt "| %s%a " - (string_of_construct prefix cn) pp_cparams args in - let rec pp_cargs fmt cargs = - match cargs with - | [] -> () - | cargs::cargs' -> - Format.fprintf fmt "%a%a" pp_c cargs pp_cargs cargs' in - Format.fprintf fmt "%a ->@\n %a@\n" - pp_cargs cargs pp_mllam body + let pp_pat fmt = function + | ConstPattern i -> + Format.fprintf fmt "| %s " + (string_of_construct prefix ~constant:true ind i) + | NonConstPattern (tag,args) -> + Format.fprintf fmt "| %s%a " + (string_of_construct prefix ~constant:false ind tag) pp_cparams args in + let rec pp_pats fmt pats = + match pats with + | [] -> () + | pat::pats -> + Format.fprintf fmt "%a%a" pp_pat pat pp_pats pats in + Format.fprintf fmt "%a ->@\n %a@\n" pp_pats cargs pp_mllam body + in Array.iter pp_branch bs and pp_primitive fmt = function @@ -1771,19 +1806,24 @@ let pp_global fmt g = pp_mllam c | Gopen s -> Format.fprintf fmt "@[open %s@]@." s - | Gtype ((mind, i), lar) -> - let l = string_of_mind mind in - let rec aux s ar = - if Int.equal ar 0 then s else aux (s^" * Nativevalues.t") (ar-1) in - let pp_const_sig i fmt j ar = - let sig_str = if ar > 0 then aux "of Nativevalues.t" (ar-1) else "" in - Format.fprintf fmt " | Construct_%s_%i_%i %s@\n" l i j sig_str - in - let pp_const_sigs i fmt lar = - Format.fprintf fmt " | Accu_%s_%i of Nativevalues.t@\n" l i; - Array.iteri (pp_const_sig i fmt) lar - in - Format.fprintf fmt "@[type ind_%s_%i =@\n%a@]@\n@." l i (pp_const_sigs i) lar + | Gtype (ind, lar) -> + let rec aux s arity = + if Int.equal arity 0 then s else aux (s^" * Nativevalues.t") (arity-1) in + let pp_const_sig fmt (tag,arity) = + if arity > 0 then + let sig_str = aux "of Nativevalues.t" (arity-1) in + let cstr = string_of_construct "" ~constant:false ind tag in + Format.fprintf fmt " | %s %s@\n" cstr sig_str + else + let sig_str = if arity > 0 then aux "of Nativevalues.t" (arity-1) else "" in + let cstr = string_of_construct "" ~constant:true ind tag in + Format.fprintf fmt " | %s %s@\n" cstr sig_str + in + let pp_const_sigs fmt lar = + Format.fprintf fmt " | %s of Nativevalues.t@\n" (string_of_accu_construct "" ind); + Array.iter (pp_const_sig fmt) lar + in + Format.fprintf fmt "@[type ind_%s =@\n%a@]@\n@." (string_of_ind ind) pp_const_sigs lar | Gtblfixtype (g, params, t) -> Format.fprintf fmt "@[let %a %a =@\n %a@]@\n@." pp_gname g pp_ldecls params pp_array t @@ -1920,7 +1960,7 @@ let compile_mind mb mind stack = (** Generate data for every block *) let f i stack ob = let ind = (mind, i) in - let gtype = Gtype(ind, Array.map snd ob.mind_reloc_tbl) in + let gtype = Gtype(ind, ob.mind_reloc_tbl) in let j = push_symbol (SymbInd ind) in let name = Gind ("", ind) in let accu = @@ -1932,16 +1972,6 @@ let compile_mind mb mind stack = Glet(name, MLapp (MLprimitive Mk_ind, args)) in let nparams = mb.mind_nparams in - let params = - Array.init nparams (fun i -> {lname = param_name; luid = i}) in - let add_construct j acc (_,arity) = - let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in - let c = ind, (j+1) in - Glet(Gconstruct ("", c), - mkMLlam (Array.append params args) - (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc - in - let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in let add_proj proj_arg acc _pb = let tbl = ob.mind_reloc_tbl in (* Building info *) @@ -1953,15 +1983,16 @@ let compile_mind mb mind stack = asw_reloc = tbl; asw_finite = true } in let c_uid = fresh_lname Anonymous in let cf_uid = fresh_lname Anonymous in - let _, arity = tbl.(0) in + let tag, arity = tbl.(0) in + assert (arity > 0); let ci_uid = fresh_lname Anonymous in let cargs = Array.init arity (fun i -> if Int.equal i proj_arg then Some ci_uid else None) in - let i = push_symbol (SymbProj (ind, j)) in + let i = push_symbol (SymbProj (ind, proj_arg)) in let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in - let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[NonConstPattern (tag,cargs)],MLlocal ci_uid|]) in let code = MLlet(cf_uid, mkForceCofix "" ind (MLlocal c_uid), code) in let gn = Gproj ("", ind, proj_arg) in Glet (gn, mkMLlam [|c_uid|] code) :: acc @@ -1972,7 +2003,7 @@ let compile_mind mb mind stack = let _, _, _, pbs = info.(i) in Array.fold_left_i add_proj [] pbs in - projs @ constructors @ gtype :: accu :: stack + projs @ gtype :: accu :: stack in Array.fold_left_i f stack mb.mind_packets diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index baa290367f..d153f84e9c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors open Names open Nativelib open Reduction @@ -152,19 +151,15 @@ let native_conv_gen pb sigma env univs t1 t2 = else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in - match compile ml_filename code ~profile:false with - | (true, fn) -> - begin - if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); - let t0 = Sys.time () in - call_linker ~fatal:true prefix fn (Some upds); - let t1 = Sys.time () in - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - (* TODO change 0 when we can have de Bruijn *) - fst (conv_val env pb 0 !rt1 !rt2 univs) - end - | _ -> anomaly (Pp.str "Compilation failure.") + let fn = compile ml_filename code ~profile:false in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); + let t0 = Sys.time () in + call_linker ~fatal:true prefix fn (Some upds); + let t1 = Sys.time () in + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + (* TODO change 0 when we can have de Bruijn *) + fst (conv_val env pb 0 !rt1 !rt2 univs) (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index ec3a7b893d..62afd9df68 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -39,11 +39,10 @@ type lambda = | Lif of lambda * lambda * lambda | Lfix of (int array * (string * inductive) array * int) * fix_decl | Lcofix of int * fix_decl - | Lmakeblock of prefix * pconstructor * int * lambda array - (* prefix, constructor Name.t, constructor tag, arguments *) - (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) - (* A partially applied constructor *) + | Lint of int (* a constant constructor *) + | Lmakeblock of prefix * inductive * int * lambda array + (* prefix, inductive name, constructor tag, arguments *) + (* A fully applied non-constant constructor *) | Luint of Uint63.t | Lval of Nativevalues.t | Lsort of Sorts.t @@ -51,7 +50,10 @@ type lambda = | Llazy | Lforce -and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array; + } and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array @@ -121,7 +123,7 @@ let get_const_prefix env c = let map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ - | Lconstruct _ | Llazy | Lforce | Lmeta _ -> lam + | Llazy | Lforce | Lmeta _ | Lint _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in @@ -143,17 +145,26 @@ let map_lam_with_binders g f n lam = | Lprim(prefix,kn,op,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lprim(prefix,kn,op,args') - | Lcase(annot,t,a,br) -> - let t' = f n t in - let a' = f n a in - let on_b b = - let (cn,ids,body) = b in - let body' = - if Array.is_empty ids then f n body - else f (g (Array.length ids) n) body in - if body == body' then b else (cn,ids,body') in - let br' = Array.Smart.map on_b br in - if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br') + | Lcase(annot,t,a,branches) -> + let const = branches.constant_branches in + let nonconst = branches.nonconstant_branches in + let t' = f n t in + let a' = f n a in + let const' = Array.Smart.map (f n) const in + let on_b b = + let (ids,body) = b in + let body' = f (g (Array.length ids) n) body in + if body == body' then b else (ids,body') in + let nonconst' = Array.Smart.map on_b nonconst in + let branches' = + if const == const' && nonconst == nonconst' then + branches + else + { constant_branches = const'; + nonconstant_branches = nonconst' } + in + if t == t' && a == a' && branches == branches' then lam else + Lcase(annot,t',a',branches') | Lif(t,bt,bf) -> let t' = f n t in let bt' = f n bt in @@ -222,7 +233,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ - | Lconstruct _ | Lmeta _ | Levar _ -> true + | Lmeta _ | Levar _ -> true | _ -> false let can_merge_if bt bf = @@ -320,16 +331,13 @@ and reduce_lapp substf lids body substa largs = let is_value lc = match lc with - | Lval _ -> true - | Lmakeblock(_,_,_,args) when Array.is_empty args -> true - | Luint _ -> true + | Lval _ | Lint _ | Luint _ -> true | _ -> false let get_value lc = match lc with | Lval v -> v - | Lmakeblock(_,_,tag,args) when Array.is_empty args -> - Nativevalues.mk_int tag + | Lint tag -> Nativevalues.mk_int tag | Luint i -> Nativevalues.mk_uint i | _ -> raise Not_found @@ -337,14 +345,30 @@ let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) (* Translation of constructors *) +let expand_constructor prefix ind tag nparams arity = + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make (nparams + arity) anon in + if Int.equal arity 0 then mkLlam ids (Lint tag) + else + let args = make_args arity 1 in + Llam(ids, Lmakeblock (prefix, ind, tag, args)) -let makeblock env cn u tag args = - if Array.for_all is_value args && Array.length args > 0 then +(* [nparams] is the number of parameters still expected *) +let makeblock env ind tag nparams arity args = + let nargs = Array.length args in + if nparams > 0 || nargs < arity then + let prefix = get_mind_prefix env (fst ind) in + mkLapp (expand_constructor prefix ind tag nparams arity) args + else + (* The constructor is fully applied *) + if Int.equal arity 0 then Lint tag + else + if Array.for_all is_value args then let args = Array.map get_value args in Lval (Nativevalues.mk_block tag args) else - let prefix = get_mind_prefix env (fst (fst cn)) in - Lmakeblock(prefix, (cn,u), tag, args) + let prefix = get_mind_prefix env (fst ind) in + Lmakeblock(prefix, ind, tag, args) (* Translation of constants *) @@ -420,8 +444,6 @@ let empty_evars = { evars_val = (fun _ -> None); evars_metas = (fun _ -> assert false) } -let empty_ids = [||] - (** Extract the inductive type over which a fixpoint is decreasing *) let rec get_fix_struct env i t = match kind (Reduction.whd_all env t) with | Prod (na, dom, t) -> @@ -492,43 +514,51 @@ let rec lambda_of_constr cache env sigma c = let prefix = get_mind_prefix env (fst ind) in mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] - | Case(ci,t,a,branches) -> - let (mind,i as ind) = ci.ci_ind in - let mib = lookup_mind mind env in - let oib = mib.mind_packets.(i) in - let tbl = oib.mind_reloc_tbl in - (* Building info *) - let prefix = get_mind_prefix env mind in - let annot_sw = - { asw_ind = ind; - asw_ci = ci; - asw_reloc = tbl; - asw_finite = mib.mind_finite <> CoFinite; - asw_prefix = prefix} - in - (* translation of the argument *) - let la = lambda_of_constr cache env sigma a in - (* translation of the type *) - let lt = lambda_of_constr cache env sigma t in - (* translation of branches *) - let mk_branch i b = - let cn = (ind,i+1) in - let _, arity = tbl.(i) in - let b = lambda_of_constr cache env sigma b in - if Int.equal arity 0 then (cn, empty_ids, b) - else - match b with - | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body) + | Case(ci,t,a,branches) -> + let (mind,i as ind) = ci.ci_ind in + let mib = lookup_mind mind env in + let oib = mib.mind_packets.(i) in + let tbl = oib.mind_reloc_tbl in + (* Building info *) + let prefix = get_mind_prefix env mind in + let annot_sw = + { asw_ind = ind; + asw_ci = ci; + asw_reloc = tbl; + asw_finite = mib.mind_finite <> CoFinite; + asw_prefix = prefix} + in + (* translation of the argument *) + let la = lambda_of_constr cache env sigma a in + (* translation of the type *) + let lt = lambda_of_constr cache env sigma t in + (* translation of branches *) + let dummy = Lrel(Anonymous,0) in + let consts = Array.make oib.mind_nb_constant dummy in + let blocks = Array.make oib.mind_nb_args ([||],dummy) in + let rtbl = oib.mind_reloc_tbl in + for i = 0 to Array.length rtbl - 1 do + let tag, arity = rtbl.(i) in + let b = lambda_of_constr cache env sigma branches.(i) in + if arity = 0 then consts.(tag) <- b + else + let b = + match b with + | Llam(ids, body) when Array.length ids = arity -> (ids, body) | _ -> - (** TODO relevance *) - let anon = Context.make_annot Anonymous Sorts.Relevant in - let ids = Array.make arity anon in - let args = make_args arity 1 in - let ll = lam_lift arity b in - (cn, ids, mkLapp ll args) in - let bs = Array.mapi mk_branch branches in - Lcase(annot_sw, lt, la, bs) - + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make arity anon in + let args = make_args arity 1 in + let ll = lam_lift arity b in + (ids, mkLapp ll args) + in blocks.(tag-1) <- b + done; + let branches = + { constant_branches = consts; + nonconstant_branches = blocks } + in + Lcase(annot_sw, lt, la, branches) + | Fix((pos, i), (names,type_bodies,rec_bodies)) -> let ltypes = lambda_of_args cache env sigma 0 type_bodies in let map i t = @@ -572,17 +602,13 @@ and lambda_of_app cache env sigma f args = let prefix = get_const_prefix env kn in mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) end - | Construct (c,u) -> - let tag, nparams, arity = Cache.get_construct_info cache env c in - let expected = nparams + arity in - let nargs = Array.length args in - let prefix = get_mind_prefix env (fst (fst c)) in - if Int.equal nargs expected then - let args = lambda_of_args cache env sigma nparams args in - makeblock env c u tag args - else - let args = lambda_of_args cache env sigma 0 args in - mkLapp (Lconstruct (prefix, (c,u))) args + | Construct ((ind,_ as c),_) -> + let tag, nparams, arity = Cache.get_construct_info cache env c in + let nargs = Array.length args in + if nparams < nargs then (* got all parameters *) + let args = lambda_of_args cache env sigma nparams args in + makeblock env ind tag 0 arity args + else makeblock env ind tag (nparams - nargs) arity empty_args | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index b0de257a27..446df1a1ea 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -33,11 +33,10 @@ type lambda = | Lif of lambda * lambda * lambda | Lfix of (int array * (string * inductive) array * int) * fix_decl | Lcofix of int * fix_decl - | Lmakeblock of prefix * pconstructor * int * lambda array - (* prefix, constructor Name.t, constructor tag, arguments *) - (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) - (* A partially applied constructor *) + | Lint of int (* a constant constructor *) + | Lmakeblock of prefix * inductive * int * lambda array + (* prefix, inductive name, constructor tag, arguments *) + (* A fully applied non-constant constructor *) | Luint of Uint63.t | Lval of Nativevalues.t | Lsort of Sorts.t @@ -45,7 +44,10 @@ type lambda = | Llazy | Lforce -and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array; + } and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 833e4082f0..43c9676f05 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -56,14 +56,15 @@ let write_ml_code fn ?(header=[]) code = List.iter (pp_global fmt) (header@code); close_out ch_out -let warn_native_compiler_failed = - let print = function +let error_native_compiler_failed e = + let msg = match e with + | Inl (Unix.WEXITED 127) -> Pp.(strbrk "The OCaml compiler was not found. Make sure it is installed, together with findlib.") | Inl (Unix.WEXITED n) -> Pp.(strbrk "Native compiler exited with status" ++ str" " ++ int n) | Inl (Unix.WSIGNALED n) -> Pp.(strbrk "Native compiler killed by signal" ++ str" " ++ int n) | Inl (Unix.WSTOPPED n) -> Pp.(strbrk "Native compiler stopped by signal" ++ str" " ++ int n) | Inr e -> Pp.(strbrk "Native compiler failed with error: " ++ strbrk (Unix.error_message e)) in - CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print + CErrors.user_err msg let call_compiler ?profile:(profile=false) ml_filename = let load_path = !get_load_paths () in @@ -100,15 +101,12 @@ let call_compiler ?profile:(profile=false) ml_filename = if !Flags.debug then Feedback.msg_debug (Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (Envars.ocamlfind ()) args in - let res = match res with - | Unix.WEXITED 0 -> true - | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> - warn_native_compiler_failed (Inl res); false - in - res, link_filename + match res with + | Unix.WEXITED 0 -> link_filename + | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> + error_native_compiler_failed (Inl res) with Unix.Unix_error (e,_,_) -> - warn_native_compiler_failed (Inr e); - false, link_filename + error_native_compiler_failed (Inr e) let compile fn code ~profile:profile = write_ml_code fn code; @@ -128,9 +126,8 @@ let compile_library dir code fn = in let fn = dirname / basename in write_ml_code fn ~header code; - let r = fst (call_compiler fn) in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; - r + let _ = call_compiler fn in + if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 25adcf224b..e113350368 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -21,9 +21,14 @@ val load_obj : (string -> unit) ref val get_ml_filename : unit -> string * string -val compile : string -> global list -> profile:bool -> bool * string - -val compile_library : Names.DirPath.t -> global list -> string -> bool +(** [compile file code ~profile] will compile native [code] to [file], + and return the name of the object file; this name depends on + whether are in byte mode or not; file is expected to be .ml file *) +val compile : string -> global list -> profile:bool -> string + +(** [compile_library lib code file] is similar to [compile file code] + but will perform some extra tweaks to handle [code] as a Coq lib. *) +val compile_library : Names.DirPath.t -> global list -> string -> unit val call_linker : ?fatal:bool -> string -> string -> code_location_updates option -> unit diff --git a/lib/envars.ml b/lib/envars.ml index 0f4670688b..af8e45b137 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -178,6 +178,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; + fprintf f "%sWARN=%s\n" prefix_var_name "-warn-error +a-3"; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) diff --git a/library/goptions.ml b/library/goptions.ml index 1b907fd966..b9c1802a72 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -57,7 +57,7 @@ module MakeTable = type key val compare : t -> t -> int val table : (string * key table_of_A) list ref - val encode : key -> t + val encode : Environ.env -> key -> t val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name @@ -111,10 +111,10 @@ module MakeTable = class table_of_A () = object - method add x = add_option (A.encode x) - method remove x = remove_option (A.encode x) + method add x = add_option (A.encode (Global.env()) x) + method remove x = remove_option (A.encode (Global.env()) x) method mem x = - let y = A.encode x in + let y = A.encode (Global.env()) x in let answer = MySet.mem y !t in Feedback.msg_info (A.member_message y answer) method print = print_table A.title A.printer !t @@ -142,7 +142,7 @@ struct type key = string let compare = String.compare let table = string_table - let encode x = x + let encode _env x = x let subst _ x = x let printer = str let key = A.key @@ -161,7 +161,7 @@ module type RefConvertArg = sig type t val compare : t -> t -> int - val encode : qualid -> t + val encode : Environ.env -> qualid -> t val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name diff --git a/library/goptions.mli b/library/goptions.mli index b91553bf3c..2e593e9d9e 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -89,8 +89,8 @@ module MakeRefTable : (A : sig type t val compare : t -> t -> int - val encode : qualid -> t - val subst : substitution -> t -> t + val encode : Environ.env -> qualid -> t + val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name val title : string @@ -172,6 +172,14 @@ type option_value = | StringValue of string | StringOptValue of string option +val set_option_value : ?locality:option_locality -> + ('a -> option_value -> option_value) -> option_name -> 'a -> unit +(** [set_option_value ?locality f name v] sets [name] to the result of + applying [f] to [v] and [name]'s current value. Use for behaviour + depending on the type of the option, eg erroring when ['a] doesn't + match it. Changing the type will result in errors later so don't do + that. *) + (** Summary of an option status *) type option_state = { opt_depr : bool; diff --git a/library/library.ml b/library/library.ml index 37dadadb76..04e38296d9 100644 --- a/library/library.ml +++ b/library/library.ml @@ -718,8 +718,7 @@ let save_library_to ?todo ~output_native_objects dir f otab = (* Writing native code files *) if output_native_objects then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in - if not (Nativelib.compile_library dir ast fn) then - user_err Pp.(str "Could not compile the library to native code.") + Nativelib.compile_library dir ast fn with reraise -> let reraise = CErrors.push reraise in let () = Feedback.msg_warning (str "Removed file " ++ str f') in diff --git a/parsing/dune b/parsing/dune index e91740650f..2bb8611e09 100644 --- a/parsing/dune +++ b/parsing/dune @@ -2,7 +2,7 @@ (name parsing) (public_name coq.parsing) (wrapped false) - (libraries coq.gramlib proofs)) + (libraries coq.gramlib interp)) (rule (targets g_prim.ml) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 0586dda555..4a9190c10a 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -56,10 +56,10 @@ let mk_fixb (id,bl,ann,body,(loc,tyc)) : fix_expr = (id,ann,bl,ty,body) let mk_cofixb (id,bl,ann,body,(loc,tyc)) : cofix_expr = - let _ = Option.map (fun { CAst.loc = aloc } -> + Option.iter (fun { CAst.loc = aloc } -> CErrors.user_err ?loc:aloc ~hdr:"Constr:mk_cofixb" - (Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in + (Pp.str"Annotation forbidden in cofix expression.")) ann; let ty = match tyc with Some ty -> ty | None -> CAst.make @@ CHole (None, IntroAnonymous, None) in @@ -440,10 +440,10 @@ GRAMMAR EXTEND Gram ] ] ; fixannot: - [ [ "{"; IDENT "struct"; id=identref; "}" -> { (Some id, CStructRec) } - | "{"; IDENT "wf"; rel=constr; id=OPT identref; "}" -> { (id, CWfRec rel) } + [ [ "{"; IDENT "struct"; id=identref; "}" -> { CAst.make ~loc @@ CStructRec id } + | "{"; IDENT "wf"; rel=constr; id=identref; "}" -> { CAst.make ~loc @@ CWfRec(id,rel) } | "{"; IDENT "measure"; m=constr; id=OPT identref; - rel=OPT constr; "}" -> { (id, CMeasureRec (m,rel)) } + rel=OPT constr; "}" -> { CAst.make ~loc @@ CMeasureRec (id,m,rel) } ] ] ; impl_name_head: @@ -452,9 +452,9 @@ GRAMMAR EXTEND Gram binders_fixannot: [ [ na = impl_name_head; assum = impl_ident_tail; bl = binders_fixannot -> { (assum na :: fst bl), snd bl } - | f = fixannot -> { [], f } + | f = fixannot -> { [], Some f } | b = binder; bl = binders_fixannot -> { b @ fst bl, snd bl } - | -> { [], (None, CStructRec) } + | -> { [], None } ] ] ; open_binders: diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 5d8897cb47..3a57c14a3b 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -191,7 +191,7 @@ module Constr : val binder : local_binder_expr list Entry.t (* closed_binder or variable *) val binders : local_binder_expr list Entry.t (* list of binder *) val open_binders : local_binder_expr list Entry.t - val binders_fixannot : (local_binder_expr list * (lident option * recursion_order_expr)) Entry.t + val binders_fixannot : (local_binder_expr list * recursion_order_expr option) Entry.t val typeclass_constraint : (lname * bool * constr_expr) Entry.t val record_declaration : constr_expr Entry.t val appl_arg : (constr_expr * explicitation CAst.t option) Entry.t diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 50fc2448fc..0e3b9fc2b6 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -67,7 +67,7 @@ let rec decompose_term env sigma t= let canon_mind = MutInd.make1 (MutInd.canonical mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in - let nargs=constructor_nallargs_env env (canon_ind,i_con) in + let nargs=constructor_nallargs env (canon_ind,i_con) in Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index c9cfd74362..9db7c8d8d3 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -854,7 +854,7 @@ and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args = and extract_case env sg mle ((kn,i) as ip,c,br) mlt = (* [br]: bodies of each branch (in functional form) *) (* [ni]: number of arguments without parameters in each branch *) - let ni = constructors_nrealargs_env env ip in + let ni = constructors_nrealargs env ip in let br_size = Array.length br in assert (Int.equal (Array.length ni) br_size); if Int.equal br_size 0 then begin diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 56b3dc97cf..4b7bc707d6 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -82,13 +82,13 @@ let pop t = Vars.lift (-1) t let kind_of_formula env sigma term = let normalize = special_nf env sigma in let cciterm = special_whd env sigma term in - match match_with_imp_term sigma cciterm with + match match_with_imp_term env sigma cciterm with Some (a,b)-> Arrow (a, pop b) |_-> - match match_with_forall_term sigma cciterm with + match match_with_forall_term env sigma cciterm with Some (_,a,b)-> Forall (a, b) |_-> - match match_with_nodep_ind sigma cciterm with + match match_with_nodep_ind env sigma cciterm with Some (i,l,n)-> let ind,u=EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in @@ -111,7 +111,7 @@ let kind_of_formula env sigma term = else Or((ind,u),l,is_trivial) | _ -> - match match_with_sigma_type sigma cciterm with + match match_with_sigma_type env sigma cciterm with Some (i,l)-> let (ind, u) = EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 01b18e2f30..9f2ceb2c28 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -188,7 +188,7 @@ let empty_seq depth= let expand_constructor_hints = List.map_append (function | GlobRef.IndRef ind -> - List.init (Inductiveops.nconstructors ind) + List.init (Inductiveops.nconstructors (Global.env()) ind) (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> [gr]) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 4e8cf80ed2..a3973732ad 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -179,8 +179,10 @@ let () = VERNAC COMMAND EXTEND Function | ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function - | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true - | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in + | _,((_,(Some { CAst.v = CMeasureRec _ } + | Some { CAst.v = CWfRec _}),_,_,_),_) -> true + | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) + | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 275b58f0aa..45a4e61846 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -317,7 +317,7 @@ let build_constructors_of_type ind' argl = Impargs.implicits_of_global constructref in let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) construct in @@ -330,7 +330,7 @@ let build_constructors_of_type ind' argl = let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) in - cases_pattern_of_glob_constr Anonymous pat_as_term + cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term ) ind.Declarations.mind_consnames @@ -415,7 +415,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) constr in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 13ff19a46b..7b758da8e8 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -361,7 +361,7 @@ let rec pattern_to_term pt = DAst.with_val (function mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) constr in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a5c19f3217..6494e90a03 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -382,8 +382,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let _ = List.map_i (fun i x -> - let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in - let env = Global.env () in + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn,i) (InProp) in let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in @@ -469,11 +469,6 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas CAst.(with_val (fun x -> x)) (Constrexpr_ops.names_of_local_assums args) in - match wf_arg with - | None -> - if Int.equal (List.length names) 1 then 1 - else error "Recursive argument must be specified" - | Some wf_arg -> List.index Name.equal (Name wf_arg) names in let unbounded_eq = @@ -575,7 +570,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas in wf_rel_with_mes,false in - register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) + register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body let map_option f = function @@ -623,15 +618,15 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let fixl,ntns = ComFixpoint.extract_fixpoint_components ~structonly:false fixpoint_exprl in let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = - List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> + List.map2 (fun ((lna,rec_order_opt,bl,ret_typ,opt_body),notation_list) fix_typ -> let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in - (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + (((lna,rec_order_opt,new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel in @@ -643,7 +638,7 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let pstate, _is_struct = match fixpoint_exprl with - | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -665,9 +660,9 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive true in if register_built - then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, false + then register_wf name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false else pstate, false - |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -692,9 +687,9 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true else pstate, true | _ -> - List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> + List.iter (function ((_na,ord,_args,_body,_type),_not) -> match ord with - | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () @@ -869,38 +864,42 @@ let make_graph ~pstate (f_ref : GlobRef.t) = ) () in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let { CAst.loc; v=rec_id } = Option.get n in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - ((((id,None), ( Some CAst.(make rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) - ) - fixexprl - in - l + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) + in + let b' = add_args id.CAst.v new_args b in + ((((id,None), ( Some (CAst.make (CStructRec (CAst.make rec_id)))),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ) + fixexprl + in + l | _ -> let id = Label.to_id (Constant.label c) in - [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [((CAst.make id,None),None,nal_tas,t,Some b),[]] in let mp = Constant.modpath c in let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/plugin_base.dune index 002eb28eea..6ccf15df29 100644 --- a/plugins/funind/plugin_base.dune +++ b/plugins/funind/plugin_base.dune @@ -1,5 +1,5 @@ (library (name recdef_plugin) - (public_name coq.plugins.recdef) + (public_name coq.plugins.funind) (synopsis "Coq's functional induction plugin") (libraries coq.plugins.extraction)) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 75565c1a34..2d40ba6562 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -119,7 +119,7 @@ let app_poly_check env evars f args = (evars, cstrs), t let app_poly_nocheck env evars f args = - let evars, fc = f evars in + let evars, fc = f evars in evars, mkApp (fc, args) let app_poly_sort b = @@ -175,25 +175,29 @@ end) = struct let rewrite_relation_class = find_global relation_classes "RewriteRelation" - let proper_class = lazy (class_info (find_reference morphisms "Proper")) - let proper_proxy_class = lazy (class_info (find_reference morphisms "ProperProxy")) - - let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - - let proper_type = - let l = lazy (Lazy.force proper_class).cl_impl in - fun (evd,cstrs) -> - let (evd, c) = Evarutil.new_global evd (Lazy.force l) in - (evd, cstrs), c - - let proper_proxy_type = - let l = lazy (Lazy.force proper_proxy_class).cl_impl in - fun (evd,cstrs) -> - let (evd, c) = Evarutil.new_global evd (Lazy.force l) in - (evd, cstrs), c + let proper_class = + let r = lazy (find_reference morphisms "Proper") in + fun env sigma -> class_info env sigma (Lazy.force r) + + let proper_proxy_class = + let r = lazy (find_reference morphisms "ProperProxy") in + fun env sigma -> class_info env sigma (Lazy.force r) + + let proper_proj env sigma = + mkConst (Option.get (pi3 (List.hd (proper_class env sigma).cl_projs))) + + let proper_type env (sigma,cstrs) = + let l = (proper_class env sigma).cl_impl in + let (sigma, c) = Evarutil.new_global sigma l in + (sigma, cstrs), c + + let proper_proxy_type env (sigma,cstrs) = + let l = (proper_proxy_class env sigma).cl_impl in + let (sigma, c) = Evarutil.new_global sigma l in + (sigma, cstrs), c let proper_proof env evars carrier relation x = - let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in + let evars, goal = app_poly env evars (proper_proxy_type env) [| carrier ; relation; x |] in new_cstr_evar evars env goal let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env @@ -800,7 +804,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in - let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type env else TypeGlobal.proper_type env) cl_args in let env' = let dosub, appsub = @@ -1310,8 +1314,8 @@ module Strategies = in let evars, proof = let proxy = - if prop then PropGlobal.proper_proxy_type - else TypeGlobal.proper_proxy_type + if prop then PropGlobal.proper_proxy_type env + else TypeGlobal.proper_proxy_type env in let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty @@ -1854,12 +1858,12 @@ let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) -let proper_projection sigma r ty = +let proper_projection env sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in let ctx, inst = decompose_prod_assum sigma ty in let mor, args = destApp sigma inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force PropGlobal.proper_proj, + let app = mkApp (PropGlobal.proper_proj env sigma, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx @@ -1869,7 +1873,7 @@ let declare_projection n instance_id r = let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in - let term = proper_projection sigma c ty in + let term = proper_projection env sigma c ty in let sigma, typ = Typing.type_of env sigma term in let ctx, typ = decompose_prod_assum sigma typ in let typ = @@ -1924,7 +1928,7 @@ let build_morphism_signature env sigma m = rel) cstrs in - let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in + let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in let evd = Evd.minimize_universes evd in let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in @@ -1938,9 +1942,9 @@ let default_morphism sign m = let evars, _, sign, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in - let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in + let evars, morph = app_poly_check env evars (PropGlobal.proper_type env) [| t; sign; m |] in let evars, mor = resolve_one_typeclass env (goalevars evars) morph in - mor, proper_projection sigma mor morph + mor, proper_projection env sigma mor morph let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> @@ -1984,8 +1988,8 @@ let add_morphism_infer ~pstate atts m n : Proof_global.t option = (None,(instance,uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); + add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst); pstate else @@ -1995,8 +1999,8 @@ let add_morphism_infer ~pstate atts m n : Proof_global.t option = let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ _ _ = function | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index caaa547a07..e617f3d45e 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -30,7 +30,7 @@ let subst_quantified_hypothesis _ x = x let subst_declared_or_quantified_hypothesis _ x = x let subst_glob_constr_and_expr subst (c, e) = - (Detyping.subst_glob_constr subst c, e) + (Detyping.subst_glob_constr (Global.env()) subst c, e) let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) @@ -99,7 +99,9 @@ let subst_evaluable subst = let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) let subst_glob_constr_or_pattern subst (bvars,c,p) = - (bvars,subst_glob_constr subst c,subst_pattern subst p) + let env = Global.env () in + let sigma = Evd.from_env env in + (bvars,subst_glob_constr subst c,subst_pattern env sigma subst p) let subst_redexp subst = Redops.map_red_expr_gen diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 4c65445b89..d1951cc18d 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -98,16 +98,18 @@ let split = Tactics.split_with_bindings false [Tactypes.NoBindings] (** Test *) let is_empty _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> - if is_empty_type sigma (assoc_var "X1" ist) then idtac else fail + if is_empty_type genv sigma (assoc_var "X1" ist) then idtac else fail (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) let is_unit_or_eq _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test sigma (assoc_var "X1" ist) then idtac else fail + if test genv sigma (assoc_var "X1" ist) then idtac else fail let bugged_is_binary sigma t = isApp sigma t && @@ -121,23 +123,25 @@ let bugged_is_binary sigma t = (** Dealing with conjunction *) let is_conj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let ind = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma ind) && - is_conjunction sigma + is_conjunction genv sigma ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode ind then idtac else fail let flatten_contravariant_conj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in - match match_with_conjunction sigma + match match_with_conjunction genv sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with @@ -151,23 +155,25 @@ let flatten_contravariant_conj _ ist = (** Dealing with disjunction *) let is_disj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let t = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma t) && - is_disjunction sigma + is_disjunction genv sigma ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode t then idtac else fail let flatten_contravariant_disj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in - match match_with_disjunction sigma + match match_with_disjunction genv sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 350bb9019e..675e4d2457 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -194,7 +194,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let sort = Tacticals.elimination_sort_of_goal gl in let gl, elim = if not is_case then - let t,gl= pf_fresh_global (Indrec.lookup_eliminator (kn,i) sort) gl in + let t,gl= pf_fresh_global (Indrec.lookup_eliminator env (kn,i) sort) gl in gl, t else Tacmach.pf_eapply (fun env sigma () -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 5abbc214de..4433f2fce7 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -340,7 +340,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in let sort = elimination_sort_of_goal gl in - let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator env ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) let elim, _ = destConst elim in let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in @@ -504,9 +504,9 @@ let rwprocess_rule dir rule gl = let sigma, rs2 = loop d sigma s a.(1) rs 0 in let s, sigma = sr sigma 1 in loop d sigma s a.(0) rs2 0 - | App (r_eq, a) when Hipattern.match_with_equality_type sigma t != None -> + | App (r_eq, a) when Hipattern.match_with_equality_type env sigma t != None -> let (ind, u) = EConstr.destInd sigma r_eq and rhs = Array.last a in - let np = Inductiveops.inductive_nparamdecls ind in + let np = Inductiveops.inductive_nparamdecls env ind in let indu = (ind, EConstr.EInstance.kind sigma u) in let ind_ct = Inductiveops.type_of_constructors env indu in let lhs0 = last_arg sigma (EConstr.of_constr (strip_prod_assum ind_ct.(0))) in diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 7cd62f4ead..f44962f213 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1200,7 +1200,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, - { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> + { v = CFix ( _, [_, Some {CAst.v = CStructRec locn}, bl, t, c]) } -> let bs = format_local_binders h bl in let bstr = if has_str then [Bstruct (Name locn.CAst.v)] else [] in bs @ bstr @ (if has_cast then [Bcast t] else []), c @@ -1424,7 +1424,7 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS (ident * ssrfwd) PRINTED BY { pr_ssrfixfwd } | [] -> CErrors.user_err (Pp.str "Bad structural argument") in loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in - let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in + let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some (CAst.make (CStructRec i))), lb, t', c']) in id, ((fk, h'), { ac with body = fix }) } END diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 0a0d9b12fa..08f028465b 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -183,7 +183,7 @@ GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> - { Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) } + { Vernacexpr.VernacSetOption (false, ["Printing"; "Implicit"; "Defensive"], Vernacexpr.OptionUnset) } ] ] ; END @@ -465,7 +465,7 @@ let interp_modloc mr = (* The unified, extended vernacular "Search" command *) let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in Feedback.msg_info (hov 2 pr_res ++ fnl ()) } diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 537fd7d7b4..075ebf006a 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -43,7 +43,7 @@ module AdaptorDb = struct term_view_adaptor_db := AdaptorMap.add k (t :: lk) !term_view_adaptor_db let subst_adaptor ( subst, (k, t as a)) = - let t' = Detyping.subst_glob_constr subst t in + let t' = Detyping.subst_glob_constr (Global.env()) subst t in if t' == t then a else k, t' let in_db = diff --git a/pretyping/cases.ml b/pretyping/cases.ml index e22368d5e5..d7a6c4c832 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -284,7 +284,7 @@ let rec find_row_ind = function let inductive_template env sigma tmloc ind = let sigma, indu = Evd.fresh_inductive_instance env sigma ind in - let arsign = inductive_alldecls_env env indu in + let arsign = inductive_alldecls env indu in let indu = on_snd EInstance.make indu in let hole_source i = match tmloc with | Some loc -> Loc.tag ~loc @@ Evar_kinds.TomatchTypeParameter (ind,i) @@ -313,7 +313,7 @@ let try_find_ind env sigma typ realnames = | Some names -> names | None -> let ind = fst (fst (dest_ind_family indf)) in - List.make (inductive_nrealdecls ind) Anonymous in + List.make (inductive_nrealdecls env ind) Anonymous in IsInd (typ,ind,names) let inh_coerce_to_ind env sigma0 loc ty tyi = @@ -1796,7 +1796,7 @@ let build_inversion_problem ~program_mode loc env sigma tms t = | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in - let n = constructor_nrealargs_env !!env cstr in + let n = constructor_nrealargs !!env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_right_map reveal_pattern l acc in DAst.make (PatCstr (cstr,l,Anonymous)), acc @@ -1929,7 +1929,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in - let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in + let nrealargs_ctxt = inductive_nrealdecls env0 ind in let arsign, inds = get_arity env0 indf' in let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 5560e5e5f5..90ce1cc594 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -15,7 +15,6 @@ open Names open Constr open Libnames open Globnames -open Libobject open Mod_subst (* usage qque peu general: utilise aussi dans record *) @@ -288,7 +287,7 @@ let get_coercion_constructor env coe = let red x = fst (Reductionops.whd_all_stack env evd x) in match EConstr.kind evd (red (mkNamed coe.coe_value)) with | Constr.Construct (c, _) -> - c, Inductiveops.constructor_nrealargs c -1 + c, Inductiveops.constructor_nrealargs env c -1 | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = @@ -305,8 +304,8 @@ let install_path_printer f = path_printer := f let print_path x = !path_printer x -let path_comparator : (inheritance_path -> inheritance_path -> bool) ref = - ref (fun _ _ -> false) +let path_comparator : (Environ.env -> Evd.evar_map -> inheritance_path -> inheritance_path -> bool) ref = + ref (fun _ _ _ _ -> false) let install_path_comparator f = path_comparator := f @@ -319,24 +318,24 @@ let warn_ambiguous_path = (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) -let different_class_params i = +let different_class_params env i = let ci = class_info_from_index i in if (snd ci).cl_param > 0 then true else match fst ci with - | CL_IND i -> Global.is_polymorphic (IndRef i) - | CL_CONST c -> Global.is_polymorphic (ConstRef c) + | CL_IND i -> Environ.is_polymorphic env (IndRef i) + | CL_CONST c -> Environ.is_polymorphic env (ConstRef c) | _ -> false -let add_coercion_in_graph (ic,source,target) = +let add_coercion_in_graph env sigma (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = - if not (Bijint.Index.equal i j) || different_class_params i then + if not (Bijint.Index.equal i j) || different_class_params env i then match lookup_path_between_class ij with | q -> - if not (compare_path p q) then + if not (compare_path env sigma p q) then ambig_paths := (ij,p)::!ambig_paths; false | exception Not_found -> (add_new_path ij p; true) @@ -374,31 +373,42 @@ type coercion = { coercion_params : int; } +let subst_coercion subst c = + let coe = subst_coe_typ subst c.coercion_type in + let cls = subst_cl_typ subst c.coercion_source in + let clt = subst_cl_typ subst c.coercion_target in + let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in + if c.coercion_type == coe && c.coercion_source == cls && + c.coercion_target == clt && c.coercion_is_proj == clp + then c + else { c with coercion_type = coe; coercion_source = cls; + coercion_target = clt; coercion_is_proj = clp; } + (* Computation of the class arity *) -let reference_arity_length ref = - let t, _ = Typeops.type_of_global_in_context (Global.env ()) ref in - List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty (EConstr.of_constr t))) (** FIXME *) +let reference_arity_length env sigma ref = + let t, _ = Typeops.type_of_global_in_context env ref in + List.length (fst (Reductionops.splay_arity env sigma (EConstr.of_constr t))) -let projection_arity_length p = - let len = reference_arity_length (ConstRef (Projection.Repr.constant p)) in +let projection_arity_length env sigma p = + let len = reference_arity_length env sigma (ConstRef (Projection.Repr.constant p)) in len - Projection.Repr.npars p -let class_params = function +let class_params env sigma = function | CL_FUN | CL_SORT -> 0 - | CL_CONST sp -> reference_arity_length (ConstRef sp) - | CL_PROJ sp -> projection_arity_length sp - | CL_SECVAR sp -> reference_arity_length (VarRef sp) - | CL_IND sp -> reference_arity_length (IndRef sp) + | CL_CONST sp -> reference_arity_length env sigma (ConstRef sp) + | CL_PROJ sp -> projection_arity_length env sigma sp + | CL_SECVAR sp -> reference_arity_length env sigma (VarRef sp) + | CL_IND sp -> reference_arity_length env sigma (IndRef sp) (* add_class : cl_typ -> locality_flag option -> bool -> unit *) -let add_class cl = - add_new_class cl { cl_param = class_params cl } +let add_class env sigma cl = + add_new_class cl { cl_param = class_params env sigma cl } -let cache_coercion (_, c) = - let () = add_class c.coercion_source in - let () = add_class c.coercion_target in +let declare_coercion env sigma c = + let () = add_class env sigma c.coercion_source in + let () = add_class env sigma c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in let xf = @@ -409,65 +419,7 @@ let cache_coercion (_, c) = coe_param = c.coercion_params; } in let () = add_new_coercion c.coercion_type xf in - add_coercion_in_graph (xf,is,it) - -let open_coercion i o = - if Int.equal i 1 then - cache_coercion o - -let subst_coercion (subst, c) = - let coe = subst_coe_typ subst c.coercion_type in - let cls = subst_cl_typ subst c.coercion_source in - let clt = subst_cl_typ subst c.coercion_target in - let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in - if c.coercion_type == coe && c.coercion_source == cls && - c.coercion_target == clt && c.coercion_is_proj == clp - then c - else { c with coercion_type = coe; coercion_source = cls; - coercion_target = clt; coercion_is_proj = clp; } - -let discharge_coercion (_, c) = - if c.coercion_local then None - else - let n = - try - let ins = Lib.section_instance c.coercion_type in - Array.length (snd ins) - with Not_found -> 0 - in - let nc = { c with - coercion_params = n + c.coercion_params; - coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; - } in - Some nc - -let classify_coercion obj = - if obj.coercion_local then Dispose else Substitute obj - -let inCoercion : coercion -> obj = - declare_object {(default_object "COERCION") with - open_function = open_coercion; - cache_function = cache_coercion; - subst_function = subst_coercion; - classify_function = classify_coercion; - discharge_function = discharge_coercion } - -let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = - let isproj = - match coef with - | ConstRef c -> Recordops.find_primitive_projection c - | _ -> None - in - let c = { - coercion_type = coef; - coercion_local = local; - coercion_is_id = isid; - coercion_is_proj = isproj; - coercion_source = cls; - coercion_target = clt; - coercion_params = ps; - } in - Lib.add_anonymous_leaf (inCoercion c) + add_coercion_in_graph env sigma (xf,is,it) (* For printing purpose *) let pr_cl_index = Bijint.Index.print @@ -490,7 +442,7 @@ module CoercionPrinting = struct type t = coe_typ let compare = GlobRef.Ordered.compare - let encode = coercion_of_reference + let encode _env = coercion_of_reference let subst = subst_coe_typ let printer x = Nametab.pr_global_env Id.Set.empty x let key = ["Printing";"Coercion"] diff --git a/pretyping/classops.mli b/pretyping/classops.mli index bd468e62ad..c04182930e 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -75,9 +75,19 @@ val inductive_class_of : inductive -> cl_index val class_args_of : env -> evar_map -> types -> constr list (** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) -val declare_coercion : - coe_typ -> ?local:bool -> isid:bool -> - src:cl_typ -> target:cl_typ -> params:int -> unit +type coercion = { + coercion_type : coe_typ; + coercion_local : bool; + coercion_is_id : bool; + coercion_is_proj : Projection.Repr.t option; + coercion_source : cl_typ; + coercion_target : cl_typ; + coercion_params : int; +} + +val subst_coercion : substitution -> coercion -> coercion + +val declare_coercion : env -> evar_map -> coercion -> unit (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool @@ -101,7 +111,7 @@ val lookup_pattern_path_between : val install_path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit val install_path_comparator : - (inheritance_path -> inheritance_path -> bool) -> unit + (env -> evar_map -> inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 87d3880f99..062e3ca8b2 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -145,9 +145,9 @@ let add_name_opt na b t (nenv, env) = (****************************************************************************) (* Tools for printing of Cases *) -let encode_inductive r = +let encode_inductive env r = let indsp = Nametab.global_inductive r in - let constr_lengths = constructors_nrealargs indsp in + let constr_lengths = constructors_nrealargs env indsp in (indsp,constr_lengths) (* Parameterization of the translation from constr to ast *) @@ -159,15 +159,15 @@ let has_two_constructors lc = let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 -let encode_bool ({CAst.loc} as r) = - let (x,lc) = encode_inductive r in +let encode_bool env ({CAst.loc} as r) = + let (x,lc) = encode_inductive env r in if not (has_two_constructors lc) then user_err ?loc ~hdr:"encode_if" (str "This type has not exactly two constructors."); x -let encode_tuple ({CAst.loc} as r) = - let (x,lc) = encode_inductive r in +let encode_tuple env ({CAst.loc} as r) = + let (x,lc) = encode_inductive env r in if not (isomorphic_to_tuple lc) then user_err ?loc ~hdr:"encode_tuple" (str "This type cannot be seen as a tuple type."); @@ -175,7 +175,7 @@ let encode_tuple ({CAst.loc} as r) = module PrintingInductiveMake = functor (Test : sig - val encode : qualid -> inductive + val encode : Environ.env -> qualid -> inductive val member_message : Pp.t -> bool -> Pp.t val field : string val title : string @@ -653,7 +653,7 @@ let detype_fix detype flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let v = Array.map3 (fun c t i -> share_names detype flags (i+1) [] def_avoid def_env sigma c (lift n t)) bodies tys vn in - GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), + GRec(GFix (Array.map (fun i -> Some i) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) @@ -1014,13 +1014,12 @@ let rec subst_cases_pattern subst = DAst.map (function let (f_subst_genarg, subst_genarg_hook) = Hook.make () -let rec subst_glob_constr subst = DAst.map (function +let rec subst_glob_constr env subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in if ref' == ref then raw else (match t with | None -> GRef (ref', u) | Some t -> - let env = Global.env () in let evd = Evd.from_env env in let t = t.Univ.univ_abstracted_value in (* XXX This seems dangerous *) DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t))) @@ -1032,33 +1031,33 @@ let rec subst_glob_constr subst = DAst.map (function | GPatVar _ as raw -> raw | GApp (r,rl) as raw -> - let r' = subst_glob_constr subst r - and rl' = List.Smart.map (subst_glob_constr subst) rl in + let r' = subst_glob_constr env subst r + and rl' = List.Smart.map (subst_glob_constr env subst) rl in if r' == r && rl' == rl then raw else GApp(r',rl') | GLambda (n,bk,r1,r2) as raw -> - let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in + let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in if r1' == r1 && r2' == r2 then raw else GLambda (n,bk,r1',r2') | GProd (n,bk,r1,r2) as raw -> - let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in + let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in if r1' == r1 && r2' == r2 then raw else GProd (n,bk,r1',r2') | GLetIn (n,r1,t,r2) as raw -> - let r1' = subst_glob_constr subst r1 in - let r2' = subst_glob_constr subst r2 in - let t' = Option.Smart.map (subst_glob_constr subst) t in + let r1' = subst_glob_constr env subst r1 in + let r2' = subst_glob_constr env subst r2 in + let t' = Option.Smart.map (subst_glob_constr env subst) t in if r1' == r1 && t == t' && r2' == r2 then raw else GLetIn (n,r1',t',r2') | GCases (sty,rtno,rl,branches) as raw -> let open CAst in - let rtno' = Option.Smart.map (subst_glob_constr subst) rtno + let rtno' = Option.Smart.map (subst_glob_constr env subst) rtno and rl' = List.Smart.map (fun (a,x as y) -> - let a' = subst_glob_constr subst a in + let a' = subst_glob_constr env subst a in let (n,topt) = x in let topt' = Option.Smart.map (fun ({loc;v=((sp,i),y)} as t) -> @@ -1069,7 +1068,7 @@ let rec subst_glob_constr subst = DAst.map (function (fun ({loc;v=(idl,cpl,r)} as branch) -> let cpl' = List.Smart.map (subst_cases_pattern subst) cpl - and r' = subst_glob_constr subst r in + and r' = subst_glob_constr env subst r in if cpl' == cpl && r' == r then branch else CAst.(make ?loc (idl,cpl',r'))) branches @@ -1078,27 +1077,27 @@ let rec subst_glob_constr subst = DAst.map (function GCases (sty,rtno',rl',branches') | GLetTuple (nal,(na,po),b,c) as raw -> - let po' = Option.Smart.map (subst_glob_constr subst) po - and b' = subst_glob_constr subst b - and c' = subst_glob_constr subst c in + let po' = Option.Smart.map (subst_glob_constr env subst) po + and b' = subst_glob_constr env subst b + and c' = subst_glob_constr env subst c in if po' == po && b' == b && c' == c then raw else GLetTuple (nal,(na,po'),b',c') | GIf (c,(na,po),b1,b2) as raw -> - let po' = Option.Smart.map (subst_glob_constr subst) po - and b1' = subst_glob_constr subst b1 - and b2' = subst_glob_constr subst b2 - and c' = subst_glob_constr subst c in + let po' = Option.Smart.map (subst_glob_constr env subst) po + and b1' = subst_glob_constr env subst b1 + and b2' = subst_glob_constr env subst b2 + and c' = subst_glob_constr env subst c in if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else GIf (c',(na,po'),b1',b2') | GRec (fix,ida,bl,ra1,ra2) as raw -> - let ra1' = Array.Smart.map (subst_glob_constr subst) ra1 - and ra2' = Array.Smart.map (subst_glob_constr subst) ra2 in + let ra1' = Array.Smart.map (subst_glob_constr env subst) ra1 + and ra2' = Array.Smart.map (subst_glob_constr env subst) ra2 in let bl' = Array.Smart.map (List.Smart.map (fun (na,k,obd,ty as dcl) -> - let ty' = subst_glob_constr subst ty in - let obd' = Option.Smart.map (subst_glob_constr subst) obd in + let ty' = subst_glob_constr env subst ty in + let obd' = Option.Smart.map (subst_glob_constr env subst) obd in if ty'==ty && obd'==obd then dcl else (na,k,obd',ty'))) bl in if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else @@ -1116,8 +1115,8 @@ let rec subst_glob_constr subst = DAst.map (function else GHole (nknd, naming, nsolve) | GCast (r1,k) as raw -> - let r1' = subst_glob_constr subst r1 in - let k' = smartmap_cast_type (subst_glob_constr subst) k in + let r1' = subst_glob_constr env subst r1 in + let k' = smartmap_cast_type (subst_glob_constr env subst) k in if r1' == r1 && k' == k then raw else GCast (r1',k') ) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 8695d52b12..1a8e97efb8 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -37,7 +37,7 @@ val print_allow_match_default_clause : bool ref val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern -val subst_glob_constr : substitution -> glob_constr -> glob_constr +val subst_glob_constr : env -> substitution -> glob_constr -> glob_constr val factorize_eqns : 'a cases_clauses_g -> 'a disjunctive_cases_clauses_g @@ -87,7 +87,7 @@ val subst_genarg_hook : module PrintingInductiveMake : functor (Test : sig - val encode : Libnames.qualid -> Names.inductive + val encode : Environ.env -> Libnames.qualid -> Names.inductive val member_message : Pp.t -> bool -> Pp.t val field : string val title : string @@ -95,7 +95,7 @@ module PrintingInductiveMake : sig type t = Names.inductive val compare : t -> t -> int - val encode : Libnames.qualid -> Names.inductive + val encode : Environ.env -> Libnames.qualid -> Names.inductive val subst : substitution -> t -> t val printer : t -> Pp.t val key : Goptions.option_name diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index a4a078bfa0..4a941a68b1 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -73,11 +73,11 @@ let normalize_evar evd ev = | Evar (evk,args) -> (evk,args) | _ -> assert false -let get_polymorphic_positions sigma f = +let get_polymorphic_positions env sigma f = let open Declarations in match EConstr.kind sigma f with - | Ind (ind, u) | Construct ((ind, _), u) -> - let mib,oib = Global.lookup_inductive ind in + | Ind (ind, u) | Construct ((ind, _), u) -> + let mib,oib = Inductive.lookup_mind_specif env ind in (match oib.mind_arity with | RegularArity _ -> assert false | TemplateArity templ -> templ.template_param_levels) @@ -128,7 +128,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) let rec refresh_term_evars ~onevars ~top t = match EConstr.kind !evdref t with | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> - let pos = get_polymorphic_positions !evdref f in + let pos = get_polymorphic_positions env !evdref f in refresh_polymorphic_positions args pos; t | App (f, args) when top && isEvar !evdref f -> let f' = refresh_term_evars ~onevars:true ~top:false f in @@ -1203,17 +1203,17 @@ exception CannotProject of evar_map * EConstr.existential of subterms to eventually discard so as to be allowed to keep ti. *) -let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = +let rec is_constrainable_in top env evd k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect evd t in match EConstr.kind evd f with | Construct ((ind,_),u) -> - let n = Inductiveops.inductive_nparams ind in + let n = Inductiveops.inductive_nparams env ind in if n > Array.length args then true (* We don't try to be more clever *) else let params = fst (Array.chop n args) in - Array.for_all (is_constrainable_in false evd k g) params - | Ind _ -> Array.for_all (is_constrainable_in false evd k g) args - | Prod (na,t1,t2) -> is_constrainable_in false evd k g t1 && is_constrainable_in false evd k g t2 + Array.for_all (is_constrainable_in false env evd k g) params + | Ind _ -> Array.for_all (is_constrainable_in false env evd k g) args + | Prod (na,t1,t2) -> is_constrainable_in false env evd k g t1 && is_constrainable_in false env evd k g t2 | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*) | Var id -> Id.Set.mem id fv_ids | Rel n -> n <= k || Int.Set.mem n fv_rels @@ -1238,7 +1238,7 @@ let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_r | None -> (* t is an instance for a proper variable; we filter it along *) (* the free variables allowed to occur *) - (not force || noccur_evar env evd ev t) && is_constrainable_in true evd k (ev,(fv_rels,fv_ids)) t + (not force || noccur_evar env evd ev t) && is_constrainable_in true env evd k (ev,(fv_rels,fv_ids)) t exception EvarSolvedOnTheFly of evar_map * EConstr.constr diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 74432cc010..85b9faac77 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -106,19 +106,9 @@ let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = Name.equal na1 na2 && binding_kind_eq bk1 bk2 && Option.equal f c1 c2 && f t1 t2 -let fix_recursion_order_eq f o1 o2 = match o1, o2 with - | GStructRec, GStructRec -> true - | GWfRec c1, GWfRec c2 -> f c1 c2 - | GMeasureRec (c1, o1), GMeasureRec (c2, o2) -> - f c1 c2 && Option.equal f o1 o2 - | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false - -let fix_kind_eq f k1 k2 = match k1, k2 with +let fix_kind_eq k1 k2 = match k1, k2 with | GFix (a1, i1), GFix (a2, i2) -> - let eq (i1, o1) (i2, o2) = - Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2 - in - Int.equal i1 i2 && Array.equal eq a1 a2 + Int.equal i1 i2 && Array.equal (Option.equal Int.equal) a1 a2 | GCoFix i1, GCoFix i2 -> Int.equal i1 i2 | (GFix _ | GCoFix _), _ -> false @@ -150,7 +140,7 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with f m1 m2 && Name.equal pat1 pat2 && Option.equal f p1 p2 && f c1 c2 && f t1 t2 | GRec (kn1, id1, decl1, t1, c1), GRec (kn2, id2, decl2, t2, c2) -> - fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 && + fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 && Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && Array.equal f c1 c2 && Array.equal f t1 t2 | GSort s1, GSort s2 -> glob_sort_eq s1 s2 @@ -492,7 +482,7 @@ let is_gvar id c = match DAst.get c with | GVar id' -> Id.equal id id' | _ -> false -let rec cases_pattern_of_glob_constr na c = +let rec cases_pattern_of_glob_constr env na c = (* Forcing evaluation to ensure that the possible raising of Not_found is not delayed *) let c = DAst.force c in @@ -509,14 +499,14 @@ let rec cases_pattern_of_glob_constr na c = | GApp (c, l) -> begin match DAst.get c with | GRef (ConstructRef cstr,_) -> - let nparams = Inductiveops.inductive_nparams (fst cstr) in + let nparams = Inductiveops.inductive_nparams env (fst cstr) in let _,l = List.chop nparams l in - PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + PatCstr (cstr,List.map (cases_pattern_of_glob_constr env Anonymous) l,na) | _ -> raise Not_found end | GLetIn (Name id as na',b,None,e) when is_gvar id e && na = Anonymous -> (* A canonical encoding of aliases *) - DAst.get (cases_pattern_of_glob_constr na' b) + DAst.get (cases_pattern_of_glob_constr env na' b) | _ -> raise Not_found ) c @@ -539,8 +529,8 @@ let drop_local_defs params decls args = | _ -> assert false in aux decls args -let add_patterns_for_params_remove_local_defs (ind,j) l = - let (mib,mip) = Global.lookup_inductive ind in +let add_patterns_for_params_remove_local_defs env (ind,j) l = + let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.Declarations.mind_nparams in let l = if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then @@ -556,12 +546,12 @@ let add_alias ?loc na c = | Name id -> GLetIn (na,DAst.make ?loc c,None,DAst.make ?loc (GVar id)) (* Turn a closed cases pattern into a glob_constr *) -let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?loc -> function +let rec glob_constr_of_cases_pattern_aux env isclosed x = DAst.map_with_loc (fun ?loc -> function | PatCstr (cstr,[],na) -> add_alias ?loc na (GRef (ConstructRef cstr,None)) | PatCstr (cstr,l,na) -> let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in - let l = add_patterns_for_params_remove_local_defs cstr l in - add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux isclosed) l)) + let l = add_patterns_for_params_remove_local_defs env cstr l in + add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux env isclosed) l)) | PatVar (Name id) when not isclosed -> GVar id | PatVar Anonymous when not isclosed -> @@ -571,14 +561,14 @@ let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?lo | _ -> raise Not_found ) x -let glob_constr_of_closed_cases_pattern p = match DAst.get p with +let glob_constr_of_closed_cases_pattern env p = match DAst.get p with | PatCstr (cstr,l,na) -> let loc = p.CAst.loc in - na,glob_constr_of_cases_pattern_aux true (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) + na,glob_constr_of_cases_pattern_aux env true (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found -let glob_constr_of_cases_pattern p = glob_constr_of_cases_pattern_aux false p +let glob_constr_of_cases_pattern env p = glob_constr_of_cases_pattern_aux env false p (* This has to be in some file... *) diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 2f0ac76235..df902a8fa7 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -94,14 +94,15 @@ val map_pattern : (glob_constr -> glob_constr) -> Evaluation is forced. Take the current alias as parameter, @raise Not_found if translation is impossible *) -val cases_pattern_of_glob_constr : Name.t -> 'a glob_constr_g -> 'a cases_pattern_g +val cases_pattern_of_glob_constr : Environ.env -> Name.t -> 'a glob_constr_g -> 'a cases_pattern_g -val glob_constr_of_closed_cases_pattern : 'a cases_pattern_g -> Name.t * 'a glob_constr_g +val glob_constr_of_closed_cases_pattern : Environ.env -> 'a cases_pattern_g -> Name.t * 'a glob_constr_g (** A canonical encoding of cases pattern into constr such that composed with [cases_pattern_of_glob_constr Anonymous] gives identity *) -val glob_constr_of_cases_pattern : 'a cases_pattern_g -> 'a glob_constr_g +val glob_constr_of_cases_pattern : Environ.env -> 'a cases_pattern_g -> 'a glob_constr_g -val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list +val add_patterns_for_params_remove_local_defs : Environ.env -> constructor -> + 'a cases_pattern_g list -> 'a cases_pattern_g list val empty_lvar : Ltac_pretype.ltac_var_map diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index c57cf88cc6..02cb294f6d 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -41,6 +41,12 @@ type glob_constraint = glob_level * Univ.constraint_type * glob_level type sort_info = (Libnames.qualid * int) option list type glob_sort = sort_info glob_sort_gen +type glob_recarg = int option + +and glob_fix_kind = + | GFix of (glob_recarg array * int) + | GCoFix of int + (** Casts *) type 'a cast_type = @@ -78,7 +84,7 @@ type 'a glob_constr_r = (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) | GLetTuple of Name.t list * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GIf of 'a glob_constr_g * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g - | GRec of 'a fix_kind_g * Id.t array * 'a glob_decl_g list array * + | GRec of glob_fix_kind * Id.t array * 'a glob_decl_g list array * 'a glob_constr_g array * 'a glob_constr_g array | GSort of glob_sort | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option @@ -88,15 +94,6 @@ and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g -and 'a fix_recursion_order_g = - | GStructRec - | GWfRec of 'a glob_constr_g - | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option - -and 'a fix_kind_g = - | GFix of ((int option * 'a fix_recursion_order_g) array * int) - | GCoFix of int - and 'a predicate_pattern_g = Name.t * (inductive * Name.t list) CAst.t option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) @@ -117,9 +114,7 @@ type tomatch_tuples = [ `any ] tomatch_tuples_g type cases_clause = [ `any ] cases_clause_g type cases_clauses = [ `any ] cases_clauses_g type glob_decl = [ `any ] glob_decl_g -type fix_kind = [ `any ] fix_kind_g type predicate_pattern = [ `any ] predicate_pattern_g -type fix_recursion_order = [ `any ] fix_recursion_order_g type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr diff --git a/pretyping/heads.ml b/pretyping/heads.ml index cdeec875a2..ef27ca9b4e 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -12,10 +12,7 @@ open Util open Names open Constr open Vars -open Mod_subst open Environ -open Libobject -open Lib open Context.Named.Declaration (** Characterization of the head of a term *) @@ -35,40 +32,32 @@ type head_approximation = | FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) | NotImmediatelyComputableHead -(** Registration as global tables and rollback. *) - -module Evalreford = struct - type t = evaluable_global_reference - let compare gr1 gr2 = match gr1, gr2 with - | EvalVarRef id1, EvalVarRef id2 -> Id.compare id1 id2 - | EvalVarRef _, EvalConstRef _ -> -1 - | EvalConstRef c1, EvalConstRef c2 -> - Constant.CanOrd.compare c1 c2 - | EvalConstRef _, EvalVarRef _ -> 1 -end - -module Evalrefmap = - Map.Make (Evalreford) - - -let head_map = Summary.ref Evalrefmap.empty ~name:"Head_decl" - -let variable_head id = Evalrefmap.find (EvalVarRef id) !head_map -let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map +(* FIXME: maybe change interface here *) +let rec compute_head env = function + | EvalConstRef cst -> + let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in + (match body with + | None -> RigidHead (RigidParameter cst) + | Some c -> kind_of_head env c) + | EvalVarRef id -> + (match lookup_named id env with + | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> + kind_of_head env c + | _ -> RigidHead RigidOther) -let kind_of_head env t = +and kind_of_head env t = let rec aux k l t b = match kind (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> - (try on_subterm k l b (variable_head id) + (try on_subterm k l b (compute_head env (EvalVarRef id)) with Not_found -> (* a goal variable *) match lookup_named id env with | LocalDef (_,c,_) -> aux k l c b | LocalAssum _ -> NotImmediatelyComputableHead) | Const (cst,_) -> - (try on_subterm k l b (constant_head cst) + (try on_subterm k l b (compute_head env (EvalConstRef cst)) with Not_found -> CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ @@ -119,69 +108,7 @@ let kind_of_head env t = | x -> x in aux 0 [] t false -(* FIXME: maybe change interface here *) -let compute_head = function -| EvalConstRef cst -> - let env = Global.env() in - let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in - (match body with - | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head env c) -| EvalVarRef id -> - (match Global.lookup_named id with - | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> - kind_of_head (Global.env()) c - | _ -> RigidHead RigidOther) - let is_rigid env t = match kind_of_head env t with | RigidHead _ | ConstructorHead -> true | _ -> false - -(** Registration of heads as an object *) - -let load_head _ (_,(ref,(k:head_approximation))) = - head_map := Evalrefmap.add ref k !head_map - -let cache_head o = - load_head 1 o - -let subst_head_approximation subst = function - | RigidHead (RigidParameter cst) as k -> - let cst',c = subst_con subst cst in - if cst == cst' then k - else - (match c with - | None -> - (* A change of the prefix of the constant *) - RigidHead (RigidParameter cst') - | Some c -> - (* A substitution of the constant by a functor argument *) - kind_of_head (Global.env()) c.Univ.univ_abstracted_value) - | x -> x - -let subst_head (subst,(ref,k)) = - (subst_evaluable_reference subst ref, subst_head_approximation subst k) - -let discharge_head (_,(ref,k)) = - match ref with - | EvalConstRef cst -> Some (ref, k) - | EvalVarRef id -> None - -let rebuild_head (ref,k) = - (ref, compute_head ref) - -type head_obj = evaluable_global_reference * head_approximation - -let inHead : head_obj -> obj = - declare_object {(default_object "HEAD") with - cache_function = cache_head; - load_function = load_head; - subst_function = subst_head; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_head; - rebuild_function = rebuild_head } - -let declare_head c = - let hd = compute_head c in - add_anonymous_leaf (inHead (c,hd)) diff --git a/pretyping/heads.mli b/pretyping/heads.mli index 421242996c..e5f9967590 100644 --- a/pretyping/heads.mli +++ b/pretyping/heads.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open Constr open Environ @@ -17,11 +16,6 @@ open Environ provides the function to compute the head symbols and a table to store the heads *) -(** [declared_head] computes and registers the head symbol of a - possibly evaluable constant or variable *) - -val declare_head : evaluable_global_reference -> unit - (** [is_rigid] tells if some term is known to ultimately reduce to a term with a rigid head symbol *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 4f940fa16a..7615a17514 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -610,16 +610,20 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s) (* Look up function for the default elimination constant *) -let lookup_eliminator ind_sp s = +let lookup_eliminator env ind_sp s = let kn,i = ind_sp in - let mp,l = KerName.repr (MutInd.canonical kn) in - let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in + let mpu = KerName.modpath @@ MutInd.user kn in + let mpc = KerName.modpath @@ MutInd.canonical kn in + let ind_id = (lookup_mind kn env).mind_packets.(i).mind_typename in let id = add_suffix ind_id (elimination_suffix s) in + let l = Label.of_id id in + let knu = KerName.make mpu l in + let knc = KerName.make mpc l in (* Try first to get an eliminator defined in the same section as the *) (* inductive type *) try - let cst =Global.constant_of_delta_kn (KerName.make mp (Label.of_id id)) in - let _ = Global.lookup_constant cst in + let cst = Constant.make knu knc in + let _ = lookup_constant cst env in ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 91a5651f7f..8eb571a8be 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -62,7 +62,7 @@ val weaken_sort_scheme : env -> evar_map -> bool -> Sorts.t -> int -> constr -> (** Recursor names utilities *) -val lookup_eliminator : inductive -> Sorts.family -> GlobRef.t +val lookup_eliminator : env -> inductive -> Sorts.family -> GlobRef.t val elimination_suffix : Sorts.family -> string val make_elimination_ident : Id.t -> Sorts.family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 678aebfbe6..b1c98da2c7 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -112,162 +112,145 @@ let mis_nf_constructor_type ((ind,u),mib,mip) j = (* Number of constructors *) -let nconstructors ind = - let (_,mip) = Global.lookup_inductive ind in - Array.length mip.mind_consnames - -let nconstructors_env env ind = +let nconstructors env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in Array.length mip.mind_consnames -(* Arity of constructors excluding parameters, excluding local defs *) +let nconstructors_env env ind = nconstructors env ind +[@@ocaml.deprecated "Alias for Inductiveops.nconstructors"] -let constructors_nrealargs ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealargs +(* Arity of constructors excluding parameters, excluding local defs *) -let constructors_nrealargs_env env ind = +let constructors_nrealargs env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealargs -(* Arity of constructors excluding parameters, including local defs *) +let constructors_nrealargs_env env ind = constructors_nrealargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealargs"] -let constructors_nrealdecls ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealdecls +(* Arity of constructors excluding parameters, including local defs *) -let constructors_nrealdecls_env env ind = +let constructors_nrealdecls env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls +let constructors_nrealdecls_env env ind = constructors_nrealdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealdecls"] + (* Arity of constructors including parameters, excluding local defs *) -let constructor_nallargs (indsp,j) = - let (mib,mip) = Global.lookup_inductive indsp in +let constructor_nallargs env (ind,j) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealargs.(j-1) + mib.mind_nparams -let constructor_nallargs_env env ((kn,i),j) = - let mib = Environ.lookup_mind kn env in - let mip = mib.mind_packets.(i) in - mip.mind_consnrealargs.(j-1) + mib.mind_nparams +let constructor_nallargs_env env (indsp,j) = constructor_nallargs env (indsp,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nallargs"] (* Arity of constructors including params, including local defs *) -let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *) - let (mib,mip) = Global.lookup_inductive indsp in +let constructor_nalldecls env (ind,j) = (* TOCHANGE en decls *) + let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) -let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *) - let mib = Environ.lookup_mind kn env in - let mip = mib.mind_packets.(i) in - mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) +let constructor_nalldecls_env env (indsp,j) = constructor_nalldecls env (indsp,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nalldecls"] (* Arity of constructors excluding params, excluding local defs *) -let constructor_nrealargs (ind,j) = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealargs.(j-1) - -let constructor_nrealargs_env env (ind,j) = +let constructor_nrealargs env (ind,j) = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealargs.(j-1) -(* Arity of constructors excluding params, including local defs *) +let constructor_nrealargs_env env (ind,j) = constructor_nrealargs env (ind,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealargs"] -let constructor_nrealdecls (ind,j) = (* TOCHANGE en decls *) - let (_,mip) = Global.lookup_inductive ind in - mip.mind_consnrealdecls.(j-1) +(* Arity of constructors excluding params, including local defs *) -let constructor_nrealdecls_env env (ind,j) = (* TOCHANGE en decls *) +let constructor_nrealdecls env (ind,j) = (* TOCHANGE en decls *) let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_consnrealdecls.(j-1) -(* Length of arity, excluding params, excluding local defs *) +let constructor_nrealdecls_env env (ind,j) = constructor_nrealdecls env (ind,j) +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] -let inductive_nrealargs ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_nrealargs +(* Length of arity, excluding params, excluding local defs *) -let inductive_nrealargs_env env ind = +let inductive_nrealargs env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_nrealargs -(* Length of arity, excluding params, including local defs *) +let inductive_nrealargs_env env ind = inductive_nrealargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealargs"] -let inductive_nrealdecls ind = - let (_,mip) = Global.lookup_inductive ind in - mip.mind_nrealdecls +(* Length of arity, excluding params, including local defs *) -let inductive_nrealdecls_env env ind = +let inductive_nrealdecls env ind = let (_,mip) = Inductive.lookup_mind_specif env ind in mip.mind_nrealdecls -(* Full length of arity (w/o local defs) *) +let inductive_nrealdecls_env env ind = inductive_nrealdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealdecls"] -let inductive_nallargs ind = - let (mib,mip) = Global.lookup_inductive ind in - mib.mind_nparams + mip.mind_nrealargs +(* Full length of arity (w/o local defs) *) -let inductive_nallargs_env env ind = +let inductive_nallargs env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in mib.mind_nparams + mip.mind_nrealargs -(* Length of arity (w/o local defs) *) +let inductive_nallargs_env env ind = inductive_nallargs env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nallargs"] -let inductive_nparams ind = - let (mib,mip) = Global.lookup_inductive ind in - mib.mind_nparams +(* Length of arity (w/o local defs) *) -let inductive_nparams_env env ind = +let inductive_nparams env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in mib.mind_nparams -(* Length of arity (with local defs) *) +let inductive_nparams_env env ind = inductive_nparams env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparams"] -let inductive_nparamdecls ind = - let (mib,mip) = Global.lookup_inductive ind in - Context.Rel.length mib.mind_params_ctxt +(* Length of arity (with local defs) *) -let inductive_nparamdecls_env env ind = +let inductive_nparamdecls env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in Context.Rel.length mib.mind_params_ctxt -(* Full length of arity (with local defs) *) +let inductive_nparamdecls_env env ind = inductive_nparamdecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparamsdecls"] -let inductive_nalldecls ind = - let (mib,mip) = Global.lookup_inductive ind in - Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls +(* Full length of arity (with local defs) *) -let inductive_nalldecls_env env ind = +let inductive_nalldecls env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls -(* Others *) +let inductive_nalldecls_env env ind = inductive_nalldecls env ind +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nalldecls"] -let inductive_paramdecls (ind,u) = - let (mib,mip) = Global.lookup_inductive ind in - Inductive.inductive_paramdecls (mib,u) +(* Others *) -let inductive_paramdecls_env env (ind,u) = +let inductive_paramdecls env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in Inductive.inductive_paramdecls (mib,u) -let inductive_alldecls (ind,u) = - let (mib,mip) = Global.lookup_inductive ind in - Vars.subst_instance_context u mip.mind_arity_ctxt +let inductive_paramdecls_env env (ind,u) = inductive_paramdecls env (ind,u) +[@@ocaml.deprecated "Alias for Inductiveops.inductive_paramsdecls"] -let inductive_alldecls_env env (ind,u) = +let inductive_alldecls env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in Vars.subst_instance_context u mip.mind_arity_ctxt -let constructor_has_local_defs (indsp,j) = - let (mib,mip) = Global.lookup_inductive indsp in +let inductive_alldecls_env env (ind,u) = inductive_alldecls env (ind,u) +[@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] + +let constructor_has_local_defs env (indsp,j) = + let (mib,mip) = Inductive.lookup_mind_specif env indsp in let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in not (Int.equal l1 l2) -let inductive_has_local_defs ind = - let (mib,mip) = Global.lookup_inductive ind in +let inductive_has_local_defs env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in let l2 = mib.mind_nparams + mip.mind_nrealargs in not (Int.equal l1 l2) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index c74bbfe98b..cfc650938e 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -61,70 +61,85 @@ val mis_nf_constructor_type : (** {6 Extract information from an inductive name} *) (** @return number of constructors *) -val nconstructors : inductive -> int +val nconstructors : env -> inductive -> int val nconstructors_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.nconstructors"] (** @return arity of constructors excluding parameters, excluding local defs *) -val constructors_nrealargs : inductive -> int array +val constructors_nrealargs : env -> inductive -> int array val constructors_nrealargs_env : env -> inductive -> int array +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealargs"] (** @return arity of constructors excluding parameters, including local defs *) -val constructors_nrealdecls : inductive -> int array +val constructors_nrealdecls : env -> inductive -> int array val constructors_nrealdecls_env : env -> inductive -> int array +[@@ocaml.deprecated "Alias for Inductiveops.constructors_nrealdecls"] (** @return the arity, excluding params, excluding local defs *) -val inductive_nrealargs : inductive -> int +val inductive_nrealargs : env -> inductive -> int val inductive_nrealargs_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealargs"] (** @return the arity, excluding params, including local defs *) -val inductive_nrealdecls : inductive -> int +val inductive_nrealdecls : env -> inductive -> int val inductive_nrealdecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nrealdecls"] (** @return the arity, including params, excluding local defs *) -val inductive_nallargs : inductive -> int +val inductive_nallargs : env -> inductive -> int val inductive_nallargs_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nallargs"] (** @return the arity, including params, including local defs *) -val inductive_nalldecls : inductive -> int +val inductive_nalldecls : env -> inductive -> int val inductive_nalldecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nalldecls"] (** @return nb of params without local defs *) -val inductive_nparams : inductive -> int +val inductive_nparams : env -> inductive -> int val inductive_nparams_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparams"] (** @return nb of params with local defs *) -val inductive_nparamdecls : inductive -> int +val inductive_nparamdecls : env -> inductive -> int val inductive_nparamdecls_env : env -> inductive -> int +[@@ocaml.deprecated "Alias for Inductiveops.inductive_nparamsdecls"] (** @return params context *) -val inductive_paramdecls : pinductive -> Constr.rel_context +val inductive_paramdecls : env -> pinductive -> Constr.rel_context val inductive_paramdecls_env : env -> pinductive -> Constr.rel_context +[@@ocaml.deprecated "Alias for Inductiveops.inductive_paramsdecl"] (** @return full arity context, hence with letin *) -val inductive_alldecls : pinductive -> Constr.rel_context +val inductive_alldecls : env -> pinductive -> Constr.rel_context val inductive_alldecls_env : env -> pinductive -> Constr.rel_context +[@@ocaml.deprecated "Alias for Inductiveops.inductive_alldecls"] (** {7 Extract information from a constructor name} *) (** @return param + args without letin *) -val constructor_nallargs : constructor -> int +val constructor_nallargs : env -> constructor -> int val constructor_nallargs_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nallargs"] (** @return param + args with letin *) -val constructor_nalldecls : constructor -> int +val constructor_nalldecls : env -> constructor -> int val constructor_nalldecls_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nalldecls"] (** @return args without letin *) -val constructor_nrealargs : constructor -> int +val constructor_nrealargs : env -> constructor -> int val constructor_nrealargs_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealargs"] (** @return args with letin *) -val constructor_nrealdecls : constructor -> int +val constructor_nrealdecls : env -> constructor -> int val constructor_nrealdecls_env : env -> constructor -> int +[@@ocaml.deprecated "Alias for Inductiveops.constructor_nrealdecls"] (** Is there local defs in params or args ? *) -val constructor_has_local_defs : constructor -> bool -val inductive_has_local_defs : inductive -> bool +val constructor_has_local_defs : env -> constructor -> bool +val inductive_has_local_defs : env -> inductive -> bool val allowed_sorts : env -> inductive -> Sorts.family list diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0b2d760ca8..e694502231 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -222,7 +222,12 @@ and nf_type_sort env sigma v = match kind_of_value v with | Vaccu accu -> let t,s = nf_accu_type env sigma accu in - let s = try destSort s with DestKO -> assert false in + let s = + try + destSort (whd_all env s) + with DestKO -> + CErrors.anomaly (Pp.str "Value should be a sort") + in t, s | _ -> assert false @@ -487,25 +492,23 @@ let native_norm env sigma c ty = Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) - let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in - let profile = get_profiling_enabled () in - match Nativelib.compile ml_filename code ~profile:profile with - | true, fn -> - if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); - let profiler_pid = if profile then start_profiler () else None in - let t0 = Sys.time () in - Nativelib.call_linker ~fatal:true prefix fn (Some upd); - let t1 = Sys.time () in - if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - let res = nf_val env sigma !Nativelib.rt1 ty in - let t2 = Sys.time () in - let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - EConstr.of_constr res - | _ -> anomaly (Pp.str "Compilation failure.") + let ml_filename, prefix = Nativelib.get_ml_filename () in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in + let profile = get_profiling_enabled () in + let fn = Nativelib.compile ml_filename code ~profile:profile in + if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let profiler_pid = if profile then start_profiler () else None in + let t0 = Sys.time () in + Nativelib.call_linker ~fatal:true prefix fn (Some upd); + let t1 = Sys.time () in + if profile then stop_profiler profiler_pid; + let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + let res = nf_val env sigma !Nativelib.rt1 ty in + let t2 = Sys.time () in + let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + EConstr.of_constr res let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 4e3c77cb1a..c788efda48 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -280,66 +280,64 @@ let rec liftn_pattern k n = function let lift_pattern k = liftn_pattern k 1 -let rec subst_pattern subst pat = +let rec subst_pattern env sigma subst pat = match pat with | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else (match t with | None -> PRef ref' | Some t -> - let env = Global.env () in - let evd = Evd.from_env env in - pattern_of_constr env evd t.Univ.univ_abstracted_value) + pattern_of_constr env sigma t.Univ.univ_abstracted_value) | PVar _ | PEvar _ | PRel _ | PInt _ -> pat | PProj (p,c) -> let p' = Projection.map (subst_mind subst) p in - let c' = subst_pattern subst c in + let c' = subst_pattern env sigma subst c in if p' == p && c' == c then pat else PProj(p',c') | PApp (f,args) -> - let f' = subst_pattern subst f in - let args' = Array.Smart.map (subst_pattern subst) args in + let f' = subst_pattern env sigma subst f in + let args' = Array.Smart.map (subst_pattern env sigma subst) args in if f' == f && args' == args then pat else PApp (f',args') | PSoApp (i,args) -> - let args' = List.Smart.map (subst_pattern subst) args in + let args' = List.Smart.map (subst_pattern env sigma subst) args in if args' == args then pat else PSoApp (i,args') | PLambda (name,c1,c2) -> - let c1' = subst_pattern subst c1 in - let c2' = subst_pattern subst c2 in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in if c1' == c1 && c2' == c2 then pat else PLambda (name,c1',c2') | PProd (name,c1,c2) -> - let c1' = subst_pattern subst c1 in - let c2' = subst_pattern subst c2 in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in if c1' == c1 && c2' == c2 then pat else PProd (name,c1',c2') | PLetIn (name,c1,t,c2) -> - let c1' = subst_pattern subst c1 in - let t' = Option.Smart.map (subst_pattern subst) t in - let c2' = subst_pattern subst c2 in + let c1' = subst_pattern env sigma subst c1 in + let t' = Option.Smart.map (subst_pattern env sigma subst) t in + let c2' = subst_pattern env sigma subst c2 in if c1' == c1 && t' == t && c2' == c2 then pat else PLetIn (name,c1',t',c2') | PSort _ | PMeta _ -> pat | PIf (c,c1,c2) -> - let c' = subst_pattern subst c in - let c1' = subst_pattern subst c1 in - let c2' = subst_pattern subst c2 in + let c' = subst_pattern env sigma subst c in + let c1' = subst_pattern env sigma subst c1 in + let c2' = subst_pattern env sigma subst c2 in if c' == c && c1' == c1 && c2' == c2 then pat else PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in let ind' = Option.Smart.map (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in - let typ' = subst_pattern subst typ in - let c' = subst_pattern subst c in + let typ' = subst_pattern env sigma subst typ in + let c' = subst_pattern env sigma subst c in let subst_branch ((i,n,c) as br) = - let c' = subst_pattern subst c in + let c' = subst_pattern env sigma subst c in if c' == c then br else (i,n,c') in let branches' = List.Smart.map subst_branch branches in @@ -347,13 +345,13 @@ let rec subst_pattern subst pat = then pat else PCase(cip', typ', c', branches') | PFix (lni,(lna,tl,bl)) -> - let tl' = Array.Smart.map (subst_pattern subst) tl in - let bl' = Array.Smart.map (subst_pattern subst) bl in + let tl' = Array.Smart.map (subst_pattern env sigma subst) tl in + let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in if bl' == bl && tl' == tl then pat else PFix (lni,(lna,tl',bl')) | PCoFix (ln,(lna,tl,bl)) -> - let tl' = Array.Smart.map (subst_pattern subst) tl in - let bl' = Array.Smart.map (subst_pattern subst) bl in + let tl' = Array.Smart.map (subst_pattern env sigma subst) tl in + let bl' = Array.Smart.map (subst_pattern env sigma subst) bl in if bl' == bl && tl' == tl then pat else PCoFix (ln,(lna,tl',bl')) @@ -472,17 +470,19 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PCase (info, pred, pat_of_raw metas vars c, brs) | GRec (GFix (ln,n), ids, decls, tl, cl) -> - if Array.exists (function (Some n, GStructRec) -> false | _ -> true) ln then - err ?loc (Pp.str "\"struct\" annotation is expected.") - else - let ln = Array.map (fst %> Option.get) ln in - let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in - let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in - let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in - let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in - let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in - let names = Array.map (fun id -> Name id) ids in - PFix ((ln,n), (names, tl, cl)) + let get_struct_arg = function + | Some n -> n + | None -> err ?loc (Pp.str "\"struct\" annotation is expected.") + (* TODO why can't the annotation be omitted? *) + in + let ln = Array.map get_struct_arg ln in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in + let tl = Array.map (fun (ctx,tl) -> it_mkPProd_or_LetIn tl ctx) ctxtl in + let vars = Array.fold_left (fun vars na -> Name na::vars) vars ids in + let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls cl in + let cl = Array.map (fun (ctx,cl) -> it_mkPLambda_or_LetIn cl ctx) ctxtl in + let names = Array.map (fun id -> Name id) ids in + PFix ((ln,n), (names, tl, cl)) | GRec (GCoFix n, ids, decls, tl, cl) -> let ctxtl = Array.map2 (pat_of_glob_in_context metas vars) decls tl in diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 36317b3acf..3821fbf1a0 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -21,7 +21,7 @@ val constr_pattern_eq : constr_pattern -> constr_pattern -> bool val occur_meta_pattern : constr_pattern -> bool -val subst_pattern : substitution -> constr_pattern -> constr_pattern +val subst_pattern : Environ.env -> Evd.evar_map -> substitution -> constr_pattern -> constr_pattern val noccurn_pattern : int -> constr_pattern -> bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a6e3cfe085..48d981082c 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -607,10 +607,10 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env fixpoints ?) *) let possible_indexes = Array.to_list (Array.mapi - (fun i (n,_) -> match n with + (fun i annot -> match annot with | Some n -> [n] | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) + vn) in let fixdecls = (names,ftys,fdefs) in let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in @@ -644,7 +644,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env | None -> [] | Some ty -> let ((ind, i), u) = destConstruct sigma fj.uj_val in - let npars = inductive_nparams ind in + let npars = inductive_nparams !!env ind in if Int.equal npars 0 then [] else try @@ -1146,7 +1146,7 @@ let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) -let path_convertible p q = +let path_convertible env sigma p q = let open Classops in let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in @@ -1171,13 +1171,12 @@ let path_convertible p q = | [] -> anomaly (str "A coercion path shouldn't be empty.") in try - let e = Global.env () in - let sigma,tp = understand_tcc e (Evd.from_env e) (path_to_gterm p) in - let sigma,tq = understand_tcc e sigma (path_to_gterm q) in + let sigma,tp = understand_tcc env sigma (path_to_gterm p) in + let sigma,tq = understand_tcc env sigma (path_to_gterm q) in if Evd.has_undefined sigma then false else - let _ = Evarconv.unify_delay e sigma tp tq in true + let _ = Evarconv.unify_delay env sigma tp tq in true with Evarconv.UnableToUnify _ | PretypeError _ -> false let _ = Classops.install_path_comparator path_convertible diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index ef56458f99..1feb8acd5f 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -21,7 +21,6 @@ open Pp open Names open Globnames open Constr -open Libobject open Mod_subst open Reductionops @@ -50,10 +49,10 @@ let projection_table = type struc_tuple = constructor * (Name.t * bool) list * Constant.t option list -let load_structure i (_, (id,kl,projs)) = +let register_structure env (id,kl,projs) = let open Declarations in let ind = fst id in - let mib, mip = Global.lookup_inductive ind in + let mib, mip = Inductive.lookup_mind_specif env ind in let n = mib.mind_nparams in let struc = { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in @@ -62,10 +61,7 @@ let load_structure i (_, (id,kl,projs)) = List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc)) projs !projection_table -let cache_structure o = - load_structure 1 o - -let subst_structure (subst, (id, kl, projs as obj)) = +let subst_structure subst (id, kl, projs as obj) = let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) @@ -77,19 +73,6 @@ let subst_structure (subst, (id, kl, projs as obj)) = if projs' == projs && id' == id then obj else (id',kl,projs') -let discharge_structure (_, x) = Some x - -let inStruc : struc_tuple -> obj = - declare_object {(default_object "STRUCTURE") with - cache_function = cache_structure; - load_function = load_structure; - subst_function = subst_structure; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_structure } - -let declare_structure o = - Lib.add_anonymous_leaf (inStruc o) - let lookup_structure indsp = Indmap.find indsp !structure_table let lookup_projections indsp = (lookup_structure indsp).s_PROJ @@ -107,26 +90,9 @@ let is_projection cst = Cmap.mem cst !projection_table let prim_table = Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" -let load_prim i (_,(p,c)) = +let register_primitive_projection p c = prim_table := Cmap_env.add c p !prim_table -let cache_prim p = load_prim 1 p - -let subst_prim (subst,(p,c)) = subst_proj_repr subst p, subst_constant subst c - -let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) - -let inPrim : (Projection.Repr.t * Constant.t) -> obj = - declare_object { - (default_object "PRIMPROJS") with - cache_function = cache_prim ; - load_function = load_prim; - subst_function = subst_prim; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_prim } - -let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) - let is_primitive_projection c = Cmap_env.mem c !prim_table let find_primitive_projection c = @@ -224,7 +190,7 @@ let warn_projection_no_head_constant = ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) -let compute_canonical_projections env warn (con,ind) = +let compute_canonical_projections env ~warn (con,ind) = let ctx = Environ.constant_context env con in let u = Univ.make_abstract_instance ctx in let v = (mkConstU (con,u)) in @@ -274,11 +240,8 @@ let warn_redundant_canonical_projection = ++ strbrk " by " ++ prj ++ strbrk " in " ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s) -let add_canonical_structure warn o = - (* XXX: Undesired global access to env *) - let env = Global.env () in - let sigma = Evd.from_env env in - compute_canonical_projections env warn o |> +let register_canonical_structure ~warn env sigma o = + compute_canonical_projections env ~warn o |> List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in match assoc_pat cs_pat l with @@ -294,31 +257,13 @@ let add_canonical_structure warn o = warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) ) -let open_canonical_structure i (_, o) = - if Int.equal i 1 then add_canonical_structure false o - -let cache_canonical_structure (_, o) = - add_canonical_structure true o - -let subst_canonical_structure (subst,(cst,ind as obj)) = +let subst_canonical_structure subst (cst,ind as obj) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) let cst' = subst_constant subst cst in let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') -let discharge_canonical_structure (_,x) = Some x - -let inCanonStruc : Constant.t * inductive -> obj = - declare_object {(default_object "CANONICAL-STRUCTURE") with - open_function = open_canonical_structure; - cache_function = cache_canonical_structure; - subst_function = subst_canonical_structure; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_canonical_structure } - -let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) - (*s High-level declaration of a canonical structure *) let error_not_structure ref description = @@ -327,20 +272,17 @@ let error_not_structure ref description = (Id.print (Nametab.basename_of_global ref) ++ str"." ++ spc() ++ description)) -let check_and_decompose_canonical_structure ref = +let check_and_decompose_canonical_structure env sigma ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in - let env = Global.env () in let u = Univ.make_abstract_instance (Environ.constant_context env sp) in let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref (str "Could not find its value in the global environment.") in - let env = Global.env () in - let evd = Evd.from_env env in - let body = snd (splay_lam (Global.env()) evd (EConstr.of_constr vc)) in + let body = snd (splay_lam env sigma (EConstr.of_constr vc)) in let body = EConstr.Unsafe.to_constr body in let f,args = match kind body with | App (f,args) -> f,args @@ -353,15 +295,12 @@ let check_and_decompose_canonical_structure ref = try lookup_structure indsp with Not_found -> error_not_structure ref - (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env evd (EConstr.mkInd indsp)) in + (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (sp,indsp) -let declare_canonical_structure ref = - add_canonical_structure (check_and_decompose_canonical_structure ref) - let lookup_canonical_conversion (proj,pat) = assoc_pat pat (GlobRef.Map.find proj !object_table) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 53a33f6bab..f0594d513a 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -26,7 +26,8 @@ type struc_typ = { type struc_tuple = constructor * (Name.t * bool) list * Constant.t option list -val declare_structure : struc_tuple -> unit +val register_structure : Environ.env -> struc_tuple -> unit +val subst_structure : Mod_subst.substitution -> struc_tuple -> struc_tuple (** [lookup_structure isp] returns the struc_typ associated to the inductive path [isp] if it corresponds to a structure, otherwise @@ -47,7 +48,7 @@ val find_projection : GlobRef.t -> struc_typ val is_projection : Constant.t -> bool (** Sets up the mapping from constants to primitive projections *) -val declare_primitive_projection : Projection.Repr.t -> Constant.t -> unit +val register_primitive_projection : Projection.Repr.t -> Constant.t -> unit val is_primitive_projection : Constant.t -> bool @@ -80,8 +81,12 @@ val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * co val pr_cs_pattern : cs_pattern -> Pp.t val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ -val declare_canonical_structure : GlobRef.t -> unit +val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> + Constant.t * inductive -> unit +val subst_canonical_structure : Mod_subst.substitution -> Constant.t * inductive -> Constant.t * inductive val is_open_canonical_projection : Environ.env -> Evd.evar_map -> Reductionops.state -> bool val canonical_projections : unit -> ((GlobRef.t * cs_pattern) * obj_typ) list + +val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> Constant.t * inductive diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 71fbfe8716..1871609e18 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -53,7 +53,7 @@ type effect_name = string let constant_effect_table = Summary.ref ~name:"reduction-side-effect" Cmap.empty (* Table bindings function key to effective functions *) -let effect_table = Summary.ref ~name:"reduction-function-effect" String.Map.empty +let effect_table = ref String.Map.empty (** a test to know whether a constant is actually the effect function *) let reduction_effect_hook env sigma con c = diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 20120f4182..38e254a5b4 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -121,7 +121,7 @@ let retype ?(polyprop=true) sigma = Inductiveops.find_rectype env sigma t with Not_found -> retype_error BadRecursiveType in - let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in + let n = inductive_nrealdecls env (fst (fst (dest_ind_family indf))) in let t = betazetaevar_applist sigma n p realargs in (match EConstr.kind sigma (whd_all env sigma (type_of env t)) with | Prod _ -> whd_beta sigma (applist (t, [c])) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 1496712bbc..ee27aea93f 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -17,11 +17,8 @@ open Vars open Evd open Util open Typeclasses_errors -open Libobject open Context.Rel.Declaration -module RelDecl = Context.Rel.Declaration -module NamedDecl = Context.Named.Declaration (*i*) (* Core typeclasses hints *) @@ -38,12 +35,6 @@ let get_typeclasses_unique_solutions = ~key:["Typeclasses";"Unique";"Solutions"] ~value:false -let (add_instance_hint, add_instance_hint_hook) = Hook.make () -let add_instance_hint id = Hook.get add_instance_hint id - -let (remove_instance_hint, remove_instance_hint_hook) = Hook.make () -let remove_instance_hint id = Hook.get remove_instance_hint id - let (set_typeclass_transparency, set_typeclass_transparency_hook) = Hook.make () let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency gr local c @@ -97,18 +88,6 @@ let instance_impl is = is.is_impl let hint_priority is = is.is_info.hint_priority -let new_instance cl info glob impl = - let global = - if glob then Some (Lib.sections_depth ()) - else None - in - if match global with Some n -> n>0 && isVarRef impl | _ -> false then - CErrors.user_err (Pp.str "Cannot set Global an instance referring to a section variable."); - { is_class = cl.cl_impl; - is_info = info ; - is_global = global ; - is_impl = impl } - (* * states management *) @@ -122,11 +101,10 @@ let typeclass_univ_instance (cl, u) = { cl with cl_context = on_snd subst_ctx cl.cl_context; cl_props = subst_ctx cl.cl_props} -let class_info c = +let class_info env sigma c = try GlobRef.Map.find c !classes with Not_found -> - let env = Global.env() in - not_a_class env (Evd.from_env env) (EConstr.of_constr (printable_constr_of_global c)) + not_a_class env sigma (EConstr.of_constr (printable_constr_of_global c)) let global_class_of_constr env sigma c = try let gr, u = Termops.global_of_constr sigma c in @@ -142,8 +120,8 @@ let dest_class_arity env sigma c = let rels, c = decompose_prod_assum sigma c in rels, dest_class_app env sigma c -let class_of_constr sigma c = - try Some (dest_class_arity (Global.env ()) sigma c) +let class_of_constr env sigma c = + try Some (dest_class_arity env sigma c) with e when CErrors.noncritical e -> None let is_class_constr sigma c = @@ -176,103 +154,9 @@ let rec is_maybe_class_type evd c = let () = Hook.set Evd.is_maybe_typeclass_hook (fun evd c -> is_maybe_class_type evd (EConstr.of_constr c)) -(* - * classes persistent object - *) - -let load_class (_, cl) = +let load_class cl = classes := GlobRef.Map.add cl.cl_impl cl !classes -let cache_class = load_class - -let subst_class (subst,cl) = - let do_subst_con c = Mod_subst.subst_constant subst c - and do_subst c = Mod_subst.subst_mps subst c - and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx = List.Smart.map (RelDecl.map_constr do_subst) in - let do_subst_context (grs,ctx) = - List.Smart.map (Option.Smart.map do_subst_gr) grs, - do_subst_ctx ctx in - let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> - (x, y, Option.Smart.map do_subst_con z)) projs in - { cl_univs = cl.cl_univs; - cl_impl = do_subst_gr cl.cl_impl; - cl_context = do_subst_context cl.cl_context; - cl_props = do_subst_ctx cl.cl_props; - cl_projs = do_subst_projs cl.cl_projs; - cl_strict = cl.cl_strict; - cl_unique = cl.cl_unique } - -let discharge_class (_,cl) = - let repl = Lib.replacement_context () in - let rel_of_variable_context ctx = List.fold_right - ( fun (decl,_) (ctx', subst) -> - let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in - (decl' :: ctx', NamedDecl.get_id decl :: subst) - ) ctx ([], []) in - let discharge_rel_context (subst, usubst) n rel = - let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in - let fold decl (ctx, k) = - let map c = subst_univs_level_constr usubst (substn_vars k subst c) in - RelDecl.map_constr map decl :: ctx, succ k - in - let ctx, _ = List.fold_right fold rel ([], n) in - ctx - in - let abs_context cl = - match cl.cl_impl with - | VarRef _ | ConstructRef _ -> assert false - | ConstRef cst -> Lib.section_segment_of_constant cst - | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in - let discharge_context ctx' subst (grs, ctx) = - let grs' = - let newgrs = List.map (fun decl -> - match decl |> RelDecl.get_type |> EConstr.of_constr |> class_of_constr Evd.empty with - | None -> None - | Some (_, ((tc,_), _)) -> Some tc.cl_impl) - ctx' - in - grs @ newgrs - in grs', discharge_rel_context subst 1 ctx @ ctx' in - try - let info = abs_context cl in - let ctx = info.Lib.abstr_ctx in - let ctx, subst = rel_of_variable_context ctx in - let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in - let context = discharge_context ctx (subst, usubst) cl.cl_context in - let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in - let discharge_proj x = x in - { cl_univs = cl_univs'; - cl_impl = cl.cl_impl; - cl_context = context; - cl_props = props; - cl_projs = List.Smart.map discharge_proj cl.cl_projs; - cl_strict = cl.cl_strict; - cl_unique = cl.cl_unique - } - with Not_found -> (* not defined in the current section *) - cl - -let rebuild_class cl = - try - let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in - set_typeclass_transparency cst false false; cl - with e when CErrors.noncritical e -> cl - -let class_input : typeclass -> obj = - declare_object - { (default_object "type classes state") with - cache_function = cache_class; - load_function = (fun _ -> load_class); - open_function = (fun _ -> load_class); - classify_function = (fun x -> Substitute x); - discharge_function = (fun a -> Some (discharge_class a)); - rebuild_function = rebuild_class; - subst_function = subst_class } - -let add_class cl = - Lib.add_anonymous_leaf (class_input cl) - (** Build the subinstances hints. *) let check_instance env sigma c = @@ -295,7 +179,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = let ty = EConstr.of_constr ty in let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let rec aux pri c ty path = - match class_of_constr sigma ty with + match class_of_constr env sigma ty with | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = @@ -336,136 +220,23 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = aux pri term ty [glob] (* - * instances persistent object + * interface functions *) -type instance_action = - | AddInstance - | RemoveInstance - -let load_instance inst = - let insts = +let load_instance inst = + let insts = try GlobRef.Map.find inst.is_class !instances with Not_found -> GlobRef.Map.empty in let insts = GlobRef.Map.add inst.is_impl inst insts in instances := GlobRef.Map.add inst.is_class insts !instances let remove_instance inst = - let insts = + let insts = try GlobRef.Map.find inst.is_class !instances with Not_found -> assert false in let insts = GlobRef.Map.remove inst.is_impl insts in instances := GlobRef.Map.add inst.is_class insts !instances -let cache_instance (_, (action, i)) = - match action with - | AddInstance -> load_instance i - | RemoveInstance -> remove_instance i - -let subst_instance (subst, (action, inst)) = action, - { inst with - is_class = fst (subst_global subst inst.is_class); - is_impl = fst (subst_global subst inst.is_impl) } - -let discharge_instance (_, (action, inst)) = - match inst.is_global with - | None -> None - | Some n -> - assert (not (isVarRef inst.is_impl)); - Some (action, - { inst with - is_global = Some (pred n); - is_class = inst.is_class; - is_impl = inst.is_impl }) - - -let is_local i = (i.is_global == None) - -let is_local_for_hint i = - match i.is_global with - | None -> true (* i.e. either no Global keyword not in section, or in section *) - | Some n -> n <> 0 (* i.e. in a section, declare the hint as local - since discharge is managed by rebuild_instance which calls again - add_instance_hint; don't ask hints to take discharge into account - itself *) - -let add_instance check inst = - let poly = Global.is_polymorphic inst.is_impl in - let local = is_local_for_hint inst in - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local - inst.is_info poly; - List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - local pri poly) - (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) - (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) - -let rebuild_instance (action, inst) = - let () = match action with - | AddInstance -> add_instance true inst - | _ -> () - in - (action, inst) - -let classify_instance (action, inst) = - if is_local inst then Dispose - else Substitute (action, inst) - -let instance_input : instance_action * instance -> obj = - declare_object - { (default_object "type classes instances state") with - cache_function = cache_instance; - load_function = (fun _ x -> cache_instance x); - open_function = (fun _ x -> cache_instance x); - classify_function = classify_instance; - discharge_function = discharge_instance; - rebuild_function = rebuild_instance; - subst_function = subst_instance } - -let add_instance i = - Lib.add_anonymous_leaf (instance_input (AddInstance, i)); - add_instance true i - -let remove_instance i = - Lib.add_anonymous_leaf (instance_input (RemoveInstance, i)); - remove_instance_hint i.is_impl - -let warning_not_a_class = - let name = "not-a-class" in - let category = "typeclasses" in - CWarnings.create ~name ~category (fun (n, ty) -> - let env = Global.env () in - let evd = Evd.from_env env in - Pp.(str "Ignored instance declaration for “" - ++ Nametab.pr_global_env Id.Set.empty n - ++ str "”: “" - ++ Termops.Internal.print_constr_env env evd (EConstr.of_constr ty) - ++ str "” is not a class") - ) - -let declare_instance ?(warn = false) info local glob = - let ty, _ = Typeops.type_of_global_in_context (Global.env ()) glob in - let info = Option.default {hint_priority = None; hint_pattern = None} info in - match class_of_constr Evd.empty (EConstr.of_constr ty) with - | Some (rels, ((tc,_), args) as _cl) -> - assert (not (isVarRef glob) || local); - add_instance (new_instance tc info (not local) glob) - | None -> if warn then warning_not_a_class (glob, ty) - -let add_class cl = - add_class cl; - List.iter (fun (n, inst, body) -> - match inst with - | Some (Backward, info) -> - (match body with - | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") - | Some b -> declare_instance ~warn:true (Some info) false (ConstRef b)) - | _ -> ()) - cl.cl_projs - - -(* - * interface functions - *) let instance_constructor (cl,u) args = let lenpars = List.count is_local_assum (snd cl.cl_context) in @@ -497,8 +268,8 @@ let all_instances () = GlobRef.Map.fold (fun k v acc -> v :: acc) v acc) !instances [] -let instances r = - let cl = class_info r in instances_of cl +let instances env sigma r = + let cl = class_info env sigma r in instances_of cl let is_class gr = GlobRef.Map.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index f8aedf88c2..e42b82c51f 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Constr open Evd open Environ @@ -54,19 +53,25 @@ type typeclass = { no backtracking and sharing of resolution. *) } -type instance +type instance = { + is_class: GlobRef.t; + is_info: hint_info; + (* Sections where the instance should be redeclared, + None for discard, Some 0 for none. *) + is_global: int option; + is_impl: GlobRef.t; +} -val instances : GlobRef.t -> instance list +val instances : env -> evar_map -> GlobRef.t -> instance list val typeclasses : unit -> typeclass list val all_instances : unit -> instance list -val add_class : typeclass -> unit +val load_class : typeclass -> unit -val new_instance : typeclass -> hint_info -> bool -> GlobRef.t -> instance -val add_instance : instance -> unit +val load_instance : instance -> unit val remove_instance : instance -> unit -val class_info : GlobRef.t -> typeclass (** raises a UserError if not a class *) +val class_info : env -> evar_map -> GlobRef.t -> typeclass (** raises a UserError if not a class *) (** These raise a UserError if not a class. @@ -78,7 +83,8 @@ val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.E val typeclass_univ_instance : typeclass Univ.puniverses -> typeclass (** Just return None if not a class *) -val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option +val class_of_constr : env -> evar_map -> EConstr.constr -> + (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option val instance_impl : instance -> GlobRef.t @@ -122,23 +128,9 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u val classes_transparent_state_hook : (unit -> TransparentState.t) Hook.t val classes_transparent_state : unit -> TransparentState.t -val add_instance_hint_hook : - (global_reference_or_constr -> GlobRef.t list -> - bool (* local? *) -> hint_info -> Decl_kinds.polymorphic -> unit) Hook.t -val remove_instance_hint_hook : (GlobRef.t -> unit) Hook.t -val add_instance_hint : global_reference_or_constr -> GlobRef.t list -> - bool -> hint_info -> Decl_kinds.polymorphic -> unit -val remove_instance_hint : GlobRef.t -> unit - val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t -(** Declares the given global reference as an instance of its type. - Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — - when said type is not a registered type class. *) -val declare_instance : ?warn:bool -> hint_info option -> bool -> GlobRef.t -> unit - - (** Build the subinstances hints for a given typeclass object. check tells if we should check for existence of the subinstances and add only the missing ones. *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 89f72c874b..be71f44a5e 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -198,7 +198,7 @@ let check_type_fixpoint ?loc env sigma lna lar vdefj = (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = - let specif = Global.lookup_inductive (fst ind) in + let specif = lookup_mind_specif env (fst ind) in let sorts = elim_sorts specif in let pj = Retyping.get_judgment_of env sigma p in let _, s = splay_prod env sigma pj.uj_type in diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 0ae3de7321..78733784a7 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -399,12 +399,12 @@ let tag_var = tag Tag.variable pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c - let pr_guard_annot pr_aux bl (n,ro) = - match n with + let pr_guard_annot pr_aux bl ro = + match ro with | None -> mt () - | Some {loc; v = id} -> - match (ro : Constrexpr.recursion_order_expr) with - | CStructRec -> + | Some {loc; v = ro} -> + match ro with + | CStructRec { v = id } -> let names_of_binder = function | CLocalAssum (nal,_,_) -> nal | CLocalDef (_,_,_) -> [] @@ -413,10 +413,11 @@ let tag_var = tag Tag.variable if List.length ids > 1 then spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}" else mt() - | CWfRec c -> - spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_id id ++ str"}" - | CMeasureRec (m,r) -> - spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ spc() ++ pr_id id++ + | CWfRec (id,c) -> + spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_lident id ++ str"}" + | CMeasureRec (id,m,r) -> + spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ + match id with None -> mt() | Some id -> spc () ++ pr_lident id ++ (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}" let pr_fixdecl pr prd dangling_with_for ({v=id},ro,bl,t,c) = diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index db1687a49b..1332cd0168 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -35,10 +35,11 @@ val pr_patvar : Pattern.patvar -> Pp.t val pr_glob_level : Glob_term.glob_level -> Pp.t val pr_glob_sort : Glob_term.glob_sort -> Pp.t -val pr_guard_annot : (constr_expr -> Pp.t) -> - local_binder_expr list -> - lident option * recursion_order_expr -> - Pp.t +val pr_guard_annot + : (constr_expr -> Pp.t) + -> local_binder_expr list + -> recursion_order_expr option + -> Pp.t val pr_record_body : (qualid * constr_expr) list -> Pp.t val pr_binders : Environ.env -> Evd.evar_map -> local_binder_expr list -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 8bf86e9ef6..9541ea5882 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -952,5 +952,6 @@ let print_all_instances () = let print_instances r = let env = Global.env () in - let inst = instances r in + let sigma = Evd.from_env env in + let inst = instances env sigma r in prlist_with_sep fnl (pr_instance env) inst diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index d042a1d650..f378a5d2dd 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -438,18 +438,18 @@ let match_goals ot nt = | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (2)") in let recursion_order_expr ogname exp exp2 = - match exp, exp2 with - | CStructRec, CStructRec -> () - | CWfRec c, CWfRec c2 -> + match exp.CAst.v, exp2.CAst.v with + | CStructRec _, CStructRec _ -> () + | CWfRec (_,c), CWfRec (_,c2) -> constr_expr ogname c c2 - | CMeasureRec (m,r), CMeasureRec (m2,r2) -> + | CMeasureRec (_,m,r), CMeasureRec (_,m2,r2) -> constr_expr ogname m m2; constr_expr_opt ogname r r2 | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (3)") in let fix_expr ogname exp exp2 = - let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in - recursion_order_expr ogname ro ro2; + let (l,ro,lb,ce1,ce2), (l2,ro2,lb2,ce12,ce22) = exp,exp2 in + Option.iter2 (recursion_order_expr ogname) ro ro2; iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 diff --git a/proofs/dune b/proofs/dune index 679c45f6bf..36e9799998 100644 --- a/proofs/dune +++ b/proofs/dune @@ -3,4 +3,4 @@ (synopsis "Coq's Higher-level Refinement Proof Engine and Top-level Proof Structure") (public_name coq.proofs) (wrapped false) - (libraries interp)) + (libraries pretyping)) diff --git a/proofs/logic.ml b/proofs/logic.ml index 3581e90b79..a01ddf2388 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -63,7 +63,6 @@ let catchable_exception = function | CErrors.UserError _ | TypeError _ | Proof.OpenProof _ (* abstract will call close_proof inside a tactic *) - | Notation.PrimTokenNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 472db790f2..ef4a74b273 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -109,10 +109,6 @@ let solve ?with_end_tac gi info_lvl tac pr = let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) -let instantiate_nth_evar_com n com = - Proof_global.simple_with_current_proof (fun _ p -> - Proof.V82.instantiate_evar Global.(env ()) n com p) - (**********************************************************************) (* Shortcut to build a term using tactics *) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 2fe4bc6385..77d701b41f 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -54,13 +54,6 @@ val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool (** Option telling if unification heuristics should be used. *) val use_unification_heuristics : unit -> bool -(** [instantiate_nth_evar_com n c] instantiate the [n]th undefined - existential variable of the current focused proof by [c] or raises a - UserError if no proof is focused or if there is no such [n]th - existential variable *) - -val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> Proof_global.t -> Proof_global.t - (** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac]. The return boolean, if [false] indicates the use of an unsafe tactic. *) diff --git a/proofs/proof.ml b/proofs/proof.ml index e40940f652..978b1f6f78 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -480,7 +480,7 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } (* Main component of vernac command Existential *) - let instantiate_evar env n com pr = + let instantiate_evar env n intern pr = let tac = Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> let (evk, evi) = @@ -494,7 +494,7 @@ module V82 = struct CList.nth evl (n-1) in let env = Evd.evar_filtered_env evi in - let rawc = Constrintern.intern_constr env sigma com in + let rawc = intern env sigma in let ltac_vars = Glob_ops.empty_lvar in let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma diff --git a/proofs/proof.mli b/proofs/proof.mli index 40e8ff7eef..defef57a8d 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -249,8 +249,11 @@ module V82 : sig val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : - Environ.env -> int -> Constrexpr.constr_expr -> t -> t + val instantiate_evar + : Environ.env + -> int + -> (Environ.env -> Evd.evar_map -> Glob_term.glob_constr) + -> t -> t end (* returns the set of all goals in the proof *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 8196f5e198..7b3d9e534b 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -65,14 +65,8 @@ let pf_ids_set_of_hyps gls = let pf_get_new_id id gls = next_ident_away id (pf_ids_set_of_hyps gls) -let pf_global gls id = - let env = pf_env gls in - let sigma = project gls in - Evd.fresh_global env sigma (Constrintern.construct_reference (pf_hyps gls) id) - let pf_apply f gls = f (pf_env gls) (project gls) -let pf_eapply f gls x = - on_sig gls (fun evm -> f (pf_env gls) evm x) +let pf_eapply f gls x = on_sig gls (fun evm -> f (pf_env gls) evm x) let pf_reduce = pf_apply let pf_e_reduce = pf_apply @@ -126,11 +120,6 @@ module New = struct let of_old f gl = f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; } - let pf_global id gl = - (* We only check for the existence of an [id] in [hyps] *) - let hyps = Proofview.Goal.hyps gl in - Constrintern.construct_reference hyps id - let pf_env = Proofview.Goal.env let pf_concl = Proofview.Goal.concl diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 1454140dd7..218011c316 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -33,7 +33,6 @@ val pf_hyps_types : Goal.goal sigma -> (Id.t Context.binder_annot * type val pf_nth_hyp_id : Goal.goal sigma -> int -> Id.t val pf_last_hyp : Goal.goal sigma -> named_declaration val pf_ids_of_hyps : Goal.goal sigma -> Id.t list -val pf_global : Goal.goal sigma -> Id.t -> evar_map * constr val pf_unsafe_type_of : Goal.goal sigma -> constr -> types val pf_type_of : Goal.goal sigma -> constr -> evar_map * types val pf_hnf_type_of : Goal.goal sigma -> constr -> types @@ -76,7 +75,6 @@ val pr_glls : Goal.goal list sigma -> Pp.t module New : sig val pf_apply : (env -> evar_map -> 'a) -> Proofview.Goal.t -> 'a - val pf_global : Id.t -> Proofview.Goal.t -> GlobRef.t (** FIXME: encapsulate the level in an existential type. *) val of_old : (Goal.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index d1bd3692ab..2493b1fac4 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -139,7 +139,7 @@ module Make(T : Task) () = struct (* We need to pass some options with one argument *) | ( "-I" | "-include" | "-top" | "-topfile" | "-coqlib" | "-exclude-dir" | "-compat" | "-load-ml-object" | "-load-ml-source" | "-require" | "-w" | "-color" | "-init-file" - | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" + | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" | "-set" | "-unset" | "-diffs" | "-mangle-name" | "-dump-glob" | "-bytecode-compiler" | "-native-compiler" as x) :: a :: tl -> x :: a :: set_slave_opt tl (* We need to pass some options with two arguments *) diff --git a/stm/stm.ml b/stm/stm.ml index d54a5fdf43..e1ab45163a 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2970,7 +2970,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise else @@ -3054,7 +3054,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> State.exn_on ~valid:Stateid.dummy newtip |> Exninfo.iraise else let id = VCS.new_node ~id:newtip proof_mode () in diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 58fe923f9e..243b5c333d 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -57,6 +57,7 @@ let options_affecting_stm_scheduling = stm_allow_nested_proofs_option_name; Vernacentries.proof_mode_opt_name; Attributes.program_mode_option_name; + Proof_using.proof_using_opt_name; ] let classify_vernac e = @@ -64,7 +65,7 @@ let classify_vernac e = (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) - | ( VernacSetOption (_, l,_) | VernacUnsetOption (_, l)) + | VernacSetOption (_, l,_) when CList.exists (CList.equal String.equal l) options_affecting_stm_scheduling -> VtSideff [], VtNow @@ -91,9 +92,6 @@ let classify_vernac e = VtProofStep { parallel = `No; proof_block_detection = Some "curly" }, VtLater - (* Options changing parser *) - | VernacUnsetOption (_, ["Default";"Proof";"Using"]) - | VernacSetOption (_, ["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ((Decl_kinds.DoDischarge,_),({v=i},_),ProveBody _) -> VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater @@ -156,7 +154,7 @@ let classify_vernac e = | VernacReserve _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ - | VernacUnsetOption _ | VernacSetOption _ + | VernacSetOption _ | VernacAddOption _ | VernacRemoveOption _ | VernacMemOption _ | VernacPrintOption _ | VernacGlobalCheck _ diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a28f4597cf..c1ac7d201a 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -362,7 +362,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm try match hdc with | Some (hd,_) when only_classes -> - let cl = Typeclasses.class_info hd in + let cl = Typeclasses.class_info env sigma hd in if cl.cl_strict then Evarutil.undefined_evars_of_term sigma concl else Evar.Set.empty @@ -1052,7 +1052,7 @@ let error_unresolvable env comp evd = | Some s -> Evar.Set.mem ev s in let fold ev evi (found, accu) = - let ev_class = class_of_constr evd evi.evar_concl in + let ev_class = class_of_constr env evd evi.evar_concl in if not (Option.is_empty ev_class) && is_part ev then (* focus on one instance if only one was searched for *) if not found then (true, Some ev) diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 3ff2e3852d..d9d3764b2a 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -67,17 +67,17 @@ let contradiction_context = let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma typ in - if is_empty_type sigma typ then + if is_empty_type env sigma typ then simplest_elim (mkVar id) else match EConstr.kind sigma typ with - | Prod (na,t,u) when is_empty_type sigma u -> - let is_unit_or_eq = match_with_unit_or_eq_type sigma t in + | Prod (na,t,u) when is_empty_type env sigma u -> + let is_unit_or_eq = match_with_unit_or_eq_type env sigma t in Tacticals.New.tclORELSE (match is_unit_or_eq with | Some _ -> let hd,args = decompose_app sigma t in let (ind,_ as indu) = destInd sigma hd in - let nparams = Inductiveops.inductive_nparams_env env ind in + let nparams = Inductiveops.inductive_nparams env ind in let params = Util.List.firstn nparams args in let p = applist ((mkConstructUi (indu,1)), params) in (* Checking on the fly that it type-checks *) @@ -103,7 +103,7 @@ let contradiction_context = let is_negation_of env sigma typ t = match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,t,u) -> - is_empty_type sigma u && is_conv_leq env sigma typ t + is_empty_type env sigma u && is_conv_leq env sigma typ t | _ -> false let contradiction_term (c,lbind as cl) = @@ -113,7 +113,7 @@ let contradiction_term (c,lbind as cl) = let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in let _, ccl = splay_prod env sigma typ in - if is_empty_type sigma ccl then + if is_empty_type env sigma ccl then Tacticals.New.tclTHEN (elim false None cl None) (Tacticals.New.tclTRY assumption) diff --git a/tactics/elim.ml b/tactics/elim.ml index 003b069b6e..71ea0098a3 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -81,12 +81,13 @@ let up_to_delta = ref false (* true *) let general_decompose recognizer c = Proofview.Goal.enter begin fun gl -> let type_of = pf_unsafe_type_of gl in + let env = pf_env gl in let sigma = project gl in let typc = type_of c in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId - (ifOnHyp (recognizer sigma) (general_decompose_aux (recognizer sigma)) + (ifOnHyp (recognizer env sigma) (general_decompose_aux (recognizer env sigma)) (fun id -> clear [id]))); exact_no_check c ] end @@ -105,17 +106,17 @@ let head_in indl t gl = let decompose_these c l = Proofview.Goal.enter begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in - general_decompose (fun sigma (_,t) -> head_in indl t gl) c + general_decompose (fun env sigma (_,t) -> head_in indl t gl) c end let decompose_and c = general_decompose - (fun sigma (_,t) -> is_record sigma t) + (fun env sigma (_,t) -> is_record env sigma t) c let decompose_or c = general_decompose - (fun sigma (_,t) -> is_disjunction sigma t) + (fun env sigma (_,t) -> is_disjunction env sigma t) c let h_decompose l c = decompose_these c l diff --git a/tactics/equality.ml b/tactics/equality.ml index 412fbbfd1b..3d760f1c3d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -356,7 +356,7 @@ let find_elim hdcncl lft2rgt dep cls ot = match EConstr.kind sigma hdcncl with | Ind (ind_sp,u) -> let pr1 = - lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) + lookup_eliminator env ind_sp (elimination_sort_of_clause cls gl) in begin match lft2rgt, cls with | Some true, None @@ -446,7 +446,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in - match match_with_equality_type sigma t with + match match_with_equality_type env sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) @@ -462,7 +462,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) - match match_with_equality_type sigma t' with + match match_with_equality_type env sigma t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c @@ -743,7 +743,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let hd2,args2 = whd_all_stack env sigma t2 in match (EConstr.kind sigma hd1, EConstr.kind sigma hd2) with | Construct ((ind1,i1 as sp1),u1), Construct (sp2,_) - when Int.equal (List.length args1) (constructor_nallargs_env env sp1) + when Int.equal (List.length args1) (constructor_nallargs env sp1) -> let sorts' = Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) @@ -751,7 +751,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) if eq_constructor sp1 sp2 then - let nparams = inductive_nparams_env env ind1 in + let nparams = inductive_nparams env ind1 in let params1,rargs1 = List.chop nparams args1 in let _,rargs2 = List.chop nparams args2 in let (mib,mip) = lookup_mind_specif env ind1 in @@ -966,9 +966,10 @@ let rec build_discriminator env sigma true_0 false_0 dirn c = function let gen_absurdity id = Proofview.Goal.enter begin fun gl -> + let env = pf_env gl in let sigma = project gl in let hyp_typ = pf_get_hyp_typ id gl in - if is_empty_type sigma hyp_typ + if is_empty_type env sigma hyp_typ then simplest_elim (mkVar id) else @@ -1066,7 +1067,7 @@ let onNegatedEquality with_evars tac = let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match EConstr.kind sigma (hnf_constr env sigma ccl) with - | Prod (_,t,u) when is_empty_type sigma u -> + | Prod (_,t,u) when is_empty_type env sigma u -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) diff --git a/tactics/hints.ml b/tactics/hints.ml index f49b1660b8..11a8816159 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1064,7 +1064,9 @@ let subst_autohint (subst, obj) = in let subst_hint (k,data as hint) = let k' = Option.Smart.map subst_key k in - let pat' = Option.Smart.map (subst_pattern subst) data.pat in + let env = Global.env () in + let sigma = Evd.from_env env in + let pat' = Option.Smart.map (subst_pattern env sigma subst) data.pat in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in let code' = match data.code.obj with | Res_pf (c,t,ctx) -> @@ -1353,7 +1355,7 @@ let interp_hints poly = let ind = global_inductive_with_alias qid in let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; - List.init (nconstructors ind) + List.init (nconstructors env ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in empty_hint_info, @@ -1389,7 +1391,7 @@ let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> match EConstr.kind sigma lem with | Ind (ind,u) -> - List.init (nconstructors ind) + List.init (nconstructors env ind) (fun i -> let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) (Evd.universe_context_set sigma) in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 08131f6309..e1dad9ad20 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -34,44 +34,42 @@ module RelDecl = Context.Rel.Declaration -- Eduardo (6/8/97). *) -type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option +type 'a matching_function = Environ.env -> Evd.evar_map -> EConstr.constr -> 'a option -type testing_function = Evd.evar_map -> EConstr.constr -> bool +type testing_function = Environ.env -> Evd.evar_map -> EConstr.constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 let meta2 = mkmeta 2 -let op2bool = function Some _ -> true | None -> false - -let match_with_non_recursive_type sigma t = +let match_with_non_recursive_type env sigma t = match EConstr.kind sigma t with | App _ -> let (hdapp,args) = decompose_app sigma t in (match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if (Global.lookup_mind (fst ind)).mind_finite == CoFinite then + if (Environ.lookup_mind (fst ind) env).mind_finite == CoFinite then Some (hdapp,args) else None | _ -> None) | _ -> None -let is_non_recursive_type sigma t = op2bool (match_with_non_recursive_type sigma t) +let is_non_recursive_type env sigma t = Option.has_some (match_with_non_recursive_type env sigma t) (* Test dependencies *) (* NB: we consider also the let-in case in the following function, since they may appear in types of inductive constructors (see #2629) *) -let rec has_nodep_prod_after n sigma c = +let rec has_nodep_prod_after n env sigma c = match EConstr.kind sigma c with | Prod (_,_,b) | LetIn (_,_,_,b) -> ( n>0 || Vars.noccurn sigma 1 b) - && (has_nodep_prod_after (n-1) sigma b) + && (has_nodep_prod_after (n-1) env sigma b) | _ -> true -let has_nodep_prod sigma c = has_nodep_prod_after 0 sigma c +let has_nodep_prod env sigma c = has_nodep_prod_after 0 env sigma c (* A general conjunctive type is a non-recursive with-no-indices inductive type with only one constructor and no dependencies between argument; @@ -96,11 +94,11 @@ let rec whd_beta_prod sigma c = match EConstr.kind sigma c with | LetIn (n,d,t,c) -> mkLetIn (n,d,t,whd_beta_prod sigma c) | _ -> c -let match_with_one_constructor sigma style onlybinary allow_rec t = +let match_with_one_constructor env sigma style onlybinary allow_rec t = let (hdapp,args) = decompose_app sigma t in let res = match EConstr.kind sigma hdapp with | Ind ind -> - let (mib,mip) = Global.lookup_inductive (fst ind) in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) @@ -125,7 +123,7 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = let ctyp = whd_beta_prod sigma (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) cty args) in let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in - if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then + if not (is_lax_conjunction style) || has_nodep_prod env sigma ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) else @@ -138,20 +136,20 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = | Some (hdapp, [_; _]) -> res | _ -> None -let match_with_conjunction ?(strict=false) ?(onlybinary=false) sigma t = - match_with_one_constructor sigma (Some strict) onlybinary false t +let match_with_conjunction ?(strict=false) ?(onlybinary=false) env sigma t = + match_with_one_constructor env sigma (Some strict) onlybinary false t -let match_with_record sigma t = - match_with_one_constructor sigma None false false t +let match_with_record env sigma t = + match_with_one_constructor env sigma None false false t -let is_conjunction ?(strict=false) ?(onlybinary=false) sigma t = - op2bool (match_with_conjunction sigma ~strict ~onlybinary t) +let is_conjunction ?(strict=false) ?(onlybinary=false) env sigma t = + Option.has_some (match_with_conjunction env sigma ~strict ~onlybinary t) -let is_record sigma t = - op2bool (match_with_record sigma t) +let is_record env sigma t = + Option.has_some (match_with_record env sigma t) -let match_with_tuple sigma t = - let t = match_with_one_constructor sigma None false true t in +let match_with_tuple env sigma t = + let t = match_with_one_constructor env sigma None false true t in Option.map (fun (hd,l) -> let ind = destInd sigma hd in let ind = on_snd (fun u -> EInstance.kind sigma u) ind in @@ -159,8 +157,8 @@ let match_with_tuple sigma t = let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t -let is_tuple sigma t = - op2bool (match_with_tuple sigma t) +let is_tuple env sigma t = + Option.has_some (match_with_tuple env sigma t) (* A general disjunction type is a non-recursive with-no-indices inductive type with of which all constructors have a single argument; @@ -175,11 +173,11 @@ let test_strict_disjunction (mib, mip) = in Array.for_all_i check 0 mip.mind_nf_lc -let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = +let match_with_disjunction ?(strict=false) ?(onlybinary=false) env sigma t = let (hdapp,args) = decompose_app sigma t in let res = match EConstr.kind sigma hdapp with | Ind (ind,u) -> - let car = constructors_nrealargs ind in + let car = constructors_nrealargs env ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car && not (mis_is_recursive (ind,mib,mip)) @@ -205,31 +203,31 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = | Some (hdapp,[_; _]) -> res | _ -> None -let is_disjunction ?(strict=false) ?(onlybinary=false) sigma t = - op2bool (match_with_disjunction ~strict ~onlybinary sigma t) +let is_disjunction ?(strict=false) ?(onlybinary=false) env sigma t = + Option.has_some (match_with_disjunction ~strict ~onlybinary env sigma t) (* An empty type is an inductive type, possible with indices, that has no constructors *) -let match_with_empty_type sigma t = +let match_with_empty_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind, _) -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Inductive.lookup_mind_specif env ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None -let is_empty_type sigma t = op2bool (match_with_empty_type sigma t) +let is_empty_type env sigma t = Option.has_some (match_with_empty_type env sigma t) (* This filters inductive types with one constructor with no arguments; Parameters and indices are allowed *) -let match_with_unit_or_eq_type sigma t = +let match_with_unit_or_eq_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind , _) -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Inductive.lookup_mind_specif env ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 && Int.equal mip.mind_consnrealargs.(0) 0 then Some hdapp @@ -237,14 +235,14 @@ let match_with_unit_or_eq_type sigma t = None | _ -> None -let is_unit_or_eq_type sigma t = op2bool (match_with_unit_or_eq_type sigma t) +let is_unit_or_eq_type env sigma t = Option.has_some (match_with_unit_or_eq_type env sigma t) (* A unit type is an inductive type with no indices but possibly (useless) parameters, and that has no arguments in its unique constructor *) -let is_unit_type sigma t = - match match_with_conjunction sigma t with +let is_unit_type env sigma t = + match match_with_conjunction env sigma t with | Some (_,[]) -> true | _ -> false @@ -331,15 +329,16 @@ let match_with_equation env sigma t = let is_inductive_equality ind = let (mib,mip) = Global.lookup_inductive ind in let nconstr = Array.length mip.mind_consnames in - Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 + let env = Global.env () in + Int.equal nconstr 1 && Int.equal (constructor_nrealargs env (ind,1)) 0 -let match_with_equality_type sigma t = +let match_with_equality_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None -let is_equality_type sigma t = op2bool (match_with_equality_type sigma t) +let is_equality_type env sigma t = Option.has_some (match_with_equality_type env sigma t) (* Arrows/Implication/Negation *) @@ -353,39 +352,39 @@ let match_arrow_pattern env sigma t = assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) | _ -> anomaly (Pp.str "Incorrect pattern matching.") -let match_with_imp_term sigma c = +let match_with_imp_term env sigma c = match EConstr.kind sigma c with | Prod (_,a,b) when Vars.noccurn sigma 1 b -> Some (a,b) | _ -> None -let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) +let is_imp_term env sigma c = Option.has_some (match_with_imp_term env sigma c) let match_with_nottype env sigma t = try let (arg,mind) = match_arrow_pattern env sigma t in - if is_empty_type sigma mind then Some (mind,arg) else None + if is_empty_type env sigma mind then Some (mind,arg) else None with PatternMatchingFailure -> None -let is_nottype env sigma t = op2bool (match_with_nottype env sigma t) +let is_nottype env sigma t = Option.has_some (match_with_nottype env sigma t) (* Forall *) -let match_with_forall_term sigma c= +let match_with_forall_term env sigma c = match EConstr.kind sigma c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None -let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) +let is_forall_term env sigma c = Option.has_some (match_with_forall_term env sigma c) -let match_with_nodep_ind sigma t = +let match_with_nodep_ind env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind, _) -> - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Inductive.lookup_mind_specif env ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr (ctx, cty) = let c = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in - has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma c in + has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) env sigma c in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else @@ -395,9 +394,9 @@ let match_with_nodep_ind sigma t = None | _ -> None -let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) +let is_nodep_ind env sigma t = Option.has_some (match_with_nodep_ind env sigma t) -let match_with_sigma_type sigma t = +let match_with_sigma_type env sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with | Ind (ind, _) -> @@ -405,7 +404,7 @@ let match_with_sigma_type sigma t = if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) - && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) sigma + && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) env sigma (let (ctx, cty) = mip.mind_nf_lc.(0) in EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx)) then (*allowing only 1 existential*) @@ -414,7 +413,7 @@ let match_with_sigma_type sigma t = None | _ -> None -let is_sigma_type sigma t = op2bool (match_with_sigma_type sigma t) +let is_sigma_type env sigma t = Option.has_some (match_with_sigma_type env sigma t) (***** Destructing patterns bound to some theory *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 741f6713e3..b8c3ddb0f0 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -43,8 +43,8 @@ open Coqlib also work on ad-hoc disjunctions introduced by the user. (Eduardo, 6/8/97). *) -type 'a matching_function = evar_map -> constr -> 'a option -type testing_function = evar_map -> constr -> bool +type 'a matching_function = Environ.env -> evar_map -> constr -> 'a option +type testing_function = Environ.env -> evar_map -> constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function @@ -83,8 +83,8 @@ val is_inductive_equality : inductive -> bool val match_with_equality_type : (constr * constr list) matching_function val is_equality_type : testing_function -val match_with_nottype : Environ.env -> (constr * constr) matching_function -val is_nottype : Environ.env -> testing_function +val match_with_nottype : (constr * constr) matching_function +val is_nottype : testing_function val match_with_forall_term : (Name.t Context.binder_annot * constr * constr) matching_function val is_forall_term : testing_function diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index d1b77f3758..16829482e5 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -181,10 +181,7 @@ let define_mutual_scheme kind mode names mind = let find_scheme_on_env_too kind ind = let s = String.Map.find kind (Indmap.find ind !scheme_map) in - s, Safe_typing.concat_private - (Safe_typing.private_con_of_scheme - ~kind (Global.safe_env()) [ind, s]) - Safe_typing.empty_private_constants + s, Safe_typing.empty_private_constants let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index aabfae444e..447b908a1d 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -259,10 +259,12 @@ let subst_mps subst c = EConstr.of_constr (Mod_subst.subst_mps subst (EConstr.Unsafe.to_constr c)) let subst_red_expr subs = + let env = Global.env () in + let sigma = Evd.from_env env in Redops.map_red_expr_gen (subst_mps subs) (Mod_subst.subst_evaluable_reference subs) - (Patternops.subst_pattern subs) + (Patternops.subst_pattern env sigma subs) let inReduction : bool * string * red_expr -> obj = declare_object diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index ec8d4d0e14..dcd63fe760 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -704,7 +704,8 @@ module New = struct (* computing the case/elim combinators *) let gl_make_elim ind = begin fun gl -> - let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + let env = Proofview.Goal.env gl in + let gr = Indrec.lookup_eliminator env (fst ind) (elimination_sort_of_goal gl) in let (sigma, c) = pf_apply Evd.fresh_global gl gr in (sigma, c) end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 206f35c8ba..066b9c7794 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1432,7 +1432,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); - elimrename = Some (false, constructors_nrealdecls (fst mind))}) + elimrename = Some (false, constructors_nrealdecls env (fst mind))}) end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1455,7 +1455,8 @@ exception IsNonrec let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Declarations.BiFinite let find_ind_eliminator ind s gl = - let gr = lookup_eliminator ind s in + let env = Proofview.Goal.env gl in + let gr = lookup_eliminator env ind s in Tacmach.New.pf_apply Evd.fresh_global gl gr let find_eliminator c gl = @@ -1463,7 +1464,7 @@ let find_eliminator c gl = if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); - elimrename = Some (true, constructors_nrealdecls ind)} + elimrename = Some (true, constructors_nrealdecls (Global.env()) ind)} let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE @@ -1609,9 +1610,9 @@ let descend_in_conjunctions avoid tac (err, info) c = let t = Retyping.get_type_of env sigma c in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = EConstr.decompose_prod_assum sigma t in - match match_with_tuple sigma ccl with + match match_with_tuple env sigma ccl with | Some (_,_,isrec) -> - let n = (constructors_nrealargs ind).(0) in + let n = (constructors_nrealargs env ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in let IndType (indf,_) = find_rectype env sigma ccl in let (_,inst), params = dest_ind_family indf in @@ -2299,7 +2300,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (type_of (mkVar id)) in - let eqtac, thin = match match_with_equality_type sigma t with + let eqtac, thin = match match_with_equality_type env sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then let id' = destVar sigma lhs in @@ -4128,7 +4129,7 @@ let guess_elim isrec dep s hyp0 gl = let sigma, elimc = if isrec && not (is_nonrec mind) then - let gr = lookup_eliminator mind s in + let gr = lookup_eliminator env mind s in Evd.fresh_global env sigma gr else let u = EInstance.kind sigma u in @@ -4739,9 +4740,10 @@ let reflexivity_red allowred = (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match match_with_equality_type sigma concl with + match match_with_equality_type env sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings end diff --git a/test-suite/bugs/closed/bug_9684.v b/test-suite/bugs/closed/bug_9684.v new file mode 100644 index 0000000000..436a00585b --- /dev/null +++ b/test-suite/bugs/closed/bug_9684.v @@ -0,0 +1,19 @@ +Set Primitive Projections. + +Record foo := mkFoo { proj1 : bool; proj2 : bool }. + +Definition x := mkFoo true false. +Definition proj x := proj2 x. + +Lemma oops : proj = fun x => proj1 x. +Proof. Fail native_compute; reflexivity. Abort. + +(* +Lemma bad : False. +assert (proj1 x = proj x). + rewrite oops; reflexivity. +discriminate. +Qed. + +Print Assumptions bad. +*) diff --git a/test-suite/coq-makefile/missing-install/run.sh b/test-suite/coq-makefile/missing-install/run.sh new file mode 100755 index 0000000000..4f36fdcb1c --- /dev/null +++ b/test-suite/coq-makefile/missing-install/run.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +. ../template/init.sh + +rm -rf _test; mkdir _test; cd _test + +cat > _CoqProject <<EOF +-R theories Test +theories/a.v +theories/b.v +EOF +mkdir theories +touch theories/a.v theories/b.v + +coq_makefile -f _CoqProject -o Makefile +make theories/b.vo +if make install; then exit 1; fi diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 78a3f7c63a..4ee4aae36c 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -49,16 +49,15 @@ TO_SED_IN_BOTH=( -e s'/[0-9]*\.[0-9]*//g' # the precise timing numbers vary, so we strip them out -e s'/^-*$/------/g' # When none of the numbers get over 100 (or 1000, in per-file), the width of the table is different, so we normalize the number of dashes for table separators -e s'/+/-/g' # some code lines don't really change, but this can show up as either -0m00.01s or +0m00.01s, so we need to normalize the signs; additionally, some N/A's show up where we expect to get -∞ on the per-line file, and so the ∞-replacement gets the sign wrong, so we must correct it + -e s'/[0-9]//g' # sometimes the time is under 1 minute, sometimes it's over 1 minute, so we want to remove/normalize both instances; see https://github.com/coq/coq/issues/5675#issuecomment-487378622 ) TO_SED_IN_PER_FILE=( - -e s'/[0-9]//g' # unclear whether this is actually needed above and beyond s'/[0-9]*\.[0-9]*//g'; it's been here from the start -e s'/ */ /g' # unclear whether this is actually needed for per-file timing; it's been here from the start -e s'/\(Total.*\)-\(.*\)-/\1+\2+/g' # Overall time in the per-file timing diff should be around 0; if it comes out negative, we remove the sign ) TO_SED_IN_PER_LINE=( - -e s'/0//g' # unclear whether this is actually needed above and beyond s'/[0-9]*\.[0-9]*//g'; it's been here from the start -e s'/ */ /g' # Sometimes 0 will show up as 0m00.s, sometimes it'll end up being more like 0m00.001s; we must strip out the spaces that result from left-aligning numbers of different widths based on how many digits Coq's [-time] gives ) diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out index fdd5599565..4d76f1210b 100644 --- a/test-suite/output/Int63Syntax.out +++ b/test-suite/output/Int63Syntax.out @@ -1,3 +1,7 @@ +2%int63 + : int +(2 + 2)%int63 + : int 2 : int 9223372036854775807 @@ -14,3 +18,15 @@ The command has indeed failed with message: int63 are only non-negative numbers. The command has indeed failed with message: overflow in int63 literal: 9223372036854775808 +2 + : nat +2%int63 + : int +t = 2%i63 + : int +t = 2%i63 + : int +2 + : nat +2 + : int diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v index 3dc364eddb..0385e529bf 100644 --- a/test-suite/output/Int63Syntax.v +++ b/test-suite/output/Int63Syntax.v @@ -1,5 +1,7 @@ Require Import Int63 Cyclic63. +Check 2%int63. +Check (2 + 2)%int63. Open Scope int63_scope. Check 2. Check 9223372036854775807. @@ -9,4 +11,15 @@ Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. Fail Check -1. Fail Check 9223372036854775808. +Open Scope nat_scope. +Check 2. (* : nat *) +Check 2%int63. +Delimit Scope int63_scope with i63. +Definition t := 2%int63. +Print t. +Delimit Scope nat_scope with int63. +Print t. +Check 2. +Close Scope nat_scope. +Check 2. Close Scope int63_scope. diff --git a/test-suite/output/NumeralNotations.out b/test-suite/output/NumeralNotations.out index cb49e66ed7..460c77879c 100644 --- a/test-suite/output/NumeralNotations.out +++ b/test-suite/output/NumeralNotations.out @@ -82,10 +82,6 @@ function (of_uint) targets an option type. The command has indeed failed with message: The 'abstract after' directive has no effect when the parsing function (of_uint) targets an option type. [abstract-large-number-no-op,numbers] -The command has indeed failed with message: -The reference of_uint was not found in the current environment. -The command has indeed failed with message: -The reference of_uint was not found in the current environment. let v := of_uint (Decimal.D1 Decimal.Nil) in v : unit : unit let v := 0%test13 in v : unit diff --git a/test-suite/output/NumeralNotations.v b/test-suite/output/NumeralNotations.v index fcfdd82dcc..44805ad09d 100644 --- a/test-suite/output/NumeralNotations.v +++ b/test-suite/output/NumeralNotations.v @@ -207,21 +207,6 @@ Module Test10. Numeral Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). End Test10. -Module Test11. - (* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) - Inductive unit11 := tt11. - Declare Scope unit11_scope. - Delimit Scope unit11_scope with unit11. - Goal True. - evar (to_uint : unit11 -> Decimal.uint). - evar (of_uint : Decimal.uint -> unit11). - Fail Numeral Notation unit11 of_uint to_uint : uint11_scope. - exact I. - Unshelve. - all: solve [ constructor ]. - Qed. -End Test11. - Module Test12. (* Test for numeral notations on context variables *) Declare Scope test12_scope. diff --git a/test-suite/success/NumeralNotationsNoLocal.v b/test-suite/success/NumeralNotationsNoLocal.v new file mode 100644 index 0000000000..ea3907ef8a --- /dev/null +++ b/test-suite/success/NumeralNotationsNoLocal.v @@ -0,0 +1,12 @@ +(* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) +Inductive unit11 := tt11. +Declare Scope unit11_scope. +Delimit Scope unit11_scope with unit11. +Goal True. + evar (to_uint : unit11 -> Decimal.uint). + evar (of_uint : Decimal.uint -> unit11). + Fail Numeral Notation unit11 of_uint to_uint : uint11_scope. + exact I. + Unshelve. + all: solve [ constructor ]. +Qed. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 85d7a770fc..02adb012d9 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -13,7 +13,7 @@ Print sigT_rect. Obligation Tactic := program_simplify ; auto with *. About MR. -Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat := +Program Fixpoint merge (n m : nat) {measure (n + m) lt} : nat := match n with | 0 => 0 | S n' => merge n' m @@ -101,5 +101,5 @@ Next Obligation. simpl in *; intros. Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) - {measure (p - n) p} : nat := + {measure (p - n)} : nat := _. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index bc58995fd6..c46c23ad60 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -52,7 +52,7 @@ Proof. intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS. Qed. -(** Recursion fonction *) +(** Recursion function *) Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := nat_rect (fun _ => A). diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index bd9d8c9221..2ec55d1bd0 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -38,6 +38,7 @@ DOCDIR := $(COQMF_DOCDIR) OCAMLFIND := $(COQMF_OCAMLFIND) CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) +OCAMLWARN := $(COQMF_WARN) @CONF_FILE@: @PROJECT_FILE@ @COQ_MAKEFILE_INVOCATION@ @@ -176,7 +177,7 @@ COQCHKEXTRAFLAGS?= COQDOCEXTRAFLAGS?= # these flags do NOT contain the libraries, to make them easier to overwrite -COQFLAGS?=-q $(OPT) $(OTHERFLAGS) $(COQEXTRAFLAGS) +COQFLAGS?=-q $(OTHERFLAGS) $(COQEXTRAFLAGS) COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) @@ -190,9 +191,9 @@ COQMAKEFILE_VERSION:=@COQ_VERSION@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) - # ocamldoc fails with unknown argument otherwise -CAMLDOCFLAGS=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLFLAGS+=$(OCAMLWARN) ifneq (,$(TIMING)) TIMING_ARG=-time @@ -468,6 +469,9 @@ beautify: $(BEAUTYFILES) # Extensions can't assume when they run. install: + $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ + if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ + done; exit $$code $(HIDE)for f in $(FILESTOINSTALL); do\ df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ if [ "$$?" != "0" -o -z "$$df" ]; then\ diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 66f1f257b8..7114965a11 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -563,4 +563,5 @@ let _ = try coqdep () with CoqlibError msg -> - eprintf "*** Error: %s@\n%!" msg + eprintf "*** Error: %s@\n%!" msg; + exit 1 diff --git a/topbin/dune b/topbin/dune index e35a3de54b..3b861afe78 100644 --- a/topbin/dune +++ b/topbin/dune @@ -28,6 +28,11 @@ (libraries coq.toplevel) (link_flags -linkall)) +(install + (section bin) + (package coq) + (files (coqc_bin.bc as coqc.byte))) + ; Workers (executables (names coqqueryworker_bin coqtacticworker_bin coqproofworker_bin) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index bf1297d661..319f5c8ad6 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -38,6 +38,8 @@ type color = [`ON | `AUTO | `OFF] type native_compiler = NativeOff | NativeOn of { ondemand : bool } +type option_command = OptionSet of string option | OptionUnset + type t = { load_init : bool; @@ -63,6 +65,8 @@ type t = { allow_sprop : bool; cumulative_sprop : bool; + set_options : (Goptions.option_name * option_command) list; + stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; @@ -115,6 +119,8 @@ let default = { allow_sprop = false; cumulative_sprop = false; + set_options = []; + stm_flags = Stm.AsyncOpts.default_opts; debug = false; diffs_set = false; @@ -245,6 +251,16 @@ let get_native_name s = Nativelib.output_dir; Library.native_name_from_filename s] with _ -> "" +let to_opt_key = Str.(split (regexp " +")) + +let parse_option_set opt = + match String.index_opt opt '=' with + | None -> to_opt_key opt, None + | Some eqi -> + let len = String.length opt in + let v = String.sub opt (eqi+1) (len - eqi - 1) in + to_opt_key (String.sub opt 0 eqi), Some v + (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] between coqtop and coqc. *) @@ -450,6 +466,16 @@ let parse_args ~help ~init arglist : t * string list = in { oval with native_compiler } + | "-set" -> + let opt = next() in + let opt, v = parse_option_set opt in + { oval with set_options = (opt, OptionSet v) :: oval.set_options } + + | "-unset" -> + let opt = next() in + let opt = to_opt_key opt in + { oval with set_options = (opt, OptionUnset) :: oval.set_options } + (* Options with zero arg *) |"-async-queries-always-delegate" |"-async-proofs-always-delegate" diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 97a62e97e4..9bcfdca332 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -14,6 +14,8 @@ val default_toplevel : Names.DirPath.t type native_compiler = NativeOff | NativeOn of { ondemand : bool } +type option_command = OptionSet of string option | OptionUnset + type t = { load_init : bool; @@ -38,6 +40,8 @@ type t = { allow_sprop : bool; cumulative_sprop : bool; + set_options : (Goptions.option_name * option_command) list; + stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index b3de8dd85f..4129562065 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -340,9 +340,7 @@ let print_anyway_opts = [ let print_anyway c = let open Vernacexpr in match c with - | VernacExpr (_, VernacSetOption (_, opt, _)) - | VernacExpr (_, VernacUnsetOption (_, opt)) -> - List.mem opt print_anyway_opts + | VernacExpr (_, VernacSetOption (_, opt, _)) -> List.mem opt print_anyway_opts | _ -> false (* We try to behave better when goal printing raises an exception diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 626023737b..8fae561be8 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -50,6 +50,41 @@ let print_memory_stat () = let _ = at_exit print_memory_stat +let interp_set_option opt v old = + let open Goptions in + let err expect = + let opt = String.concat " " opt in + let got = v in (* avoid colliding with Pp.v *) + CErrors.user_err + Pp.(str "-set: " ++ str opt ++ + str" expects " ++ str expect ++ + str" but got " ++ str got) + in + match old with + | BoolValue _ -> + let v = match String.trim v with + | "true" -> true + | "false" | "" -> false + | _ -> err "a boolean" + in + BoolValue v + | IntValue _ -> + let v = String.trim v in + let v = match int_of_string_opt v with + | Some _ as v -> v + | None -> if v = "" then None else err "an int" + in + IntValue v + | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) + +let set_option = let open Goptions in function + | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt + | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true + | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v + +let set_options = List.iter set_option + (******************************************************************************) (* Input/Output State *) (******************************************************************************) @@ -195,6 +230,8 @@ let init_toplevel ~help ~init custom_init arglist = Global.set_allow_sprop opts.allow_sprop; if opts.cumulative_sprop then Global.make_sprop_cumulative (); + set_options opts.set_options; + (* Allow the user to load an arbitrary state here *) inputstate opts; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 513374c2af..7074215afe 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -74,6 +74,9 @@ let print_usage_common co command = \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ +\n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ +\n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ +\n -unset \"Foo Bar\" disable Foo Bar (as Unset Foo Bar. in a file)\ \n -time display the time taken by each command\ \n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ diff --git a/vernac/canonical.ml b/vernac/canonical.ml new file mode 100644 index 0000000000..92d5731f92 --- /dev/null +++ b/vernac/canonical.ml @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Names +open Libobject +open Recordops + +let open_canonical_structure i (_, o) = + let env = Global.env () in + let sigma = Evd.from_env env in + if Int.equal i 1 then register_canonical_structure env sigma ~warn:false o + +let cache_canonical_structure (_, o) = + let env = Global.env () in + let sigma = Evd.from_env env in + register_canonical_structure ~warn:true env sigma o + +let discharge_canonical_structure (_,x) = Some x + +let inCanonStruc : Constant.t * inductive -> obj = + declare_object {(default_object "CANONICAL-STRUCTURE") with + open_function = open_canonical_structure; + cache_function = cache_canonical_structure; + subst_function = (fun (subst,c) -> subst_canonical_structure subst c); + classify_function = (fun x -> Substitute x); + discharge_function = discharge_canonical_structure } + +let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) + +let declare_canonical_structure ref = + let env = Global.env () in + let sigma = Evd.from_env env in + add_canonical_structure (check_and_decompose_canonical_structure env sigma ref) diff --git a/vernac/canonical.mli b/vernac/canonical.mli new file mode 100644 index 0000000000..5b223a0615 --- /dev/null +++ b/vernac/canonical.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * 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 + +val declare_canonical_structure : GlobRef.t -> unit diff --git a/vernac/class.ml b/vernac/class.ml index 0837beccee..f3a279eab1 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -23,6 +23,7 @@ open Classops open Declare open Globnames open Decl_kinds +open Libobject let strength_min l = if List.mem `LOCAL l then `LOCAL else `GLOBAL @@ -230,6 +231,58 @@ let check_source = function | Some (CL_FUN as s) -> raise (CoercionError (ForbiddenSourceClass s)) | _ -> () +let cache_coercion (_,c) = + let env = Global.env () in + let sigma = Evd.from_env env in + Classops.declare_coercion env sigma c + +let open_coercion i o = + if Int.equal i 1 then + cache_coercion o + +let discharge_coercion (_, c) = + if c.coercion_local then None + else + let n = + try + let ins = Lib.section_instance c.coercion_type in + Array.length (snd ins) + with Not_found -> 0 + in + let nc = { c with + coercion_params = n + c.coercion_params; + coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; + } in + Some nc + +let classify_coercion obj = + if obj.coercion_local then Dispose else Substitute obj + +let inCoercion : coercion -> obj = + declare_object {(default_object "COERCION") with + open_function = open_coercion; + cache_function = cache_coercion; + subst_function = (fun (subst,c) -> subst_coercion subst c); + classify_function = classify_coercion; + discharge_function = discharge_coercion } + +let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = + let isproj = + match coef with + | ConstRef c -> Recordops.find_primitive_projection c + | _ -> None + in + let c = { + coercion_type = coef; + coercion_local = local; + coercion_is_id = isid; + coercion_is_proj = isproj; + coercion_source = cls; + coercion_target = clt; + coercion_params = ps; + } in + Lib.add_anonymous_leaf (inCoercion c) + (* nom de la fonction coercion strength de f diff --git a/vernac/classes.ml b/vernac/classes.ml index d61d324941..9f233a2551 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -22,8 +22,10 @@ open Constrintern open Constrexpr open Context.Rel.Declaration open Class_tactics +open Libobject module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration (*i*) open Decl_kinds @@ -49,17 +51,224 @@ let classes_transparent_state () = with Not_found -> TransparentState.empty let () = - Hook.set Typeclasses.add_instance_hint_hook - (fun inst path local info poly -> + Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; + Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state + +let add_instance_hint inst path local info poly = let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) | IsGlobal gr -> Hints.IsGlobRef gr in Flags.silently (fun () -> Hints.add_hints ~local [typeclasses_db] (Hints.HintsResolveEntry - [info, poly, false, Hints.PathHints path, inst'])) ()); - Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; - Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state + [info, poly, false, Hints.PathHints path, inst'])) () + +let is_local_for_hint i = + match i.is_global with + | None -> true (* i.e. either no Global keyword not in section, or in section *) + | Some n -> n <> 0 (* i.e. in a section, declare the hint as local + since discharge is managed by rebuild_instance which calls again + add_instance_hint; don't ask hints to take discharge into account + itself *) + +let add_instance check inst = + let poly = Global.is_polymorphic inst.is_impl in + let local = is_local_for_hint inst in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local + inst.is_info poly; + List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path + local pri poly) + (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) + (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) + +let mk_instance cl info glob impl = + let global = + if glob then Some (Lib.sections_depth ()) + else None + in + if match global with Some n -> n>0 && isVarRef impl | _ -> false then + CErrors.user_err (Pp.str "Cannot set Global an instance referring to a section variable."); + { is_class = cl.cl_impl; + is_info = info ; + is_global = global ; + is_impl = impl } + +(* + * instances persistent object + *) +let cache_instance (_, i) = + load_instance i + +let subst_instance (subst, inst) = + { inst with + is_class = fst (subst_global subst inst.is_class); + is_impl = fst (subst_global subst inst.is_impl) } + +let discharge_instance (_, inst) = + match inst.is_global with + | None -> None + | Some n -> + assert (not (isVarRef inst.is_impl)); + Some + { inst with + is_global = Some (pred n); + is_class = inst.is_class; + is_impl = inst.is_impl } + +let is_local i = (i.is_global == None) + +let rebuild_instance inst = + add_instance true inst; + inst + +let classify_instance inst = + if is_local inst then Dispose + else Substitute inst + +let instance_input : instance -> obj = + declare_object + { (default_object "type classes instances state") with + cache_function = cache_instance; + load_function = (fun _ x -> cache_instance x); + open_function = (fun _ x -> cache_instance x); + classify_function = classify_instance; + discharge_function = discharge_instance; + rebuild_function = rebuild_instance; + subst_function = subst_instance } + +let add_instance i = + Lib.add_anonymous_leaf (instance_input i); + add_instance true i + +let warning_not_a_class = + let name = "not-a-class" in + let category = "typeclasses" in + CWarnings.create ~name ~category (fun (n, ty) -> + let env = Global.env () in + let evd = Evd.from_env env in + Pp.(str "Ignored instance declaration for “" + ++ Nametab.pr_global_env Id.Set.empty n + ++ str "”: “" + ++ Termops.Internal.print_constr_env env evd (EConstr.of_constr ty) + ++ str "” is not a class") + ) + +let declare_instance ?(warn = false) env sigma info local glob = + let ty, _ = Typeops.type_of_global_in_context env glob in + let info = Option.default {hint_priority = None; hint_pattern = None} info in + match class_of_constr env sigma (EConstr.of_constr ty) with + | Some (rels, ((tc,_), args) as _cl) -> + assert (not (isVarRef glob) || local); + add_instance (mk_instance tc info (not local) glob) + | None -> if warn then warning_not_a_class (glob, ty) + +(* + * classes persistent object + *) + +let cache_class (_,c) = load_class c + +let subst_class (subst,cl) = + let do_subst_con c = Mod_subst.subst_constant subst c + and do_subst c = Mod_subst.subst_mps subst c + and do_subst_gr gr = fst (subst_global subst gr) in + let do_subst_ctx = List.Smart.map (RelDecl.map_constr do_subst) in + let do_subst_context (grs,ctx) = + List.Smart.map (Option.Smart.map do_subst_gr) grs, + do_subst_ctx ctx in + let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> + (x, y, Option.Smart.map do_subst_con z)) projs in + { cl_univs = cl.cl_univs; + cl_impl = do_subst_gr cl.cl_impl; + cl_context = do_subst_context cl.cl_context; + cl_props = do_subst_ctx cl.cl_props; + cl_projs = do_subst_projs cl.cl_projs; + cl_strict = cl.cl_strict; + cl_unique = cl.cl_unique } + +let discharge_class (_,cl) = + let open CVars in + let repl = Lib.replacement_context () in + let rel_of_variable_context ctx = List.fold_right + ( fun (decl,_) (ctx', subst) -> + let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in + (decl' :: ctx', NamedDecl.get_id decl :: subst) + ) ctx ([], []) in + let discharge_rel_context (subst, usubst) n rel = + let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in + let fold decl (ctx, k) = + let map c = subst_univs_level_constr usubst (substn_vars k subst c) in + RelDecl.map_constr map decl :: ctx, succ k + in + let ctx, _ = List.fold_right fold rel ([], n) in + ctx + in + let abs_context cl = + match cl.cl_impl with + | VarRef _ | ConstructRef _ -> assert false + | ConstRef cst -> Lib.section_segment_of_constant cst + | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in + let discharge_context ctx' subst (grs, ctx) = + let env = Global.env () in + let sigma = Evd.from_env env in + let grs' = + let newgrs = List.map (fun decl -> + match decl |> RelDecl.get_type |> EConstr.of_constr |> class_of_constr env sigma with + | None -> None + | Some (_, ((tc,_), _)) -> Some tc.cl_impl) + ctx' + in + grs @ newgrs + in grs', discharge_rel_context subst 1 ctx @ ctx' in + try + let info = abs_context cl in + let ctx = info.Lib.abstr_ctx in + let ctx, subst = rel_of_variable_context ctx in + let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in + let context = discharge_context ctx (subst, usubst) cl.cl_context in + let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in + let discharge_proj x = x in + { cl_univs = cl_univs'; + cl_impl = cl.cl_impl; + cl_context = context; + cl_props = props; + cl_projs = List.Smart.map discharge_proj cl.cl_projs; + cl_strict = cl.cl_strict; + cl_unique = cl.cl_unique + } + with Not_found -> (* not defined in the current section *) + cl + +let rebuild_class cl = + try + let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in + set_typeclass_transparency cst false false; cl + with e when CErrors.noncritical e -> cl + +let class_input : typeclass -> obj = + declare_object + { (default_object "type classes state") with + cache_function = cache_class; + load_function = (fun _ -> cache_class); + open_function = (fun _ -> cache_class); + classify_function = (fun x -> Substitute x); + discharge_function = (fun a -> Some (discharge_class a)); + rebuild_function = rebuild_class; + subst_function = subst_class } + +let add_class cl = + Lib.add_anonymous_leaf (class_input cl) + +let add_class env sigma cl = + add_class cl; + List.iter (fun (n, inst, body) -> + match inst with + | Some (Backward, info) -> + (match body with + | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") + | Some b -> declare_instance ~warn:true env sigma (Some info) false (ConstRef b)) + | _ -> ()) + cl.cl_projs let intern_info {hint_priority;hint_pattern} = let env = Global.env() in @@ -72,10 +281,12 @@ let existing_instance glob g info = let c = Nametab.global g in let info = Option.default Hints.empty_hint_info info in let info = intern_info info in - let instance, _ = Typeops.type_of_global_in_context (Global.env ()) c in + let env = Global.env() in + let sigma = Evd.from_env env in + let instance, _ = Typeops.type_of_global_in_context env c in let _, r = Term.decompose_prod_assum instance in - match class_of_constr Evd.empty (EConstr.of_constr r) with - | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob c) + match class_of_constr env sigma (EConstr.of_constr r) with + | Some (_, ((tc,u), _)) -> add_instance (mk_instance tc info glob c) | None -> user_err ?loc:g.CAst.loc ~hdr:"declare_instance" (Pp.str "Constant does not build instances of a declared type class.") @@ -111,7 +322,9 @@ let id_of_class cl = let instance_hook k info global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst imps; let info = intern_info info in - Typeclasses.declare_instance (Some info) (not global) cst; + let env = Global.env () in + let sigma = Evd.from_env env in + declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k info global imps ?hook id decl poly sigma term termtype = @@ -154,7 +367,9 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr imps; let pri = intern_info pri in - Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) + let env = Global.env () in + let sigma = Evd.from_env env in + declare_instance env sigma (Some pri) (not global) (ConstRef cst) in let obls, constr, typ = match term with @@ -360,96 +575,3 @@ let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) interp_instance_context ~program_mode env ctx pl bk cl in do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst instid - -let named_of_rel_context l = - let open Vars in - let acc, ctx = - List.fold_right - (fun decl (subst, ctx) -> - let id = match RelDecl.get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in - let d = match decl with - | LocalAssum (_,t) -> id, None, substl subst t - | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in - (mkVar id :: subst, d :: ctx)) - l ([], []) - in ctx - -let context ~pstate poly l = - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in - (* Note, we must use the normalized evar from now on! *) - let sigma = Evd.minimize_universes sigma in - let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in - let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in - let ctx = - try named_of_rel_context fullctx - with e when CErrors.noncritical e -> - user_err Pp.(str "Anonymous variables not allowed in contexts.") - in - let univs = - match ctx with - | [] -> assert false - | [_] -> Evd.univ_entry ~poly sigma - | _::_::_ -> - if Lib.sections_are_opened () - then - (* More than 1 variable in a section: we can't associate - universes to any specific variable so we declare them - separately. *) - begin - let uctx = Evd.universe_context_set sigma in - Declare.declare_universe_context poly uctx; - if poly then Polymorphic_entry ([||], Univ.UContext.empty) - else Monomorphic_entry Univ.ContextSet.empty - end - else if poly then - (* Multiple polymorphic axioms: they are all polymorphic the same way. *) - Evd.univ_entry ~poly sigma - else - (* Multiple monomorphic axioms: declare universes separately - to avoid redeclaring them. *) - begin - let uctx = Evd.universe_context_set sigma in - Declare.declare_universe_context poly uctx; - Monomorphic_entry Univ.ContextSet.empty - end - in - let fn status (id, b, t) = - let b, t = Option.map (to_constr sigma) b, to_constr sigma t in - if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - (* Declare the universe context once *) - let decl = match b with - | None -> - (ParameterEntry (None,(t,univs),None), IsAssumption Logical) - | Some b -> - let entry = Declare.definition_entry ~univs ~types:t b in - (DefinitionEntry entry, IsAssumption Logical) - in - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in - match class_of_constr sigma (of_constr t) with - | Some (rels, ((tc,_), args) as _cl) -> - add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (ConstRef cst)); - status - (* declare_subclasses (ConstRef cst) cl *) - | None -> status - else - let test (x, _) = match x with - | ExplByPos (_, Some id') -> Id.equal id id' - | _ -> false - in - let impl = List.exists test impls in - let decl = (Discharge, poly, Definitional) in - let nstatus = match b with - | None -> - pi3 (ComAssumption.declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl - Declaremods.NoInline (CAst.make id)) - | Some b -> - let decl = (Discharge, poly, Definition) in - let entry = Declare.definition_entry ~univs ~types:t b in - let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in - Lib.sections_are_opened () || Lib.is_modtype_strict () - in - status && nstatus - in - List.fold_left fn true (List.rev ctx) diff --git a/vernac/classes.mli b/vernac/classes.mli index 73e4b024ef..e7f90ff306 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,6 +22,12 @@ val mismatched_props : env -> constr_expr list -> Constr.rel_context -> 'a (** Instance declaration *) +val declare_instance : ?warn:bool -> env -> Evd.evar_map -> + hint_info option -> bool -> GlobRef.t -> unit +(** Declares the given global reference as an instance of its type. + Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — + when said type is not a registered type class. *) + val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) @@ -64,6 +70,12 @@ val declare_new_instance : Hints.hint_info_expr -> unit +(** {6 Low level interface used by Add Morphism, do not use } *) +val mk_instance : typeclass -> hint_info -> bool -> GlobRef.t -> instance +val add_instance : instance -> unit + +val add_class : env -> Evd.evar_map -> typeclass -> unit + (** Setting opacity *) val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit @@ -71,13 +83,3 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u (** For generation on names based on classes only *) val id_of_class : typeclass -> Id.t - -(** Context command *) - -(** returns [false] if, for lack of section, it declares an assumption - (unless in a module type). *) -val context - : pstate:Proof_global.t option - -> Decl_kinds.polymorphic - -> local_binder_expr list - -> bool diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index d7bd64067b..3406b6276f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -22,6 +22,7 @@ open Decl_kinds open Pretyping open Entries +module RelDecl = Context.Rel.Declaration (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) let axiom_into_instance = ref false @@ -59,7 +60,9 @@ match local with in let r = VarRef ident in let () = maybe_declare_manual_implicits true r imps in - let () = Typeclasses.declare_instance None true r in + let env = Global.env () in + let sigma = Evd.from_env env in + let () = Classes.declare_instance env sigma None true r in let () = if is_coe then Class.try_add_new_coercion r ~local:true false in (r,Univ.Instance.empty,true) @@ -77,7 +80,9 @@ match local with let () = maybe_declare_manual_implicits false gr imps in let () = Declare.declare_univ_binders gr pl in let () = assumption_message ident in - let () = if do_instance then Typeclasses.declare_instance None false gr in + let env = Global.env () in + let sigma = Evd.from_env env in + let () = if do_instance then Classes.declare_instance env sigma None false gr in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx @@ -173,7 +178,7 @@ let do_assumptions ~pstate ~program_mode kind nl l = let ubinders = Evd.universe_binders sigma in pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in - let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in + let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs @@ -206,3 +211,94 @@ let do_primitive id prim typopt = in let _kn = declare_constant id.CAst.v (PrimitiveEntry entry,IsPrimitive) in Flags.if_verbose Feedback.msg_info Pp.(Id.print id.CAst.v ++ str " is declared") + +let named_of_rel_context l = + let open EConstr.Vars in + let open RelDecl in + let acc, ctx = + List.fold_right + (fun decl (subst, ctx) -> + let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in + let d = match decl with + | LocalAssum (_,t) -> id, None, substl subst t + | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in + (EConstr.mkVar id :: subst, d :: ctx)) + l ([], []) + in ctx + +let context ~pstate poly l = + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in + (* Note, we must use the normalized evar from now on! *) + let sigma = Evd.minimize_universes sigma in + let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in + let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in + let ctx = + try named_of_rel_context fullctx + with e when CErrors.noncritical e -> + user_err Pp.(str "Anonymous variables not allowed in contexts.") + in + let univs = + match ctx with + | [] -> assert false + | [_] -> Evd.univ_entry ~poly sigma + | _::_::_ -> + if Lib.sections_are_opened () + then + (* More than 1 variable in a section: we can't associate + universes to any specific variable so we declare them + separately. *) + begin + let uctx = Evd.universe_context_set sigma in + Declare.declare_universe_context poly uctx; + if poly then Polymorphic_entry ([||], Univ.UContext.empty) + else Monomorphic_entry Univ.ContextSet.empty + end + else if poly then + (* Multiple polymorphic axioms: they are all polymorphic the same way. *) + Evd.univ_entry ~poly sigma + else + (* Multiple monomorphic axioms: declare universes separately + to avoid redeclaring them. *) + begin + let uctx = Evd.universe_context_set sigma in + Declare.declare_universe_context poly uctx; + Monomorphic_entry Univ.ContextSet.empty + end + in + let fn status (id, b, t) = + let b, t = Option.map (EConstr.to_constr sigma) b, EConstr.to_constr sigma t in + if Lib.is_modtype () && not (Lib.sections_are_opened ()) then + (* Declare the universe context once *) + let decl = match b with + | None -> + (ParameterEntry (None,(t,univs),None), IsAssumption Logical) + | Some b -> + let entry = Declare.definition_entry ~univs ~types:t b in + (DefinitionEntry entry, IsAssumption Logical) + in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in + let env = Global.env () in + Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (ConstRef cst); + status + else + let test (x, _) = match x with + | Constrexpr.ExplByPos (_, Some id') -> Id.equal id id' + | _ -> false + in + let impl = List.exists test impls in + let decl = (Discharge, poly, Definitional) in + let nstatus = match b with + | None -> + pi3 (declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl + Declaremods.NoInline (CAst.make id)) + | Some b -> + let decl = (Discharge, poly, Definition) in + let entry = Declare.definition_entry ~univs ~types:t b in + let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in + Lib.sections_are_opened () || Lib.is_modtype_strict () + in + status && nstatus + in + List.fold_left fn true (List.rev ctx) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 32914cc11b..7c64317b70 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -9,8 +9,6 @@ (************************************************************************) open Names -open Constr -open Entries open Vernacexpr open Constrexpr open Decl_kinds @@ -25,19 +23,13 @@ val do_assumptions -> (ident_decl list * constr_expr) with_coercion list -> bool -(************************************************************************) -(** Internal API *) -(************************************************************************) - -(** Exported for Classes *) - (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) val declare_assumption : pstate:Proof_global.t option -> coercion_flag -> assumption_kind - -> types in_universes_entry + -> Constr.types Entries.in_universes_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> bool (** implicit *) @@ -45,4 +37,14 @@ val declare_assumption -> variable CAst.t -> GlobRef.t * Univ.Instance.t * bool +(** Context command *) + +(** returns [false] if, for lack of section, it declares an assumption + (unless in a module type). *) +val context + : pstate:Proof_global.t option + -> Decl_kinds.polymorphic + -> local_binder_expr list + -> bool + val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 2aadbd224f..1912646ffd 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -329,16 +329,27 @@ let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,c List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; pstate -let extract_decreasing_argument limit = function - | (na,CStructRec) -> na - | (na,_) when not limit -> na +let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v with + | CStructRec na -> na + | (CWfRec (na,_) | CMeasureRec (Some na,_,_)) when not structonly -> na + | CMeasureRec (None,_,_) when not structonly -> + user_err Pp.(str "Decreasing argument must be specificed in measure clause.") | _ -> user_err Pp.(str - "Only structural decreasing is supported for a non-Program Fixpoint") + "Well-founded induction requires Program Fixpoint or Function.") -let extract_fixpoint_components limit l = +let extract_fixpoint_components ~structonly l = let fixl, ntnl = List.split l in let fixl = List.map (fun (({CAst.v=id},pl),ann,bl,typ,def) -> - let ann = extract_decreasing_argument limit ann in + (* This is a special case: if there's only one binder, we pick it as the + recursive argument if none is provided. *) + let ann = Option.map (fun ann -> match bl, ann with + | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> + CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) + | _, x -> x) ann + in + let ann = Option.map (extract_decreasing_argument ~structonly) ann in {fix_name = id; fix_annot = ann; fix_univs = pl; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl @@ -356,7 +367,7 @@ let check_safe () = flags.check_universes && flags.check_guarded let do_fixpoint ~ontop local poly l = - let fixl, ntns = extract_fixpoint_components true l in + let fixl, ntns = extract_fixpoint_components ~structonly:true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences info in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 15ff5f4498..5937842f17 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -62,7 +62,7 @@ val interp_recursive : (** Extracting the semantical components out of the raw syntax of (co)fixpoints declarations *) -val extract_fixpoint_components : bool -> +val extract_fixpoint_components : structonly:bool -> (fixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 350b2d2945..20a2db7ca2 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -85,7 +85,7 @@ let rec telescope sigma l = let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx -let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = +let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let open EConstr in let open Vars in let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in @@ -304,22 +304,26 @@ let do_program_recursive local poly fixkind fixl ntns = let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> - let recarg = - match n with - | Some n -> mkIdentC n.CAst.v - | None -> - user_err ~hdr:"do_program_fixpoint" - (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn + | [Some { CAst.v = CWfRec (n,r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + let recarg = mkIdentC n.CAst.v in + build_wellfounded (id, pl, bl, typ, out_def def) poly r recarg ntn - | [(n, CMeasureRec (m, r))], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> - build_wellfounded (id, pl, n, bl, typ, out_def def) poly + | [Some { CAst.v = CMeasureRec (n, m, r) }], [((({CAst.v=id},pl),_,bl,typ,def),ntn)] -> + (* We resolve here a clash between the syntax of Program Fixpoint and the one of funind *) + let r = match n, r with + | Some id, None -> + let loc = id.CAst.loc in + Some (CAst.make ?loc @@ CRef(qualid_of_ident ?loc id.CAst.v,None)) + | Some _, Some _ -> + user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") + | _, _ -> r + in + build_wellfounded (id, pl, bl, typ, out_def def) poly (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn - | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> - let fixl,ntns = extract_fixpoint_components true l in - let fixkind = Obligations.IsFixpoint g in + | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> + let fixl,ntns = extract_fixpoint_components ~structonly:true l in + let fixkind = Obligations.IsFixpoint (List.map (fun d -> d.fix_annot) fixl) in do_program_recursive local poly fixkind fixl ntns | _, _ -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 1533d0ccd3..3f491d1dd4 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -875,10 +875,10 @@ GRAMMAR EXTEND Gram GLOBAL: command query_command class_rawexpr gallina_ext; gallina_ext: - [ [ IDENT "Export"; "Set"; table = option_table; v = option_value -> + [ [ IDENT "Export"; "Set"; table = option_table; v = option_setting -> { VernacSetOption (true, table, v) } | IDENT "Export"; IDENT "Unset"; table = option_table -> - { VernacUnsetOption (true, table) } + { VernacSetOption (true, table, OptionUnset) } ] ]; command: @@ -943,10 +943,10 @@ GRAMMAR EXTEND Gram { VernacAddMLPath (true, dir) } (* For acting on parameter tables *) - | "Set"; table = option_table; v = option_value -> + | "Set"; table = option_table; v = option_setting -> { VernacSetOption (false, table, v) } | IDENT "Unset"; table = option_table -> - { VernacUnsetOption (false, table) } + { VernacSetOption (false, table, OptionUnset) } | IDENT "Print"; IDENT "Table"; table = option_table -> { VernacPrintOption table } @@ -1057,10 +1057,10 @@ GRAMMAR EXTEND Gram | IDENT "Library"; qid = global -> { LocateLibrary qid } | IDENT "Module"; qid = global -> { LocateModule qid } ] ] ; - option_value: - [ [ -> { BoolValue true } - | n = integer -> { IntValue (Some n) } - | s = STRING -> { StringValue s } ] ] + option_setting: + [ [ -> { OptionSetTrue } + | n = integer -> { OptionSetInt n } + | s = STRING -> { OptionSetString s } ] ] ; option_ref_value: [ [ id = global -> { QualidRefValue id } @@ -1130,10 +1130,10 @@ GRAMMAR EXTEND Gram (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> - { VernacSetOption (false, ["Ltac";"Debug"], BoolValue true) } + { VernacSetOption (false, ["Ltac";"Debug"], OptionSetTrue) } | IDENT "Debug"; IDENT "Off" -> - { VernacSetOption (false, ["Ltac";"Debug"], BoolValue false) } + { VernacSetOption (false, ["Ltac";"Debug"], OptionUnset) } (* registration of a custom reduction *) diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 32754478a5..082b22b373 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -601,7 +601,7 @@ let rec explain_evar_kind env sigma evk ty = (pr_leconstr_env env sigma ty') src let explain_typeclass_resolution env sigma evi k = - match Typeclasses.class_of_constr sigma evi.evar_concl with + match Typeclasses.class_of_constr env sigma evi.evar_concl with | Some _ -> let env = Evd.evar_filtered_env evi in fnl () ++ str "Could not find an instance for " ++ @@ -614,7 +614,7 @@ let explain_placeholder_kind env sigma c e = | Some (SeveralInstancesFound n) -> strbrk " (several distinct possible type class instances found)" | None -> - match Typeclasses.class_of_constr sigma c with + match Typeclasses.class_of_constr env sigma c with | Some _ -> strbrk " (no type class instance found)" | _ -> mt () @@ -731,7 +731,9 @@ let explain_undeclared_universe env sigma l = spc () ++ str "(maybe a bugged tactic)." let explain_disallowed_sprop () = - Pp.(str "SProp not allowed, you need to use -allow-sprop.") + Pp.(strbrk "SProp not allowed, you need to " + ++ str "Set Allow StrictProp" + ++ strbrk " or to use the -allow-sprop command-line-flag.") let explain_bad_relevance env = strbrk "Bad relevance (maybe a bugged tactic)." diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 1e733acc59..642695bda4 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -313,7 +313,9 @@ let warn_cannot_build_congruence = strbrk "Cannot build congruence scheme because eq is not found") let declare_congr_scheme ind = - if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin + let env = Global.env () in + let sigma = Evd.from_env env in + if Hipattern.is_equality_type env sigma (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true with e when CErrors.noncritical e -> false diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 07194578c1..1b1c618dc7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -295,7 +295,7 @@ type obligation = type obligations = (obligation array * int) type fixpoint_kind = - | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of lident option list | IsCoFixpoint type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -486,7 +486,7 @@ let rec lam_index n t acc = lam_index n b (succ acc) | _ -> raise Not_found -let compute_possible_guardness_evidences (n,_) fixbody fixtype = +let compute_possible_guardness_evidences n fixbody fixtype = match n with | Some { CAst.loc; v = n } -> [lam_index n fixbody 0] | None -> diff --git a/vernac/obligations.mli b/vernac/obligations.mli index b1b7b1ec90..d25daeed9c 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -70,7 +70,7 @@ type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type fixpoint_kind = - | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of lident option list | IsCoFixpoint val add_mutual_definitions : diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index b602e134da..4e4d431e89 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -173,15 +173,10 @@ open Pputils pr_opt (prlist_with_sep sep pr_option_ref_value) b let pr_set_option a b = - let pr_opt_value = function - | IntValue None -> assert false - (* This should not happen because of the grammar *) - | IntValue (Some n) -> spc() ++ int n - | StringValue s -> spc() ++ str s - | StringOptValue None -> mt() - | StringOptValue (Some s) -> spc() ++ str s - | BoolValue b -> mt() - in pr_printoption a None ++ pr_opt_value b + pr_printoption a None ++ (match b with + | OptionUnset | OptionSetTrue -> mt() + | OptionSetInt n -> spc() ++ int n + | OptionSetString s -> spc() ++ quote (str s)) let pr_opt_hintbases l = match l with | [] -> mt() @@ -1140,15 +1135,11 @@ open Pputils hov 1 (keyword "Strategy" ++ spc() ++ hv 0 (prlist_with_sep sep pr_line l)) ) - | VernacUnsetOption (export, na) -> - let export = if export then keyword "Export" ++ spc () else mt () in - return ( - hov 1 (export ++ keyword "Unset" ++ spc() ++ pr_printoption na None) - ) | VernacSetOption (export, na,v) -> let export = if export then keyword "Export" ++ spc () else mt () in + let set = if v == OptionUnset then "Unset" else "Set" in return ( - hov 2 (export ++ keyword "Set" ++ spc() ++ pr_set_option na v) + hov 2 (export ++ keyword set ++ spc() ++ pr_set_option na v) ) | VernacAddOption (na,l) -> return ( diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 526845084a..1d089d0a55 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -172,11 +172,12 @@ let value = ref None let using_to_string us = Pp.string_of_ppcmds (Ppvernac.pr_using us) let using_from_string us = Pcoq.Entry.parse G_vernac.section_subset_expr (Pcoq.Parsable.make (Stream.of_string us)) +let proof_using_opt_name = ["Default";"Proof";"Using"] let () = Goptions.(declare_stringopt_option { optdepr = false; optname = "default value for Proof using"; - optkey = ["Default";"Proof";"Using"]; + optkey = proof_using_opt_name; optread = (fun () -> Option.map using_to_string !value); optwrite = (fun b -> value := Option.map using_from_string b); }) diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index 7d1110aaa2..702043a4a9 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -21,3 +21,6 @@ val suggest_constant : Environ.env -> Names.Constant.t -> unit val suggest_variable : Environ.env -> Names.Id.t -> unit val get_default_proof_using : unit -> Vernacexpr.section_subset_expr option + +val proof_using_opt_name : string list +(** For the stm *) diff --git a/vernac/record.ml b/vernac/record.ml index cb67548667..74e5a03659 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -30,6 +30,7 @@ open Constrexpr open Constrexpr_ops open Goptions open Context.Rel.Declaration +open Libobject module RelDecl = Context.Rel.Declaration @@ -373,6 +374,27 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f open Typeclasses +let load_structure i (_, structure) = + Recordops.register_structure (Global.env()) structure + +let cache_structure o = + load_structure 1 o + +let subst_structure (subst, (id, kl, projs as obj)) = + Recordops.subst_structure subst obj + +let discharge_structure (_, x) = Some x + +let inStruc : Recordops.struc_tuple -> obj = + declare_object {(default_object "STRUCTURE") with + cache_function = cache_structure; + load_function = load_structure; + subst_function = subst_structure; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_structure } + +let declare_structure_entry o = + Lib.add_anonymous_leaf (inStruc o) let declare_structure ~cum finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data = let nparams = List.length params in @@ -443,7 +465,7 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in let build = ConstructRef cstr in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in - let () = Recordops.declare_structure(cstr, List.rev kinds, List.rev sp_projs) in + let () = declare_structure_entry (cstr, List.rev kinds, List.rev sp_projs) in rsp in List.mapi map record_data @@ -520,8 +542,10 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity List.map map inds in let ctx_context = + let env = Global.env () in + let sigma = Evd.from_env env in List.map (fun decl -> - match Typeclasses.class_of_constr Evd.empty (EConstr.of_constr (RelDecl.get_type decl)) with + match Typeclasses.class_of_constr env sigma (EConstr.of_constr (RelDecl.get_type decl)) with | Some (_, ((cl,_), _)) -> Some cl.cl_impl | None -> None) params, params @@ -548,12 +572,14 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity cl_props = fields; cl_projs = projs } in - add_class k; impl + let env = Global.env () in + let sigma = Evd.from_env env in + Classes.add_class env sigma k; impl in List.map map data -let add_constant_class env cst = +let add_constant_class env sigma cst = let ty, univs = Typeops.type_of_global_in_context env (ConstRef cst) in let r = (Environ.lookup_constant cst env).const_relevance in let ctx, arity = decompose_prod_assum ty in @@ -566,10 +592,11 @@ let add_constant_class env cst = cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } - in add_class tc; + in + Classes.add_class env sigma tc; set_typeclass_transparency (EvalConstRef cst) false false - -let add_inductive_class env ind = + +let add_inductive_class env sigma ind = let mind, oneind = Inductive.lookup_mind_specif env ind in let k = let ctx = oneind.mind_arity_ctxt in @@ -586,7 +613,8 @@ let add_inductive_class env ind = cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } - in add_class k + in + Classes.add_class env sigma k let warn_already_existing_class = CWarnings.create ~name:"already-existing-class" ~category:"automation" Pp.(fun g -> @@ -594,11 +622,12 @@ let warn_already_existing_class = let declare_existing_class g = let env = Global.env () in + let sigma = Evd.from_env env in if Typeclasses.is_class g then warn_already_existing_class g else match g with - | ConstRef x -> add_constant_class env x - | IndRef x -> add_inductive_class env x + | ConstRef x -> add_constant_class env sigma x + | IndRef x -> add_inductive_class env sigma x | _ -> user_err ~hdr:"declare_existing_class" (Pp.str"Unsupported class type, only constants and inductives are allowed") diff --git a/vernac/record.mli b/vernac/record.mli index 9852840d12..12a2a765b5 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -24,6 +24,8 @@ val declare_projections : Constr.rel_context -> (Name.t * bool) list * Constant.t option list +val declare_structure_entry : Recordops.struc_tuple -> unit + val definition_structure : universe_decl_expr option -> inductive_kind -> template:bool option -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index ce93a8baaf..7f5c265eea 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -12,6 +12,7 @@ Vernacextend Ppvernac Proof_using Lemmas +Canonical Class Egramcoq Metasyntax @@ -21,11 +22,11 @@ Indschemes DeclareDef Obligations ComDefinition +Classes ComAssumption ComInductive ComFixpoint ComProgramFixpoint -Classes Record Assumptions Vernacstate diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 02db75c0f9..3a305c3b61 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -572,7 +572,7 @@ let vernac_definition_hook p = function | Coercion -> Some (Class.add_coercion_hook p) | CanonicalStructure -> - Some (Lemmas.mk_hook (fun _ _ _ -> Recordops.declare_canonical_structure)) + Some (Lemmas.mk_hook (fun _ _ _ -> Canonical.declare_canonical_structure)) | SubClass -> Some (Class.add_subclass_hook p) | _ -> None @@ -1041,7 +1041,7 @@ let vernac_require from import qidl = (* Coercions and canonical structures *) let vernac_canonical r = - Recordops.declare_canonical_structure (smart_global r) + Canonical.declare_canonical_structure (smart_global r) let vernac_coercion ~atts ref qids qidt = let local, polymorphic = Attributes.(parse Notations.(locality ++ polymorphic) atts) in @@ -1075,7 +1075,7 @@ let vernac_declare_instance ~atts sup inst pri = Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri let vernac_context ~pstate ~poly l = - if not (Classes.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom + if not (ComAssumption.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_existing_instance ~section_local insts = let glob = not section_local in @@ -1096,7 +1096,10 @@ let focus_command_cond = Proof.no_cond command_focus there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) -let vernac_solve_existential ~pstate i e = Pfedit.instantiate_nth_evar_com i e pstate +let vernac_solve_existential ~pstate n com = + Proof_global.simple_with_current_proof (fun _ p -> + let intern env sigma = Constrintern.intern_constr env sigma com in + Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in @@ -1704,18 +1707,17 @@ let get_option_locality export local = let vernac_set_option0 ~local export key opt = let locality = get_option_locality export local in match opt with - | StringValue s -> set_string_option_value_gen ~locality key s - | StringOptValue (Some s) -> set_string_option_value_gen ~locality key s - | StringOptValue None -> unset_option_value_gen ~locality key - | IntValue n -> set_int_option_value_gen ~locality key n - | BoolValue b -> set_bool_option_value_gen ~locality key b + | OptionUnset -> unset_option_value_gen ~locality key + | OptionSetString s -> set_string_option_value_gen ~locality key s + | OptionSetInt n -> set_int_option_value_gen ~locality key (Some n) + | OptionSetTrue -> set_bool_option_value_gen ~locality key true let vernac_set_append_option ~local export key s = let locality = get_option_locality export local in set_string_option_append_value_gen ~locality key s let vernac_set_option ~local export table v = match v with -| StringValue s -> +| OptionSetString s -> (* We make a special case for warnings because appending is their natural semantics *) if CString.List.equal table ["Warnings"] then @@ -1728,10 +1730,6 @@ let vernac_set_option ~local export table v = match v with vernac_set_option0 ~local export table v | _ -> vernac_set_option0 ~local export table v -let vernac_unset_option ~local export key = - let locality = get_option_locality export local in - unset_option_value_gen ~locality key - let vernac_add_option key lv = let f = function | StringRefValue s -> (get_string_table key)#add s @@ -2459,9 +2457,6 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = | VernacSetOption (export, key,v) -> vernac_set_option ~local:(only_locality atts) export key v; pstate - | VernacUnsetOption (export, key) -> - vernac_unset_option ~local:(only_locality atts) export key; - pstate | VernacRemoveOption (key,v) -> unsupported_attributes atts; vernac_remove_option key v; diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index ebfc473522..d0dae1aa53 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -109,11 +109,11 @@ type onlyparsing_flag = Flags.compat_version option which this notation is trying to be compatible with *) type locality_flag = bool (* true = Local *) -type option_value = Goptions.option_value = - | BoolValue of bool - | IntValue of int option - | StringValue of string - | StringOptValue of string option +type option_setting = + | OptionUnset + | OptionSetTrue + | OptionSetInt of int + | OptionSetString of string type option_ref_value = | StringRefValue of string @@ -129,7 +129,7 @@ type definition_expr = * constr_expr option type fixpoint_expr = - ident_decl * (lident option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option + ident_decl * recursion_order_expr option * local_binder_expr list * constr_expr * constr_expr option type cofixpoint_expr = ident_decl * local_binder_expr list * constr_expr * constr_expr option @@ -363,8 +363,7 @@ type nonrec vernac_expr = | VernacSetOpacity of (Conv_oracle.level * qualid or_by_notation list) | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list - | VernacUnsetOption of export_flag * Goptions.option_name - | VernacSetOption of export_flag * Goptions.option_name * option_value + | VernacSetOption of export_flag * Goptions.option_name * option_setting | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list |