diff options
155 files changed, 2090 insertions, 1801 deletions
diff --git a/.bintray.json b/.bintray.json deleted file mode 100644 index 1b32a144c8..0000000000 --- a/.bintray.json +++ /dev/null @@ -1,20 +0,0 @@ -{ - "package": { - "name": "coq", - "repo": "coq", - "subject": "coq" - }, - - "version": { - "name": "8.10+alpha" - }, - - "files": - [ - {"includePattern": "_build/(.*\\.dmg)", "uploadPattern": "$1", - "matrixParams": { - "override": 1 } - } - ], - "publish": true -} diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7ebc2d8a4d..f434b63d74 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -4,6 +4,7 @@ stages: - docker - build - test + - deploy # some default values variables: @@ -321,7 +322,7 @@ pkg:nix:deploy: url: https://coq.cachix.org before_script: # Install Cachix as documented at https://github.com/cachix/cachix - - nix-env -iA cachix -f https://cachix.org/api/v1/install + - nix-env -iA cachix --prebuilt-only -f https://cachix.org/api/v1/install only: - master - /^v.*\..*$/ @@ -347,6 +348,37 @@ doc:refman:dune: paths: - _build/default/doc/sphinx_build/html +doc:refman:deploy: + stage: deploy + environment: + name: deployment + url: https://coq.github.io/ + only: + variables: + - $DOCUMENTATION_DEPLOY_KEY + dependencies: + - doc:refman + before_script: + - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) + - eval $(ssh-agent -s) + - echo "$DOCUMENTATION_DEPLOY_KEY" | tr -d '\r' | ssh-add - > /dev/null + - mkdir -p ~/.ssh + - chmod 700 ~/.ssh + - ssh-keyscan -t rsa github.com >> ~/.ssh/known_hosts + - git config --global user.name "coqbot" + - git config --global user.email "coqbot@users.noreply.github.com" + script: + - git clone git@github.com:coq/doc.git _deploy + - rm -rf _deploy/$CI_COMMIT_REF_NAME/refman + - rm -rf _deploy/$CI_COMMIT_REF_NAME/stdlib + - mkdir -p _deploy/$CI_COMMIT_REF_NAME + - cp -rv _install_ci/share/doc/coq/sphinx/html _deploy/$CI_COMMIT_REF_NAME/refman + - cp -rv _install_ci/share/doc/coq/html/stdlib _deploy/$CI_COMMIT_REF_NAME/stdlib + - cd _deploy/$CI_COMMIT_REF_NAME/ + - git add refman stdlib + - git commit -m "Documentation of branch “$CI_COMMIT_REF_NAME” at $CI_COMMIT_SHORT_SHA" + - git push # TODO: rebase and retry on failure + doc:ml-api:odoc: <<: *dune-ci-template variables: @@ -492,7 +524,6 @@ validate:quick: library:ci-bedrock2: <<: *ci-template - allow_failure: true library:ci-color: <<: *ci-template-flambda @@ -565,7 +596,7 @@ plugin:ci-elpi: plugin:ci-equations: <<: *ci-template -plugin:ci-fiat-parsers: +plugin:ci-fiat_parsers: <<: *ci-template plugin:ci-ltac2: diff --git a/CHANGES.md b/CHANGES.md index 1a0b53f84a..26573b9185 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -126,6 +126,10 @@ Vernacular commands class will have to be changed into `Instance foo : C := {}.` or `Instance foo : C. Proof. Qed.`. +- Option `Program Mode` now means that the `Program` attribute is enabled + for all commands that support it. In particular, it does not have any effect + on tactics anymore. May cause some incompatibilities. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: diff --git a/Makefile.build b/Makefile.build index 26e2819990..ca988aaac2 100644 --- a/Makefile.build +++ b/Makefile.build @@ -239,6 +239,10 @@ OPT:= BESTOBJ:=.cmo BESTLIB:=.cma BESTDYN:=.cma + +# needed while booting if non -local +CAML_LD_LIBRARY_PATH := $(PWD)/kernel/byterun:$(CAML_LD_LIBRARY_PATH) +export CAML_LD_LIBRARY_PATH endif define bestobj @@ -350,12 +354,12 @@ kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_x86.ml kernel/uint63_amd6 .PHONY: coqbinaries coqbyte -coqbinaries: $(TOPBINOPT) $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) -coqbyte: $(TOPBYTE) $(CHICKENBYTE) +coqbinaries: $(TOPBIN) $(COQC) $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) +coqbyte: $(TOPBYTE) $(COQCBYTE) $(CHICKENBYTE) # Special rule for coqtop, we imitate `ocamlopt` can delete the target # to avoid #7666 -$(COQTOPEXE): $(TOPBINOPT:.opt=.$(BEST)) +$(COQTOPEXE): $(TOPBIN) rm -f $@ && cp $< $@ $(COQC): $(COQCOPT:.opt=.$(BEST)) @@ -380,12 +384,12 @@ COQTOP_BYTE=topbin/coqtop_byte_bin.ml # Special rule for coqtop.byte # VMBYTEFLAGS will either contain -custom of the right -dllpath for the VM -$(COQTOPBYTE): $(LINKCMO) $(LIBCOQRUN) $(COQTOP_BYTE) +$(COQTOPBYTE): $(COQTOP_BYTE) $(LINKCMO) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLC) -linkall -linkpkg -I lib -I vernac -I toplevel \ -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ $(SYSMOD) -package compiler-libs.toplevel \ - $(LINKCMO) $(BYTEFLAGS) $(COQTOP_BYTE) -o $@ + $(LINKCMO) $(BYTEFLAGS) $< -o $@ ########################################################################### # other tools @@ -501,7 +505,7 @@ $(COQWORKMGRBYTE): $(COQWORKMGRCMO) FAKEIDECMO:=config/config.cma clib/clib.cma lib/lib.cma ide/protocol/ideprotocol.cma ide/document.cmo ide/fake_ide.cmo -$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOP) +$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPEXE) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I ide -I ide/protocol -package str -package dynlink) diff --git a/Makefile.ci b/Makefile.ci index b8bff98f5f..0307d39d54 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -25,7 +25,7 @@ CI_TARGETS= \ ci-fcsl-pcm \ ci-fiat-crypto \ ci-fiat-crypto-legacy \ - ci-fiat-parsers \ + ci-fiat_parsers \ ci-flocq \ ci-geocoq \ ci-coqhammer \ diff --git a/Makefile.common b/Makefile.common index 8292158ef8..bd0e19cd00 100644 --- a/Makefile.common +++ b/Makefile.common @@ -75,10 +75,12 @@ endif # for Declare ML Module files. ifeq ($(BEST),opt) +TOPBIN:=$(TOPBINOPT) COQTOPBEST:=$(COQTOPEXE) DYNOBJ:=.cmxs DYNLIB:=.cmxs else +TOPBIN:=$(TOPBYTE) COQTOPBEST:=$(COQTOPBYTE) DYNOBJ:=.cmo DYNLIB:=.cma diff --git a/Makefile.doc b/Makefile.doc index 7ac710b8c9..4b2dd8ed4d 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -54,6 +54,7 @@ DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex doc: refman stdlib +SPHINX_DEPS ?= ifndef QUICK SPHINX_DEPS := coq endif diff --git a/Makefile.dune b/Makefile.dune index 78ecc4b056..e3a8a30bc2 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -91,9 +91,9 @@ ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all trunk: - dune build $(DUNEOPT) --profile=ocaml408 @vodeps + dune build $(DUNEOPT) --profile=ocaml409 @vodeps dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d - dune build $(DUNEOPT) --profile=ocaml408 coq.install coqide-server.install + dune build $(DUNEOPT) --profile=ocaml409 coq.install coqide-server.install ireport: dune clean diff --git a/Makefile.install b/Makefile.install index b6e2ec2aeb..5b5e548f9c 100644 --- a/Makefile.install +++ b/Makefile.install @@ -68,7 +68,7 @@ endif install-binaries: install-tools $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQC) $(CHICKEN) $(COQTOPEXE) $(TOPBINOPT) $(FULLBINDIR) + $(INSTALLBIN) $(COQC) $(CHICKEN) $(COQTOPEXE) $(TOPBIN) $(FULLBINDIR) install-byte: install-coqide-byte $(MKDIR) $(FULLBINDIR) @@ -100,18 +100,15 @@ INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% \ configure.cmx toplevel/coqtop_byte_bin.cmx plugins/extraction/big.cmx, \ $(filter %.cmx, $(GRAMMLFILES:.ml=.cmx)) $(MLFILES:.ml=.cmx))) -foo: - @echo $(INSTALLCMX) - install-devfiles: $(MKDIR) $(FULLBINDIR) $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) # Regular CMI files + $(INSTALLSH) $(FULLCOQLIB) $(TOOLS_HELPERS) +ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMX) # To avoid warning 58 "-opaque" $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.cmx) # For static linking of plugins $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.o) # For static linking of plugins - $(INSTALLSH) $(FULLCOQLIB) $(TOOLS_HELPERS) -ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) endif diff --git a/Makefile.vofiles b/Makefile.vofiles index d5217ef4b7..a71d68e565 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -42,7 +42,10 @@ GLOBFILES:=$(ALLVO:.$(VO)=.glob) endif ifdef NATIVECOMPUTE -NATIVEFILES := $(call vo_to_cm,$(ALLVO)) $(call vo_to_obj,$(ALLVO)) +NATIVEFILES := $(call vo_to_cm,$(ALLVO)) +ifeq ($(BEST),opt) +NATIVEFILES += $(call vo_to_obj,$(ALLVO)) +endif else NATIVEFILES := endif @@ -50,5 +53,5 @@ LIBFILES:=$(ALLVO:.$(VO)=.vo) $(NATIVEFILES) $(VFILES) $(GLOBFILES) # For emacs: # Local Variables: -# mode: makefile +# mode: makefile-gmake # End: @@ -93,10 +93,12 @@ To be effective, bug reports should mention the OCaml version used to compile and run Coq, the Coq version (`coqtop -v`), the configuration used, and include a complete source example leading to the bug. -## Contributing +## Contributing to Coq Guidelines for contributing to Coq in various ways are listed in the [contributor's guide](CONTRIBUTING.md). +Information about the next release is at https://github.com/coq/coq/wiki/Release-Plan + ## Supporting Coq Help the Coq community grow and prosper by becoming a sponsor! The [Coq diff --git a/checker/checker.ml b/checker/checker.ml index d97ab5409e..af8d1e5617 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -319,6 +319,8 @@ let explain_exn = function let deprecated flag = Feedback.msg_warning (str "Deprecated flag " ++ quote (str flag)) +let boot_opt = ref false + let parse_args argv = let rec parse = function | [] -> () @@ -348,14 +350,14 @@ let parse_args argv = | "-debug" :: rem -> set_debug (); parse rem | "-where" :: _ -> - Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); + Envars.set_coqlib ~boot:!boot_opt ~fail:(fun x -> CErrors.user_err Pp.(str x)); print_endline (Envars.coqlib ()); exit 0 | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> version () - | "-boot" :: rem -> Flags.boot := true; parse rem + | "-boot" :: rem -> boot_opt := true; parse rem | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem @@ -384,7 +386,7 @@ let init_with_argv argv = try parse_args argv; if !Flags.debug then Printexc.record_backtrace true; - Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); + Envars.set_coqlib ~boot:!boot_opt ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); init_load_path (); make_senv () diff --git a/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 5205946261..2ac78d3c2b 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && make ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat_parsers.sh index ac74ebf667..ac74ebf667 100755 --- a/dev/ci/ci-fiat-parsers.sh +++ b/dev/ci/ci-fiat_parsers.sh diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 277e9ee08f..94e0a666e2 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -39,11 +39,21 @@ let corn = (coqPackages.corn.override { inherit coq bignums math-classes; }) src = fetchTarball "https://github.com/coq-community/corn/archive/master.tar.gz"; }); in +let stdpp = coqPackages.stdpp.overrideAttrs (o: { + src = fetchTarball "https://gitlab.mpi-sws.org/iris/stdpp/-/archive/master/stdpp-master.tar.bz2"; + }); in + +let iris = (coqPackages.iris.override { inherit coq stdpp; }) + .overrideAttrs (o: { + src = fetchTarball "https://gitlab.mpi-sws.org/iris/iris/-/archive/master/iris-master.tar.bz2"; + propagatedBuildInputs = [ stdpp ]; + }); in + let unicoq = callPackage ./unicoq { inherit coq; }; in let callPackage = newScope { inherit coq - bignums coq-ext-lib coqprime corn math-classes - mathcomp simple-io ssreflect unicoq; + bignums coq-ext-lib coqprime corn iris math-classes + mathcomp simple-io ssreflect stdpp unicoq; }; in # Environments for building CI libraries with this Coq @@ -62,6 +72,8 @@ let projects = { formal-topology = callPackage ./formal-topology.nix {}; GeoCoq = callPackage ./GeoCoq.nix {}; HoTT = callPackage ./HoTT.nix {}; + iris = callPackage ./iris.nix {}; + lambda-rust = callPackage ./lambda-rust.nix {}; math_classes = callPackage ./math_classes.nix {}; mathcomp = {}; mtac2 = callPackage ./mtac2.nix {}; diff --git a/dev/ci/nix/iris.nix b/dev/ci/nix/iris.nix new file mode 100644 index 0000000000..b55cccc7c6 --- /dev/null +++ b/dev/ci/nix/iris.nix @@ -0,0 +1,4 @@ +{ stdpp }: +{ + coqBuildInputs = [ stdpp ]; +} diff --git a/dev/ci/nix/lambda-rust.nix b/dev/ci/nix/lambda-rust.nix new file mode 100644 index 0000000000..0d07c3028a --- /dev/null +++ b/dev/ci/nix/lambda-rust.nix @@ -0,0 +1,4 @@ +{ iris }: +{ + coqBuildInputs = [ iris ]; +} diff --git a/dev/ci/nix/unicoq/META b/dev/ci/nix/unicoq/META deleted file mode 100644 index 30dd8b5559..0000000000 --- a/dev/ci/nix/unicoq/META +++ /dev/null @@ -1,2 +0,0 @@ -archive(native) = "unicoq.cmxa" -plugin(native) = "unicoq.cmxs" diff --git a/dev/ci/nix/unicoq/default.nix b/dev/ci/nix/unicoq/default.nix index 36f40dbe33..54c67ac0fd 100644 --- a/dev/ci/nix/unicoq/default.nix +++ b/dev/ci/nix/unicoq/default.nix @@ -1,4 +1,10 @@ -{ stdenv, coq }: +{ stdenv, writeText, coq }: + +let META = writeText "META" '' + archive(native) = "unicoq.cmxa" + plugin(native) = "unicoq.cmxs" +''; in + stdenv.mkDerivation { name = "coq${coq.coq-version}-unicoq-0.0-git"; @@ -12,8 +18,9 @@ stdenv.mkDerivation { installFlags = [ "COQLIB=$(out)/lib/coq/${coq.coq-version}/" ]; postInstall = '' + cp ${META} META install -d $OCAMLFIND_DESTDIR ln -s $out/lib/coq/${coq.coq-version}/user-contrib/Unicoq $OCAMLFIND_DESTDIR/ - install -m 0644 ${./META} src/unicoq.a $OCAMLFIND_DESTDIR/Unicoq + install -m 0644 META src/unicoq.a $OCAMLFIND_DESTDIR/Unicoq ''; } diff --git a/dev/ci/user-overlays/06914-maximedenes-primitive-integers.sh b/dev/ci/user-overlays/06914-maximedenes-primitive-integers.sh deleted file mode 100644 index 6e89741e29..0000000000 --- a/dev/ci/user-overlays/06914-maximedenes-primitive-integers.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6914" ] || [ "$CI_BRANCH" = "primitive-bool-list" ]; then - - bignums_CI_REF=primitive-integers - bignums_CI_GITURL=https://github.com/vbgl/bignums - - mtac2_CI_REF=primitive-integers - mtac2_CI_GITURL=https://github.com/vbgl/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09102-ejgallego-ltac+remove_aliases.sh b/dev/ci/user-overlays/09102-ejgallego-ltac+remove_aliases.sh deleted file mode 100644 index 2df8affd14..0000000000 --- a/dev/ci/user-overlays/09102-ejgallego-ltac+remove_aliases.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9102" ] || [ "$CI_BRANCH" = "ltac+remove_aliases" ]; then - - elpi_CI_REF=ltac+remove_aliases - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh b/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh deleted file mode 100644 index f2a113b118..0000000000 --- a/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9150" ] || [ "$CI_BRANCH" = "build+warn_50" ]; then - - mtac2_CI_REF=build+warn_50 - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh b/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh deleted file mode 100644 index f532fdfc52..0000000000 --- a/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9172" ] || [ "$CI_BRANCH" = "proof_rework" ]; then - - ltac2_CI_REF=proof_rework - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - mtac2_CI_REF=proof_rework - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh b/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh new file mode 100644 index 0000000000..23eb24c304 --- /dev/null +++ b/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9173" ] || [ "$CI_BRANCH" = "proofview+proof_info" ]; then + + ltac2_CI_REF=proofview+proof_info + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + fiat_parsers_CI_REF=proofview+proof_info + fiat_parsers_CI_GITURL=https://github.com/ejgallego/fiat + +fi diff --git a/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh b/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh deleted file mode 100644 index efcdd2e97f..0000000000 --- a/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9220" ] || [ "$CI_BRANCH" = "stm-shallow-logic" ]; then - - paramcoq_CI_REF=stm-shallow-logic - paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq - -fi diff --git a/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh b/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh deleted file mode 100644 index ebd1b524da..0000000000 --- a/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9263" ] || [ "$CI_BRANCH" = "parsing-state" ]; then - - mtac2_CI_REF=proof-mode - mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 - - ltac2_CI_REF=proof-mode - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - equations_CI_REF=proof-mode - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/core_dune.dbg b/dev/core_dune.dbg index cf9c5bd39a..4e1035f7b6 100644 --- a/dev/core_dune.dbg +++ b/dev/core_dune.dbg @@ -1,10 +1,10 @@ load_printer threads.cma load_printer str.cma -load_printer gramlib.cma load_printer config.cma load_printer clib.cma load_printer dynlink.cma load_printer lib.cma +load_printer gramlib.cma load_printer byterun.cma load_printer kernel.cma load_printer library.cma diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index d05b6c8eef..60c0886896 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -92,7 +92,11 @@ ### These steps are the same for all releases (beta, final, patch-level) ### - [ ] Send an e-mail on Coqdev announcing that the tag has been put so that - package managers can start preparing package updates. + package managers can start preparing package updates (including a + `coq-bignums` compatible version). +- [ ] Ping **@erikmd** to update the Docker images in `coqorg/coq` + (requires `coq-bignums` in `extra-dev` for a beta / in `released` + for a final release). - [ ] Draft a release on GitHub. - [ ] Get **@maximedenes** to sign the Windows and MacOS packages and upload them on GitHub. diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 5eac3e2b9c..4d874cdd12 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -161,6 +161,7 @@ val ppobj : Libobject.obj -> unit val cast_kind_display : Constr.cast_kind -> string val constr_display : Constr.constr -> unit val print_pure_constr : Constr.types -> unit +val print_pure_econstr : EConstr.types -> unit val pploc : Loc.t -> unit diff --git a/doc/README.md b/doc/README.md index c41d269437..b784fe92f6 100644 --- a/doc/README.md +++ b/doc/README.md @@ -9,8 +9,10 @@ The Coq documentation includes The documentation of the latest released version is available on the Coq web site at [coq.inria.fr/documentation](http://coq.inria.fr/documentation). -Additionally, you can view the documentation for the current master version at -<https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman>. +Additionally, you can view the reference manual for the development version +at <https://coq.github.io/doc/master/refman/>, and the documentation of the +standard library for the development version at +<https://coq.github.io/doc/master/stdlib/>. The reference manual is written is reStructuredText and compiled using Sphinx. See [`sphinx/README.rst`](sphinx/README.rst) diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 7b8a86d1ab..d77690458d 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -59,7 +59,7 @@ pattern matching. Consider for example the function that computes the maximum of two natural numbers. We can write it in primitive syntax by: -.. coqtop:: in undo +.. coqtop:: in Fixpoint max (n m:nat) {struct m} : nat := match n with @@ -75,7 +75,7 @@ Multiple patterns Using multiple patterns in the definition of ``max`` lets us write: -.. coqtop:: in undo +.. coqtop:: in reset Fixpoint max (n m:nat) {struct m} : nat := match n, m with @@ -103,7 +103,7 @@ Aliasing subpatterns We can also use :n:`as @ident` to associate a name to a sub-pattern: -.. coqtop:: in undo +.. coqtop:: in reset Fixpoint max (n m:nat) {struct n} : nat := match n, m with @@ -128,18 +128,22 @@ Here is now an example of nested patterns: This is compiled into: -.. coqtop:: all undo +.. coqtop:: all Unset Printing Matching. Print even. +.. coqtop:: none + + Set Printing Matching. + In the previous examples patterns do not conflict with, but sometimes it is comfortable to write patterns that admit a non trivial superposition. Consider the boolean function :g:`lef` that given two natural numbers yields :g:`true` if the first one is less or equal than the second one and :g:`false` otherwise. We can write it as follows: -.. coqtop:: in undo +.. coqtop:: in Fixpoint lef (n m:nat) {struct m} : bool := match n, m with @@ -158,7 +162,7 @@ is matched by the first pattern, and so :g:`(lef O O)` yields true. Another way to write this function is: -.. coqtop:: in +.. coqtop:: in reset Fixpoint lef (n m:nat) {struct m} : bool := match n, m with @@ -191,7 +195,7 @@ Multiple patterns that share the same right-hand-side can be factorized using the notation :n:`{+| @mult_pattern}`. For instance, :g:`max` can be rewritten as follows: -.. coqtop:: in undo +.. coqtop:: in reset Fixpoint max (n m:nat) {struct m} : nat := match n, m with @@ -269,7 +273,7 @@ When we use parameters in patterns there is an error message: Set Asymmetric Patterns. Check (fun l:List nat => match l with - | nil => nil + | nil => nil _ | cons _ l' => l' end). Unset Asymmetric Patterns. @@ -325,7 +329,7 @@ Understanding dependencies in patterns We can define the function length over :g:`listn` by: -.. coqtop:: in +.. coqdoc:: Definition length (n:nat) (l:listn n) := n. @@ -367,6 +371,10 @@ different types and we need to provide the elimination predicate: | consn n' a y => consn (n' + m) a (concat n' y m l') end. +.. coqtop:: none + + Reset concat. + The elimination predicate is :g:`fun (n:nat) (l:listn n) => listn (n+m)`. In general if :g:`m` has type :g:`(I q1 … qr t1 … ts)` where :g:`q1, …, qr` are parameters, the elimination predicate should be of the form :g:`fun y1 … ys x : (I q1 … qr y1 … ys ) => Q`. @@ -503,7 +511,7 @@ can also be caught in the matching. .. example:: - .. coqtop:: in + .. coqtop:: in reset Inductive list : nat -> Set := | nil : list 0 diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index b606fb4dd2..cc788b3595 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -121,7 +121,7 @@ parameters is any term :math:`f \, t_1 \ldots t_n`. morphism parametric over ``A`` that respects the relation instance ``(set_eq A)``. The latter condition is proved by showing: - .. coqtop:: in + .. coqdoc:: forall (A: Type) (S1 S1' S2 S2': list A), set_eq A S1 S1' -> @@ -205,7 +205,7 @@ Adding new relations and morphisms For Leibniz equality, we may declare: - .. coqtop:: in + .. coqdoc:: Add Parametric Relation (A : Type) : A (@eq A) [reflexivity proved by @refl_equal A] @@ -274,7 +274,7 @@ following command. (maximally inserted) implicit arguments. If ``A`` is always set as maximally implicit in the previous example, one can write: - .. coqtop:: in + .. coqdoc:: Add Parametric Relation A : (set A) eq_set reflexivity proved by eq_set_refl @@ -282,13 +282,8 @@ following command. transitivity proved by eq_set_trans as eq_set_rel. - .. coqtop:: in - Add Parametric Morphism A : (@union A) with signature eq_set ==> eq_set ==> eq_set as union_mor. - - .. coqtop:: in - Proof. exact (@union_compat A). Qed. We proceed now by proving a simple lemma performing a rewrite step and @@ -300,7 +295,7 @@ following command. .. coqtop:: in Goal forall (S : set nat), - eq_set (union (union S empty) S) (union S S). + eq_set (union (union S (empty nat)) S) (union S S). .. coqtop:: in @@ -486,7 +481,7 @@ registered as parametric relations and morphisms. .. example:: First class setoids - .. coqtop:: in + .. coqtop:: in reset Require Import Relation_Definitions Setoid. @@ -623,6 +618,10 @@ declared as morphisms in the ``Classes.Morphisms_Prop`` module. For example, to declare that universal quantification is a morphism for logical equivalence: +.. coqtop:: none + + Require Import Morphisms. + .. coqtop:: in Instance all_iff_morphism (A : Type) : @@ -632,6 +631,10 @@ logical equivalence: Proof. simpl_relation. +.. coqtop:: none + + Abort. + One then has to show that if two predicates are equivalent at every point, their universal quantifications are equivalent. Once we have declared such a morphism, it will be used by the setoid rewriting @@ -650,7 +653,7 @@ functional arguments (or whatever subrelation of the pointwise extension). For example, one could declare the ``map`` combinator on lists as a morphism: -.. coqtop:: in +.. coqdoc:: Instance map_morphism `{Equivalence A eqA, Equivalence B eqB} : Proper ((eqA ==> eqB) ==> list_equiv eqA ==> list_equiv eqB) (@map A B). diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index e5b41be691..d15aacad44 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -37,7 +37,7 @@ In addition to these user-defined classes, we have two built-in classes: * ``Funclass``, the class of functions; its objects are all the terms with a functional type, i.e. of form :g:`forall x:A,B`. -Formally, the syntax of a classes is defined as: +Formally, the syntax of classes is defined as: .. productionlist:: class: `qualid` @@ -289,7 +289,7 @@ by extending the existing :cmd:`Record` macro. Its new syntax is: The first identifier :token:`ident` is the name of the defined record and :token:`sort` is its type. The optional identifier after ``:=`` is the name - of the constuctor (it will be :n:`Build_@ident` if not given). + of the constructor (it will be :n:`Build_@ident` if not given). The other identifiers are the names of the fields, and :token:`term` are their respective types. If ``:>`` is used instead of ``:`` in the declaration of a field, then the name of this field is automatically @@ -365,7 +365,7 @@ We first give an example of coercion between atomic inductive types .. warning:: - Note that ``Check true=O`` would fail. This is "normal" behavior of + Note that ``Check (true = O)`` would fail. This is "normal" behavior of coercions. To validate ``true=O``, the coercion is searched from ``nat`` to ``bool``. There is none. diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index b076aac1ed..e56b36caad 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -124,7 +124,7 @@ and checked to be :math:`-1`. that :tacn:`omega` does not solve, such as the following so-called *omega nightmare* :cite:`TheOmegaPaper`. -.. coqtop:: in +.. coqdoc:: Goal forall x y, 27 <= 11 * x + 13 * y <= 45 -> @@ -234,7 +234,8 @@ proof by abstracting monomials by variables. To illustrate the working of the tactic, consider we wish to prove the following Coq goal: -.. coqtop:: all +.. needs csdp +.. coqdoc:: Require Import ZArith Psatz. Open Scope Z_scope. diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 8204d93fa7..20e4c6a3d6 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -197,7 +197,7 @@ be either Leibniz equality, or any relation declared as a setoid (see :ref:`tactics-enabled-on-user-provided-relations`). The definitions of ring and semiring (see module ``Ring_theory``) are: -.. coqtop:: in +.. coqdoc:: Record ring_theory : Prop := mk_rt { Radd_0_l : forall x, 0 + x == x; @@ -235,7 +235,7 @@ coefficients could be the rational numbers, upon which the ring operations can be implemented. The fact that there exists a morphism is defined by the following properties: -.. coqtop:: in +.. coqdoc:: Record ring_morph : Prop := mkmorph { morph0 : [cO] == 0; @@ -285,13 +285,14 @@ following property: .. coqtop:: in + Require Import Reals. Section POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Record power_theory : Prop := mkpow_th { - rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) + rpow_pow_N : forall r n, rpow r (Cp_phi n) = pow_N 1%R Rmult r n }. End POWER. @@ -422,7 +423,7 @@ The interested reader is strongly advised to have a look at the file ``Ring_polynom.v``. Here a type for polynomials is defined: -.. coqtop:: in +.. coqdoc:: Inductive PExpr : Type := | PEc : C -> PExpr @@ -437,7 +438,7 @@ file ``Ring_polynom.v``. Here a type for polynomials is defined: Polynomials in normal form are defined as: -.. coqtop:: in +.. coqdoc:: Inductive Pol : Type := | Pc : C -> Pol @@ -454,7 +455,7 @@ polynomial to an element of the concrete ring, and the second one that does the same for normal forms: -.. coqtop:: in +.. coqdoc:: Definition PEeval : list R -> PExpr -> R := [...]. @@ -465,7 +466,7 @@ A function to normalize polynomials is defined, and the big theorem is its correctness w.r.t interpretation, that is: -.. coqtop:: in +.. coqdoc:: Definition norm : PExpr -> Pol := [...]. Lemma Pphi_dev_ok : @@ -616,7 +617,7 @@ also supported. The equality can be either Leibniz equality, or any relation declared as a setoid (see :ref:`tactics-enabled-on-user-provided-relations`). The definition of fields and semifields is: -.. coqtop:: in +.. coqdoc:: Record field_theory : Prop := mk_field { F_R : ring_theory rO rI radd rmul rsub ropp req; @@ -636,7 +637,7 @@ fields and semifields is: The result of the normalization process is a fraction represented by the following type: -.. coqtop:: in +.. coqdoc:: Record linear : Type := mk_linear { num : PExpr C; @@ -690,7 +691,7 @@ for |Coq|’s type checker. Let us see why: x + 3 + y + y * z = x + 3 + y + z * y. intros; rewrite (Zmult_comm y z); reflexivity. Save foo. - Print foo. + Print foo. At each step of rewriting, the whole context is duplicated in the proof term. Then, a tactic that does hundreds of rewriting generates diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 04aedd0cf6..6b10b7c0b3 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -223,7 +223,7 @@ The following is an example of a record with non-trivial subtyping relation: E[Γ] ⊢ \mathsf{packType}@\{i\} =_{βδιζη} \mathsf{packType}@\{j\}~\mbox{ whenever }~i ≤ j -Cumulative inductive types, coninductive types, variants and records +Cumulative inductive types, coinductive types, variants and records only make sense when they are universe polymorphic. Therefore, an error is issued whenever the user uses the :g:`Cumulative` or :g:`NonCumulative` prefix in a monomorphic context. @@ -236,11 +236,11 @@ Consider the following examples. .. coqtop:: all reset - Monomorphic Cumulative Inductive Unit := unit. + Fail Monomorphic Cumulative Inductive Unit := unit. .. coqtop:: all reset - Monomorphic NonCumulative Inductive Unit := unit. + Fail Monomorphic NonCumulative Inductive Unit := unit. .. coqtop:: all reset diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 39047f4f23..9d2afc080f 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -28,7 +28,7 @@ from shutil import copyfile import sphinx # Increase recursion limit for sphinx -sys.setrecursionlimit(1500) +sys.setrecursionlimit(3000) # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index df6d433051..3ef88e6506 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -782,7 +782,7 @@ the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` Inductive even : nat -> Prop := | even_O : even 0 | even_S : forall n, odd n -> even (S n) - with odd : nat -> prop := + with odd : nat -> Prop := | odd_S : forall n, even n -> odd (S n). @@ -929,7 +929,7 @@ condition* for a constant :math:`X` in the following cases: Inductive nattree (A:Type) : Type := | leaf : nattree A - | node : A -> (nat -> nattree A) -> nattree A. + | natnode : A -> (nat -> nattree A) -> nattree A. Then every instantiated constructor of ``nattree A`` satisfies the nested positivity condition for ``nattree``: @@ -939,7 +939,7 @@ condition* for a constant :math:`X` in the following cases: type of that constructor (primarily because ``nattree`` does not have any (real) arguments) ... (bullet 1) - + Type ``A → (nat → nattree A) → nattree A`` of constructor ``node`` satisfies the + + Type ``A → (nat → nattree A) → nattree A`` of constructor ``natnode`` satisfies the positivity condition for ``nattree`` because: - ``nattree`` occurs only strictly positively in ``A`` ... (bullet 1) diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index b82b3b0e80..963242ea72 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -146,7 +146,7 @@ Propositional Connectives First, we find propositional calculus connectives: -.. coqtop:: in +.. coqdoc:: Inductive True : Prop := I. Inductive False : Prop := . @@ -236,7 +236,7 @@ Finally, a few easy lemmas are provided. single: eq_rect (term) single: eq_rect_r (term) -.. coqtop:: in +.. coqdoc:: Theorem absurd : forall A C:Prop, A -> ~ A -> C. Section equality. @@ -271,6 +271,10 @@ For instance ``f_equal3`` is defined the following way. (x1 y1:A1) (x2 y2:A2) (x3 y3:A3), x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3. +.. coqtop:: none + + Abort. + .. _datatypes: Datatypes @@ -465,7 +469,7 @@ Intuitionistic Type Theory. single: Choice2 (term) single: bool_choice (term) -.. coqtop:: in +.. coqdoc:: Lemma Choice : forall (S S':Set) (R:S -> S' -> Prop), @@ -506,7 +510,7 @@ realizability interpretation. single: absurd_set (term) single: and_rect (term) -.. coqtop:: in +.. coqdoc:: Definition except := False_rec. Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C. @@ -531,7 +535,7 @@ section :tacn:`refine`). This scope is opened by default. The following example is not part of the standard library, but it shows the usage of the notations: - .. coqtop:: in + .. coqtop:: in reset Fixpoint even (n:nat) : bool := match n with @@ -558,7 +562,7 @@ section :tacn:`refine`). This scope is opened by default. Now comes the content of module ``Peano``: -.. coqtop:: in +.. coqdoc:: Theorem eq_S : forall x y:nat, x = y -> S x = S y. Definition pred (n:nat) : nat := @@ -610,7 +614,7 @@ Finally, it gives the definition of the usual orderings ``le``, Inductive le (n:nat) : nat -> Prop := | le_n : le n n - | le_S : forall m:nat, n <= m -> n <= (S m). + | le_S : forall m:nat, n <= m -> n <= (S m) where "n <= m" := (le n m) : nat_scope. Definition lt (n m:nat) := S n <= m. Definition ge (n m:nat) := m <= n. @@ -625,7 +629,7 @@ induction principle. single: nat_case (term) single: nat_double_ind (term) -.. coqtop:: in +.. coqdoc:: Theorem nat_case : forall (n:nat) (P:nat -> Prop), @@ -652,7 +656,7 @@ well-founded induction, in module ``Wf.v``. single: Acc_rect (term) single: well_founded (term) -.. coqtop:: in +.. coqdoc:: Section Well_founded. Variable A : Type. @@ -681,7 +685,7 @@ fixpoint equation can be proved. single: Fix_F_inv (term) single: Fix_F_eq (term) -.. coqtop:: in +.. coqdoc:: Section FixPoint. Variable P : A -> Type. @@ -715,7 +719,7 @@ of equality: .. coqtop:: in Inductive identity (A:Type) (a:A) : A -> Type := - identity_refl : identity a a. + identity_refl : identity A a a. Some properties of ``identity`` are proved in the module ``Logic_Type``, which also provides the definition of ``Type`` level negation: diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 50a56f1d51..437b8e557e 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1970,6 +1970,10 @@ in :ref:`canonicalstructures`; here only a simple example is given. Lemma is_law_S : is_law S. + .. coqtop:: none + + Abort. + .. note:: If a same field occurs in several canonical structures, then only the structure declared first as canonical is considered. @@ -2019,10 +2023,10 @@ or :g:`m` to the type :g:`nat` of natural numbers). Implicit Types m n : nat. Lemma cons_inj_nat : forall m n l, n :: l = m :: l -> n = m. - - intros m n. + Proof. intros m n. Abort. Lemma cons_inj_bool : forall (m n:bool) l, n :: l = m :: l -> n = m. + Abort. .. cmdv:: Implicit Type @ident : @type diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 5ecf007eff..9ab3f905e6 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -434,6 +434,10 @@ the identifier :g:`b` being used to represent the dependency. the return type. For instance, the following alternative definition is accepted and has the same meaning as the previous one. + .. coqtop:: none + + Reset bool_case. + .. coqtop:: in Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := @@ -471,7 +475,7 @@ For instance, in the following example: Definition eq_sym (A:Type) (x y:A) (H:eq A x y) : eq A y x := match H in eq _ _ z return eq A z x with - | eq_refl _ => eq_refl A x + | eq_refl _ _ => eq_refl A x end. the type of the branch is :g:`eq A x x` because the third argument of @@ -826,6 +830,10 @@ Simple inductive types .. example:: + .. coqtop:: none + + Reset nat. + .. coqtop:: in Inductive nat : Set := O | S (_:nat). @@ -904,6 +912,10 @@ Parametrized inductive types Once again, it is possible to specify only the type of the arguments of the constructors, and to omit the type of the conclusion: + .. coqtop:: none + + Reset list. + .. coqtop:: in Inductive list (A:Set) : Set := nil | cons (_:A) (_:list A). @@ -949,7 +961,7 @@ Parametrized inductive types inductive definitions are abstracted over their parameters before type checking constructors, allowing to write: - .. coqtop:: all undo + .. coqtop:: all Set Uniform Inductive Parameters. Inductive list3 (A:Set) : Set := @@ -960,7 +972,7 @@ Parametrized inductive types and using :cmd:`Context` to give the uniform parameters, like so (cf. :ref:`section-mechanism`): - .. coqtop:: all undo + .. coqtop:: all reset Section list3. Context (A:Set). @@ -1038,7 +1050,7 @@ Mutually defined inductive types two type variables :g:`A` and :g:`B`, the declaration should be done the following way: - .. coqtop:: in + .. coqdoc:: Inductive tree (A B:Set) : Set := node : A -> forest A B -> tree A B @@ -1130,6 +1142,10 @@ found in e.g. Agda, and preserves subject reduction. The above example can be rewritten in the following way. +.. coqtop:: none + + Reset Stream. + .. coqtop:: all Set Primitive Projections. @@ -1147,7 +1163,7 @@ axiom. .. coqtop:: all - Axiom Stream_eta : forall s: Stream, s = cons (hs s) (tl s). + Axiom Stream_eta : forall s: Stream, s = Seq (hd s) (tl s). More generally, as in the case of positive coinductive types, it is consistent to further identify extensional equality of coinductive types with propositional diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 9455228e7d..8b7fe20191 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -230,10 +230,12 @@ mathematical symbols ∀ and ∃, you may define: .. coqtop:: in - Notation "∀ x : T, P" := - (forall x : T, P) (at level 200, x ident). - Notation "∃ x : T, P" := - (exists x : T, P) (at level 200, x ident). + Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) + : type_scope. + Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) + (at level 200, x binder, y binder, right associativity) + : type_scope. There exists a small set of such notations already defined, in the file `utf8.v` of Coq library, so you may enable them just by diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 442077616f..4f486a777d 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -859,6 +859,10 @@ We can carry out pattern matching on terms with: Goal True. f (3+4). + .. coqtop:: none + + Abort. + .. _ltac-match-goal: Pattern matching on goals @@ -1026,6 +1030,10 @@ Counting the goals all:pr_numgoals. + .. coqtop:: none + + Abort. + Testing boolean expressions ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 483dbd311d..ec97377128 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -233,7 +233,7 @@ construct differs from the latter in that .. coqtop:: reset all - Definition f u := let (m, n) := u in m + n. + Fail Definition f u := let (m, n) := u in m + n. The ``let:`` construct is just (more legible) notation for the primitive @@ -413,7 +413,7 @@ each point of use, e.g., the above definition can be written: Variable all : (T -> bool) -> list T -> bool. - .. coqtop:: all undo + .. coqtop:: all Prenex Implicits null. Definition all_null (s : list T) := all null s. @@ -436,7 +436,7 @@ The syntax of the new declaration is a ``Set Printing All`` command). All |SSR| library files thus start with the incantation - .. coqtop:: all undo + .. coqdoc:: Set Implicit Arguments. Unset Strict Implicit. @@ -505,7 +505,7 @@ Definitions |SSR| pose tactic supports *open syntax*: the body of the definition does not need surrounding parentheses. For instance: -.. coqtop:: in +.. coqdoc:: pose t := x + y. @@ -534,7 +534,7 @@ The |SSR| pose tactic also supports (co)fixpoints, by providing the local counterpart of the ``Fixpoint f := …`` and ``CoFixpoint f := …`` constructs. For instance, the following tactic: -.. coqtop:: in +.. coqdoc:: pose fix f (x y : nat) {struct x} : nat := if x is S p then S (f p y) else 0. @@ -544,7 +544,7 @@ on natural numbers. Similarly, local cofixpoints can be defined by a tactic of the form: -.. coqtop:: in +.. coqdoc:: pose cofix f (arg : T) := … . @@ -553,26 +553,26 @@ offers a smooth way of defining local abstractions. The type of “holes” is guessed by type inference, and the holes are abstracted. For instance the tactic: -.. coqtop:: in +.. coqdoc:: pose f := _ + 1. is shorthand for: -.. coqtop:: in +.. coqdoc:: pose f n := n + 1. When the local definition of a function involves both arguments and holes, hole abstractions appear first. For instance, the tactic: -.. coqtop:: in +.. coqdoc:: pose f x := x + _. is shorthand for: -.. coqtop:: in +.. coqdoc:: pose f n x := x + n. @@ -580,13 +580,13 @@ The interaction of the pose tactic with the interpretation of implicit arguments results in a powerful and concise syntax for local definitions involving dependent types. For instance, the tactic: -.. coqtop:: in +.. coqdoc:: pose f x y := (x, y). adds to the context the local definition: -.. coqtop:: in +.. coqdoc:: pose f (Tx Ty : Type) (x : Tx) (y : Ty) := (x, y). @@ -766,7 +766,7 @@ Moreover: .. coqtop:: all Lemma test : forall x : nat, x + 1 = 0. - set t := _ + 1. + Fail set t := _ + 1. + Typeclass inference should fill in any residual hole, but matching should never assign a value to a global existential variable. @@ -889,7 +889,7 @@ only one occurrence of the selected term. .. coqtop:: all Lemma test x y z : (x + y) + (z + z) = z + z. - set a := {2}(_ + _). + Fail set a := {2}(_ + _). .. _basic_localization_ssr: @@ -1079,7 +1079,7 @@ constants to the goal. Because they are tacticals, ``:`` and ``=>`` can be combined, as in -.. coqtop:: in +.. coqdoc:: move: m le_n_m => p le_n_p. @@ -1139,7 +1139,7 @@ Basic tactics like apply and elim can also be used without the ’:’ tactical: for example we can directly start a proof of ``subnK`` by induction on the top variable ``m`` with -.. coqtop:: in +.. coqdoc:: elim=> [|m IHm] n le_n. @@ -1150,7 +1150,7 @@ explained in terms of the goal stack:: is basically equivalent to -.. coqtop:: in +.. coqdoc:: move: a H1 H2; tactic => a H1 H2. @@ -1163,13 +1163,13 @@ temporary abbreviation to hide the statement of the goal from The general form of the in tactical can be used directly with the ``move``, ``case`` and ``elim`` tactics, so that one can write -.. coqtop:: in +.. coqdoc:: elim: n => [|n IHn] in m le_n_m *. instead of -.. coqtop:: in +.. coqdoc:: elim: n m le_n_m => [|n IHn] m le_n_m. @@ -1398,7 +1398,7 @@ Switches affect the discharging of a :token:`d_item` as follows: For example, the tactic: -.. coqtop:: in +.. coqdoc:: move: n {2}n (refl_equal n). @@ -1409,7 +1409,7 @@ For example, the tactic: Therefore this tactic changes any goal ``G`` into -.. coqtop:: +.. coqdoc:: forall n n0 : nat, n = n0 -> G. @@ -1843,7 +1843,7 @@ Generation of equations The generation of named equations option stores the definition of a new constant as an equation. The tactic: -.. coqtop:: in +.. coqdoc:: move En: (size l) => n. @@ -1851,7 +1851,7 @@ where ``l`` is a list, replaces ``size l`` by ``n`` in the goal and adds the fact ``En : size l = n`` to the context. This is quite different from: -.. coqtop:: in +.. coqdoc:: pose n := (size l). @@ -1936,7 +1936,7 @@ be substituted. inferred looking at the type of the top assumption. This allows for the compact syntax: - .. coqtop:: in + .. coqdoc:: case: {2}_ / eqP. @@ -2112,7 +2112,7 @@ In the script provided as example in section :ref:`indentation_ssr`, the paragraph corresponding to each sub-case ends with a tactic line prefixed with a ``by``, like in: -.. coqtop:: in +.. coqdoc:: by apply/eqP; rewrite -dvdn1. @@ -2147,13 +2147,13 @@ A natural and common way of closing a goal is to apply a lemma which is the exact one needed for the goal to be solved. The defective form of the tactic: -.. coqtop:: in +.. coqdoc:: exact. is equivalent to: -.. coqtop:: in +.. coqdoc:: do [done | by move=> top; apply top]. @@ -2161,13 +2161,13 @@ where ``top`` is a fresh name assigned to the top assumption of the goal. This applied form is supported by the ``:`` discharge tactical, and the tactic: -.. coqtop:: in +.. coqdoc:: exact: MyLemma. is equivalent to: -.. coqtop:: in +.. coqdoc:: by apply: MyLemma. @@ -2179,19 +2179,19 @@ is equivalent to: follows the ``by`` keyword is considered to be a parenthesized block applied to the current goal. Hence for example if the tactic: - .. coqtop:: in + .. coqdoc:: by rewrite my_lemma1. succeeds, then the tactic: - .. coqtop:: in + .. coqdoc:: by rewrite my_lemma1; apply my_lemma2. usually fails since it is equivalent to: - .. coqtop:: in + .. coqdoc:: by (rewrite my_lemma1; apply my_lemma2). @@ -2247,7 +2247,7 @@ Finally, the tactics ``last`` and ``first`` combine with the branching syntax of Ltac: if the tactic generates n subgoals on a given goal, then the tactic -.. coqtop:: in +.. coqdoc:: tactic ; last k [ tactic1 |…| tacticm ] || tacticn. @@ -2262,7 +2262,6 @@ to the others. .. coqtop:: reset - Abort. From Coq Require Import ssreflect. Set Implicit Arguments. Unset Strict Implicit. @@ -2296,13 +2295,13 @@ Iteration A tactic of the form: -.. coqtop:: in +.. coqdoc:: do [ tactic 1 | … | tactic n ]. is equivalent to the standard Ltac expression: -.. coqtop:: in +.. coqdoc:: first [ tactic 1 | … | tactic n ]. @@ -2327,14 +2326,14 @@ Their meaning is: For instance, the tactic: -.. coqtop:: in +.. coqdoc:: tactic; do 1? rewrite mult_comm. rewrites at most one time the lemma ``mult_comm`` in all the subgoals generated by tactic , whereas the tactic: -.. coqtop:: in +.. coqdoc:: tactic; do 2! rewrite mult_comm. @@ -2518,7 +2517,7 @@ tactics of the form: which behave like: -.. coqtop:: in +.. coqdoc:: have: term ; first by tactic. move=> clear_switch i_item. @@ -2531,7 +2530,7 @@ to introduce the new assumption itself. The ``by`` feature is especially convenient when the proof script of the statement is very short, basically when it fits in one line like in: -.. coqtop:: in +.. coqdoc:: have H23 : 3 + 2 = 2 + 3 by rewrite addnC. @@ -2559,7 +2558,7 @@ the further use of the intermediate step. For instance, Thanks to the deferred execution of clears, the following idiom is also supported (assuming x occurs in the goal only): -.. coqtop:: in +.. coqdoc:: have {x} -> : x = y. @@ -2635,7 +2634,7 @@ Since the :token:`i_pattern` can be omitted, to avoid ambiguity, bound variables can be surrounded with parentheses even if no type is specified: -.. coqtop:: in +.. coqdoc:: have (x) : 2 * x = x + x by omega. @@ -2816,7 +2815,7 @@ The + but the optional clear item is still performed in the *second* branch. This means that the tactic: - .. coqtop:: in + .. coqdoc:: suff {H} H : forall x : nat, x >= 0. @@ -2888,7 +2887,7 @@ name of the local definition with the ``@`` character. In the second subgoal, the tactic: -.. coqtop:: in +.. coqdoc:: move=> clear_switch i_item. @@ -2995,10 +2994,13 @@ illustrated in the following example. the pattern ``id (addx x)``, that would produce the following first subgoal - .. coqtop:: none + .. coqtop:: none reset + + From Coq Require Import ssreflect Omega. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - Abort All. - From Coq Require Import Omega. Section Test. Variable x : nat. Definition addx z := z + x. @@ -3153,7 +3155,7 @@ An :token:`r_item` can be: Definition f := fun x y => x + y. Lemma test x y : x + y = f y x. - rewrite -[f y]/(y + _). + Fail rewrite -[f y]/(y + _). but the following script succeeds @@ -3192,7 +3194,7 @@ tactics. In a rewrite tactic of the form: -.. coqtop:: in +.. coqdoc:: rewrite occ_switch [term1]term2. @@ -3235,7 +3237,7 @@ Performing rewrite and simplification operations in a single tactic enhances significantly the concision of scripts. For instance the tactic: -.. coqtop:: in +.. coqdoc:: rewrite /my_def {2}[f _]/= my_eq //=. @@ -3316,7 +3318,7 @@ the equality. .. coqtop:: all Lemma test (H : forall t u, t + u * 0 = t) x y : x + y * 4 + 2 * 0 = x + 2 * 0. - rewrite [x + _]H. + Fail rewrite [x + _]H. Indeed the left hand side of ``H`` does not match the redex identified by the pattern ``x + y * 4``. @@ -3498,7 +3500,7 @@ reasoning purposes. The library also provides one lemma per such operation, stating that both versions return the same values when applied to the same arguments: -.. coqtop:: in +.. coqdoc:: Lemma addE : add =2 addn. Lemma doubleE : double =1 doublen. @@ -3514,7 +3516,7 @@ hand side. In order to reason conveniently on expressions involving the efficient operations, we gather all these rules in the definition ``trecE``: -.. coqtop:: in +.. coqdoc:: Definition trecE := (addE, (doubleE, oddE), (mulE, add_mulE, (expE, mul_expE))). @@ -3572,14 +3574,14 @@ cases: + |SSR| never accepts to rewrite indeterminate patterns like: - .. coqtop:: in + .. coqdoc:: Lemma foo (x : unit) : x = tt. |SSR| will however accept the ηζ expansion of this rule: - .. coqtop:: in + .. coqdoc:: Lemma fubar (x : unit) : (let u := x in u) = tt. @@ -3617,7 +3619,7 @@ cases: .. coqtop:: all - rewrite H. + Fail rewrite H. Rewriting with ``H`` first requires unfolding the occurrences of ``f`` @@ -3729,7 +3731,7 @@ copy of any term t. However this copy is (on purpose) *not convertible* to t in the |Coq| system [#8]_. The job is done by the following construction: -.. coqtop:: in +.. coqdoc:: Lemma master_key : unit. Proof. exact tt. Qed. Definition locked A := let: tt := master_key in fun x : A => x. @@ -3793,14 +3795,14 @@ some functions by the partial evaluation switch ``/=``, unless this allowed the evaluation of a condition. This is possible thanks to another mechanism of term tagging, resting on the following *Notation*: -.. coqtop:: in +.. coqdoc:: Notation "'nosimpl' t" := (let: tt := tt in t). The term ``(nosimpl t)`` simplifies to ``t`` *except* in a definition. More precisely, given: -.. coqtop:: in +.. coqdoc:: Definition foo := (nosimpl bar). @@ -3816,7 +3818,7 @@ Note that ``nosimpl bar`` is simply notation for a term that reduces to The ``nosimpl`` trick only works if no reduction is apparent in ``t``; in particular, the declaration: - .. coqtop:: in + .. coqdoc:: Definition foo x := nosimpl (bar x). @@ -3824,14 +3826,14 @@ Note that ``nosimpl bar`` is simply notation for a term that reduces to function, and to use the following definition, which blocks the reduction as expected: - .. coqtop:: in + .. coqdoc:: Definition foo x := nosimpl bar x. A standard example making this technique shine is the case of arithmetic operations. We define for instance: -.. coqtop:: in +.. coqdoc:: Definition addn := nosimpl plus. @@ -3851,7 +3853,7 @@ Congruence Because of the way matching interferes with parameters of type families, the tactic: -.. coqtop:: in +.. coqdoc:: apply: my_congr_property. @@ -4047,7 +4049,7 @@ For a quick glance at what can be expressed with the last :token:`r_pattern` consider the goal ``a = b`` and the tactic -.. coqtop:: in +.. coqdoc:: rewrite [in X in _ = X]rule. @@ -4148,14 +4150,14 @@ patterns over simple terms, but to interpret a pattern with double parentheses as a simple term. For example, the following tactic would capture any occurrence of the term ``a in A``. -.. coqtop:: in +.. coqdoc:: set t := ((a in A)). Contextual patterns can also be used as arguments of the ``:`` tactical. For example: -.. coqtop:: in +.. coqdoc:: elim: n (n in _ = n) (refl_equal n). @@ -4246,7 +4248,7 @@ context shortcuts. The following example is taken from ``ssreflect.v`` where the ``LHS`` and ``RHS`` shortcuts are defined. -.. coqtop:: in +.. coqdoc:: Notation RHS := (X in _ = X)%pattern. Notation LHS := (X in X = _)%pattern. @@ -4254,7 +4256,7 @@ The following example is taken from ``ssreflect.v`` where the Shortcuts defined this way can be freely used in place of the trailing ``ident in term`` part of any contextual pattern. Some examples follow: -.. coqtop:: in +.. coqdoc:: set rhs := RHS. rewrite [in RHS]rule. @@ -4287,13 +4289,13 @@ The view syntax combined with the ``elim`` tactic specifies an elimination scheme to be used instead of the default, generated, one. Hence the |SSR| tactic: -.. coqtop:: in +.. coqdoc:: elim/V. is a synonym for: -.. coqtop:: in +.. coqdoc:: intro top; elim top using V; clear top. @@ -4303,13 +4305,13 @@ Since an elimination view supports the two bookkeeping tacticals of discharge and introduction (see section :ref:`basic_tactics_ssr`), the |SSR| tactic: -.. coqtop:: in +.. coqdoc:: elim/V: x => y. is a synonym for: -.. coqtop:: in +.. coqdoc:: elim x using V; clear x; intro y. @@ -4367,13 +4369,13 @@ command) can be combined with the type family switches described in section :ref:`type_families_ssr`. Consider an eliminator ``foo_ind`` of type: -.. coqtop:: in +.. coqdoc:: foo_ind : forall …, forall x : T, P p1 … pm. and consider the tactic: -.. coqtop:: in +.. coqdoc:: elim/foo_ind: e1 … / en. @@ -4424,7 +4426,7 @@ Here is an example of a regular, but nontrivial, eliminator. The following tactics are all valid and perform the same elimination on this goal. - .. coqtop:: in + .. coqdoc:: elim/plus_ind: z / (plus _ z). elim/plus_ind: {z}(plus _ z). @@ -4473,7 +4475,7 @@ Here is an example of a regular, but nontrivial, eliminator. .. coqtop:: all - elim/plus_ind: y / _. + Fail elim/plus_ind: y / _. triggers an error: in the conclusion of the ``plus_ind`` eliminator, the first argument of the predicate @@ -4494,7 +4496,7 @@ Here is an example of a truncated eliminator: Unset Printing Implicit Defensive. Section Test. - .. coqtop:: in + .. coqdoc:: Lemma test p n (n_gt0 : 0 < n) (pr_p : prime p) : p %| \prod_(i <- prime_decomp n | i \in prime_decomp n) i.1 ^ i.2 -> @@ -4505,7 +4507,7 @@ Here is an example of a truncated eliminator: where the type of the ``big_prop`` eliminator is - .. coqtop:: in + .. coqdoc:: big_prop: forall (R : Type) (Pb : R -> Type) (idx : R) (op1 : R -> R -> R), Pb idx -> @@ -4518,7 +4520,7 @@ Here is an example of a truncated eliminator: inferred one is used instead: ``big[_/_]_(i <- _ | _ i) _ i``, and after the introductions, the following goals are generated: - .. coqtop:: in + .. coqdoc:: subgoal 1 is: p %| 1 -> exists2 x : nat * nat, x \in prime_decomp n & p = x.1 @@ -4624,7 +4626,7 @@ equation name generation mechanism (see section :ref:`generation_of_equations_ss This view tactic performs: - .. coqtop:: in + .. coqdoc:: move=> HQ; case: {HQ}(Q2P HQ) => [HPa | HPb]. @@ -4661,14 +4663,14 @@ relevant for the current goal. the double implication into the expected simple implication. The last script is in fact equivalent to: - .. coqtop:: in + .. coqdoc:: Lemma test a b : P (a || b) -> True. move/(iffLR (PQequiv _ _)). where: - .. coqtop:: in + .. coqdoc:: Lemma iffLR P Q : (P <-> Q) -> P -> Q. @@ -4810,7 +4812,7 @@ decidable predicate to its boolean version. First, booleans are injected into propositions using the coercion mechanism: -.. coqtop:: in +.. coqdoc:: Coercion is_true (b : bool) := b = true. @@ -4827,7 +4829,7 @@ To get all the benefits of the boolean reflection, it is in fact convenient to introduce the following inductive predicate ``reflect`` to relate propositions and booleans: -.. coqtop:: in +.. coqdoc:: Inductive reflect (P: Prop): bool -> Type := | Reflect_true : P -> reflect P true @@ -4838,7 +4840,7 @@ logically equivalent propositions. For instance, the following lemma: -.. coqtop:: in +.. coqdoc:: Lemma andP: forall b1 b2, reflect (b1 /\ b2) (b1 && b2). @@ -4853,20 +4855,20 @@ to the case analysis of |Coq|’s inductive types. Since the equivalence predicate is defined in |Coq| as: -.. coqtop:: in +.. coqdoc:: Definition iff (A B:Prop) := (A -> B) /\ (B -> A). where ``/\`` is a notation for ``and``: -.. coqtop:: in +.. coqdoc:: Inductive and (A B:Prop) : Prop := conj : A -> B -> and A B. This make case analysis very different according to the way an equivalence property has been defined. -.. coqtop:: in +.. coqdoc:: Lemma andE (b1 b2 : bool) : (b1 /\ b2) <-> (b1 && b2). @@ -4950,13 +4952,13 @@ Specializing assumptions The |SSR| tactic: -.. coqtop:: in +.. coqdoc:: move/(_ term1 … termn). is equivalent to the tactic: -.. coqtop:: in +.. coqdoc:: intro top; generalize (top term1 … termn); clear top. @@ -5013,13 +5015,13 @@ If ``term`` is a double implication, then the view hint will be one of the defined view hints for implication. These hints are by default the ones present in the file ``ssreflect.v``: -.. coqtop:: in +.. coqdoc:: Lemma iffLR : forall P Q, (P <-> Q) -> P -> Q. which transforms a double implication into the left-to-right one, or: -.. coqtop:: in +.. coqdoc:: Lemma iffRL : forall P Q, (P <-> Q) -> Q -> P. @@ -5123,7 +5125,7 @@ equality, while the second term is the one applied to the right hand side. In this context, the identity view can be used when no view has to be applied: -.. coqtop:: in +.. coqdoc:: Lemma idP : reflect b1 b1. @@ -5198,7 +5200,7 @@ in sequence. Both move and apply can be followed by an arbitrary number of ``/term``. The main difference between the following two tactics -.. coqtop:: in +.. coqdoc:: apply/v1/v2/v3. apply/v1; apply/v2; apply/v3. @@ -5210,7 +5212,7 @@ line would apply the view ``v2`` to all the goals generated by ``apply/v1``. Note that the NO-OP intro pattern ``-`` can be used to separate two views, making the two following examples equivalent: -.. coqtop:: in +.. coqdoc:: move=> /v1; move=> /v2. move=> /v1 - /v2. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 081fef07b9..0bcfce2322 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -2493,7 +2493,7 @@ and an explanation of the underlying technique. Let us consider the relation Le over natural numbers and the following variables: - .. coqtop:: all + .. coqtop:: all reset Inductive Le : nat -> nat -> Set := | LeO : forall n:nat, Le 0 n @@ -3406,129 +3406,140 @@ Automation This tactic implements a Prolog-like resolution procedure to solve the current goal. It first tries to solve the goal using the :tacn:`assumption` - tactic, then it reduces the goal to an atomic one using intros and + tactic, then it reduces the goal to an atomic one using :tacn:`intros` and introduces the newly generated hypotheses as hints. Then it looks at the list of tactics associated to the head symbol of the goal and tries to apply one of them (starting from the tactics with lower cost). This process is recursively applied to the generated subgoals. - By default, auto only uses the hypotheses of the current goal and the - hints of the database named core. + By default, :tacn:`auto` only uses the hypotheses of the current goal and + the hints of the database named ``core``. + + .. warning:: + + :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to + :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will + fail even if applying manually one of the hints would succeed. + + .. tacv:: auto @num + + Forces the search depth to be :token:`num`. The maximal search depth + is 5 by default. + + .. tacv:: auto with {+ @ident} -.. tacv:: auto @num + Uses the hint databases :n:`{+ @ident}` in addition to the database ``core``. - Forces the search depth to be :token:`num`. The maximal search depth - is 5 by default. + .. note:: + + Use the fake database `nocore` if you want to *not* use the `core` + database. -.. tacv:: auto with {+ @ident} + .. tacv:: auto with * - Uses the hint databases :n:`{+ @ident}` in addition to the database core. + Uses all existing hint databases. Using this variant is highly discouraged + in finished scripts since it is both slower and less robust than the variant + where the required databases are explicitly listed. .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of pre-defined databases and the way to create or extend a database. -.. tacv:: auto with * + .. tacv:: auto using {+ @ident__i} {? with {+ @ident } } - Uses all existing hint databases. + Uses lemmas :n:`@ident__i` in addition to hints. If :n:`@ident` is an + inductive type, it is the collection of its constructors which are added + as hints. - .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + .. note:: -.. tacv:: auto using {+ @ident__i} {? with {+ @ident } } + The hints passed through the `using` clause are used in the same + way as if they were passed through a hint database. Consequently, + they use a weaker version of :tacn:`apply` and :n:`auto using @ident` + may fail where :n:`apply @ident` succeeds. - Uses lemmas :n:`@ident__i` in addition to hints. If :n:`@ident` is an - inductive type, it is the collection of its constructors which are added - as hints. + Given that this can be seen as counter-intuitive, it could be useful + to have an option to use full-blown :tacn:`apply` for lemmas passed + through the `using` clause. Contributions welcome! -.. tacv:: info_auto + .. tacv:: info_auto - Behaves like auto but shows the tactics it uses to solve the goal. This - variant is very useful for getting a better understanding of automation, or - to know what lemmas/assumptions were used. + Behaves like :tacn:`auto` but shows the tactics it uses to solve the goal. This + variant is very useful for getting a better understanding of automation, or + to know what lemmas/assumptions were used. -.. tacv:: debug auto - :name: debug auto + .. tacv:: debug auto + :name: debug auto - Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, - including failing paths. + Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, + including failing paths. -.. tacv:: {? info_}auto {? @num} {? using {+ @lemma}} {? with {+ @ident}} + .. tacv:: {? info_}auto {? @num} {? using {+ @lemma}} {? with {+ @ident}} - This is the most general form, combining the various options. + This is the most general form, combining the various options. .. tacv:: trivial :name: trivial - This tactic is a restriction of auto that is not recursive + This tactic is a restriction of :tacn:`auto` that is not recursive and tries only hints that cost `0`. Typically it solves trivial equalities like :g:`X=X`. -.. tacv:: trivial with {+ @ident} - :undocumented: - -.. tacv:: trivial with * - :undocumented: - -.. tacv:: trivial using {+ @lemma} - :undocumented: - -.. tacv:: debug trivial - :name: debug trivial - :undocumented: - -.. tacv:: info_trivial - :name: info_trivial - :undocumented: - -.. tacv:: {? info_}trivial {? using {+ @lemma}} {? with {+ @ident}} - :undocumented: + .. tacv:: trivial with {+ @ident} + trivial with * + trivial using {+ @lemma} + debug trivial + info_trivial + {? info_}trivial {? using {+ @lemma}} {? with {+ @ident}} + :name: _; _; _; debug trivial; info_trivial; _ + :undocumented: .. note:: - :tacn:`auto` either solves completely the goal or else leaves it - intact. :tacn:`auto` and :tacn:`trivial` never fail. - -The following options enable printing of informative or debug information for -the :tacn:`auto` and :tacn:`trivial` tactics: + :tacn:`auto` and :tacn:`trivial` either solve completely the goal or + else succeed without changing the goal. Use :g:`solve [ auto ]` and + :g:`solve [ trivial ]` if you would prefer these tactics to fail when + they do not manage to solve the goal. .. flag:: Info Auto Debug Auto Info Trivial Debug Trivial - :undocumented: -.. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + These options enable printing of informative or debug information for + the :tacn:`auto` and :tacn:`trivial` tactics. .. tacn:: eauto :name: eauto This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try resolution hints which would leave existential variables in the goal, - :tacn:`eauto` does try them (informally speaking, it usessimple :tacn:`eapply` - where :tacn:`auto` uses simple :tacn:`apply`). As a consequence, :tacn:`eauto` + :tacn:`eauto` does try them (informally speaking, it internally uses a tactic + close to :tacn:`simple eapply` instead of a tactic close to :tacn:`simple apply` + in the case of :tacn:`auto`). As a consequence, :tacn:`eauto` can solve such a goal: .. example:: .. coqtop:: all - Hint Resolve ex_intro. + Hint Resolve ex_intro : core. Goal forall P:nat -> Prop, P 0 -> exists n, P n. eauto. Note that ``ex_intro`` should be declared as a hint. -.. tacv:: {? info_}eauto {? @num} {? using {+ @lemma}} {? with {+ @ident}} + .. tacv:: {? info_}eauto {? @num} {? using {+ @lemma}} {? with {+ @ident}} - The various options for :tacn:`eauto` are the same as for :tacn:`auto`. + The various options for :tacn:`eauto` are the same as for :tacn:`auto`. -:tacn:`eauto` also obeys the following options: + :tacn:`eauto` also obeys the following options: -.. flag:: Info Eauto - Debug Eauto - :undocumented: + .. flag:: Info Eauto + Debug Eauto + :undocumented: -.. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` .. tacn:: autounfold with {+ @ident} diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 105b0445fd..4f46a80dcf 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -181,7 +181,7 @@ rules. Some simple left factorization work has to be done. Here is an example. .. coqtop:: all Notation "x < y" := (lt x y) (at level 70). - Notation "x < y < z" := (x < y /\ y < z) (at level 70). + Fail Notation "x < y < z" := (x < y /\ y < z) (at level 70). In order to factorize the left part of the rules, the subexpression referred to by ``y`` has to be at the same level in both rules. However the @@ -486,7 +486,7 @@ Sometimes, for the sake of factorization of rules, a binder has to be parsed as a term. This is typically the case for a notation such as the following: -.. coqtop:: in +.. coqdoc:: Notation "{ x : A | P }" := (sig (fun x : A => P)) (at level 0, x at level 99 as ident). @@ -788,9 +788,9 @@ main grammar, or from another custom entry as is the case in to indicate that ``e`` has to be parsed at level ``2`` of the grammar associated to the custom entry ``expr``. The level can be omitted, as in -.. coqtop:: in +.. coqdoc:: - Notation "[ e ]" := e (e custom expr)`. + Notation "[ e ]" := e (e custom expr). in which case Coq tries to infer it. @@ -1058,7 +1058,7 @@ Binding arguments of a constant to an interpretation scope in the scope delimited by the key ``F`` (``Rfun_scope``) and the last argument in the scope delimited by the key ``R`` (``R_scope``). - .. coqtop:: in + .. coqdoc:: Arguments plus_fct (f1 f2)%F x%R. @@ -1066,7 +1066,7 @@ Binding arguments of a constant to an interpretation scope parentheses. In the following example arguments A and B are marked as maximally inserted implicit arguments and are put into the type_scope scope. - .. coqtop:: in + .. coqdoc:: Arguments respectful {A B}%type (R R')%signature _ _. @@ -1148,7 +1148,7 @@ Binding types of arguments to an interpretation scope can be bound to an interpretation scope. The command to do it is :n:`Bind Scope @scope with @class` - .. coqtop:: in + .. coqtop:: in reset Parameter U : Set. Bind Scope U_scope with U. diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 067af954ad..0dd9b3aa3e 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -560,7 +560,7 @@ class CoqtopDirective(Directive): Example:: - .. coqtop:: in reset undo + .. coqtop:: in undo Print nat. Definition a := 1. @@ -580,8 +580,7 @@ class CoqtopDirective(Directive): - Behavior options - ``reset``: Send a ``Reset Initial`` command before running this block - - ``undo``: Send an ``Undo n`` (``n`` = number of sentences) command after - running all the commands in this block + - ``undo``: Reset state after executing. Not compatible with ``reset``. ``coqtop``\ 's state is preserved across consecutive ``.. coqtop::`` blocks of the same document (``coqrst`` creates a single ``coqtop`` process per diff --git a/engine/evarutil.ml b/engine/evarutil.ml index db56d0628f..d70c009c6d 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -337,6 +337,7 @@ type naming_mode = | KeepUserNameAndRenameExistingEvenSectionNames | KeepExistingNames | FailIfConflict + | ProgramNaming let push_rel_decl_to_named_context ?(hypnaming=KeepUserNameAndRenameExistingButSectionNames) @@ -364,7 +365,7 @@ let push_rel_decl_to_named_context using this function. For now, we only attempt to preserve the old behaviour of Program, but ultimately, one should do something about this whole name generation problem. *) - if Flags.is_program_mode () then next_name_away na avoid + if hypnaming = ProgramNaming then next_name_away na avoid else (* id_of_name_using_hdchar only depends on the rel context which is empty here *) @@ -372,7 +373,8 @@ let push_rel_decl_to_named_context in match extract_if_neq id na with | Some id0 when hypnaming = KeepUserNameAndRenameExistingEvenSectionNames || - hypnaming = KeepUserNameAndRenameExistingButSectionNames && + (hypnaming = KeepUserNameAndRenameExistingButSectionNames || + hypnaming = ProgramNaming) && not (is_section_variable id0) -> (* spiwack: if [id<>id0], rather than introducing a new binding named [id], we will keep [id0] (the name given diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 0e67475778..23b240f1a0 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -38,6 +38,7 @@ type naming_mode = | KeepUserNameAndRenameExistingEvenSectionNames | KeepExistingNames | FailIfConflict + | ProgramNaming val new_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> diff --git a/engine/proofview.ml b/engine/proofview.ml index d4ad53ff5f..a725444e81 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -223,9 +223,9 @@ module Proof = Logical type +'a tactic = 'a Proof.t (** Applies a tactic to the current proofview. *) -let apply env t sp = +let apply ~name ~poly env t sp = let open Logic_monad in - let ans = Proof.repr (Proof.run t false (sp,env)) in + let ans = Proof.repr (Proof.run t P.{trace=false; name; poly} (sp,env)) in let ans = Logic_monad.NonLogical.run ans in match ans with | Nil (e, info) -> iraise (TacticFailure e, info) @@ -993,7 +993,10 @@ let tclTIME s t = tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) in aux 0 t - +let tclProofInfo = + let open Proof in + Logical.current >>= fun P.{name; poly} -> + tclUNIT (name, poly) (** {7 Unsafe primitives} *) @@ -1275,7 +1278,8 @@ module V82 = struct let of_tactic t gls = try let init = { shelf = []; solution = gls.Evd.sigma ; comb = [with_empty_state gls.Evd.it] } in - let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in + let name, poly = Names.Id.of_string "legacy_pe", false in + let (_,final,_,_) = apply ~name ~poly (goal_env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = CList.map drop_state final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = CErrors.push src in diff --git a/engine/proofview.mli b/engine/proofview.mli index 286703c0dc..680a93f0cc 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -156,10 +156,15 @@ type +'a tactic tactic has given up. In case of multiple success the first one is selected. If there is no success, fails with {!Logic_monad.TacticFailure}*) -val apply : Environ.env -> 'a tactic -> proofview -> 'a - * proofview - * (bool*Evar.t list*Evar.t list) - * Proofview_monad.Info.tree +val apply + : name:Names.Id.t + -> poly:bool + -> Environ.env + -> 'a tactic + -> proofview + -> 'a * proofview + * (bool*Evar.t list*Evar.t list) + * Proofview_monad.Info.tree (** {7 Monadic primitives} *) @@ -407,6 +412,10 @@ val tclTIMEOUT : int -> 'a tactic -> 'a tactic identifying annotation if present *) val tclTIME : string option -> 'a tactic -> 'a tactic +(** Internal, don't use. *) +val tclProofInfo : (Names.Id.t * bool) tactic +[@@ocaml.deprecated "internal, don't use"] + (** {7 Unsafe primitives} *) (** The primitives in the [Unsafe] module should be avoided as much as diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 69341d97df..80eb9d0124 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -177,7 +177,7 @@ module P = struct type s = proofview * Environ.env (** Recording info trace (true) or not. *) - type e = bool + type e = { trace: bool; name : Names.Id.t; poly : bool } (** Status (safe/unsafe) * shelved goals * given up *) type w = bool * goal list @@ -254,13 +254,16 @@ end (** Lens and utilies pertaining to the info trace *) module InfoL = struct - let recording = Logical.current + let recording = Logical.(map (fun {P.trace} -> trace) current) let if_recording t = let open Logical in recording >>= fun r -> if r then t else return () - let record_trace t = Logical.local true t + let record_trace t = + Logical.( + current >>= fun s -> + local {s with P.trace = true} t) let raw_update = Logical.update let update f = if_recording (raw_update f) diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index a08cab3bf6..3437b6ce77 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -98,7 +98,7 @@ module P : sig val wprod : w -> w -> w (** Recording info trace (true) or not. *) - type e = bool + type e = { trace: bool; name : Names.Id.t; poly : bool } type u = Info.state diff --git a/gramlib/gramext.ml b/gramlib/gramext.ml index 46c2688f05..c396bbab34 100644 --- a/gramlib/gramext.ml +++ b/gramlib/gramext.ml @@ -2,51 +2,6 @@ (* gramext.ml,v *) (* Copyright (c) INRIA 2007-2017 *) -open Printf - -type 'a parser_t = 'a Stream.t -> Obj.t - -type 'te grammar = - { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - glexer : 'te Plexing.lexer } - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - elocal : bool; - mutable estart : int -> 'te parser_t; - mutable econtinue : int -> int -> Obj.t -> 'te parser_t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of 'te parser_t -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = NonA | RightA | LeftA -and 'te g_symbol = - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol * bool - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol * bool - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Plexing.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -and err_fun = unit -> string - type position = First | Last @@ -54,408 +9,4 @@ type position = | After of string | Level of string -let rec derive_eps = - function - Slist0 _ -> true - | Slist0sep (_, _, _) -> true - | Sopt _ -> true - | Stree t -> tree_derive_eps t - | Slist1 _ | Slist1sep (_, _, _) | Snterm _ | - Snterml (_, _) | Snext | Sself | Stoken _ -> - false -and tree_derive_eps = - function - LocAct (_, _) -> true - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> false - -let rec eq_symbol s1 s2 = - match s1, s2 with - Snterm e1, Snterm e2 -> e1 == e2 - | Snterml (e1, l1), Snterml (e2, l2) -> e1 == e2 && l1 = l2 - | Slist0 s1, Slist0 s2 -> eq_symbol s1 s2 - | Slist0sep (s1, sep1, b1), Slist0sep (s2, sep2, b2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 && b1 = b2 - | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2 - | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 && b1 = b2 - | Sopt s1, Sopt s2 -> eq_symbol s1 s2 - | Stree _, Stree _ -> false - | _ -> s1 = s2 - -let is_before s1 s2 = - match s1, s2 with - Stoken ("ANY", _), _ -> false - | _, Stoken ("ANY", _) -> true - | Stoken (_, s), Stoken (_, "") when s <> "" -> true - | Stoken _, Stoken _ -> false - | Stoken _, _ -> true - | _ -> false - -let insert_tree ~warning entry_name gsymbols action tree = - let rec insert symbols tree = - match symbols with - s :: sl -> insert_in_tree s sl tree - | [] -> - match tree with - Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert [] bro} - | LocAct (old_action, action_list) -> - begin match warning with - | None -> () - | Some warn_fn -> - let msg = - "<W> Grammar extension: " ^ - (if entry_name <> "" then "" else "in ["^entry_name^"%s], ") ^ - "some rule has been masked" in - warn_fn msg - end; - LocAct (action, old_action :: action_list) - | DeadEnd -> LocAct (action, []) - and insert_in_tree s sl tree = - match try_insert s sl tree with - Some t -> t - | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} - and try_insert s sl tree = - match tree with - Node {node = s1; son = son; brother = bro} -> - if eq_symbol s s1 then - let t = Node {node = s1; son = insert sl son; brother = bro} in - Some t - else if is_before s1 s || derive_eps s && not (derive_eps s1) then - let bro = - match try_insert s sl bro with - Some bro -> bro - | None -> Node {node = s; son = insert sl DeadEnd; brother = bro} - in - let t = Node {node = s1; son = son; brother = bro} in Some t - else - begin match try_insert s sl bro with - Some bro -> - let t = Node {node = s1; son = son; brother = bro} in Some t - | None -> None - end - | LocAct (_, _) | DeadEnd -> None - in - insert gsymbols tree - -let srules ~warning rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree ~warning "" symbols action tree) - DeadEnd rl - in - Stree t - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false - -let insert_level ~warning entry_name e1 symbols action slev = - match e1 with - true -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree ~warning entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | false -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree ~warning entry_name symbols action slev.lprefix} - -let empty_lev lname assoc = - let assoc = - match assoc with - Some a -> a - | None -> LeftA - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} - -let change_lev ~warning lev n lname assoc = - let a = - match assoc with - None -> lev.assoc - | Some a -> - if a <> lev.assoc then - begin - match warning with - | None -> () - | Some warn_fn -> - warn_fn ("<W> Changing associativity of level \""^n^"\"") - end; - a - in - begin match lname with - Some n -> - if lname <> lev.lname then - begin match warning with - | None -> () - | Some warn_fn -> - warn_fn ("<W> Level label \""^n^"\" ignored") - end; - | None -> () - end; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} - -let get_level ~warning entry position levs = - match position with - Some First -> [], empty_lev, levs - | Some Last -> levs, empty_lev, [] - | Some (Level n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [], change_lev ~warning lev n, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | Some (Before n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [], empty_lev, lev :: levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | Some (After n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [lev], empty_lev, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | None -> - match levs with - lev :: levs -> [], change_lev ~warning lev "<top>", levs - | [] -> [], empty_lev, [] - -let change_to_self entry = - function - Snterm e when e == entry -> Sself - | x -> x - -let get_initial entry = - function - Sself :: symbols -> true, symbols - | symbols -> false, symbols - -let insert_tokens gram symbols = - let rec insert = - function - | Slist0 s -> insert s - | Slist1 s -> insert s - | Slist0sep (s, t, _) -> insert s; insert t - | Slist1sep (s, t, _) -> insert s; insert t - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - gram.glexer.Plexing.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r - in - incr r - | Snterm _ | Snterml (_, _) | Snext | Sself -> () - and tinsert = - function - Node {node = s; brother = bro; son = son} -> - insert s; tinsert bro; tinsert son - | LocAct (_, _) | DeadEnd -> () - in - List.iter insert symbols - -let levels_of_rules ~warning entry position rules = - let elev = - match entry.edesc with - Dlevels elev -> elev - | Dparser _ -> - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush stderr; - failwith "Grammar.extend" - in - if rules = [] then elev - else - let (levs1, make_lev, levs2) = get_level ~warning entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = List.map (change_to_self entry) symbols in - let (e1, symbols) = get_initial entry symbols in - insert_tokens entry.egram symbols; - insert_level ~warning entry.ename e1 symbols action lev) - lev level - in - lev :: levs, empty_lev) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 - -let logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match s1, s2 with - Snterm e1, Snterm e2 -> e1.ename = e2.ename - | Snterm e1, Sself -> e1.ename = entry.ename - | Sself, Snterm e2 -> entry.ename = e2.ename - | Snterml (e1, l1), Snterml (e2, l2) -> e1.ename = e2.ename && l1 = l2 - | Slist0 s1, Slist0 s2 -> eq_symbols s1 s2 - | Slist0sep (s1, sep1, b1), Slist0sep (s2, sep2, b2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2 - | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2 - | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2 - | Sopt s1, Sopt s2 -> eq_symbols s1 s2 - | Stree t1, Stree t2 -> eq_trees t1 t2 - | _ -> s1 = s2 - and eq_trees t1 t2 = - match t1, t2 with - Node n1, Node n2 -> - eq_symbols n1.node n2.node && eq_trees n1.son n2.son && - eq_trees n1.brother n2.brother - | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true - | _ -> false - in - eq_symbols - -(* [delete_rule_in_tree] returns - [Some (dsl, t)] if success - [dsl] = - Some (list of deleted nodes) if branch deleted - None if action replaced by previous version of action - [t] = remaining tree - [None] if failure *) - -let delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match symbols, tree with - s :: sl, Node n -> - if logically_eq_symbols entry s n.node then delete_son sl n - else - begin match delete_in_tree symbols n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | s :: sl, _ -> None - | [], Node n -> - begin match delete_in_tree [] n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | [], DeadEnd -> None - | [], LocAct (_, []) -> Some (Some [], DeadEnd) - | [], LocAct (_, action :: list) -> Some (None, LocAct (action, list)) - and delete_son sl n = - match delete_in_tree sl n.son with - Some (Some dsl, DeadEnd) -> Some (Some (n.node :: dsl), n.brother) - | Some (Some dsl, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some (n.node :: dsl), t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) - | None -> None - in - delete_in_tree - -let rec decr_keyw_use gram = - function - Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - decr r; - if !r == 0 then - begin - Hashtbl.remove gram.gtokens tok; - gram.glexer.Plexing.tok_removing tok - end - | Slist0 s -> decr_keyw_use gram s - | Slist1 s -> decr_keyw_use gram s - | Slist0sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Slist1sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml (_, _) -> () -and decr_keyw_use_in_tree gram = - function - DeadEnd | LocAct (_, _) -> () - | Node n -> - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother - -let rec delete_rule_in_suffix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lsuffix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin match t with - DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = t; - lprefix = lev.lprefix} - in - lev :: levs - end - | None -> - let levs = delete_rule_in_suffix entry symbols levs in lev :: levs - end - | [] -> raise Not_found - -let rec delete_rule_in_prefix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lprefix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin match t with - DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = t} - in - lev :: levs - end - | None -> - let levs = delete_rule_in_prefix entry symbols levs in lev :: levs - end - | [] -> raise Not_found - -let delete_rule_in_level_list entry symbols levs = - match symbols with - Sself :: symbols -> delete_rule_in_suffix entry symbols levs - | Snterm e :: symbols when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs +type g_assoc = NonA | RightA | LeftA diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli index f1e294fb4c..f9daf5bf10 100644 --- a/gramlib/gramext.mli +++ b/gramlib/gramext.mli @@ -2,49 +2,6 @@ (* gramext.mli,v *) (* Copyright (c) INRIA 2007-2017 *) -type 'a parser_t = 'a Stream.t -> Obj.t - -type 'te grammar = - { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - glexer : 'te Plexing.lexer } - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - elocal : bool; - mutable estart : int -> 'te parser_t; - mutable econtinue : int -> int -> Obj.t -> 'te parser_t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of 'te parser_t -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = NonA | RightA | LeftA -and 'te g_symbol = - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol * bool - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol * bool - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Plexing.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -and err_fun = unit -> string - type position = First | Last @@ -52,14 +9,4 @@ type position = | After of string | Level of string -val levels_of_rules : warning:(string -> unit) option -> - 'te g_entry -> position option -> - (string option * g_assoc option * ('te g_symbol list * g_action) list) - list -> - 'te g_level list - -val srules : warning:(string -> unit) option -> ('te g_symbol list * g_action) list -> 'te g_symbol -val eq_symbol : 'a g_symbol -> 'a g_symbol -> bool - -val delete_rule_in_level_list : - 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list +type g_assoc = NonA | RightA | LeftA diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 0ad11d075f..e313f2e648 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -5,14 +5,644 @@ open Gramext open Format -external gramext_action : 'a -> g_action = "%identity" +type ('a, 'b) eq = Refl : ('a, 'a) eq -let rec flatten_tree = +(* Functorial interface *) + +module type GLexerType = sig type te val lexer : te Plexing.lexer end + +module type S = + sig + type te + type parsable + val parsable : char Stream.t -> parsable + val tokens : string -> (string * int) list + module Entry : + sig + type 'a e + val create : string -> 'a e + val parse : 'a e -> parsable -> 'a + val name : 'a e -> string + val of_parser : string -> (te Stream.t -> 'a) -> 'a e + val parse_token_stream : 'a e -> te Stream.t -> 'a + val print : Format.formatter -> 'a e -> unit + end + type ('self, 'a) ty_symbol + type ('self, 'f, 'r) ty_rule + type 'a ty_production + val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol + val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol + val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + val s_list0sep : + ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> + ('self, 'a list) ty_symbol + val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + val s_list1sep : + ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> + ('self, 'a list) ty_symbol + val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol + val s_self : ('self, 'self) ty_symbol + val s_next : ('self, 'self) ty_symbol + val s_token : Plexing.pattern -> ('self, string) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol + val r_stop : ('self, 'r, 'r) ty_rule + val r_next : + ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> + ('self, 'b -> 'a, 'r) ty_rule + val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production + module Unsafe : + sig + val clear_entry : 'a Entry.e -> unit + end + val safe_extend : warning:(string -> unit) option -> + 'a Entry.e -> Gramext.position option -> + (string option * Gramext.g_assoc option * 'a ty_production list) + list -> + unit + val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit + end + +(* Implementation *) + +module GMake (L : GLexerType) = +struct + +type te = L.te + +type 'a parser_t = L.te Stream.t -> 'a + +type grammar = + { gtokens : (Plexing.pattern, int ref) Hashtbl.t; + glexer : L.te Plexing.lexer } + +let egram = + {gtokens = Hashtbl.create 301; glexer = L.lexer } + +let tokens con = + let list = ref [] in + Hashtbl.iter + (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list) + egram.gtokens; + !list + +type 'a ty_entry = { + ename : string; + mutable estart : int -> 'a parser_t; + mutable econtinue : int -> int -> 'a -> 'a parser_t; + mutable edesc : 'a ty_desc; +} + +and 'a ty_desc = +| Dlevels of 'a ty_level list +| Dparser of 'a parser_t + +and 'a ty_level = { + assoc : g_assoc; + lname : string option; + lsuffix : ('a, 'a -> Loc.t -> 'a) ty_tree; + lprefix : ('a, Loc.t -> 'a) ty_tree; +} + +and ('self, 'a) ty_symbol = +| Stoken : Plexing.pattern -> ('self, string) ty_symbol +| Slist1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol +| Slist1sep : ('self, 'a) ty_symbol * ('self, _) ty_symbol * bool -> ('self, 'a list) ty_symbol +| Slist0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol +| Slist0sep : ('self, 'a) ty_symbol * ('self, _) ty_symbol * bool -> ('self, 'a list) ty_symbol +| Sopt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol +| Sself : ('self, 'self) ty_symbol +| Snext : ('self, 'self) ty_symbol +| Snterm : 'a ty_entry -> ('self, 'a) ty_symbol +| Snterml : 'a ty_entry * string -> ('self, 'a) ty_symbol +| Stree : ('self, Loc.t -> 'a) ty_tree -> ('self, 'a) ty_symbol + +and ('self, _, 'r) ty_rule = +| TStop : ('self, 'r, 'r) ty_rule +| TNext : ('self, 'a, 'r) ty_rule * ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule + +and ('self, 'a) ty_tree = +| Node : ('self, 'b, 'a) ty_node -> ('self, 'a) ty_tree +| LocAct : 'k * 'k list -> ('self, 'k) ty_tree +| DeadEnd : ('self, 'k) ty_tree + +and ('self, 'a, 'r) ty_node = { + node : ('self, 'a) ty_symbol; + son : ('self, 'a -> 'r) ty_tree; + brother : ('self, 'r) ty_tree; +} + +type 'a ty_production = +| TProd : ('a, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_production + +let rec derive_eps : type s a. (s, a) ty_symbol -> bool = + function + Slist0 _ -> true + | Slist0sep (_, _, _) -> true + | Sopt _ -> true + | Stree t -> tree_derive_eps t + | Slist1 _ -> false + | Slist1sep (_, _, _) -> false + | Snterm _ | Snterml (_, _) -> false + | Snext -> false + | Sself -> false + | Stoken _ -> false +and tree_derive_eps : type s a. (s, a) ty_tree -> bool = + function + LocAct (_, _) -> true + | Node {node = s; brother = bro; son = son} -> + derive_eps s && tree_derive_eps son || tree_derive_eps bro + | DeadEnd -> false + +(** FIXME: find a way to do that type-safely *) +let eq_entry : type a1 a2. a1 ty_entry -> a2 ty_entry -> (a1, a2) eq option = fun e1 e2 -> + if (Obj.magic e1) == (Obj.magic e2) then Some (Obj.magic Refl) + else None + +let rec eq_symbol : type s a1 a2. (s, a1) ty_symbol -> (s, a2) ty_symbol -> (a1, a2) eq option = fun s1 s2 -> + match s1, s2 with + Snterm e1, Snterm e2 -> eq_entry e1 e2 + | Snterml (e1, l1), Snterml (e2, l2) -> + if String.equal l1 l2 then eq_entry e1 e2 else None + | Slist0 s1, Slist0 s2 -> + begin match eq_symbol s1 s2 with None -> None | Some Refl -> Some Refl end + | Slist0sep (s1, sep1, b1), Slist0sep (s2, sep2, b2) -> + if b1 = b2 then match eq_symbol s1 s2 with + | None -> None + | Some Refl -> + match eq_symbol sep1 sep2 with + | None -> None + | Some Refl -> Some Refl + else None + | Slist1 s1, Slist1 s2 -> + begin match eq_symbol s1 s2 with None -> None | Some Refl -> Some Refl end + | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) -> + if b1 = b2 then match eq_symbol s1 s2 with + | None -> None + | Some Refl -> + match eq_symbol sep1 sep2 with + | None -> None + | Some Refl -> Some Refl + else None + | Sopt s1, Sopt s2 -> + begin match eq_symbol s1 s2 with None -> None | Some Refl -> Some Refl end + | Stree _, Stree _ -> None + | Sself, Sself -> Some Refl + | Snext, Snext -> Some Refl + | Stoken p1, Stoken p2 -> if p1 = p2 then Some Refl else None + | _ -> None + +let is_before : type s1 s2 a1 a2. (s1, a1) ty_symbol -> (s2, a2) ty_symbol -> bool = fun s1 s2 -> + match s1, s2 with + Stoken ("ANY", _), _ -> false + | _, Stoken ("ANY", _) -> true + | Stoken (_, s), Stoken (_, "") when s <> "" -> true + | Stoken _, Stoken _ -> false + | Stoken _, _ -> true + | _ -> false + +(** Ancilliary datatypes *) + +type ('self, _) ty_symbols = +| TNil : ('self, unit) ty_symbols +| TCns : ('self, 'a) ty_symbol * ('self, 'b) ty_symbols -> ('self, 'a * 'b) ty_symbols + +(** ('i, 'p, 'f, 'r) rel_prod0 ~ + ∃ α₁ ... αₙ. + p ≡ αₙ * ... α₁ * 'i ∧ + f ≡ α₁ -> ... -> αₙ -> 'r +*) +type ('i, _, 'f, _) rel_prod0 = +| Rel0 : ('i, 'i, 'f, 'f) rel_prod0 +| RelS : ('i, 'p, 'f, 'a -> 'r) rel_prod0 -> ('i, 'a * 'p, 'f, 'r) rel_prod0 + +type ('p, 'k, 'r) rel_prod = (unit, 'p, 'k, 'r) rel_prod0 + +type ('s, 'i, 'k, 'r) any_symbols = +| AnyS : ('s, 'p) ty_symbols * ('i, 'p, 'k, 'r) rel_prod0 -> ('s, 'i, 'k, 'r) any_symbols + +(** FIXME *) +let rec symbols : type s p k r. (s, p) ty_symbols -> (s, k, r) ty_rule -> (s, unit, k, r) any_symbols = + fun accu r -> match r with + | TStop -> AnyS (Obj.magic accu, Rel0) + | TNext (r, s) -> + let AnyS (r, pf) = symbols (TCns (s, accu)) r in + AnyS (Obj.magic r, RelS (Obj.magic pf)) + +let get_symbols : type s k r. (s, k, r) ty_rule -> (s, unit, k, r) any_symbols = + fun r -> symbols TNil r + +let insert_tree (type s p k a) ~warning entry_name (gsymbols : (s, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, a) ty_tree) = + let rec insert : type p f k. (s, p) ty_symbols -> (p, k, f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree = + fun symbols pf tree action -> + match symbols, pf with + TCns (s, sl), RelS pf -> insert_in_tree s sl pf tree action + | TNil, Rel0 -> + match tree with + Node {node = s; son = son; brother = bro} -> + Node {node = s; son = son; brother = insert TNil Rel0 bro action} + | LocAct (old_action, action_list) -> + begin match warning with + | None -> () + | Some warn_fn -> + let msg = + "<W> Grammar extension: " ^ + (if entry_name <> "" then "" else "in ["^entry_name^"%s], ") ^ + "some rule has been masked" in + warn_fn msg + end; + LocAct (action, old_action :: action_list) + | DeadEnd -> LocAct (action, []) + and insert_in_tree : type a p f k. (s, a) ty_symbol -> (s, p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree = + fun s sl pf tree action -> + match try_insert s sl pf tree action with + Some t -> t + | None -> Node {node = s; son = insert sl pf DeadEnd action; brother = tree} + and try_insert : type a p f k. (s, a) ty_symbol -> (s, p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree option = + fun s sl pf tree action -> + match tree with + Node {node = s1; son = son; brother = bro} -> + begin match eq_symbol s s1 with + | Some Refl -> + let t = Node {node = s1; son = insert sl pf son action; brother = bro} in + Some t + | None -> + if is_before s1 s || derive_eps s && not (derive_eps s1) then + let bro = + match try_insert s sl pf bro action with + Some bro -> bro + | None -> Node {node = s; son = insert sl pf DeadEnd action; brother = bro} + in + let t = Node {node = s1; son = son; brother = bro} in Some t + else + begin match try_insert s sl pf bro action with + Some bro -> + let t = Node {node = s1; son = son; brother = bro} in Some t + | None -> None + end + end + | LocAct (_, _) | DeadEnd -> None + in + insert gsymbols pf tree action + +let srules (type self a) ~warning (rl : a ty_production list) = + let t = + List.fold_left + (fun tree (TProd (symbols, action)) -> + let AnyS (symbols, pf) = get_symbols symbols in + insert_tree ~warning "" symbols pf action tree) + DeadEnd rl + in + (* FIXME: use an universal self type to ensure well-typedness *) + (Obj.magic (Stree t) : (self, a) ty_symbol) + +let is_level_labelled n lev = + match lev.lname with + Some n1 -> n = n1 + | None -> false + +let insert_level (type s p k) ~warning entry_name (symbols : (s, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = + match symbols with + | TCns (Sself, symbols) -> + let RelS pf = pf in + {assoc = slev.assoc; lname = slev.lname; + lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix; + lprefix = slev.lprefix} + | _ -> + {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; + lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix} + +let empty_lev lname assoc = + let assoc = + match assoc with + Some a -> a + | None -> LeftA + in + {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} + +let change_lev ~warning lev n lname assoc = + let a = + match assoc with + None -> lev.assoc + | Some a -> + if a <> lev.assoc then + begin + match warning with + | None -> () + | Some warn_fn -> + warn_fn ("<W> Changing associativity of level \""^n^"\"") + end; + a + in + begin match lname with + Some n -> + if lname <> lev.lname then + begin match warning with + | None -> () + | Some warn_fn -> + warn_fn ("<W> Level label \""^n^"\" ignored") + end; + | None -> () + end; + {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} + +let get_level ~warning entry position levs = + match position with + Some First -> [], empty_lev, levs + | Some Last -> levs, empty_lev, [] + | Some (Level n) -> + let rec get = + function + [] -> + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush stderr; + failwith "Grammar.extend" + | lev :: levs -> + if is_level_labelled n lev then [], change_lev ~warning lev n, levs + else + let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 + in + get levs + | Some (Before n) -> + let rec get = + function + [] -> + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush stderr; + failwith "Grammar.extend" + | lev :: levs -> + if is_level_labelled n lev then [], empty_lev, lev :: levs + else + let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 + in + get levs + | Some (After n) -> + let rec get = + function + [] -> + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush stderr; + failwith "Grammar.extend" + | lev :: levs -> + if is_level_labelled n lev then [lev], empty_lev, levs + else + let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 + in + get levs + | None -> + match levs with + lev :: levs -> [], change_lev ~warning lev "<top>", levs + | [] -> [], empty_lev, [] + +let change_to_self0 (type s) (type a) (entry : s ty_entry) : (s, a) ty_symbol -> (s, a) ty_symbol = + function + | Snterm e -> + begin match eq_entry e entry with + | None -> Snterm e + | Some Refl -> Sself + end + | x -> x + +let rec change_to_self : type s a r. s ty_entry -> (s, a, r) ty_rule -> (s, a, r) ty_rule = fun e r -> match r with +| TStop -> TStop +| TNext (r, t) -> TNext (change_to_self e r, change_to_self0 e t) + +let insert_tokens gram symbols = + let rec insert : type s a. (s, a) ty_symbol -> unit = + function + | Slist0 s -> insert s + | Slist1 s -> insert s + | Slist0sep (s, t, _) -> insert s; insert t + | Slist1sep (s, t, _) -> insert s; insert t + | Sopt s -> insert s + | Stree t -> tinsert t + | Stoken ("ANY", _) -> () + | Stoken tok -> + gram.glexer.Plexing.tok_using tok; + let r = + try Hashtbl.find gram.gtokens tok with + Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r + in + incr r + | Snterm _ | Snterml (_, _) -> () + | Snext -> () + | Sself -> () + and tinsert : type s a. (s, a) ty_tree -> unit = + function + Node {node = s; brother = bro; son = son} -> + insert s; tinsert bro; tinsert son + | LocAct (_, _) | DeadEnd -> () + and linsert : type s p. (s, p) ty_symbols -> unit = function + | TNil -> () + | TCns (s, r) -> insert s; linsert r + in + linsert symbols + +let levels_of_rules ~warning entry position rules = + let elev = + match entry.edesc with + Dlevels elev -> elev + | Dparser _ -> + eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; + flush stderr; + failwith "Grammar.extend" + in + match rules with + | [] -> elev + | _ -> + let (levs1, make_lev, levs2) = get_level ~warning entry position elev in + let (levs, _) = + List.fold_left + (fun (levs, make_lev) (lname, assoc, level) -> + let lev = make_lev lname assoc in + let lev = + List.fold_left + (fun lev (TProd (symbols, action)) -> + let symbols = change_to_self entry symbols in + let AnyS (symbols, pf) = get_symbols symbols in + insert_tokens egram symbols; + insert_level ~warning entry.ename symbols pf action lev) + lev level + in + lev :: levs, empty_lev) + ([], make_lev) rules + in + levs1 @ List.rev levs @ levs2 + +let logically_eq_symbols entry = + let rec eq_symbols : type s1 s2 a1 a2. (s1, a1) ty_symbol -> (s2, a2) ty_symbol -> bool = fun s1 s2 -> + match s1, s2 with + Snterm e1, Snterm e2 -> e1.ename = e2.ename + | Snterm e1, Sself -> e1.ename = entry.ename + | Sself, Snterm e2 -> entry.ename = e2.ename + | Snterml (e1, l1), Snterml (e2, l2) -> e1.ename = e2.ename && l1 = l2 + | Slist0 s1, Slist0 s2 -> eq_symbols s1 s2 + | Slist0sep (s1, sep1, b1), Slist0sep (s2, sep2, b2) -> + eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2 + | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2 + | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) -> + eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2 + | Sopt s1, Sopt s2 -> eq_symbols s1 s2 + | Stree t1, Stree t2 -> eq_trees t1 t2 + | Stoken p1, Stoken p2 -> p1 = p2 + | Sself, Sself -> true + | Snext, Snext -> true + | _ -> false + and eq_trees : type s1 s2 a1 a2. (s1, a1) ty_tree -> (s2, a2) ty_tree -> bool = fun t1 t2 -> + match t1, t2 with + Node n1, Node n2 -> + eq_symbols n1.node n2.node && eq_trees n1.son n2.son && + eq_trees n1.brother n2.brother + | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true + | _ -> false + in + eq_symbols + +(* [delete_rule_in_tree] returns + [Some (dsl, t)] if success + [dsl] = + Some (list of deleted nodes) if branch deleted + None if action replaced by previous version of action + [t] = remaining tree + [None] if failure *) + +type 's ex_symbols = +| ExS : ('s, 'p) ty_symbols -> 's ex_symbols + +let delete_rule_in_tree entry = + let rec delete_in_tree : + type s p r. (s, p) ty_symbols -> (s, r) ty_tree -> (s ex_symbols option * (s, r) ty_tree) option = + fun symbols tree -> + match symbols, tree with + | TCns (s, sl), Node n -> + if logically_eq_symbols entry s n.node then delete_son sl n + else + begin match delete_in_tree symbols n.brother with + Some (dsl, t) -> + Some (dsl, Node {node = n.node; son = n.son; brother = t}) + | None -> None + end + | TCns (s, sl), _ -> None + | TNil, Node n -> + begin match delete_in_tree TNil n.brother with + Some (dsl, t) -> + Some (dsl, Node {node = n.node; son = n.son; brother = t}) + | None -> None + end + | TNil, DeadEnd -> None + | TNil, LocAct (_, []) -> Some (Some (ExS TNil), DeadEnd) + | TNil, LocAct (_, action :: list) -> Some (None, LocAct (action, list)) + and delete_son : + type s p a r. (s, p) ty_symbols -> (s, a, r) ty_node -> (s ex_symbols option * (s, r) ty_tree) option = + fun sl n -> + match delete_in_tree sl n.son with + Some (Some (ExS dsl), DeadEnd) -> Some (Some (ExS (TCns (n.node, dsl))), n.brother) + | Some (Some (ExS dsl), t) -> + let t = Node {node = n.node; son = t; brother = n.brother} in + Some (Some (ExS (TCns (n.node, dsl))), t) + | Some (None, t) -> + let t = Node {node = n.node; son = t; brother = n.brother} in + Some (None, t) + | None -> None + in + delete_in_tree + +let rec decr_keyw_use : type s a. _ -> (s, a) ty_symbol -> unit = fun gram -> + function + Stoken tok -> + let r = Hashtbl.find gram.gtokens tok in + decr r; + if !r == 0 then + begin + Hashtbl.remove gram.gtokens tok; + gram.glexer.Plexing.tok_removing tok + end + | Slist0 s -> decr_keyw_use gram s + | Slist1 s -> decr_keyw_use gram s + | Slist0sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2 + | Slist1sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2 + | Sopt s -> decr_keyw_use gram s + | Stree t -> decr_keyw_use_in_tree gram t + | Sself -> () + | Snext -> () + | Snterm _ | Snterml (_, _) -> () +and decr_keyw_use_in_tree : type s a. _ -> (s, a) ty_tree -> unit = fun gram -> + function + DeadEnd | LocAct (_, _) -> () + | Node n -> + decr_keyw_use gram n.node; + decr_keyw_use_in_tree gram n.son; + decr_keyw_use_in_tree gram n.brother +and decr_keyw_use_in_list : type s p. _ -> (s, p) ty_symbols -> unit = fun gram -> + function + | TNil -> () + | TCns (s, l) -> decr_keyw_use gram s; decr_keyw_use_in_list gram l + +let rec delete_rule_in_suffix entry symbols = + function + lev :: levs -> + begin match delete_rule_in_tree entry symbols lev.lsuffix with + Some (dsl, t) -> + begin match dsl with + Some (ExS dsl) -> decr_keyw_use_in_list egram dsl + | None -> () + end; + begin match t with + DeadEnd when lev.lprefix == DeadEnd -> levs + | _ -> + let lev = + {assoc = lev.assoc; lname = lev.lname; lsuffix = t; + lprefix = lev.lprefix} + in + lev :: levs + end + | None -> + let levs = delete_rule_in_suffix entry symbols levs in lev :: levs + end + | [] -> raise Not_found + +let rec delete_rule_in_prefix entry symbols = + function + lev :: levs -> + begin match delete_rule_in_tree entry symbols lev.lprefix with + Some (dsl, t) -> + begin match dsl with + Some (ExS dsl) -> decr_keyw_use_in_list egram dsl + | None -> () + end; + begin match t with + DeadEnd when lev.lsuffix == DeadEnd -> levs + | _ -> + let lev = + {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix; + lprefix = t} + in + lev :: levs + end + | None -> + let levs = delete_rule_in_prefix entry symbols levs in lev :: levs + end + | [] -> raise Not_found + +let delete_rule_in_level_list (type s p) (entry : s ty_entry) (symbols : (s, p) ty_symbols) levs = + match symbols with + TCns (Sself, symbols) -> delete_rule_in_suffix entry symbols levs + | TCns (Snterm e, symbols') -> + begin match eq_entry e entry with + | None -> delete_rule_in_prefix entry symbols levs + | Some Refl -> + delete_rule_in_suffix entry symbols' levs + end + | _ -> delete_rule_in_prefix entry symbols levs + +let rec flatten_tree : type s a. (s, a) ty_tree -> s ex_symbols list = function DeadEnd -> [] - | LocAct (_, _) -> [[]] + | LocAct (_, _) -> [ExS TNil] | Node {node = n; brother = b; son = s} -> - List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b + List.map (fun (ExS l) -> ExS (TCns (n, l))) (flatten_tree s) @ flatten_tree b let utf8_print = ref true @@ -41,7 +671,8 @@ let string_escaped s = let print_str ppf s = fprintf ppf "\"%s\"" (string_escaped s) -let rec print_symbol ppf = +let rec print_symbol : type s r. formatter -> (s, r) ty_symbol -> unit = + fun ppf -> function | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s | Slist0sep (s, t, osep) -> @@ -55,36 +686,38 @@ let rec print_symbol ppf = | Stoken (con, prm) when con <> "" && prm <> "" -> fprintf ppf "%s@ %a" con print_str prm | Snterml (e, l) -> - fprintf ppf "%s%s@ LEVEL@ %a" e.ename (if e.elocal then "*" else "") + fprintf ppf "%s%s@ LEVEL@ %a" e.ename "" print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> - print_symbol1 ppf s -and print_symbol1 ppf = + | s -> print_symbol1 ppf s +and print_symbol1 : type s r. formatter -> (s, r) ty_symbol -> unit = + fun ppf -> function - | Snterm e -> fprintf ppf "%s%s" e.ename (if e.elocal then "*" else "") + | Snterm e -> fprintf ppf "%s%s" e.ename "" | Sself -> pp_print_string ppf "SELF" | Snext -> pp_print_string ppf "NEXT" | Stoken ("", s) -> print_str ppf s | Stoken (con, "") -> pp_print_string ppf con | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Snterml (_, _) | Slist0 _ | Slist0sep (_, _, _) | - Slist1 _ | Slist1sep (_, _, _) | Sopt _ | Stoken _ as s -> + | s -> fprintf ppf "(%a)" print_symbol s -and print_rule ppf symbols = +and print_rule : type s p. formatter -> (s, p) ty_symbols -> unit = + fun ppf symbols -> fprintf ppf "@[<hov 0>"; - let _ = - List.fold_left - (fun sep symbol -> - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ") - (fun ppf -> ()) symbols + let rec fold : type s p. _ -> (s, p) ty_symbols -> unit = + fun sep symbols -> match symbols with + | TNil -> () + | TCns (symbol, symbols) -> + fprintf ppf "%t%a" sep print_symbol symbol; + fold (fun ppf -> fprintf ppf ";@ ") symbols in + let () = fold (fun ppf -> ()) symbols in fprintf ppf "@]" -and print_level ppf pp_print_space rules = +and print_level : type s. _ -> _ -> s ex_symbols list -> _ = + fun ppf pp_print_space rules -> fprintf ppf "@[<hov 0>[ "; let _ = List.fold_left - (fun sep rule -> + (fun sep (ExS rule) -> fprintf ppf "%t%a" sep print_rule rule; fun ppf -> fprintf ppf "%a| " pp_print_space ()) (fun ppf -> ()) rules @@ -96,7 +729,7 @@ let print_levels ppf elev = List.fold_left (fun sep lev -> let rules = - List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix) @ + List.map (fun (ExS t) -> ExS (TCns (Sself, t))) (flatten_tree lev.lsuffix) @ flatten_tree lev.lprefix in fprintf ppf "%t@[<hov 2>" sep; @@ -132,21 +765,32 @@ let loc_of_token_interval bp ep = else let loc1 = !floc bp in let loc2 = !floc (pred ep) in Loc.merge loc1 loc2 -let name_of_symbol entry = +let name_of_symbol : type s a. s ty_entry -> (s, a) ty_symbol -> string = + fun entry -> function Snterm e -> "[" ^ e.ename ^ "]" | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Plexing.tok_text tok + | Sself -> "[" ^ entry.ename ^ "]" + | Snext -> "[" ^ entry.ename ^ "]" + | Stoken tok -> egram.glexer.Plexing.tok_text tok | _ -> "???" -let rec get_token_list entry rev_tokl last_tok tree = +type ('r, 'f) tok_list = +| TokNil : ('f, 'f) tok_list +| TokCns : ('r, 'f) tok_list -> (string -> 'r, 'f) tok_list + +type ('s, 'f) tok_tree = TokTree : ('s, string -> 'r) ty_tree * ('r, 'f) tok_list -> ('s, 'f) tok_tree + +let rec get_token_list : type s r f. + s ty_entry -> _ -> _ -> _ -> (r, f) tok_list -> (s, string -> r) ty_tree -> (_ * _ * _ * (s, f) tok_tree) option = + fun entry first_tok rev_tokl last_tok pf tree -> match tree with Node {node = Stoken tok; son = son; brother = DeadEnd} -> - get_token_list entry (last_tok :: rev_tokl) tok son - | _ -> if rev_tokl = [] then None else Some (rev_tokl, last_tok, tree) + get_token_list entry first_tok (last_tok :: rev_tokl) tok (TokCns pf) son + | _ -> if rev_tokl = [] then None else Some (first_tok, rev_tokl, last_tok, TokTree (tree, pf)) -let rec name_of_symbol_failed entry = +let rec name_of_symbol_failed : type s a. s ty_entry -> (s, a) ty_symbol -> _ = + fun entry -> function | Slist0 s -> name_of_symbol_failed entry s | Slist0sep (s, _, _) -> name_of_symbol_failed entry s @@ -155,12 +799,13 @@ let rec name_of_symbol_failed entry = | Sopt s -> name_of_symbol_failed entry s | Stree t -> name_of_tree_failed entry t | s -> name_of_symbol entry s -and name_of_tree_failed entry = +and name_of_tree_failed : type s a. s ty_entry -> (s, a) ty_tree -> _ = + fun entry -> function Node {node = s; brother = bro; son = son} -> let tokl = match s with - Stoken tok -> get_token_list entry [] tok son + Stoken tok -> get_token_list entry tok [] tok TokNil son | _ -> None in begin match tokl with @@ -177,16 +822,16 @@ and name_of_tree_failed entry = | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro in txt - | Some (rev_tokl, last_tok, son) -> + | Some (_, rev_tokl, last_tok, _) -> List.fold_left (fun s tok -> (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Plexing.tok_text tok) + egram.glexer.Plexing.tok_text tok) "" (List.rev (last_tok :: rev_tokl)) end | DeadEnd | LocAct (_, _) -> "???" -let tree_failed entry prev_symb_result prev_symb tree = +let tree_failed (type s a) (entry : s ty_entry) (prev_symb_result : a) (prev_symb : (s, a) ty_symbol) tree = let txt = name_of_tree_failed entry tree in let txt = match prev_symb with @@ -197,7 +842,7 @@ let tree_failed entry prev_symb_result prev_symb tree = let txt1 = name_of_symbol_failed entry s in txt1 ^ " or " ^ txt ^ " expected" | Slist0sep (s, sep, _) -> - begin match Obj.magic prev_symb_result with + begin match prev_symb_result with [] -> let txt1 = name_of_symbol_failed entry s in txt1 ^ " or " ^ txt ^ " expected" @@ -206,7 +851,7 @@ let tree_failed entry prev_symb_result prev_symb tree = txt1 ^ " or " ^ txt ^ " expected" end | Slist1sep (s, sep, _) -> - begin match Obj.magic prev_symb_result with + begin match prev_symb_result with [] -> let txt1 = name_of_symbol_failed entry s in txt1 ^ " or " ^ txt ^ " expected" @@ -214,7 +859,8 @@ let tree_failed entry prev_symb_result prev_symb tree = let txt1 = name_of_symbol_failed entry sep in txt1 ^ " or " ^ txt ^ " expected" end - | Sopt _ | Stree _ -> txt ^ " expected" + | Sopt _ -> txt ^ " expected" + | Stree _ -> txt ^ " expected" | _ -> txt ^ " expected after " ^ name_of_symbol_failed entry prev_symb in txt ^ " (in [" ^ entry.ename ^ "])" @@ -223,8 +869,6 @@ let symb_failed entry prev_symb_result prev_symb symb = let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in tree_failed entry prev_symb_result prev_symb tree -external app : Obj.t -> 'a = "%identity" - let is_level_labelled n lev = match lev.lname with Some n1 -> n = n1 @@ -241,28 +885,33 @@ let level_number entry lab = Dlevels elev -> lookup 0 elev | Dparser _ -> raise Not_found -let rec top_symb entry = +let rec top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> (s, a) ty_symbol = + fun entry -> function - Sself | Snext -> Snterm entry + Sself -> Snterm entry + | Snext -> Snterm entry | Snterml (e, _) -> Snterm e | Slist1sep (s, sep, b) -> Slist1sep (top_symb entry s, sep, b) | _ -> raise Stream.Failure -let entry_of_symb entry = +let entry_of_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a ty_entry = + fun entry -> function - Sself | Snext -> entry + Sself -> entry + | Snext -> entry | Snterm e -> e | Snterml (e, _) -> e | _ -> raise Stream.Failure -let top_tree entry = +let top_tree : type s a. s ty_entry -> (s, a) ty_tree -> (s, a) ty_tree = + fun entry -> function Node {node = s; brother = bro; son = son} -> Node {node = top_symb entry s; brother = bro; son = son} | LocAct (_, _) | DeadEnd -> raise Stream.Failure let skip_if_empty bp p strm = - if Stream.count strm == bp then gramext_action (fun a -> p strm) + if Stream.count strm == bp then fun a -> p strm else raise Stream.Failure let continue entry bp a s son p1 (strm__ : _ Stream.t) = @@ -271,7 +920,7 @@ let continue entry bp a s son p1 (strm__ : _ Stream.t) = try p1 strm__ with Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) in - gramext_action (fun _ -> app act a) + fun _ -> act a let do_recover parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) = @@ -309,27 +958,28 @@ let call_and_push ps al strm = let token_ematch gram tok = let tematch = gram.glexer.Plexing.tok_match tok in - fun tok -> Obj.repr (tematch tok : string) + fun tok -> tematch tok -let rec parser_of_tree entry nlevn alevn = +let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> r parser_t = + fun entry nlevn alevn -> function DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> (fun (strm__ : _ Stream.t) -> - let a = entry.estart alevn strm__ in app act a) + let a = entry.estart alevn strm__ in act a) | Node {node = Sself; son = LocAct (act, _); brother = bro} -> let p2 = parser_of_tree entry nlevn alevn bro in (fun (strm__ : _ Stream.t) -> match try Some (entry.estart alevn strm__) with Stream.Failure -> None with - Some a -> app act a + Some a -> act a | _ -> p2 strm__) | Node {node = s; son = son; brother = DeadEnd} -> let tokl = match s with - Stoken tok -> get_token_list entry [] tok son + Stoken tok -> get_token_list entry tok [] tok TokNil son | _ -> None in begin match tokl with @@ -345,19 +995,20 @@ let rec parser_of_tree entry nlevn alevn = Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) in - app act a) - | Some (rev_tokl, last_tok, son) -> + act a) + | Some (first_tok, rev_tokl, last_tok, TokTree (son, pf)) -> + let s = Stoken first_tok in let lt = Stoken last_tok in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in - parser_of_token_list entry s son p1 + parser_of_token_list entry s son pf p1 (fun (strm__ : _ Stream.t) -> raise Stream.Failure) rev_tokl last_tok end | Node {node = s; son = son; brother = bro} -> let tokl = match s with - Stoken tok -> get_token_list entry [] tok son + Stoken tok -> get_token_list entry tok [] tok TokNil son | _ -> None in match tokl with @@ -373,71 +1024,81 @@ let rec parser_of_tree entry nlevn alevn = begin match (try Some (p1 bp a strm) with Stream.Failure -> None) with - Some act -> app act a + Some act -> act a | None -> raise (Stream.Error (tree_failed entry a s son)) end | None -> p2 strm) - | Some (rev_tokl, last_tok, son) -> + | Some (first_tok, rev_tokl, last_tok, TokTree (son, pf)) -> let lt = Stoken last_tok in let p2 = parser_of_tree entry nlevn alevn bro in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in let p1 = - parser_of_token_list entry lt son p1 p2 rev_tokl last_tok + parser_of_token_list entry lt son pf p1 p2 rev_tokl last_tok in fun (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> p2 strm__ -and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) = +and parser_cont : type s a r. + (a -> r) parser_t -> s ty_entry -> int -> int -> (s, a) ty_symbol -> (s, a -> r) ty_tree -> int -> a -> (a -> r) parser_t = + fun p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> recover parser_of_tree entry nlevn alevn bp a s son strm__ -and parser_of_token_list entry s son p1 p2 rev_tokl last_tok = - let plast = +and parser_of_token_list : type s r f. + s ty_entry -> (s, string) ty_symbol -> (s, string -> r) ty_tree -> + (r, f) tok_list -> (int -> string -> (string -> r) parser_t) -> f parser_t -> _ -> _ -> f parser_t = + fun entry s son pf p1 p2 rev_tokl last_tok -> + let plast : r parser_t = let n = List.length rev_tokl + 1 in - let tematch = token_ematch entry.egram last_tok in + let tematch = token_ematch egram last_tok in let ps strm = match peek_nth n strm with Some tok -> let r = tematch tok in - for _i = 1 to n do Stream.junk strm done; Obj.repr r + for _i = 1 to n do Stream.junk strm done; r | None -> raise Stream.Failure in fun (strm : _ Stream.t) -> let bp = Stream.count strm in let a = ps strm in match try Some (p1 bp a strm) with Stream.Failure -> None with - Some act -> app act a + Some act -> act a | None -> raise (Stream.Error (tree_failed entry a s son)) in - match List.rev rev_tokl with - [] -> (fun (strm__ : _ Stream.t) -> plast strm__) - | tok :: tokl -> - let tematch = token_ematch entry.egram tok in + match List.rev rev_tokl, pf with + [], TokNil -> (fun (strm__ : _ Stream.t) -> plast strm__) + | tok :: tokl, TokCns pf -> + let tematch = token_ematch egram tok in let ps strm = match peek_nth 1 strm with Some tok -> tematch tok | None -> raise Stream.Failure in let p1 = - let rec loop n = - function - [] -> plast - | tok :: tokl -> - let tematch = token_ematch entry.egram tok in + let rec loop : type s f. _ -> _ -> (s, f) tok_list -> (string -> s) parser_t -> (string -> f) parser_t = + fun n tokl pf plast -> + match tokl, pf with + [], TokNil -> plast + | tok :: tokl, TokCns pf -> + let tematch = token_ematch egram tok in let ps strm = match peek_nth n strm with Some tok -> tematch tok | None -> raise Stream.Failure in - let p1 = loop (n + 1) tokl in + let p1 = loop (n + 1) tokl pf (Obj.magic plast) in (* FIXME *) fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in app act a + let a = ps strm__ in let act = p1 strm__ in (Obj.magic act a) (* FIXME *) + | _ -> assert false in - loop 2 tokl + loop 2 tokl pf plast in fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in app act a -and parser_of_symbol entry nlevn = + let a = ps strm__ in let act = p1 strm__ in act a + | _ -> assert false +and parser_of_symbol : type s a. + s ty_entry -> int -> (s, a) ty_symbol -> a parser_t = + fun entry nlevn -> function | Slist0 s -> let ps = call_and_push (parser_of_symbol entry nlevn s) in @@ -447,7 +1108,7 @@ and parser_of_symbol entry nlevn = | _ -> al in (fun (strm__ : _ Stream.t) -> - let a = loop [] strm__ in Obj.repr (List.rev a)) + let a = loop [] strm__ in List.rev a) | Slist0sep (symb, sep, false) -> let ps = call_and_push (parser_of_symbol entry nlevn symb) in let pt = parser_of_symbol entry nlevn sep in @@ -464,8 +1125,8 @@ and parser_of_symbol entry nlevn = in (fun (strm__ : _ Stream.t) -> match try Some (ps [] strm__) with Stream.Failure -> None with - Some al -> let a = kont al strm__ in Obj.repr (List.rev a) - | _ -> Obj.repr []) + Some al -> let a = kont al strm__ in List.rev a + | _ -> []) | Slist0sep (symb, sep, true) -> let ps = call_and_push (parser_of_symbol entry nlevn symb) in let pt = parser_of_symbol entry nlevn sep in @@ -482,8 +1143,8 @@ and parser_of_symbol entry nlevn = in (fun (strm__ : _ Stream.t) -> match try Some (ps [] strm__) with Stream.Failure -> None with - Some al -> let a = kont al strm__ in Obj.repr (List.rev a) - | _ -> Obj.repr []) + Some al -> let a = kont al strm__ in List.rev a + | _ -> []) | Slist1 s -> let ps = call_and_push (parser_of_symbol entry nlevn s) in let rec loop al (strm__ : _ Stream.t) = @@ -493,7 +1154,7 @@ and parser_of_symbol entry nlevn = in (fun (strm__ : _ Stream.t) -> let al = ps [] strm__ in - let a = loop al strm__ in Obj.repr (List.rev a)) + let a = loop al strm__ in List.rev a) | Slist1sep (symb, sep, false) -> let ps = call_and_push (parser_of_symbol entry nlevn symb) in let pt = parser_of_symbol entry nlevn sep in @@ -515,7 +1176,7 @@ and parser_of_symbol entry nlevn = in (fun (strm__ : _ Stream.t) -> let al = ps [] strm__ in - let a = kont al strm__ in Obj.repr (List.rev a)) + let a = kont al strm__ in List.rev a) | Slist1sep (symb, sep, true) -> let ps = call_and_push (parser_of_symbol entry nlevn symb) in let pt = parser_of_symbol entry nlevn sep in @@ -538,33 +1199,37 @@ and parser_of_symbol entry nlevn = in (fun (strm__ : _ Stream.t) -> let al = ps [] strm__ in - let a = kont al strm__ in Obj.repr (List.rev a)) + let a = kont al strm__ in List.rev a) | Sopt s -> let ps = parser_of_symbol entry nlevn s in (fun (strm__ : _ Stream.t) -> match try Some (ps strm__) with Stream.Failure -> None with - Some a -> Obj.repr (Some a) - | _ -> Obj.repr None) + Some a -> Some a + | _ -> None) | Stree t -> let pt = parser_of_tree entry 1 0 t in (fun (strm__ : _ Stream.t) -> let bp = Stream.count strm__ in let a = pt strm__ in let ep = Stream.count strm__ in - let loc = loc_of_token_interval bp ep in app a loc) + let loc = loc_of_token_interval bp ep in a loc) | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__) | Snterml (e, l) -> (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__) | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) | Stoken tok -> parser_of_token entry tok -and parser_of_token entry tok = - let f = entry.egram.glexer.Plexing.tok_match tok in +and parser_of_token : type s. + s ty_entry -> Plexing.pattern -> string parser_t = + fun entry tok -> + let f = egram.glexer.Plexing.tok_match tok in fun strm -> match Stream.peek strm with - Some tok -> let r = f tok in Stream.junk strm; Obj.repr r + Some tok -> let r = f tok in Stream.junk strm; r | None -> raise Stream.Failure -and parse_top_symb entry symb = parser_of_symbol entry 0 (top_symb entry symb) +and parse_top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a parser_t = + fun entry symb -> + parser_of_symbol entry 0 (top_symb entry symb) let rec start_parser_of_levels entry clevn = function @@ -594,7 +1259,7 @@ let rec start_parser_of_levels entry clevn = let bp = Stream.count strm__ in let act = p2 strm__ in let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in + let a = act (loc_of_token_interval bp ep) in entry.econtinue levn bp a strm) | _ -> fun levn strm -> @@ -605,7 +1270,7 @@ let rec start_parser_of_levels entry clevn = match try Some (p2 strm__) with Stream.Failure -> None with Some act -> let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in + let a = act (loc_of_token_interval bp ep) in entry.econtinue levn bp a strm | _ -> p1 levn strm__ @@ -631,7 +1296,7 @@ let rec continue_parser_of_levels entry clevn = Stream.Failure -> let act = p2 strm__ in let ep = Stream.count strm__ in - let a = app act a (loc_of_token_interval bp ep) in + let a = act a (loc_of_token_interval bp ep) in entry.econtinue levn bp a strm let continue_parser_of_entry entry = @@ -663,20 +1328,15 @@ let init_entry_functions entry = entry.econtinue <- f; f lev bp a strm) let extend_entry ~warning entry position rules = - try - let elev = Gramext.levels_of_rules ~warning entry position rules in + let elev = levels_of_rules ~warning entry position rules in entry.edesc <- Dlevels elev; init_entry_functions entry - with Plexing.Error s -> - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" (* Deleting a rule *) let delete_rule entry sl = match entry.edesc with Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in + let levs = delete_rule_in_level_list entry sl levs in entry.edesc <- Dlevels levs; entry.estart <- (fun lev strm -> @@ -690,20 +1350,9 @@ let delete_rule entry sl = (* Normal interface *) -let create_toktab () = Hashtbl.create 301 -let gcreate glexer = - {gtokens = create_toktab (); glexer = glexer } - -let tokens g con = - let list = ref [] in - Hashtbl.iter - (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list) - g.gtokens; - !list - -type 'te gen_parsable = +type parsable = { pa_chr_strm : char Stream.t; - pa_tok_strm : 'te Stream.t; + pa_tok_strm : L.te Stream.t; pa_loc_func : Plexing.location_function } let parse_parsable entry p = @@ -746,95 +1395,30 @@ let clear_entry e = Dlevels _ -> e.edesc <- Dlevels [] | Dparser _ -> () -(* Functorial interface *) - -module type GLexerType = sig type te val lexer : te Plexing.lexer end - -module type S = - sig - type te - type parsable - val parsable : char Stream.t -> parsable - val tokens : string -> (string * int) list - module Entry : - sig - type 'a e - val create : string -> 'a e - val parse : 'a e -> parsable -> 'a - val name : 'a e -> string - val of_parser : string -> (te Stream.t -> 'a) -> 'a e - val parse_token_stream : 'a e -> te Stream.t -> 'a - val print : Format.formatter -> 'a e -> unit - end - type ('self, 'a) ty_symbol - type ('self, 'f, 'r) ty_rule - type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol - val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol - val s_list0sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol - val s_list1sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_self : ('self, 'self) ty_symbol - val s_next : ('self, 'self) ty_symbol - val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol - val r_stop : ('self, 'r, 'r) ty_rule - val r_next : - ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> - ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production - module Unsafe : - sig - val clear_entry : 'a Entry.e -> unit - end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a ty_production list) - list -> - unit - val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit - end - -module GMake (L : GLexerType) = - struct - type te = L.te - type parsable = te gen_parsable - let gram = gcreate L.lexer let parsable cs = let (ts, lf) = L.lexer.Plexing.tok_func cs in {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} - let tokens = tokens gram module Entry = struct - type 'a e = te g_entry + type 'a e = 'a ty_entry let create n = - {egram = gram; ename = n; elocal = false; estart = empty_entry n; + { ename = n; estart = empty_entry n; econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); edesc = Dlevels []} - external obj : 'a e -> te Gramext.g_entry = "%identity" let parse (e : 'a e) p : 'a = - Obj.magic (parse_parsable e p : Obj.t) + parse_parsable e p let parse_token_stream (e : 'a e) ts : 'a = - Obj.magic (e.estart 0 ts : Obj.t) + e.estart 0 ts let name e = e.ename let of_parser n (p : te Stream.t -> 'a) : 'a e = - {egram = gram; ename = n; elocal = false; - estart = (fun _ -> (Obj.magic p : te Stream.t -> Obj.t)); + { ename = n; + estart = (fun _ -> p); econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p : te Stream.t -> Obj.t)} - let print ppf e = fprintf ppf "%a@." print_entry (obj e) + edesc = Dparser p} + let print ppf e = fprintf ppf "%a@." print_entry e end - type ('self, 'a) ty_symbol = te Gramext.g_symbol - type ('self, 'f, 'r) ty_rule = ('self, Obj.t) ty_symbol list - type 'a ty_production = ('a, Obj.t, Obj.t) ty_rule * Gramext.g_action let s_nterm e = Snterm e let s_nterml e l = Snterml (e, l) let s_list0 s = Slist0 s @@ -845,20 +1429,21 @@ module GMake (L : GLexerType) = let s_self = Sself let s_next = Snext let s_token tok = Stoken tok - let s_rules ~warning (t : Obj.t ty_production list) = Gramext.srules ~warning (Obj.magic t) - let r_stop = [] - let r_next r s = r @ [s] - let production - (p : ('a, 'f, Loc.t -> 'a) ty_rule * 'f) : 'a ty_production = - Obj.magic p + let s_rules ~warning (t : 'a ty_production list) = srules ~warning t + let r_stop = TStop + let r_next r s = TNext (r, s) + let production (p, act) = TProd (p, act) module Unsafe = struct let clear_entry = clear_entry end - let safe_extend ~warning e pos + let safe_extend ~warning (e : 'a Entry.e) pos (r : - (string option * Gramext.g_assoc option * Obj.t ty_production list) + (string option * Gramext.g_assoc option * 'a ty_production list) list) = - extend_entry ~warning e pos (Obj.magic r) - let safe_delete_rule e r = delete_rule (Entry.obj e) r - end + extend_entry ~warning e pos r + let safe_delete_rule e r = + let AnyS (symbols, _) = get_symbols r in + delete_rule e symbols + +end diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index f99a3c2480..fce5445ad8 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -4,8 +4,6 @@ type pattern = string * string -exception Error of string - type location_function = int -> Loc.t type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index eed4082e00..6139dc4020 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -19,9 +19,6 @@ type pattern = string * string - The way tokens patterns are interpreted to parse tokens is done by the lexer, function [tok_match] below. *) -exception Error of string - (** A lexing error exception to be used by lexers. *) - (** Lexer type *) type 'te lexer = diff --git a/gramlib/ploc.ml b/gramlib/ploc.ml index 9342fc6c1d..056a2b7ad3 100644 --- a/gramlib/ploc.ml +++ b/gramlib/ploc.ml @@ -6,17 +6,16 @@ open Loc let make_unlined (bp, ep) = {fname = InFile ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; - bp = bp; ep = ep; comm = ""; ecomm = ""} + bp = bp; ep = ep; } let dummy = {fname = InFile ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; - bp = 0; ep = 0; comm = ""; ecomm = ""} + bp = 0; ep = 0; } (* *) let sub loc sh len = {loc with bp = loc.bp + sh; ep = loc.bp + sh + len} let after loc sh len = {loc with bp = loc.ep + sh; ep = loc.ep + sh + len} -let with_comment loc comm = {loc with comm = comm} exception Exc of Loc.t * exn diff --git a/gramlib/ploc.mli b/gramlib/ploc.mli index 100fbc7271..15a5a74455 100644 --- a/gramlib/ploc.mli +++ b/gramlib/ploc.mli @@ -35,6 +35,3 @@ val after : Loc.t -> int -> int -> Loc.t (** [Ploc.after loc sh len] is the location just after loc (starting at the end position of [loc]) shifted with [sh] characters and of length [len]. *) - -val with_comment : Loc.t -> string -> Loc.t - (** Change the comment part of the given location *) diff --git a/ide/idetop.ml b/ide/idetop.ml index e157696294..608577b297 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -93,23 +93,22 @@ let add ((s,eid),(sid,verbose)) = let pa = Pcoq.Parsable.make (Stream.of_string s) in match Stm.parse_sentence ~doc sid ~entry:Pvernac.main_entry pa with | None -> assert false (* s is not an empty string *) - | Some (loc, ast) -> - let loc_ast = CAst.make ~loc ast in - ide_cmd_checks ~last_valid:sid loc_ast; - let doc, newid, rc = Stm.add ~doc ~ontop:sid verbose loc_ast in - set_doc doc; - let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in - ide_cmd_warns ~id:newid loc_ast; - (* TODO: the "" parameter is a leftover of the times the protocol - * used to include stderr/stdout output. - * - * Currently, we force all the output meant for the to go via the - * feedback mechanism, and we don't manipulate stderr/stdout, which - * are left to the client's discrection. The parameter is still there - * as not to break the core protocol for this minor change, but it should - * be removed in the next version of the protocol. - *) - newid, (rc, "") + | Some ast -> + ide_cmd_checks ~last_valid:sid ast; + let doc, newid, rc = Stm.add ~doc ~ontop:sid verbose ast in + set_doc doc; + let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in + ide_cmd_warns ~id:newid ast; + (* TODO: the "" parameter is a leftover of the times the protocol + * used to include stderr/stdout output. + * + * Currently, we force all the output meant for the to go via the + * feedback mechanism, and we don't manipulate stderr/stdout, which + * are left to the client's discrection. The parameter is still there + * as not to break the core protocol for this minor change, but it should + * be removed in the next version of the protocol. + *) + newid, (rc, "") let edit_at id = let doc = get_doc () in @@ -136,9 +135,9 @@ let annotate phrase = let pa = Pcoq.Parsable.make (Stream.of_string phrase) in match Stm.parse_sentence ~doc (Stm.get_current_state ~doc) ~entry:Pvernac.main_entry pa with | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) - | Some (_, ast) -> - (* XXX: Width should be a parameter of annotate... *) - Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) + | Some ast -> + (* XXX: Width should be a parameter of annotate... *) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast.CAst.v) (** Goal display *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c8c38ffe05..24894fc9f5 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2328,36 +2328,38 @@ let interp_open_constr env sigma c = (* Not all evars expected to be resolved and computation of implicit args *) -let interp_constr_evars_gen_impls env sigma +let interp_constr_evars_gen_impls ?(program_mode=false) env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env sigma c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - let sigma, c = understand_tcc env sigma ~expected_type c in + let flags = { Pretyping.all_no_fail_flags with program_mode } in + let sigma, c = understand_tcc ~flags env sigma ~expected_type c in sigma, (c, imps) -let interp_constr_evars_impls env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls env sigma ~impls WithoutTypeConstraint c +let interp_constr_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls ?program_mode env sigma ~impls WithoutTypeConstraint c -let interp_casted_constr_evars_impls env evdref ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen_impls env evdref ~impls (OfType typ) c +let interp_casted_constr_evars_impls ?program_mode env evdref ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen_impls ?program_mode env evdref ~impls (OfType typ) c -let interp_type_evars_impls env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls env sigma ~impls IsType c +let interp_type_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls ?program_mode env sigma ~impls IsType c (* Not all evars expected to be resolved, with side-effect on evars *) -let interp_constr_evars_gen env sigma ?(impls=empty_internalization_env) expected_type c = +let interp_constr_evars_gen ?(program_mode=false) env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env sigma c in - understand_tcc env sigma ~expected_type c + let flags = { Pretyping.all_no_fail_flags with program_mode } in + understand_tcc ~flags env sigma ~expected_type c -let interp_constr_evars env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c +let interp_constr_evars ?program_mode env evdref ?(impls=empty_internalization_env) c = + interp_constr_evars_gen ?program_mode env evdref WithoutTypeConstraint ~impls c -let interp_casted_constr_evars env sigma ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen env sigma ~impls (OfType typ) c +let interp_casted_constr_evars ?program_mode env sigma ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen ?program_mode env sigma ~impls (OfType typ) c -let interp_type_evars env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen env sigma IsType ~impls c +let interp_type_evars ?program_mode env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen ?program_mode env sigma IsType ~impls c (* Miscellaneous *) @@ -2419,8 +2421,9 @@ let intern_context global_level env impl_env binders = with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) -let interp_glob_context_evars env sigma k bl = +let interp_glob_context_evars ?(program_mode=false) env sigma k bl = let open EConstr in + let flags = { Pretyping.all_no_fail_flags with program_mode } in let env, sigma, par, _, impls = List.fold_left (fun (env,sigma,params,n,impls) (na, k, b, t) -> @@ -2428,7 +2431,7 @@ let interp_glob_context_evars env sigma k bl = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t in - let sigma, t = understand_tcc env sigma ~expected_type:IsType t' in + let sigma, t = understand_tcc ~flags env sigma ~expected_type:IsType t' in match b with None -> let d = LocalAssum (na,t) in @@ -2440,13 +2443,13 @@ let interp_glob_context_evars env sigma k bl = in (push_rel d env, sigma, d::params, succ n, impls) | Some b -> - let sigma, c = understand_tcc env sigma ~expected_type:(OfType t) b in + let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in let d = LocalDef (na, c, t) in (push_rel d env, sigma, d::params, n, impls)) (env,sigma,[],k+1,[]) (List.rev bl) in sigma, ((env, par), impls) -let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = +let interp_context_evars ?program_mode ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = let int_env,bl = intern_context global_level env impl_env params in - let sigma, x = interp_glob_context_evars env sigma shift bl in + let sigma, x = interp_glob_context_evars ?program_mode env sigma shift bl in sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 61acd09d65..2d14a0d0a7 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -113,26 +113,26 @@ val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr (** Accepting unresolved evars *) -val interp_constr_evars : env -> evar_map -> +val interp_constr_evars : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> evar_map * constr -val interp_casted_constr_evars : env -> evar_map -> +val interp_casted_constr_evars : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> types -> evar_map * constr -val interp_type_evars : env -> evar_map -> +val interp_type_evars : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> evar_map * types (** Accepting unresolved evars and giving back the manual implicit arguments *) -val interp_constr_evars_impls : env -> evar_map -> +val interp_constr_evars_impls : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> evar_map * (constr * Impargs.manual_implicits) -val interp_casted_constr_evars_impls : env -> evar_map -> +val interp_casted_constr_evars_impls : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> types -> evar_map * (constr * Impargs.manual_implicits) -val interp_type_evars_impls : env -> evar_map -> +val interp_type_evars_impls : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> evar_map * (types * Impargs.manual_implicits) @@ -158,7 +158,7 @@ val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * (** Interpret contexts: returns extended env and context *) val interp_context_evars : - ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> + ?program_mode:bool -> ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 474ce3e871..18a257047d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1114,7 +1114,7 @@ let start_library dir senv = modvariant = LIBRARY; required = senv.required } -let export ?except senv dir = +let export ?except ~output_native_objects senv dir = let senv = try join_safe_environment ?except senv with e -> @@ -1136,7 +1136,7 @@ let export ?except senv dir = } in let ast, symbols = - if !Flags.output_native_objects then + if output_native_objects then Nativelibrary.dump_library mp dir senv.env str else [], Nativecode.empty_symbols in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 1b7239da23..8539fdd504 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -187,7 +187,7 @@ val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.sym val start_library : DirPath.t -> ModPath.t safe_transformer val export : - ?except:Future.UUIDSet.t -> + ?except:Future.UUIDSet.t -> output_native_objects:bool -> safe_environment -> DirPath.t -> ModPath.t * compiled_library * native_library diff --git a/lib/envars.ml b/lib/envars.ml index b5036e7340..8a75d9a552 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -110,11 +110,11 @@ let set_user_coqlib path = coqlib := Some path (** coqlib is now computed once during coqtop initialization *) -let set_coqlib ~fail = +let set_coqlib ~boot ~fail = match !coqlib with | Some _ -> () | None -> - let lib = if !Flags.boot then coqroot else guess_coqlib fail in + let lib = if boot then coqroot else guess_coqlib fail in coqlib := Some lib let coqlib () = Option.default "" !coqlib diff --git a/lib/envars.mli b/lib/envars.mli index ebf86d0650..21365c48f6 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -39,7 +39,7 @@ val datadir : unit -> string val configdir : unit -> string (** [set_coqlib] must be runned once before any access to [coqlib] *) -val set_coqlib : fail:(string -> string) -> unit +val set_coqlib : boot:bool -> fail:(string -> string) -> unit (** [set_user_coqlib path] sets the coqlib directory explicitedly. *) val set_user_coqlib : string -> unit diff --git a/lib/flags.ml b/lib/flags.ml index 55bfa3cbde..768d359cce 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -41,8 +41,6 @@ let with_options ol f x = let () = List.iter2 (:=) ol vl in Exninfo.iraise reraise -let boot = ref false - let record_aux_file = ref false let test_mode = ref false @@ -107,12 +105,6 @@ let polymorphic_inductive_cumulativity = ref false let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity -(** [program_mode] tells that Program mode has been activated, either - globally via [Set Program] or locally via the Program command prefix. *) - -let program_mode = ref false -let is_program_mode () = !program_mode - let warn = ref true let make_warn flag = warn := flag; () let if_warn f x = if !warn then f x @@ -124,8 +116,5 @@ let inline_level = ref default_inline_level let set_inline_level = (:=) inline_level let get_inline_level () = !inline_level -(* Native code compilation for conversion and normalization *) -let output_native_objects = ref false - let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 diff --git a/lib/flags.mli b/lib/flags.mli index 7336b9beaf..4ef5fb4445 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -31,8 +31,6 @@ (** Command-line flags *) -val boot : bool ref - (** Set by coqtop to tell the kernel to output to the aux file; will be eventually removed by cleanups such as PR#1103 *) val record_aux_file : bool ref @@ -77,10 +75,6 @@ val verbosely : ('a -> 'b) -> 'a -> 'b val if_silent : ('a -> unit) -> 'a -> unit val if_verbose : ('a -> unit) -> 'a -> unit -(* Miscellaneus flags for vernac *) -val program_mode : bool ref -val is_program_mode : unit -> bool - (** Global polymorphic inductive cumulativity flag. *) val make_polymorphic_inductive_cumulativity : bool -> unit val is_polymorphic_inductive_cumulativity : unit -> bool @@ -116,9 +110,6 @@ val set_inline_level : int -> unit val get_inline_level : unit -> int val default_inline_level : int -(** When producing vo objects, also compile the native-code version *) -val output_native_objects : bool ref - (** Global profile_ltac flag *) val profile_ltac : bool ref val profile_ltac_cutoff : float ref diff --git a/lib/loc.ml b/lib/loc.ml index c08648911b..66b7a7da70 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -22,19 +22,17 @@ type t = { bol_pos_last : int; (** position of the beginning of end line *) bp : int; (** start position *) ep : int; (** end position *) - comm : string; (** start comment *) - ecomm : string (** end comment *) } let create fname line_nb bol_pos bp ep = { fname = fname; line_nb = line_nb; bol_pos = bol_pos; line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; - comm = ""; ecomm = "" } +} let make_loc (bp, ep) = { fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; - comm = ""; ecomm = "" } +} let mergeable loc1 loc2 = loc1.fname = loc2.fname @@ -50,7 +48,7 @@ let merge loc1 loc2 = line_nb_last = loc2.line_nb_last; bol_pos_last = loc2.bol_pos_last; bp = loc1.bp; ep = loc2.ep; - comm = loc1.comm; ecomm = loc2.comm } + } else loc1 else if loc2.ep < loc1.ep then { fname = loc2.fname; @@ -59,7 +57,6 @@ let merge loc1 loc2 = line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last; bp = loc2.bp; ep = loc1.ep; - comm = loc2.comm; ecomm = loc1.comm } else loc2 diff --git a/lib/loc.mli b/lib/loc.mli index c46311b639..23df1ebd9a 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -22,8 +22,6 @@ type t = { bol_pos_last : int; (** position of the beginning of end line *) bp : int; (** start position *) ep : int; (** end position *) - comm : string; (** start comment *) - ecomm : string (** end comment *) } (** {5 Location manipulation} *) diff --git a/library/declaremods.ml b/library/declaremods.ml index 8699583cdf..5fd11e187a 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -928,10 +928,10 @@ let append_end_library_hook f = let old_f = !end_library_hook in end_library_hook := fun () -> old_f(); f () -let end_library ?except dir = +let end_library ?except ~output_native_objects dir = !end_library_hook(); let oname = Lib.end_compilation_checks dir in - let mp,cenv,ast = Global.export ?except dir in + let mp,cenv,ast = Global.export ?except ~output_native_objects dir in let prefix, lib_stack = Lib.end_compilation oname in assert (ModPath.equal mp (MPfile dir)); let substitute, keep, _ = Lib.classify_segment lib_stack in diff --git a/library/declaremods.mli b/library/declaremods.mli index 7aa4bc30ce..2b28ba908e 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -99,7 +99,7 @@ val get_library_native_symbols : library_name -> Nativecode.symbols val start_library : library_name -> unit val end_library : - ?except:Future.UUIDSet.t -> library_name -> + ?except:Future.UUIDSet.t -> output_native_objects:bool -> library_name -> Safe_typing.compiled_library * library_objects * Safe_typing.native_library (** append a function to be executed at end_library *) diff --git a/library/global.ml b/library/global.ml index 784a02449c..cf996ce644 100644 --- a/library/global.ml +++ b/library/global.ml @@ -143,7 +143,8 @@ let mind_of_delta_kn kn = (** Operations on libraries *) let start_library dir = globalize (Safe_typing.start_library dir) -let export ?except s = Safe_typing.export ?except (safe_env ()) s +let export ?except ~output_native_objects s = + Safe_typing.export ?except ~output_native_objects (safe_env ()) s let import c u d = globalize (Safe_typing.import c u d) diff --git a/library/global.mli b/library/global.mli index df18625a5f..4e2ad92717 100644 --- a/library/global.mli +++ b/library/global.mli @@ -108,7 +108,7 @@ val body_of_constant_body : Declarations.constant_body -> (Constr.constr * Univ. (** {6 Compiled libraries } *) val start_library : DirPath.t -> ModPath.t -val export : ?except:Future.UUIDSet.t -> DirPath.t -> +val export : ?except:Future.UUIDSet.t -> output_native_objects:bool -> DirPath.t -> ModPath.t * Safe_typing.compiled_library * Safe_typing.native_library val import : Safe_typing.compiled_library -> Univ.ContextSet.t -> Safe_typing.vodigest -> diff --git a/library/library.ml b/library/library.ml index 9b9bd07c93..37dadadb76 100644 --- a/library/library.ml +++ b/library/library.ml @@ -657,7 +657,7 @@ let error_recursively_dependent_library dir = (* Security weakness: file might have been changed on disk between writing the content and computing the checksum... *) -let save_library_to ?todo dir f otab = +let save_library_to ?todo ~output_native_objects dir f otab = let except = match todo with | None -> (* XXX *) @@ -668,7 +668,7 @@ let save_library_to ?todo dir f otab = assert(Filename.check_suffix f ".vio"); List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in - let cenv, seg, ast = Declaremods.end_library ~except dir in + let cenv, seg, ast = Declaremods.end_library ~output_native_objects ~except dir in let opaque_table, univ_table, disch_table, f2t_map = Opaqueproof.dump otab in let tasks, utab, dtab = match todo with @@ -716,7 +716,7 @@ let save_library_to ?todo dir f otab = System.marshal_out_segment f' ch (opaque_table : seg_proofs); close_out ch; (* Writing native code files *) - if !Flags.output_native_objects then + 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.") diff --git a/library/library.mli b/library/library.mli index c016352808..a976be0184 100644 --- a/library/library.mli +++ b/library/library.mli @@ -38,9 +38,11 @@ type seg_proofs = Constr.constr Future.computation array an export otherwise just a simple import *) val import_module : bool -> qualid list -> unit -(** End the compilation of a library and save it to a ".vo" file *) +(** End the compilation of a library and save it to a ".vo" file. + [output_native_objects]: when producing vo objects, also compile the native-code version. *) val save_library_to : ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> + output_native_objects:bool -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit val load_library_todo : diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 6f9384941b..d06a241969 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -40,7 +40,7 @@ let start_deriving f suchthat lemma = let f_type = EConstr.Unsafe.to_constr f_type in let ef = EConstr.Unsafe.to_constr ef in let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in - let sigma, suchthat = Constrintern.interp_type_evars env' sigma suchthat in + let sigma, suchthat = Constrintern.interp_type_evars ~program_mode:false env' sigma suchthat in TCons ( env' , sigma , suchthat , (fun sigma _ -> TNil sigma)))))) in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d9b0330e2b..42dc66dcf4 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -166,7 +166,7 @@ let build_newrecursive let arityc = Constrexpr_ops.mkCProdN bl arityc in let arity,ctx = Constrintern.interp_type env0 sigma arityc in let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars env evd bl in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd bl in let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in let open Context.Named.Declaration in (EConstr.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 1b5286dce4..0c97f9f373 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1518,10 +1518,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let open CVars in let env = Global.env() in let evd = Evd.from_env env in - let evd, function_type = interp_type_evars env evd type_of_f in + let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in + let evd, ty = interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq in let evd = Evd.minimize_universes evd in let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 47f593ff3e..ffd8b71e5d 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -50,7 +50,8 @@ let with_delayed_uconstr ist c tac = Pretyping.use_typeclasses = false; solve_unification_constraints = true; fail_evar = false; - expand_evars = true + expand_evars = true; + program_mode = false; } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -344,7 +345,9 @@ let constr_flags () = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); Pretyping.fail_evar = false; - Pretyping.expand_evars = true } + Pretyping.expand_evars = true; + Pretyping.program_mode = false; +} let refine_tac ist simple with_classes c = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 7be8f67616..663537f3e8 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -56,7 +56,8 @@ let eval_uconstrs ist cs = Pretyping.use_typeclasses = false; solve_unification_constraints = true; fail_evar = false; - expand_evars = true + expand_evars = true; + program_mode = false; } in let map c env sigma = c env sigma in List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 3e7479903a..62906303a4 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -530,7 +530,15 @@ let interp_gen kind ist pattern_mode flags env sigma c = invariant that running the tactic returned by push_trace does not modify sigma. *) let (_, dummy_proofview) = Proofview.init sigma [] in - let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in + + (* Again this is called at times with no open proof! *) + let name, poly = + try + let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in + name, poly + with | Proof_global.NoCurrentProof -> Id.of_string "tacinterp", false + in + let (trace,_,_,_) = Proofview.apply ~name ~poly env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) term in @@ -544,7 +552,9 @@ let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; fail_evar = true; - expand_evars = true } + expand_evars = true; + program_mode = false; +} (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = @@ -558,19 +568,25 @@ let open_constr_use_classes_flags () = { use_typeclasses = true; solve_unification_constraints = true; fail_evar = false; - expand_evars = true } + expand_evars = true; + program_mode = false; +} let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; fail_evar = false; - expand_evars = true } + expand_evars = true; + program_mode = false; +} let pure_open_constr_flags = { use_typeclasses = false; solve_unification_constraints = true; fail_evar = false; - expand_evars = false } + expand_evars = false; + program_mode = false; +} (* Interprets an open constr *) let interp_open_constr ?(expected_type=WithoutTypeConstraint) ?(flags=open_constr_no_classes_flags ()) ist env sigma c = @@ -2033,7 +2049,16 @@ let _ = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun = lfun; extra; } in let tac = interp_tactic ist tac in - let name, poly = Id.of_string "ltac_sub", false in + (* XXX: This depends on the global state which is bad; the hooking + mechanism should be modified. *) + let name, poly = + try + let (_, poly, _) = Proof_global.get_current_persistence () in + let name = Proof_global.get_current_proof_name () in + name, poly + with | Proof_global.NoCurrentProof -> + Id.of_string "ltac_gen", false + in let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 9ce9250a43..0897d3b45b 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -137,6 +137,9 @@ type 'tac ssrhint = bool * 'tac option list type 'tac fwdbinders = bool * (ssrhpats * ((ssrfwdfmt * ast_closure_term) * 'tac ssrhint)) +type 'tac ffwbinders = + (ssrhpats * ((ssrfwdfmt * ast_closure_term) * 'tac ssrhint)) + type clause = (ssrclear * ((ssrhyp_or_id * string) * Ssrmatching_plugin.Ssrmatching.cpattern option) option) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index c3b9bde9b8..0961edb6cb 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -243,7 +243,9 @@ let interp_refine ist gl rc = Pretyping.use_typeclasses = true; solve_unification_constraints = true; fail_evar = false; - expand_evars = true } + expand_evars = true; + program_mode = false; + } in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 3fb21e5ef6..2a2cd73df2 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -591,10 +591,8 @@ END GRAMMAR EXTEND Gram GLOBAL: ssrfwdview; ssrfwdview: [ - [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> - { [mk_ast_closure_term `None c] } - | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrfwdview -> - { (mk_ast_closure_term `None c) :: w } ]]; + [ test_not_ssrslashnum; "/"; c = ast_closure_term -> { [c] } + | test_not_ssrslashnum; "/"; c = ast_closure_term; w = ssrfwdview -> { c :: w } ]]; END (* ipats *) diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index a2cbd3c9c8..7844050272 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -32,6 +32,19 @@ type ssrfwdview = ast_closure_term list type ssreqid = ssripat option type ssrarg = ssrfwdview * (ssreqid * (cpattern ssragens * ssripats)) +val wit_ssrseqdir : ssrdir Genarg.uniform_genarg_type +val wit_ssrseqarg : (Tacexpr.raw_tactic_expr ssrseqarg, Tacexpr.glob_tactic_expr ssrseqarg, Geninterp.Val.t ssrseqarg) Genarg.genarg_type + +val wit_ssrintrosarg : + (Tacexpr.raw_tactic_expr * ssripats, + Tacexpr.glob_tactic_expr * ssripats, + Geninterp.Val.t * ssripats) Genarg.genarg_type + +val wit_ssrsufffwd : + (Tacexpr.raw_tactic_expr ffwbinders, + Tacexpr.glob_tactic_expr ffwbinders, + Geninterp.Val.t ffwbinders) Genarg.genarg_type + val wit_ssripatrep : ssripat Genarg.uniform_genarg_type val wit_ssrarg : ssrarg Genarg.uniform_genarg_type val wit_ssrrwargs : ssrrwarg list Genarg.uniform_genarg_type @@ -47,3 +60,43 @@ val wit_ssrhintarg : (Tacexpr.raw_tactic_expr ssrhint, Tacexpr.glob_tactic_expr ssrhint, Tacinterp.Value.t ssrhint) Genarg.genarg_type + +val wit_ssrexactarg : ssrapplyarg Genarg.uniform_genarg_type +val wit_ssrcongrarg : ((int * ssrterm) * cpattern ssragens) Genarg.uniform_genarg_type +val wit_ssrfwdid : Names.Id.t Genarg.uniform_genarg_type + +val wit_ssrsetfwd : + ((ssrfwdfmt * (cpattern * ast_closure_term option)) * ssrdocc) Genarg.uniform_genarg_type + +val wit_ssrdoarg : + (Tacexpr.raw_tactic_expr ssrdoarg, + Tacexpr.glob_tactic_expr ssrdoarg, + Tacinterp.Value.t ssrdoarg) Genarg.genarg_type + +val wit_ssrhint : + (Tacexpr.raw_tactic_expr ssrhint, + Tacexpr.glob_tactic_expr ssrhint, + Tacinterp.Value.t ssrhint) Genarg.genarg_type + +val wit_ssrhpats : ssrhpats Genarg.uniform_genarg_type +val wit_ssrhpats_nobs : ssrhpats Genarg.uniform_genarg_type +val wit_ssrhpats_wtransp : ssrhpats_wtransp Genarg.uniform_genarg_type + +val wit_ssrposefwd : (ssrfwdfmt * ast_closure_term) Genarg.uniform_genarg_type + +val wit_ssrrpat : ssripat Genarg.uniform_genarg_type +val wit_ssrterm : ssrterm Genarg.uniform_genarg_type +val wit_ssrunlockarg : (ssrocc * ssrterm) Genarg.uniform_genarg_type +val wit_ssrunlockargs : (ssrocc * ssrterm) list Genarg.uniform_genarg_type + +val wit_ssrwgen : clause Genarg.uniform_genarg_type +val wit_ssrwlogfwd : (clause list * (ssrfwdfmt * ast_closure_term)) Genarg.uniform_genarg_type + +val wit_ssrfixfwd : (Names.Id.t * (ssrfwdfmt * ast_closure_term)) Genarg.uniform_genarg_type +val wit_ssrfwd : (ssrfwdfmt * ast_closure_term) Genarg.uniform_genarg_type +val wit_ssrfwdfmt : ssrfwdfmt Genarg.uniform_genarg_type + +val wit_ssrcpat : ssripat Genarg.uniform_genarg_type +val wit_ssrdgens : cpattern ssragens Genarg.uniform_genarg_type +val wit_ssrdgens_tl : cpattern ssragens Genarg.uniform_genarg_type +val wit_ssrdir : ssrdir Genarg.uniform_genarg_type diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 62c27297f3..ed7c3d6770 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -378,11 +378,11 @@ let is_patvar pat = | PatVar _ -> true | _ -> false -let coerce_row typing_fun env sigma pats (tomatch,(na,indopt)) = +let coerce_row ~program_mode typing_fun env sigma pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let sigma, tycon, realnames = find_tomatch_tycon !!env sigma loc indopt in let sigma, j = typing_fun tycon env sigma tomatch in - let sigma, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) !!env sigma j in + let sigma, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) ~program_mode !!env sigma j in let typ = nf_evar sigma j.uj_type in let env = make_return_predicate_ltac_lvar env sigma na tomatch j.uj_val in let sigma, t = @@ -395,12 +395,12 @@ let coerce_row typing_fun env sigma pats (tomatch,(na,indopt)) = in ((env, sigma), (j.uj_val,t)) -let coerce_to_indtype typing_fun env sigma matx tomatchl = +let coerce_to_indtype ~program_mode typing_fun env sigma matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) | m -> m in - let (env, sigma), tms = List.fold_left2_map (fun (env, sigma) -> coerce_row typing_fun env sigma) (env, sigma) matx' tomatchl in + let (env, sigma), tms = List.fold_left2_map (fun (env, sigma) -> coerce_row ~program_mode typing_fun env sigma) (env, sigma) matx' tomatchl in env, sigma, tms (************************************************************************) @@ -410,7 +410,7 @@ let mkExistential ?(src=(Loc.tag Evar_kinds.InternalHole)) env sigma = let sigma, (e, u) = Evarutil.new_type_evar env sigma ~src:src univ_flexible_alg in sigma, e -let adjust_tomatch_to_pattern sigma pb ((current,typ),deps,dep) = +let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an @@ -435,7 +435,7 @@ let adjust_tomatch_to_pattern sigma pb ((current,typ),deps,dep) = | None -> sigma, current | Some sigma -> sigma, current else - let sigma, j = Coercion.inh_conv_coerce_to true !!(pb.env) sigma (make_judge current typ) indt in + let sigma, j = Coercion.inh_conv_coerce_to ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in sigma, j.uj_val in sigma, (current, try_find_ind !!(pb.env) sigma indt names)) @@ -468,10 +468,11 @@ let remove_current_pattern eqn = alias_stack = alias_of_pat pat :: eqn.alias_stack } | [] -> anomaly (Pp.str "Empty list of patterns.") -let push_current_pattern sigma (cur,ty) eqn = +let push_current_pattern ~program_mode sigma (cur,ty) eqn = + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in match eqn.patterns with | pat::pats -> - let _,rhs_env = push_rel sigma (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in + let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -562,16 +563,17 @@ let occur_in_rhs na rhs = | Name id -> Id.Set.mem id rhs.rhs_vars let is_dep_patt_in eqn pat = match DAst.get pat with - | PatVar name -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs + | PatVar name -> occur_in_rhs name eqn.rhs | PatCstr _ -> true -let mk_dep_patt_row (pats,_,eqn) = - List.map (is_dep_patt_in eqn) pats +let mk_dep_patt_row ~program_mode (pats,_,eqn) = + if program_mode then List.map (fun _ -> true) pats + else List.map (is_dep_patt_in eqn) pats -let dependencies_in_pure_rhs nargs eqns = +let dependencies_in_pure_rhs ~program_mode nargs eqns = if List.is_empty eqns then - List.make nargs (not (Flags.is_program_mode ())) (* Only "_" patts *) else - let deps_rows = List.map mk_dep_patt_row eqns in + List.make nargs (not program_mode) (* Only "_" patts *) else + let deps_rows = List.map (mk_dep_patt_row ~program_mode) eqns in let deps_columns = matrix_transpose deps_rows in List.map (List.exists (fun x -> x)) deps_columns @@ -585,10 +587,10 @@ let rec dep_in_tomatch sigma n = function | Abstract (_,d) :: l -> RelDecl.exists (fun c -> not (noccurn sigma n c)) d || dep_in_tomatch sigma (n+1) l | [] -> false -let dependencies_in_rhs sigma nargs current tms eqns = +let dependencies_in_rhs ~program_mode sigma nargs current tms eqns = match EConstr.kind sigma current with | Rel n when dep_in_tomatch sigma n tms -> List.make nargs true - | _ -> dependencies_in_pure_rhs nargs eqns + | _ -> dependencies_in_pure_rhs ~program_mode nargs eqns (* Computing the matrix of dependencies *) @@ -788,9 +790,9 @@ let recover_and_adjust_alias_names (_,avoid) names sign = in List.split (aux (names,sign)) -let push_rels_eqn sigma sign eqn = +let push_rels_eqn ~hypnaming sigma sign eqn = {eqn with - rhs = {eqn.rhs with rhs_env = snd (push_rel_context sigma sign eqn.rhs.rhs_env) } } + rhs = {eqn.rhs with rhs_env = snd (push_rel_context ~hypnaming sigma sign eqn.rhs.rhs_env) } } let push_rels_eqn_with_names sigma sign eqn = let subpats = List.rev (List.firstn (List.length sign) eqn.patterns) in @@ -798,12 +800,12 @@ let push_rels_eqn_with_names sigma sign eqn = let sign = recover_initial_subpattern_names subpatnames sign in push_rels_eqn sigma sign eqn -let push_generalized_decl_eqn env sigma n decl eqn = +let push_generalized_decl_eqn ~hypnaming env sigma n decl eqn = match RelDecl.get_name decl with | Anonymous -> - push_rels_eqn sigma [decl] eqn + push_rels_eqn ~hypnaming sigma [decl] eqn | Name _ -> - push_rels_eqn sigma [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n !!(eqn.rhs.rhs_env))) decl] eqn + push_rels_eqn ~hypnaming sigma [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n !!(eqn.rhs.rhs_env))) decl] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } @@ -1266,7 +1268,7 @@ let build_leaf sigma pb = (* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *) (* spiwack: the [initial] argument keeps track whether the branch is a toplevel branch ([true]) or a deep one ([false]). *) -let build_branch initial current realargs deps (realnames,curname) sigma pb arsign eqns const_info = +let build_branch ~program_mode initial current realargs deps (realnames,curname) sigma pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in @@ -1296,7 +1298,8 @@ let build_branch initial current realargs deps (realnames,curname) sigma pb arsi let typs' = List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in - let typs,extenv = push_rel_context sigma typs pb.env in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let typs,extenv = push_rel_context ~hypnaming sigma typs pb.env in let typs' = List.map (fun (c,d) -> @@ -1306,7 +1309,7 @@ let build_branch initial current realargs deps (realnames,curname) sigma pb arsi (* generalization *) let dep_sign = find_dependencies_signature sigma - (dependencies_in_rhs sigma const_info.cs_nargs current pb.tomatch eqns) + (dependencies_in_rhs ~program_mode sigma const_info.cs_nargs current pb.tomatch eqns) (List.rev typs') in (* The dependent term to subst in the types of the remaining UnPushed @@ -1375,7 +1378,7 @@ let build_branch initial current realargs deps (realnames,curname) sigma pb arsi tomatch = tomatch; pred = pred; history = history; - mat = List.map (push_rels_eqn_with_names sigma typs) submat } + mat = List.map (push_rels_eqn_with_names ~hypnaming sigma typs) submat } (********************************************************************** INVARIANT: @@ -1390,181 +1393,187 @@ let build_branch initial current realargs deps (realnames,curname) sigma pb arsi (**********************************************************************) (* Main compiling descent *) -let rec compile sigma pb = - match pb.tomatch with - | Pushed cur :: rest -> match_current sigma { pb with tomatch = rest } cur - | Alias (initial,x) :: rest -> compile_alias initial sigma pb x rest - | NonDepAlias :: rest -> compile_non_dep_alias sigma pb rest - | Abstract (i,d) :: rest -> compile_generalization sigma pb i d rest - | [] -> build_leaf sigma pb +let compile ~program_mode sigma pb = + let rec compile sigma pb = + match pb.tomatch with + | Pushed cur :: rest -> match_current sigma { pb with tomatch = rest } cur + | Alias (initial,x) :: rest -> compile_alias initial sigma pb x rest + | NonDepAlias :: rest -> compile_non_dep_alias sigma pb rest + | Abstract (i,d) :: rest -> compile_generalization sigma pb i d rest + | [] -> build_leaf sigma pb (* Case splitting *) -and match_current sigma pb (initial,tomatch) = - let sigma, tm = adjust_tomatch_to_pattern sigma pb tomatch in - let pb,tomatch = adjust_predicate_from_tomatch tomatch tm pb in - let ((current,typ),deps,dep) = tomatch in - match typ with - | NotInd (_,typ) -> - check_all_variables !!(pb.env) sigma typ pb.mat; - compile_all_variables initial tomatch sigma pb - | IsInd (_,(IndType(indf,realargs) as indt),names) -> + and match_current sigma pb (initial,tomatch) = + let sigma, tm = adjust_tomatch_to_pattern ~program_mode sigma pb tomatch in + let pb,tomatch = adjust_predicate_from_tomatch tomatch tm pb in + let ((current,typ),deps,dep) = tomatch in + match typ with + | NotInd (_,typ) -> + check_all_variables !!(pb.env) sigma typ pb.mat; + compile_all_variables initial tomatch sigma pb + | IsInd (_,(IndType(indf,realargs) as indt),names) -> let mind,_ = dest_ind_family indf in - let mind = Tacred.check_privacy !!(pb.env) mind in - let cstrs = get_constructors !!(pb.env) indf in - let arsign, _ = get_arity !!(pb.env) indf in + let mind = Tacred.check_privacy !!(pb.env) mind in + let cstrs = get_constructors !!(pb.env) indf in + let arsign, _ = get_arity !!(pb.env) indf in let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in - let no_cstr = Int.equal (Array.length cstrs) 0 in + let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then - compile_all_variables initial tomatch sigma pb + compile_all_variables initial tomatch sigma pb else (* We generalize over terms depending on current term to match *) - let pb,deps = generalize_problem (names,dep) sigma pb deps in + let pb,deps = generalize_problem (names,dep) sigma pb deps in (* We compile branches *) - let fold_br sigma eqn cstr = - compile_branch initial current realargs (names,dep) deps sigma pb arsign eqn cstr - in - let sigma, brvals = Array.fold_left2_map fold_br sigma eqns cstrs in + let fold_br sigma eqn cstr = + compile_branch initial current realargs (names,dep) deps sigma pb arsign eqn cstr + in + let sigma, brvals = Array.fold_left2_map fold_br sigma eqns cstrs in (* We build the (elementary) case analysis *) - let depstocheck = current::binding_vars_of_inductive sigma typ in - let brvals,tomatch,pred,inst = - postprocess_dependencies sigma depstocheck - brvals pb.tomatch pb.pred deps cstrs in - let brvals = Array.map (fun (sign,body) -> - it_mkLambda_or_LetIn body sign) brvals in + let depstocheck = current::binding_vars_of_inductive sigma typ in + let brvals,tomatch,pred,inst = + postprocess_dependencies sigma depstocheck + brvals pb.tomatch pb.pred deps cstrs in + let brvals = Array.map (fun (sign,body) -> + it_mkLambda_or_LetIn body sign) brvals in let (pred,typ) = - find_predicate pb.caseloc pb.env sigma + find_predicate pb.caseloc pb.env sigma pred current indt (names,dep) tomatch in - let ci = make_case_info !!(pb.env) (fst mind) pb.casestyle in - let pred = nf_betaiota !!(pb.env) sigma pred in + let ci = make_case_info !!(pb.env) (fst mind) pb.casestyle in + let pred = nf_betaiota !!(pb.env) sigma pred in let case = - make_case_or_project !!(pb.env) sigma indf ci pred current brvals + make_case_or_project !!(pb.env) sigma indf ci pred current brvals in - let sigma, _ = Typing.type_of !!(pb.env) sigma pred in - Typing.check_allowed_sort !!(pb.env) sigma mind current pred; - sigma, { uj_val = applist (case, inst); - uj_type = prod_applist sigma typ inst } - - -(* Building the sub-problem when all patterns are variables. Case - where [current] is an intially pushed term. *) -and shift_problem ((current,t),_,na) sigma pb = - let ty = type_of_tomatch t in - let tomatch = lift_tomatch_stack 1 pb.tomatch in - let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in - let env = Name.fold_left (fun env id -> hide_variable env Anonymous id) pb.env na in - let pb = - { pb with - env = snd (push_rel sigma (LocalDef (na,current,ty)) env); - tomatch = tomatch; - pred = lift_predicate 1 pred tomatch; - history = pop_history pb.history; - mat = List.map (push_current_pattern sigma (current,ty)) pb.mat } in - let sigma, j = compile sigma pb in - sigma, { uj_val = subst1 current j.uj_val; - uj_type = subst1 current j.uj_type } - -(* Building the sub-problem when all patterns are variables, - non-initial case. Variables which appear as subterms of constructor - are already introduced in the context, we avoid creating aliases to - themselves by treating this case specially. *) -and pop_problem ((current,t),_,na) sigma pb = - let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in - let pb = - { pb with - pred = pred; - history = pop_history pb.history; - mat = List.map push_noalias_current_pattern pb.mat } in - compile sigma pb + let sigma, _ = Typing.type_of !!(pb.env) sigma pred in + Typing.check_allowed_sort !!(pb.env) sigma mind current pred; + sigma, { uj_val = applist (case, inst); + uj_type = prod_applist sigma typ inst } + + + (* Building the sub-problem when all patterns are variables. Case + where [current] is an intially pushed term. *) + and shift_problem ((current,t),_,na) sigma pb = + let ty = type_of_tomatch t in + let tomatch = lift_tomatch_stack 1 pb.tomatch in + let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in + let env = Name.fold_left (fun env id -> hide_variable env Anonymous id) pb.env na in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let pb = + { pb with + env = snd (push_rel ~hypnaming sigma (LocalDef (na,current,ty)) env); + tomatch = tomatch; + pred = lift_predicate 1 pred tomatch; + history = pop_history pb.history; + mat = List.map (push_current_pattern ~program_mode sigma (current,ty)) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = subst1 current j.uj_val; + uj_type = subst1 current j.uj_type } + + (* Building the sub-problem when all patterns are variables, + non-initial case. Variables which appear as subterms of constructor + are already introduced in the context, we avoid creating aliases to + themselves by treating this case specially. *) + and pop_problem ((current,t),_,na) sigma pb = + let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in + let pb = + { pb with + pred = pred; + history = pop_history pb.history; + mat = List.map push_noalias_current_pattern pb.mat } in + compile sigma pb -(* Building the sub-problem when all patterns are variables. *) -and compile_all_variables initial cur sigma pb = - if initial then shift_problem cur sigma pb - else pop_problem cur sigma pb + (* Building the sub-problem when all patterns are variables. *) + and compile_all_variables initial cur sigma pb = + if initial then shift_problem cur sigma pb + else pop_problem cur sigma pb -(* Building the sub-problem when all patterns are variables *) -and compile_branch initial current realargs names deps sigma pb arsign eqns cstr = - let sigma, sign, pb = build_branch initial current realargs deps names sigma pb arsign eqns cstr in - let sigma, j = compile sigma pb in - sigma, (sign, j.uj_val) + (* Building the sub-problem when all patterns are variables *) + and compile_branch initial current realargs names deps sigma pb arsign eqns cstr = + let sigma, sign, pb = build_branch ~program_mode initial current realargs deps names sigma pb arsign eqns cstr in + let sigma, j = compile sigma pb in + sigma, (sign, j.uj_val) -(* Abstract over a declaration before continuing splitting *) -and compile_generalization sigma pb i d rest = - let pb = - { pb with - env = snd (push_rel sigma d pb.env); - tomatch = rest; - mat = List.map (push_generalized_decl_eqn pb.env sigma i d) pb.mat } in - let sigma, j = compile sigma pb in - sigma, { uj_val = mkLambda_or_LetIn d j.uj_val; - uj_type = mkProd_wo_LetIn d j.uj_type } - -(* spiwack: the [initial] argument keeps track whether the alias has - been introduced by a toplevel branch ([true]) or a deep one - ([false]). *) -and compile_alias initial sigma pb (na,orig,(expanded,expanded_typ)) rest = - let f c t = - let alias = LocalDef (na,c,t) in + (* Abstract over a declaration before continuing splitting *) + and compile_generalization sigma pb i d rest = + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let pb = { pb with - env = snd (push_rel sigma alias pb.env); - tomatch = lift_tomatch_stack 1 rest; - pred = lift_predicate 1 pb.pred pb.tomatch; - history = pop_history_pattern pb.history; - mat = List.map (push_alias_eqn sigma alias) pb.mat } in + env = snd (push_rel ~hypnaming sigma d pb.env); + tomatch = rest; + mat = List.map (push_generalized_decl_eqn ~hypnaming pb.env sigma i d) pb.mat } in let sigma, j = compile sigma pb in - sigma, { uj_val = - if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then - subst1 c j.uj_val - else - mkLetIn (na,c,t,j.uj_val); - uj_type = subst1 c j.uj_type } in - (* spiwack: when an alias appears on a deep branch, its non-expanded - form is automatically a variable of the same name. We avoid - introducing such superfluous aliases so that refines are elegant. *) - let just_pop sigma = + sigma, { uj_val = mkLambda_or_LetIn d j.uj_val; + uj_type = mkProd_wo_LetIn d j.uj_type } + + (* spiwack: the [initial] argument keeps track whether the alias has + been introduced by a toplevel branch ([true]) or a deep one + ([false]). *) + and compile_alias initial sigma pb (na,orig,(expanded,expanded_typ)) rest = + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let f c t = + let alias = LocalDef (na,c,t) in + let pb = + { pb with + env = snd (push_rel ~hypnaming sigma alias pb.env); + tomatch = lift_tomatch_stack 1 rest; + pred = lift_predicate 1 pb.pred pb.tomatch; + history = pop_history_pattern pb.history; + mat = List.map (push_alias_eqn ~hypnaming sigma alias) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = + if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then + subst1 c j.uj_val + else + mkLetIn (na,c,t,j.uj_val); + uj_type = subst1 c j.uj_type } in + (* spiwack: when an alias appears on a deep branch, its non-expanded + form is automatically a variable of the same name. We avoid + introducing such superfluous aliases so that refines are elegant. *) + let just_pop sigma = + let pb = + { pb with + tomatch = rest; + history = pop_history_pattern pb.history; + mat = List.map drop_alias_eqn pb.mat } in + compile sigma pb + in + (* If the "match" was orginally over a variable, as in "match x with + O => true | n => n end", we give preference to non-expansion in + the default clause (i.e. "match x with O => true | n => n end" + rather than "match x with O => true | S p => S p end"; + computationally, this avoids reallocating constructors in cbv + evaluation; the drawback is that it might duplicate the instances + of the term to match when the corresponding variable is + substituted by a non-evaluated expression *) + if not program_mode && (isRel sigma orig || isVar sigma orig) then + (* Try to compile first using non expanded alias *) + try + if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) + else just_pop sigma + with e when precatchable_exception e -> + (* Try then to compile using expanded alias *) + (* Could be needed in case of dependent return clause *) + f expanded expanded_typ + else + (* Try to compile first using expanded alias *) + try f expanded expanded_typ + with e when precatchable_exception e -> + (* Try then to compile using non expanded alias *) + (* Could be needed in case of a recursive call which requires to + be on a variable for size reasons *) + if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) + else just_pop sigma + + + (* Remember that a non-trivial pattern has been consumed *) + and compile_non_dep_alias sigma pb rest = let pb = { pb with - tomatch = rest; - history = pop_history_pattern pb.history; - mat = List.map drop_alias_eqn pb.mat } in + tomatch = rest; + history = pop_history_pattern pb.history; + mat = List.map drop_alias_eqn pb.mat } in compile sigma pb in - (* If the "match" was orginally over a variable, as in "match x with - O => true | n => n end", we give preference to non-expansion in - the default clause (i.e. "match x with O => true | n => n end" - rather than "match x with O => true | S p => S p end"; - computationally, this avoids reallocating constructors in cbv - evaluation; the drawback is that it might duplicate the instances - of the term to match when the corresponding variable is - substituted by a non-evaluated expression *) - if not (Flags.is_program_mode ()) && (isRel sigma orig || isVar sigma orig) then - (* Try to compile first using non expanded alias *) - try - if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) - else just_pop sigma - with e when precatchable_exception e -> - (* Try then to compile using expanded alias *) - (* Could be needed in case of dependent return clause *) - f expanded expanded_typ - else - (* Try to compile first using expanded alias *) - try f expanded expanded_typ - with e when precatchable_exception e -> - (* Try then to compile using non expanded alias *) - (* Could be needed in case of a recursive call which requires to - be on a variable for size reasons *) - if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) - else just_pop sigma - - -(* Remember that a non-trivial pattern has been consumed *) -and compile_non_dep_alias sigma pb rest = - let pb = - { pb with - tomatch = rest; - history = pop_history_pattern pb.history; - mat = List.map drop_alias_eqn pb.mat } in compile sigma pb (* pour les alias des initiaux, enrichir les env de ce qu'il faut et @@ -1650,7 +1659,7 @@ let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = (subst0, t0) let push_binder sigma d (k,env,subst) = - (k+1,snd (push_rel sigma d env),List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) + (k+1,snd (push_rel ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma d env),List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) let rec list_assoc_in_triple x = function [] -> raise Not_found @@ -1771,7 +1780,7 @@ let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = * further explanations *) -let build_inversion_problem loc env sigma tms t = +let build_inversion_problem ~program_mode loc env sigma tms t = let make_patvar t (subst,avoid) = let id = next_name_away (named_hd !!env sigma t Anonymous) avoid in DAst.make @@ PatVar (Name id), ((id,t)::subst, Id.Set.add id avoid) in @@ -1796,13 +1805,13 @@ let build_inversion_problem loc env sigma tms t = let patl = pat :: List.rev patl in let patl,sign = recover_and_adjust_alias_names acc patl sign in let p = List.length patl in - let _,env' = push_rel_context sigma sign env in + let _,env' = push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma sign env in let patl',acc_sign,acc = aux (n+p) env' (sign@acc_sign) tms acc in List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in let d = LocalAssum (alias_of_pat pat,typ) in - let patl,acc_sign,acc = aux (n+1) (snd (push_rel sigma d env)) (d::acc_sign) tms acc in + let patl,acc_sign,acc = aux (n+1) (snd (push_rel ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma d env)) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = GlobEnv.vars_of_env env in (* [patl] is a list of patterns revealing the substructure of @@ -1820,7 +1829,7 @@ let build_inversion_problem loc env sigma tms t = let decls = List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in - let _,pb_env = push_rel_context sigma sign env in + let _,pb_env = push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma sign env in let decls = List.map (fun (c,d) -> (c,extract_inductive_data !!(pb_env) sigma d,d)) decls in @@ -1881,7 +1890,7 @@ let build_inversion_problem loc env sigma tms t = caseloc = loc; casestyle = RegularStyle; typing_function = build_tycon ?loc env pb_env s subst} in - let sigma, j = compile sigma pb in + let sigma, j = compile ~program_mode sigma pb in (sigma, j.uj_val) (* Here, [pred] is assumed to be in the context built from all *) @@ -1934,9 +1943,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) -let inh_conv_coerce_to_tycon ?loc env sigma j tycon = +let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon = match tycon with - | Some p -> Coercion.inh_conv_coerce_to ?loc true env sigma j p + | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma j p | None -> sigma, j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) @@ -1953,7 +1962,7 @@ let dependent_rel_or_var sigma tm c = | Var id -> Termops.local_occur_var sigma id c | _ -> assert false -let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = +let prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in let (rel_subst,var_subst), len = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> @@ -2006,7 +2015,8 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = in assert (len == 0); let p = predicate 0 c in - let arsign,env' = List.fold_right_map (push_rel_context sigma) arsign env in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let arsign,env' = List.fold_right_map (push_rel_context ~hypnaming sigma) arsign env in try let sigma' = fst (Typing.type_of !!env' sigma p) in Some (sigma', p, arsign) with e when precatchable_exception e -> None @@ -2019,7 +2029,7 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = * Each matched term is independently considered dependent or not. *) -let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = +let prepare_predicate ?loc ~program_mode typing_fun env sigma tomatchs arsign tycon pred = let refresh_tycon sigma t = (* If we put the typing constraint in the term, it has to be refreshed to preserve the invariant that no algebraic universe @@ -2041,10 +2051,10 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = sigma, t in (* First strategy: we build an "inversion" predicate, also replacing the *) (* dependencies with existential variables *) - let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in + let sigma1,pred1 = build_inversion_problem loc ~program_mode env sigma tomatchs t in (* Optional second strategy: we abstract the tycon wrt to the dependencies *) let p2 = - prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in + prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs arsign t in (* Third strategy: we take the type constraint as it is; of course we could *) (* need something inbetween, abstracting some but not all of the dependencies *) (* the "inversion" strategy deals with that but unification may not be *) @@ -2060,7 +2070,7 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = (* Some type annotation *) | Some rtntyp -> (* We extract the signature of the arity *) - let building_arsign,envar = List.fold_right_map (push_rel_context sigma) arsign env in + let building_arsign,envar = List.fold_right_map (push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma) arsign env in let sigma, newt = new_sort_variable univ_flexible sigma in let sigma, predcclj = typing_fun (mk_tycon (mkSort newt)) envar sigma rtntyp in let predccl = nf_evar sigma predcclj.uj_val in @@ -2320,7 +2330,7 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = in let sigma, ineqs = build_ineqs sigma prevpatterns pats signlen in let rhs_rels' = rels_of_patsign sigma rhs_rels in - let _signenv,_ = push_rel_context sigma rhs_rels' env in + let _signenv,_ = push_rel_context ~hypnaming:ProgramNaming sigma rhs_rels' env in let arity = let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> @@ -2340,7 +2350,7 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = let eqs_rels, arity = decompose_prod_n_assum sigma neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity in - let _,rhs_env = push_rel_context sigma rhs_rels' env in + let _,rhs_env = push_rel_context ~hypnaming:ProgramNaming sigma rhs_rels' env in let sigma, j = typing_fun (mk_tycon tycon) rhs_env sigma eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in @@ -2518,10 +2528,10 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let env, sigma, tomatchs = coerce_to_indtype typing_function env sigma matx tomatchl in + let env, sigma, tomatchs = coerce_to_indtype ~program_mode:true typing_function env sigma matx tomatchl in let tycon = valcon_of_tycon tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env sigma tomatchs tycon in - let _,env = push_rel_context sigma tomatchs_lets env in + let _,env = push_rel_context ~hypnaming:ProgramNaming sigma tomatchs_lets env in let len = List.length eqns in let sigma, sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) @@ -2540,7 +2550,7 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env sigma, ev, lift nar ev | Some t -> let sigma, pred = - match prepare_predicate_from_arsign_tycon env sigma loc tomatchs sign t with + match prepare_predicate_from_arsign_tycon ~program_mode:true env sigma loc tomatchs sign t with | Some (evd, pred, arsign) -> evd, pred | None -> sigma, lift nar t in @@ -2557,7 +2567,7 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env in let matx = List.rev matx in let _ = assert (Int.equal len (List.length lets)) in - let _,env = push_rel_context sigma lets env in + let _,env = push_rel_context ~hypnaming:ProgramNaming sigma lets env in let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in let args = List.rev_map (lift len) args in @@ -2604,7 +2614,7 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env casestyle= style; typing_function = typing_function } in - let sigma, j = compile sigma pb in + let sigma, j = compile ~program_mode:true sigma pb in (* We check for unused patterns *) List.iter (check_unused_pattern !!env) matx; let body = it_mkLambda_or_LetIn (applist (j.uj_val, args)) lets in @@ -2617,8 +2627,8 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env (**************************************************************************) (* Main entry of the matching compilation *) -let compile_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, eqns) = - if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then +let compile_cases ?loc ~program_mode style (typing_fun, sigma) tycon env (predopt, tomatchl, eqns) = + if predopt == None && program_mode && Program.is_program_cases () then compile_program_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, eqns) else @@ -2628,13 +2638,13 @@ let compile_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, e (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let predenv, sigma, tomatchs = coerce_to_indtype typing_fun env sigma matx tomatchl in + let predenv, sigma, tomatchs = coerce_to_indtype ~program_mode typing_fun env sigma matx tomatchl in (* If an elimination predicate is provided, we check it is compatible with the type of arguments to match; if none is provided, we build alternative possible predicates *) let arsign = extract_arity_signature !!env tomatchs tomatchl in - let preds = prepare_predicate ?loc typing_fun predenv sigma tomatchs arsign tycon predopt in + let preds = prepare_predicate ?loc ~program_mode typing_fun predenv sigma tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) @@ -2679,10 +2689,10 @@ let compile_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, e casestyle = style; typing_function = typing_fun } in - let sigma, j = compile sigma pb in + let sigma, j = compile ~program_mode sigma pb in (* We coerce to the tycon (if an elim predicate was provided) *) - inh_conv_coerce_to_tycon ?loc !!env sigma j tycon + inh_conv_coerce_to_tycon ?loc ~program_mode !!env sigma j tycon in (* Return the term compiled with the first possible elimination *) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 36cfa0a70d..b0349a3d05 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -40,7 +40,7 @@ val irrefutable : env -> cases_pattern -> bool (** {6 Compilation primitive. } *) val compile_cases : - ?loc:Loc.t -> case_style -> + ?loc:Loc.t -> program_mode:bool -> case_style -> (type_constraint -> GlobEnv.t -> evar_map -> glob_constr -> evar_map * unsafe_judgment) * evar_map -> type_constraint -> GlobEnv.t -> glob_constr option * tomatch_tuples * cases_clauses -> @@ -111,9 +111,9 @@ type 'a pattern_matching_problem = casestyle : case_style; typing_function: type_constraint -> GlobEnv.t -> evar_map -> 'a option -> evar_map * unsafe_judgment } -val compile : evar_map -> 'a pattern_matching_problem -> evar_map * unsafe_judgment +val compile : program_mode:bool -> evar_map -> 'a pattern_matching_problem -> evar_map * unsafe_judgment -val prepare_predicate : ?loc:Loc.t -> +val prepare_predicate : ?loc:Loc.t -> program_mode:bool -> (type_constraint -> GlobEnv.t -> Evd.evar_map -> glob_constr -> Evd.evar_map * unsafe_judgment) -> GlobEnv.t -> diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 4d1d405bd7..9e93c470b1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -393,7 +393,7 @@ let apply_coercion env sigma p hj typ_cl = with NoCoercion as e -> raise e (* Try to coerce to a funclass; raise NoCoercion if not possible *) -let inh_app_fun_core env evd j = +let inh_app_fun_core ~program_mode env evd j = let t = whd_all env evd j.uj_type in match EConstr.kind evd t with | Prod (_,_,_) -> (evd,j) @@ -404,25 +404,25 @@ let inh_app_fun_core env evd j = try let t,p = lookup_path_to_fun_from env evd j.uj_type in apply_coercion env evd p j t - with Not_found | NoCoercion -> - if Flags.is_program_mode () then - try - let evdref = ref evd in - let coercef, t = mu env evdref t in - let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in - (!evdref, res) - with NoSubtacCoercion | NoCoercion -> - (evd,j) - else raise NoCoercion + with Not_found | NoCoercion -> + if program_mode then + try + let evdref = ref evd in + let coercef, t = mu env evdref t in + let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in + (!evdref, res) + with NoSubtacCoercion | NoCoercion -> + (evd,j) + else raise NoCoercion (* Try to coerce to a funclass; returns [j] if no coercion is applicable *) -let inh_app_fun resolve_tc env evd j = - try inh_app_fun_core env evd j +let inh_app_fun ~program_mode resolve_tc env evd j = + try inh_app_fun_core ~program_mode env evd j with | NoCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> (evd, j) | NoCoercion -> - try inh_app_fun_core env (saturate_evd env evd) j + try inh_app_fun_core ~program_mode env (saturate_evd env evd) j with NoCoercion -> (evd, j) let type_judgment env sigma j = @@ -449,8 +449,8 @@ let inh_coerce_to_sort ?loc env evd j = | _ -> inh_tosort_force ?loc env evd j -let inh_coerce_to_base ?loc env evd j = - if Flags.is_program_mode () then +let inh_coerce_to_base ?loc ~program_mode env evd j = + if program_mode then let evdref = ref evd in let ct, typ' = mu env evdref j.uj_type in let res = @@ -459,8 +459,8 @@ let inh_coerce_to_base ?loc env evd j = in !evdref, res else (evd, j) -let inh_coerce_to_prod ?loc env evd t = - if Flags.is_program_mode () then +let inh_coerce_to_prod ?loc ~program_mode env evd t = + if program_mode then let evdref = ref evd in let _, typ' = mu env evdref t in !evdref, typ' @@ -520,13 +520,13 @@ let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) -let inh_conv_coerce_to_gen ?loc resolve_tc rigidonly env evd cj t = +let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly env evd cj t = let (evd', val') = try inh_conv_coerce_to_fail ?loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> try - if Flags.is_program_mode () then + if program_mode then coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t else raise NoSubtacCoercion with @@ -545,9 +545,11 @@ let inh_conv_coerce_to_gen ?loc resolve_tc rigidonly env evd cj t = let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) -let inh_conv_coerce_to ?loc resolve_tc = inh_conv_coerce_to_gen ?loc resolve_tc false +let inh_conv_coerce_to ?loc ~program_mode resolve_tc = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false -let inh_conv_coerce_rigid_to ?loc resolve_tc = inh_conv_coerce_to_gen resolve_tc ?loc true +let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc = + inh_conv_coerce_to_gen ~program_mode resolve_tc ?loc true let inh_conv_coerces_to ?loc env evd t t' = try diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index 6cfd958b46..a941391125 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -21,7 +21,7 @@ open Glob_term type a product; it returns [j] if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) -val inh_app_fun : bool -> +val inh_app_fun : program_mode:bool -> bool -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it @@ -33,11 +33,11 @@ val inh_coerce_to_sort : ?loc:Loc.t -> (** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type its base type (the notion depends on the coercion system) *) -val inh_coerce_to_base : ?loc:Loc.t -> +val inh_coerce_to_base : ?loc:Loc.t -> program_mode:bool -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) -val inh_coerce_to_prod : ?loc:Loc.t -> +val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> env -> evar_map -> types -> evar_map * types (** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an @@ -45,10 +45,10 @@ val inh_coerce_to_prod : ?loc:Loc.t -> a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) -val inh_conv_coerce_to : ?loc:Loc.t -> bool -> +val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool -> env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment -val inh_conv_coerce_rigid_to : ?loc:Loc.t -> bool -> +val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool -> env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 49a08afe80..d6b204561e 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -38,10 +38,10 @@ type t = { lvar : ltac_var_map; } -let make env sigma lvar = +let make ~hypnaming env sigma lvar = let get_extra env sigma = let avoid = Environ.ids_of_named_context_val (Environ.named_context_val env) in - Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) + Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context ~hypnaming sigma d acc) (rel_context env) ~init:(empty_csubst, avoid, named_context env) in { static_env = env; @@ -66,32 +66,32 @@ let ltac_interp_id { ltac_idents ; ltac_genargs } id = let ltac_interp_name lvar = Nameops.Name.map (ltac_interp_id lvar) -let push_rel sigma d env = +let push_rel ~hypnaming sigma d env = let d' = Context.Rel.Declaration.map_name (ltac_interp_name env.lvar) d in let env = { static_env = push_rel d env.static_env; renamed_env = push_rel d' env.renamed_env; - extra = lazy (push_rel_decl_to_named_context sigma d' (Lazy.force env.extra)); + extra = lazy (push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d' (Lazy.force env.extra)); lvar = env.lvar; } in d', env -let push_rel_context ?(force_names=false) sigma ctx env = +let push_rel_context ~hypnaming ?(force_names=false) sigma ctx env = let open Context.Rel.Declaration in let ctx' = List.Smart.map (map_name (ltac_interp_name env.lvar)) ctx in let ctx' = if force_names then Namegen.name_context env.renamed_env sigma ctx' else ctx' in let env = { static_env = push_rel_context ctx env.static_env; renamed_env = push_rel_context ctx' env.renamed_env; - extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context sigma d acc) ctx' (Lazy.force env.extra)); + extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d acc) ctx' (Lazy.force env.extra)); lvar = env.lvar; } in ctx', env -let push_rec_types sigma (lna,typarray) env = +let push_rec_types ~hypnaming sigma (lna,typarray) env = let open Context.Rel.Declaration in let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in - let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e in (e,d)) env ctxt in + let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e ~hypnaming in (e,d)) env ctxt in Array.map get_name ctx, env let new_evar env sigma ?src ?naming typ = diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index e8a2fbdd16..63f72e60bd 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -13,6 +13,7 @@ open Environ open Evd open EConstr open Ltac_pretype +open Evarutil (** To embed constr in glob_constr *) @@ -37,7 +38,7 @@ type t (** Build a pretyping environment from an ltac environment *) -val make : env -> evar_map -> ltac_var_map -> t +val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t (** Export the underlying environement *) @@ -47,9 +48,9 @@ val vars_of_env : t -> Id.Set.t (** Push to the environment, returning the declaration(s) with interpreted names *) -val push_rel : evar_map -> rel_declaration -> t -> rel_declaration * t -val push_rel_context : ?force_names:bool -> evar_map -> rel_context -> t -> rel_context * t -val push_rec_types : evar_map -> Name.t array * constr array -> t -> Name.t array * t +val push_rel : hypnaming:naming_mode -> evar_map -> rel_declaration -> t -> rel_declaration * t +val push_rel_context : hypnaming:naming_mode -> ?force_names:bool -> evar_map -> rel_context -> t -> rel_context * t +val push_rec_types : hypnaming:naming_mode -> evar_map -> Name.t array * constr array -> t -> Name.t array * t (** Declare an evar using renaming information *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 57705fa209..46e463512d 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -190,7 +190,8 @@ type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; fail_evar : bool; - expand_evars : bool + expand_evars : bool; + program_mode : bool; } (* Compute the set of still-undefined initial evars up to restriction @@ -226,17 +227,17 @@ let frozen_and_pending_holes (sigma, sigma') = end in FrozenProgress data -let apply_typeclasses env sigma frozen fail_evar = +let apply_typeclasses ~program_mode env sigma frozen fail_evar = let filter_frozen = match frozen with | FrozenId map -> fun evk -> Evar.Map.mem evk map | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen in let sigma = Typeclasses.resolve_typeclasses - ~filter:(if Flags.is_program_mode () + ~filter:(if program_mode then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) ~split:true ~fail:fail_evar env sigma in - let sigma = if Flags.is_program_mode () then (* Try optionally solving the obligations *) + let sigma = if program_mode then (* Try optionally solving the obligations *) Typeclasses.resolve_typeclasses ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env sigma else sigma in @@ -264,9 +265,9 @@ let apply_heuristics env sigma fail_evar = let e = CErrors.push e in if fail_evar then iraise e else sigma -let check_typeclasses_instances_are_solved env current_sigma frozen = +let check_typeclasses_instances_are_solved ~program_mode env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses env current_sigma frozen true + apply_typeclasses ~program_mode env current_sigma frozen true let check_extra_evars_are_solved env current_sigma frozen = match frozen with | FrozenId _ -> () @@ -295,18 +296,19 @@ let check_evars env initial_sigma sigma c = | _ -> EConstr.iter sigma proc_rec c in proc_rec c -let check_evars_are_solved env sigma frozen = - let sigma = check_typeclasses_instances_are_solved env sigma frozen in +let check_evars_are_solved ~program_mode env sigma frozen = + let sigma = check_typeclasses_instances_are_solved ~program_mode env sigma frozen in check_problems_are_solved env sigma; check_extra_evars_are_solved env sigma frozen (* Try typeclasses, hooks, unification heuristics ... *) let solve_remaining_evars ?hook flags env ?initial sigma = + let program_mode = flags.program_mode in let frozen = frozen_and_pending_holes (initial, sigma) in let sigma = if flags.use_typeclasses - then apply_typeclasses env sigma frozen false + then apply_typeclasses ~program_mode env sigma frozen false else sigma in let sigma = match hook with @@ -317,12 +319,12 @@ let solve_remaining_evars ?hook flags env ?initial sigma = then apply_heuristics env sigma false else sigma in - if flags.fail_evar then check_evars_are_solved env sigma frozen; + if flags.fail_evar then check_evars_are_solved ~program_mode env sigma frozen; sigma -let check_evars_are_solved env ?initial current_sigma = +let check_evars_are_solved ~program_mode env ?initial current_sigma = let frozen = frozen_and_pending_holes (initial, current_sigma) in - check_evars_are_solved env current_sigma frozen + check_evars_are_solved ~program_mode env current_sigma frozen let process_inference_flags flags env initial (sigma,c,cty) = let sigma = solve_remaining_evars flags env ~initial sigma in @@ -351,10 +353,10 @@ let adjust_evar_source sigma na c = | _, _ -> sigma, c (* coerce to tycon if any *) -let inh_conv_coerce_to_tycon ?loc resolve_tc env sigma j = function +let inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j = function | None -> sigma, j | Some t -> - Coercion.inh_conv_coerce_to ?loc resolve_tc !!env sigma j t + Coercion.inh_conv_coerce_to ?loc ~program_mode resolve_tc !!env sigma j t let check_instance loc subst = function | [] -> () @@ -453,20 +455,18 @@ let new_type_evar env sigma loc = new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) let mark_obligation_evar sigma k evc = - if Flags.is_program_mode () then - match k with - | Evar_kinds.QuestionMark _ - | Evar_kinds.ImplicitArg (_, _, false) -> - Evd.set_obligation_evar sigma (fst (destEvar sigma evc)) - | _ -> sigma - else sigma + match k with + | Evar_kinds.QuestionMark _ + | Evar_kinds.ImplicitArg (_, _, false) -> + Evd.set_obligation_evar sigma (fst (destEvar sigma evc)) + | _ -> sigma (* [pretype tycon env sigma lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = - let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc resolve_tc in +let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = + let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in let pretype_type = pretype_type k0 resolve_tc in let pretype = pretype k0 resolve_tc in let open Context.Rel.Declaration in @@ -477,7 +477,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in + let sigma, t_id = pretype_id (fun e r t -> pretype ~program_mode tycon e r t) k0 loc env sigma id in inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> @@ -488,7 +488,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -513,7 +513,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma | Some ty -> sigma, ty | None -> new_type_evar env sigma loc in let sigma, uj_val = new_evar env sigma ~src:(loc,k) ~naming ty in - let sigma = mark_obligation_evar sigma k uj_val in + let sigma = if program_mode then mark_obligation_evar sigma k uj_val else sigma in sigma, { uj_val; uj_type = ty } | GHole (k, _naming, Some arg) -> @@ -525,24 +525,25 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma sigma, { uj_val = c; uj_type = ty } | GRec (fixkind,names,bl,lar,vdef) -> + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let rec type_bl env sigma ctxt = function | [] -> sigma, ctxt | (na,bk,None,ty)::bl -> - let sigma, ty' = pretype_type empty_valcon env sigma ty in - let dcl = LocalAssum (na, ty'.utj_val) in - let dcl', env = push_rel sigma dcl env in + let sigma, ty' = pretype_type ~program_mode empty_valcon env sigma ty in + let dcl = LocalAssum (na, ty'.utj_val) in + let dcl', env = push_rel ~hypnaming sigma dcl env in type_bl env sigma (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> - let sigma, ty' = pretype_type empty_valcon env sigma ty in - let sigma, bd' = pretype (mk_tycon ty'.utj_val) env sigma bd in + let sigma, ty' = pretype_type ~program_mode empty_valcon env sigma ty in + let sigma, bd' = pretype ~program_mode (mk_tycon ty'.utj_val) env sigma bd in let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in - let dcl', env = push_rel sigma dcl env in + let dcl', env = push_rel ~hypnaming sigma dcl env in type_bl env sigma (Context.Rel.add dcl' ctxt) bl in let sigma, ctxtv = Array.fold_left_map (fun sigma -> type_bl env sigma Context.Rel.empty) sigma bl in let sigma, larj = Array.fold_left2_map (fun sigma e ar -> - pretype_type empty_valcon (snd (push_rel_context sigma e env)) sigma ar) + pretype_type ~program_mode empty_valcon (snd (push_rel_context ~hypnaming sigma e env)) sigma ar) sigma ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in @@ -562,7 +563,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma | None -> sigma in (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let names,newenv = push_rec_types sigma (names,ftys) env in + let names,newenv = push_rec_types ~hypnaming sigma (names,ftys) env in let sigma, vdefj = Array.fold_left2_map_i (fun i sigma ctxt def -> @@ -571,8 +572,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let (ctxt,ty) = decompose_prod_n_assum sigma (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in - let ctxt,nenv = push_rel_context sigma ctxt newenv in - let sigma, j = pretype (mk_tycon ty) nenv sigma def in + let ctxt,nenv = push_rel_context ~hypnaming sigma ctxt newenv in + let sigma, j = pretype ~program_mode (mk_tycon ty) nenv sigma def in sigma, { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) sigma ctxtv vdef in @@ -618,14 +619,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma inh_conv_coerce_to_tycon ?loc env sigma j tycon | GApp (f,args) -> - let sigma, fj = pretype empty_tycon env sigma f in + let sigma, fj = pretype ~program_mode empty_tycon env sigma f in let floc = loc_of_glob_constr f in let length = List.length args in let candargs = (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct sigma fj.uj_val then + if program_mode && length > 0 && isConstruct sigma fj.uj_val then match tycon with | None -> [] | Some ty -> @@ -656,12 +657,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma | [] -> sigma, resj | c::rest -> let argloc = loc_of_glob_constr c in - let sigma, resj = Coercion.inh_app_fun resolve_tc !!env sigma resj in + let sigma, resj = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in let resty = whd_all !!env sigma resj.uj_type in match EConstr.kind sigma resty with | Prod (na,c1,c2) -> let tycon = Some c1 in - let sigma, hj = pretype tycon env sigma c in + let sigma, hj = pretype ~program_mode tycon env sigma c in let sigma, candargs, ujval = match candargs with | [] -> sigma, [], j_val hj @@ -678,7 +679,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let j = { uj_val = value; uj_type = typ } in apply_rec env sigma (n+1) j candargs rest | _ -> - let sigma, hj = pretype empty_tycon env sigma c in + let sigma, hj = pretype ~program_mode empty_tycon env sigma c in error_cant_apply_not_functional ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in @@ -703,29 +704,31 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma match tycon with | None -> sigma, tycon | Some ty -> - let sigma, ty' = Coercion.inh_coerce_to_prod ?loc !!env sigma ty in + let sigma, ty' = Coercion.inh_coerce_to_prod ?loc ~program_mode !!env sigma ty in sigma, Some ty' in let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in let dom_valcon = valcon_of_tycon dom in - let sigma, j = pretype_type dom_valcon env sigma c1 in + let sigma, j = pretype_type ~program_mode dom_valcon env sigma c1 in let var = LocalAssum (name, j.utj_val) in - let var',env' = push_rel sigma var env in - let sigma, j' = pretype rng env' sigma c2 in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let var',env' = push_rel ~hypnaming sigma var env in + let sigma, j' = pretype ~program_mode rng env' sigma c2 in let name = get_name var' in let resj = judge_of_abstraction !!env (orelse_name name name') j j' in inh_conv_coerce_to_tycon ?loc env sigma resj tycon | GProd(name,bk,c1,c2) -> - let sigma, j = pretype_type empty_valcon env sigma c1 in + let sigma, j = pretype_type ~program_mode empty_valcon env sigma c1 in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let sigma, name, j' = match name with | Anonymous -> - let sigma, j = pretype_type empty_valcon env sigma c2 in + let sigma, j = pretype_type ~program_mode empty_valcon env sigma c2 in sigma, name, { j with utj_val = lift 1 j.utj_val } | Name _ -> let var = LocalAssum (name, j.utj_val) in - let var, env' = push_rel sigma var env in - let sigma, c2_j = pretype_type empty_valcon env' sigma c2 in + let var, env' = push_rel ~hypnaming sigma var env in + let sigma, c2_j = pretype_type ~program_mode empty_valcon env' sigma c2 in sigma, get_name var, c2_j in let resj = @@ -741,23 +744,24 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let sigma, tycon1 = match t with | Some t -> - let sigma, t_j = pretype_type empty_valcon env sigma t in + let sigma, t_j = pretype_type ~program_mode empty_valcon env sigma t in sigma, mk_tycon t_j.utj_val | None -> sigma, empty_tycon in - let sigma, j = pretype tycon1 env sigma c1 in + let sigma, j = pretype ~program_mode tycon1 env sigma c1 in let sigma, t = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma j.uj_type in let var = LocalDef (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in - let var, env = push_rel sigma var env in - let sigma, j' = pretype tycon env sigma c2 in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let var, env = push_rel ~hypnaming sigma var env in + let sigma, j' = pretype ~program_mode tycon env sigma c2 in let name = get_name var in sigma, { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (nal,(na,po),c,d) -> - let sigma, cj = pretype empty_tycon env sigma c in + let sigma, cj = pretype ~program_mode empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> @@ -792,7 +796,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma | _ -> assert false in aux 1 1 (List.rev nal) cs.cs_args, true in let fsign = Context.Rel.map (whd_betaiota sigma) fsign in - let fsign,env_f = push_rel_context sigma fsign env in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in let obj ind p v f = if not record then let f = it_mkLambda_or_LetIn f fsign in @@ -810,10 +815,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let nar = List.length arsgn in - let psign',env_p = push_rel_context ~force_names:true sigma psign predenv in + let psign',env_p = push_rel_context ~hypnaming ~force_names:true sigma psign predenv in (match po with | Some p -> - let sigma, pj = pretype_type empty_valcon env_p sigma p in + let sigma, pj = pretype_type ~program_mode empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let p = it_mkLambda_or_LetIn ccl psign' in let inst = @@ -821,7 +826,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist !!env sigma lp inst in - let sigma, fj = pretype (mk_tycon fty) env_f sigma d in + let sigma, fj = pretype ~program_mode (mk_tycon fty) env_f sigma d in let v = let ind,_ = dest_ind_family indf in Typing.check_allowed_sort !!env sigma ind cj.uj_val p; @@ -831,7 +836,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma | None -> let tycon = lift_tycon cs.cs_nargs tycon in - let sigma, fj = pretype tycon env_f sigma d in + let sigma, fj = pretype ~program_mode tycon env_f sigma d in let ccl = nf_evar sigma fj.uj_type in let ccl = if noccur_between sigma 1 cs.cs_nargs ccl then @@ -848,7 +853,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma in sigma, { uj_val = v; uj_type = ccl }) | GIf (c,(na,po),b1,b2) -> - let sigma, cj = pretype empty_tycon env sigma c in + let sigma, cj = pretype ~program_mode empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> @@ -869,10 +874,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in - let psign,env_p = push_rel_context sigma psign predenv in + let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in + let psign,env_p = push_rel_context ~hypnaming sigma psign predenv in let sigma, pred, p = match po with | Some p -> - let sigma, pj = pretype_type empty_valcon env_p sigma p in + let sigma, pj = pretype_type ~program_mode empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in @@ -894,8 +900,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let csgn = List.map (set_name Anonymous) cs_args in - let _,env_c = push_rel_context sigma csgn env in - let sigma, bj = pretype (mk_tycon pi) env_c sigma b in + let _,env_c = push_rel_context ~hypnaming sigma csgn env in + let sigma, bj = pretype ~program_mode (mk_tycon pi) env_c sigma b in sigma, it_mkLambda_or_LetIn bj.uj_val cs_args in let sigma, b1 = f sigma cstrs.(0) b1 in let sigma, b2 = f sigma cstrs.(1) b2 in @@ -910,23 +916,23 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma inh_conv_coerce_to_tycon ?loc env sigma cj tycon | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc sty (pretype, sigma) tycon env (po,tml,eqns) + Cases.compile_cases ?loc ~program_mode sty (pretype ~program_mode, sigma) tycon env (po,tml,eqns) | GCast (c,k) -> let sigma, cj = match k with | CastCoerce -> - let sigma, cj = pretype empty_tycon env sigma c in - Coercion.inh_coerce_to_base ?loc !!env sigma cj + let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + Coercion.inh_coerce_to_base ?loc ~program_mode !!env sigma cj | CastConv t | CastVM t | CastNative t -> let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let sigma, tj = pretype_type empty_valcon env sigma t in + let sigma, tj = pretype_type ~program_mode empty_valcon env sigma t in let sigma, tval = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in let tval = nf_evar sigma tval in let (sigma, cj), tval = match k with | VMcast -> - let sigma, cj = pretype empty_tycon env sigma c in + let sigma, cj = pretype ~program_mode empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in if not (occur_existential sigma cty || occur_existential sigma tval) then match Reductionops.vm_infer_conv !!env sigma cty tval with @@ -937,7 +943,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma else user_err ?loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> - let sigma, cj = pretype empty_tycon env sigma c in + let sigma, cj = pretype ~program_mode empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in begin match Nativenorm.native_infer_conv !!env sigma cty tval with @@ -947,7 +953,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma (ConversionFailed (!!env,cty,tval)) end | _ -> - pretype (mk_tycon tval) env sigma c, tval + pretype ~program_mode (mk_tycon tval) env sigma c, tval in let v = mkCast (cj.uj_val, k, tval) in sigma, { uj_val = v; uj_type = tval } @@ -961,7 +967,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -993,7 +999,7 @@ and pretype_instance k0 resolve_tc env sigma loc hyps evk update = let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode k0 resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1018,7 +1024,7 @@ and pretype_instance k0 resolve_tc env sigma loc hyps evk update = sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1042,10 +1048,10 @@ and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get | None -> let sigma, s = new_sort_variable univ_flexible_alg sigma in let sigma, utj_val = new_evar env sigma ~src:(loc, knd) ~naming (mkSort s) in - let sigma = mark_obligation_evar sigma knd utj_val in + let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode k0 resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1059,17 +1065,21 @@ and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get end let ise_pretype_gen flags env sigma lvar kind c = - let env = GlobEnv.make env sigma lvar in + let program_mode = flags.program_mode in + let hypnaming = + if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames + in + let env = GlobEnv.make ~hypnaming env sigma lvar in let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode k0 flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode k0 flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) @@ -1078,13 +1088,17 @@ let default_inference_flags fail = { use_typeclasses = true; solve_unification_constraints = true; fail_evar = fail; - expand_evars = true } + expand_evars = true; + program_mode = false; +} let no_classes_no_fail_inference_flags = { use_typeclasses = false; solve_unification_constraints = true; fail_evar = false; - expand_evars = true } + expand_evars = true; + program_mode = false; +} let all_and_fail_flags = default_inference_flags true let all_no_fail_flags = default_inference_flags false diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 59e6c00037..3c875e69d2 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -36,7 +36,8 @@ type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; fail_evar : bool; - expand_evars : bool + expand_evars : bool; + program_mode : bool; } val default_inference_flags : bool -> inference_flags @@ -101,7 +102,7 @@ val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> reporting an appropriate error message *) val check_evars_are_solved : - env -> ?initial:evar_map -> (* current map: *) evar_map -> unit + program_mode:bool -> env -> ?initial:evar_map -> (* current map: *) evar_map -> unit (** [check_evars env initial_sigma extended_sigma c] fails if some new unresolved evar remains in [c] *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e4d96da0a6..ac0b58b92b 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1269,7 +1269,7 @@ let is_mimick_head sigma ts f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in - let (evd',j') = inh_conv_coerce_rigid_to true env evd j tycon in + let (evd',j') = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in let evd' = Evd.map_metas_fvalue (fun c -> nf_evar evd' c) evd' in (evd',j'.uj_val) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 1f1bdf4da7..9540d3de44 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -677,7 +677,7 @@ let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in let ty = Retyping.get_type_of env sigma c in let j = Environ.make_judge c ty in - let (sigma, j) = Coercion.inh_conv_coerce_to true env sigma j t in + let (sigma, j) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in let (ev, _) = destEvar sigma ev in let sigma = Evd.define ev j.Environ.uj_val sigma in sigma diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 6c4193c66b..1b2756f49f 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -53,7 +53,9 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = false; - Pretyping.expand_evars = true } in + Pretyping.expand_evars = true; + Pretyping.program_mode = false; + } in try Pretyping.understand_ltac flags env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc with e when CErrors.noncritical e -> diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 7f1ae6d12b..9509c36ec0 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -70,11 +70,6 @@ let get_current_context ?p () = let evd = Proof.in_proof p (fun x -> x) in (evd, Global.env ()) -let current_proof_statement () = - match Proof_global.V82.get_current_initial_conclusions () with - | (id,([concl],strength)) -> id,strength,concl - | _ -> CErrors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement.") - let solve ?with_end_tac gi info_lvl tac pr = try let tac = match with_end_tac with diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 5699320af5..29ab00876a 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -34,11 +34,6 @@ val get_current_goal_context : unit -> Evd.evar_map * env val get_current_context : ?p:Proof.t -> unit -> Evd.evar_map * env -(** [current_proof_statement] *) - -val current_proof_statement : - unit -> Id.t * goal_kind * EConstr.types - (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th diff --git a/proofs/proof.ml b/proofs/proof.ml index 4ce932b93d..e40940f652 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -415,8 +415,9 @@ let run_tactic env tac pr = Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT retrieved in + let { name; poly } = pr in let (retrieved,proofview,(status,to_shelve,give_up),info_trace) = - Proofview.apply env tac sp + Proofview.apply ~name ~poly env tac sp in let sigma = Proofview.return proofview in let to_shelve = undef sigma to_shelve in @@ -498,7 +499,8 @@ module V82 = struct let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma end in - let ((), proofview, _, _) = Proofview.apply env tac pr.proofview in + let { name; poly } = pr in + let ((), proofview, _, _) = Proofview.apply ~name ~poly env tac pr.proofview in let shelf = List.filter begin fun g -> Evd.is_undefined (Proofview.return proofview) g diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 9ee9e7ae2c..0cfc010c1a 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -66,12 +66,6 @@ let pstates = ref ([] : pstate list) (* combinators for the current_proof lists *) let push a l = l := a::!l -exception NoSuchProof -let () = CErrors.register_handler begin function - | NoSuchProof -> CErrors.user_err Pp.(str "No such proof.") - | _ -> raise CErrors.Unhandled -end - exception NoCurrentProof let () = CErrors.register_handler begin function | NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") @@ -91,6 +85,7 @@ let cur_pstate () = let give_me_the_proof () = (cur_pstate ()).proof let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None let get_current_proof_name () = (Proof.data (cur_pstate ()).proof).Proof.name +let get_current_persistence () = (cur_pstate ()).strength let with_current_proof f = match !pstates with @@ -386,15 +381,6 @@ let set_terminator hook = | [] -> raise NoCurrentProof | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps -module V82 = struct - let get_current_initial_conclusions () = - let { proof; strength } = cur_pstate () in - let Proof.{ name; entry } = Proof.data proof in - let initial = Proofview.initial_goals entry in - let goals = List.map (fun (o, c) -> c) initial in - name, (goals, strength) -end - let freeze ~marshallable = if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") else !pstates diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 40920f51a3..38e234eaee 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -17,6 +17,7 @@ val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit val get_current_proof_name : unit -> Names.Id.t +val get_current_persistence : unit -> Decl_kinds.goal_kind val get_all_proof_names : unit -> Names.Id.t list val discard : Names.lident -> unit @@ -104,8 +105,6 @@ val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> val get_terminator : unit -> proof_terminator val set_terminator : proof_terminator -> unit -exception NoSuchProof - val get_open_goals : unit -> int (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is @@ -129,11 +128,6 @@ val get_used_variables : unit -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) val get_universe_decl : unit -> UState.universe_decl -module V82 : sig - val get_current_initial_conclusions : unit -> Names.Id.t *(EConstr.types list * - Decl_kinds.goal_kind) -end - val freeze : marshallable:bool -> t val unfreeze : t -> unit val proof_of_state : t -> Proof.t diff --git a/proofs/refine.ml b/proofs/refine.ml index 1d796fece5..06e6b89df1 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -137,26 +137,6 @@ let refine ~typecheck f = in Proofview.Goal.enter (make_refine_enter ~typecheck f) -(** Useful definitions *) - -let with_type env evd c t = - let my_type = Retyping.get_type_of env evd c in - let j = Environ.make_judge c my_type in - let (evd,j') = - Coercion.inh_conv_coerce_to true env evd j t - in - evd , j'.Environ.uj_val - -let refine_casted ~typecheck f = Proofview.Goal.enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let f h = - let (h, c) = f h in - with_type env h c concl - in - refine ~typecheck f -end - (** {7 solve_constraints} Ensure no remaining unification problems are left. Run at every "." by default. *) diff --git a/proofs/refine.mli b/proofs/refine.mli index 1af6463a02..55dafe521f 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -34,17 +34,6 @@ val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> Proofview.Goal.t -> 'a tactic (** The general version of refine. *) -(** {7 Helper functions} *) - -val with_type : Environ.env -> Evd.evar_map -> - EConstr.constr -> EConstr.types -> Evd.evar_map * EConstr.constr -(** [with_type env sigma c t] ensures that [c] is of type [t] - inserting a coercion if needed. *) - -val refine_casted : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic -(** Like {!refine} except the refined term is coerced to the conclusion of the - current goal. *) - (** {7 Unification constraint handling} *) val solve_constraints : unit tactic diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index be8ef24a09..73b9ef7da0 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -128,11 +128,13 @@ module Make(T : Task) () = struct | ("-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl (* Options to discard: 1 argument *) - | ("-async-proofs" |"-vio2vo" | "-o" - |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" - |"-compile" |"-compile-verbose" - |"-async-proofs-cache" - |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> + | ( "-async-proofs" | "-vio2vo" | "-o" + | "-load-vernac-source" | "-l" | "-load-vernac-source-verbose" | "-lv" + | "-compile" | "-compile-verbose" + | "-async-proofs-cache" | "-async-proofs-j" | "-async-proofs-tac-j" + | "-async-proofs-private-flags" | "-async-proofs-tactic-error-resilience" + | "-async-proofs-command-error-resilience" | "-async-proofs-delegation-threshold" + | "-async-proofs-worker-priority" | "-worker-id") :: _ :: tl -> set_slave_opt tl (* We need to pass some options with one argument *) | ( "-I" | "-include" | "-top" | "-topfile" | "-coqlib" | "-exclude-dir" | "-compat" diff --git a/stm/stm.ml b/stm/stm.ml index 0165b3c029..b4f26570c6 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2647,6 +2647,10 @@ type stm_init_options = { some point. *) doc_type : stm_doc_type; + (* Allow compiling modules in the Coq prefix. Irrelevant in + interactive mode. *) + allow_coq_overwrite : bool; + (* Initial load path in scope for the document. Usually extracted from -R options / _CoqProject *) iload_path : Mltop.coq_path list; @@ -2674,11 +2678,12 @@ let init_core () = if !cur_opt.async_proofs_mode = APon then Control.enable_thread_delay := true; State.register_root_state () -let check_coq_overwriting p = +let check_coq_overwriting ~allow_coq_overwrite p = + if not allow_coq_overwrite then let l = DirPath.repr p in let id, l = match l with id::l -> id,l | [] -> assert false in let is_empty = match l with [] -> true | _ -> false in - if not !Flags.boot && not is_empty && Id.equal (CList.last l) Libnames.coq_root then + if not is_empty && Id.equal (CList.last l) Libnames.coq_root then user_err (str "Cannot build module " ++ DirPath.print p ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") @@ -2695,7 +2700,7 @@ let dirpath_of_file f = let ldir = Libnames.add_dirpath_suffix ldir0 id in ldir -let new_doc { doc_type ; iload_path; require_libs; stm_options } = +let new_doc { doc_type ; allow_coq_overwrite; iload_path; require_libs; stm_options } = let load_objs libs = let rq_file (dir, from, exp) = @@ -2730,14 +2735,14 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = | VoDoc f -> let ldir = dirpath_of_file f in - check_coq_overwriting ldir; + check_coq_overwriting ~allow_coq_overwrite ldir; let () = Flags.verbosely Declaremods.start_library ldir in VCS.set_ldir ldir; set_compilation_hints f | VioDoc f -> let ldir = dirpath_of_file f in - check_coq_overwriting ldir; + check_coq_overwriting ~allow_coq_overwrite ldir; let () = Flags.verbosely Declaremods.start_library ldir in VCS.set_ldir ldir; set_compilation_hints f @@ -2885,11 +2890,12 @@ let handle_failure (e, info) vcs = VCS.print (); Exninfo.iraise (e, info) -let snapshot_vio ~doc ldir long_f_dot_vo = +let snapshot_vio ~doc ~output_native_objects ldir long_f_dot_vo = let doc = finish ~doc in if List.length (VCS.branches ()) > 1 then CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); - Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo + Library.save_library_to ~todo:(dump_snapshot ()) ~output_native_objects + ldir long_f_dot_vo (Global.opaque_tables ()); doc @@ -3197,12 +3203,12 @@ let query ~doc ~at ~route s = let rec loop () = match parse_sentence ~doc at ~entry:Pvernac.main_entry s with | None -> () - | Some (loc, ast) -> - let indentation, strlen = compute_indentation ~loc at in + | Some {CAst.loc; v=ast} -> + let indentation, strlen = compute_indentation ?loc at in let st = State.get_cached at in let aast = { verbose = true; indentation; strlen; - loc = Some loc; expr = ast } in + loc; expr = ast } in ignore(stm_vernac_interp ~route at st aast); loop () in diff --git a/stm/stm.mli b/stm/stm.mli index 821ab59a43..102e832d3e 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -67,6 +67,10 @@ type stm_init_options = { some point. *) doc_type : stm_doc_type; + (* Allow compiling modules in the Coq prefix. Irrelevant in + interactive mode. *) + allow_coq_overwrite : bool; + (* Initial load path in scope for the document. Usually extracted from -R options / _CoqProject *) iload_path : Mltop.coq_path list; @@ -156,7 +160,7 @@ val join : doc:doc -> doc - if the worker proof is not empty, then it waits until all workers are done with their current jobs and then dumps (or fails if one of the completed tasks is a failure) *) -val snapshot_vio : doc:doc -> DirPath.t -> string -> doc +val snapshot_vio : doc:doc -> output_native_objects:bool -> DirPath.t -> string -> doc (* Empties the task queue, can be used only if the worker pool is empty (E.g. * after having built a .vio in batch mode *) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 42540af991..feb8e2a67f 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -56,6 +56,7 @@ let options_affecting_stm_scheduling = [ Attributes.universe_polymorphism_option_name; stm_allow_nested_proofs_option_name; Vernacentries.proof_mode_opt_name; + Attributes.program_mode_option_name; ] let classify_vernac e = diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 3a687a6b41..c3e3a62e26 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -11,7 +11,6 @@ module CVars = Vars open Util -open Names open Termops open EConstr open Decl_kinds @@ -87,10 +86,26 @@ let shrink_entry sign const = } in (const, args) -let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = +let name_op_to_name ~name_op ~name ~goal_kind suffix = + match name_op with + | Some s -> s, goal_kind + | None -> Nameops.add_suffix name suffix, goal_kind + +let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> + (* This is important: The [Global] and [Proof Theorem] parts of the + goal_kind are not relevant here as build_constant_by_tactic does + use the noop terminator; but beware if some day we remove the + redundancy on constrant declaration. This opens up an interesting + question, how does abstract behave when discharge is local for example? + *) + let goal_kind, suffix = if opaque + then (Global,poly,Proof Theorem), "_subproof" + else (Global,poly,DefinitionBody Definition), "_subterm" in + let id, goal_kind = name_op_to_name ~name_op ~name ~goal_kind suffix in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -126,7 +141,7 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in let ectx = Evd.evar_universe_context evd in let (const, safe, ectx) = - try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac + try Pfedit.build_constant_by_tactic ~goal_kind id ectx secsign concl solve_tac with Logic_monad.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it @@ -170,26 +185,8 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) tac end -let abstract_subproof ~opaque id gk tac = - cache_term_by_tactic_then ~opaque id gk tac (fun lem args -> Tactics.exact_no_check (applist (lem, args))) - -let anon_id = Id.of_string "anonymous" - -let name_op_to_name name_op object_kind suffix = - let open Proof_global in - let default_gk = (Global, false, object_kind) in - let name, gk = match Proof_global.V82.get_current_initial_conclusions () with - | (id, (_, gk)) -> Some id, gk - | exception NoCurrentProof -> None, default_gk - in - match name_op with - | Some s -> s, gk - | None -> - let name = Option.default anon_id name in - Nameops.add_suffix name suffix, gk +let abstract_subproof ~opaque tac = + cache_term_by_tactic_then ~opaque tac (fun lem args -> Tactics.exact_no_check (applist (lem, args))) let tclABSTRACT ?(opaque=true) name_op tac = - let s, gk = if opaque - then name_op_to_name name_op (Proof Theorem) "_subproof" - else name_op_to_name name_op (DefinitionBody Definition) "_subterm" in - abstract_subproof ~opaque s gk tac + abstract_subproof ~opaque ~name_op tac diff --git a/tactics/abstract.mli b/tactics/abstract.mli index 7fb671fbf8..9d4f3cfb27 100644 --- a/tactics/abstract.mli +++ b/tactics/abstract.mli @@ -11,6 +11,12 @@ open Names open EConstr -val cache_term_by_tactic_then : opaque:bool -> ?goal_type:(constr option) -> Id.t -> Decl_kinds.goal_kind -> unit Proofview.tactic -> (constr -> constr list -> unit Proofview.tactic) -> unit Proofview.tactic +val cache_term_by_tactic_then + : opaque:bool + -> name_op:Id.t option + -> ?goal_type:(constr option) + -> unit Proofview.tactic + -> (constr -> constr list -> unit Proofview.tactic) + -> unit Proofview.tactic val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index ba7645446d..e505bb3a42 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -930,8 +930,16 @@ module Search = struct let _, pv = Proofview.init evm [] in let pv = Proofview.unshelve goals pv in try + (* Instance may try to call this before a proof is set up! + Thus, give_me_the_proof will fail. Beware! *) + let name, poly = try + let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in + name, poly + with | Proof_global.NoCurrentProof -> + Id.of_string "instance", false + in let (), pv', (unsafe, shelved, gaveup), _ = - Proofview.apply env tac pv + Proofview.apply ~name ~poly env tac pv in if not (List.is_empty gaveup) then CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals."); diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 356b43ec14..48997163de 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -250,7 +250,7 @@ let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let add_inversion_lemma_exn ~poly na com comsort bool tac = let env = Global.env () in let sigma = Evd.from_env env in - let sigma, c = Constrintern.interp_type_evars env sigma com in + let sigma, c = Constrintern.interp_type_evars ~program_mode:false env sigma com in let sigma, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid sigma comsort in try add_inversion_lemma ~poly na env sigma c sort bool tac diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 070b2356e5..db59f7cfc2 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1155,7 +1155,9 @@ let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = not with_evar; - Pretyping.expand_evars = true } + Pretyping.expand_evars = true; + Pretyping.program_mode = false; +} type evars_flag = bool (* true = pose evars false = fail on evars *) type rec_flag = bool (* true = recursive false = not recursive *) @@ -4522,8 +4524,11 @@ let induction_gen clear_flag isrec with_evars elim declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) + let avoid = match eqname with + | Some {CAst.v=IntroIdentifier id} -> Id.Set.singleton id + | _ -> Id.Set.empty in let x = id_of_name_using_hdchar env evd t Anonymous in - new_fresh_id Id.Set.empty x gl in + new_fresh_id avoid x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in pose_induction_arg_then isrec with_evars info_arg elim id arg t inhyps cls diff --git a/test-suite/Makefile b/test-suite/Makefile index 68acb6f04d..03bfc5ffac 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -260,6 +260,7 @@ ifeq ($(LOCAL),true) endif OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) +OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) # ML files from unit-test framework, not containing tests UNIT_SRCFILES:=$(shell find ./unit-tests/src -name *.ml) @@ -267,24 +268,31 @@ UNIT_ALLMLFILES:=$(shell find ./unit-tests -name *.ml) UNIT_MLFILES:=$(filter-out $(UNIT_SRCFILES),$(UNIT_ALLMLFILES)) UNIT_LOGFILES:=$(patsubst %.ml,%.ml.log,$(UNIT_MLFILES)) -UNIT_CMXS=utest.cmx +ifneq ($(BEST),opt) +UNIT_LINK:=utest.cmo +OCAMLBEST:=$(OCAMLC) +else +UNIT_LINK:=utest.cmx +OCAMLBEST:=$(OCAMLOPT) +endif unit-tests/src/utest.cmx: unit-tests/src/utest.ml unit-tests/src/utest.cmi $(SHOW) 'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) -c -I unit-tests/src -package oUnit $< +unit-tests/src/utest.cmo: unit-tests/src/utest.ml unit-tests/src/utest.cmi + $(SHOW) 'OCAMLC $<' + $(HIDE)$(OCAMLC) -c -I unit-tests/src -package oUnit $< unit-tests/src/utest.cmi: unit-tests/src/utest.mli - $(SHOW) 'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) -package oUnit $< - -$(UNIT_LOGFILES): unit-tests/src/utest.cmx + $(SHOW) 'OCAMLC $<' + $(HIDE)$(OCAMLC) -package oUnit -c $< unit-tests: $(UNIT_LOGFILES) # Build executable, run it to generate log file -unit-tests/%.ml.log: unit-tests/%.ml +unit-tests/%.ml.log: unit-tests/%.ml unit-tests/src/$(UNIT_LINK) $(SHOW) 'TEST $<' - $(HIDE)$(OCAMLOPT) -linkall -linkpkg -package coq.toplevel,oUnit \ - -I unit-tests/src $(UNIT_CMXS) $< -o $<.test; + $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,oUnit \ + -I unit-tests/src $(UNIT_LINK) $< -o $<.test; $(HIDE)./$<.test ####################################################################### diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v index b80e0bb0e4..e28314cada 100644 --- a/test-suite/bugs/closed/HoTT_coq_056.v +++ b/test-suite/bugs/closed/HoTT_coq_056.v @@ -82,7 +82,7 @@ Notation "F ^op" := (OppositeFunctor F) : functor_scope. Definition FunctorProduct' C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D') := admit. -Global Class FunctorApplicationInterpretable +Class FunctorApplicationInterpretable {C D} (F : Functor C D) {argsT : Type} (args : argsT) {T : Type} (rtn : T) diff --git a/test-suite/bugs/closed/HoTT_coq_061.v b/test-suite/bugs/closed/HoTT_coq_061.v index 19551dc92e..72bc04e05e 100644 --- a/test-suite/bugs/closed/HoTT_coq_061.v +++ b/test-suite/bugs/closed/HoTT_coq_061.v @@ -96,7 +96,7 @@ Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F' := Build_NaturalTransformation (F o G) (F' o G) (fun c => T (G c)) admit. -Global Class NTC_Composable A B (a : A) (b : B) (T : Type) (term : T) := {}. +Class NTC_Composable A B (a : A) (b : B) (T : Type) (term : T) := {}. Definition NTC_Composable_term `{@NTC_Composable A B a b T term} := term. Notation "T 'o' U" diff --git a/test-suite/bugs/closed/HoTT_coq_120.v b/test-suite/bugs/closed/HoTT_coq_120.v index a80d075f69..cd6539b51c 100644 --- a/test-suite/bugs/closed/HoTT_coq_120.v +++ b/test-suite/bugs/closed/HoTT_coq_120.v @@ -89,7 +89,7 @@ Definition set_cat : PreCategory := @Build_PreCategory hSet (fun x y => forall _ : x, y)%core (fun _ _ _ f g x => f (g x))%core. -Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. +Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, diff --git a/test-suite/bugs/closed/bug_3427.v b/test-suite/bugs/closed/bug_3427.v index 317efb0b32..f00d2fcf09 100644 --- a/test-suite/bugs/closed/bug_3427.v +++ b/test-suite/bugs/closed/bug_3427.v @@ -146,7 +146,7 @@ Section Univalence. := (equiv_path A B)^-1 f. End Univalence. -Local Inductive minus1Trunc (A :Type) : Type := +Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. diff --git a/test-suite/bugs/closed/bug_7795.v b/test-suite/bugs/closed/bug_7795.v index 5db0f81cc5..5f9d42f5f7 100644 --- a/test-suite/bugs/closed/bug_7795.v +++ b/test-suite/bugs/closed/bug_7795.v @@ -52,6 +52,8 @@ Definition hh: false = true. Admitted. +Require Import Program. + Set Program Mode. (* removing this line prevents the bug *) Obligation Tactic := repeat t_base. diff --git a/test-suite/bugs/closed/bug_9494.v b/test-suite/bugs/closed/bug_9494.v new file mode 100644 index 0000000000..a0b8383d16 --- /dev/null +++ b/test-suite/bugs/closed/bug_9494.v @@ -0,0 +1,10 @@ +Lemma foo (a : nat) : True. +Proof. +destruct a eqn:n; exact I. +Qed. + +Set Mangle Names. +Lemma foo2 (a : nat) : True. +Proof. +let N := fresh in destruct a eqn:N; exact I. +Qed. diff --git a/test-suite/misc/poly-capture-global-univs.sh b/test-suite/misc/poly-capture-global-univs.sh index e066ac039b..39d20fd524 100755 --- a/test-suite/misc/poly-capture-global-univs.sh +++ b/test-suite/misc/poly-capture-global-univs.sh @@ -11,7 +11,7 @@ coq_makefile -f _CoqProject -o Makefile make clean -make src/evil_plugin.cmxs +make src/evil_plugin.cma if make; then >&2 echo 'Should have failed!' diff --git a/test-suite/ssr/autoclean.v b/test-suite/ssr/autoclean.v new file mode 100644 index 0000000000..db80a62259 --- /dev/null +++ b/test-suite/ssr/autoclean.v @@ -0,0 +1,4 @@ +Require Import ssreflect. + +Lemma view_disappears A B (AB : A -> B) : A -> False. +Proof. move=> {}/(AB). have := AB. Abort. diff --git a/test-suite/stm/arg_filter_1.v b/test-suite/stm/arg_filter_1.v new file mode 100644 index 0000000000..ed87d67405 --- /dev/null +++ b/test-suite/stm/arg_filter_1.v @@ -0,0 +1,4 @@ +(* coq-prog-args: ("-async-proofs-tac-j" "1") *) + +Lemma foo (A B : Prop) n : n + 0 = n /\ (A -> B -> A). +Proof. split. par: now auto. Qed. diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 5fd894e908..5526970d3f 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -431,7 +431,7 @@ let _ = check_overlapping_include project; - Envars.set_coqlib ~fail:(fun x -> Printf.eprintf "Error: %s\n" x; exit 1); + Envars.set_coqlib ~boot:false ~fail:(fun x -> Printf.eprintf "Error: %s\n" x; exit 1); let ocm = Option.cata open_out stdout project.makefile in generate_makefile ocm conf_file local_file (prog :: args) project; diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 4e80caa4cc..5f8cc99ed1 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -530,7 +530,8 @@ let coqdep () = add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin - Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); + (* option_boot is actually always false in this branch *) + Envars.set_coqlib ~boot:!option_boot ~fail:(fun msg -> raise (CoqlibError msg)); let coqlib = Envars.coqlib () in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index df2b983029..8064ee8880 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -96,6 +96,9 @@ let compile opts copts ~echo ~f_in ~f_out = let iload_path = build_load_path opts in let require_libs = require_libs opts in let stm_options = opts.stm_flags in + let output_native_objects = match opts.native_compiler with + | NativeOff -> false | NativeOn {ondemand} -> not ondemand + in match copts.compilation_mode with | BuildVo -> Flags.record_aux_file := true; @@ -109,6 +112,7 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc Stm.{ doc_type = VoDoc long_f_dot_vo; + allow_coq_overwrite = opts.boot; iload_path; require_libs; stm_options; } in let state = { doc; sid; proof = None; time = opts.time } in @@ -125,7 +129,7 @@ let compile opts copts ~echo ~f_in ~f_out = let _doc = Stm.join ~doc:state.doc in let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); - Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); + Library.save_library_to ~output_native_objects ldir long_f_dot_vo (Global.opaque_tables ()); Aux_file.record_in_aux_at "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); @@ -159,6 +163,7 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc Stm.{ doc_type = VioDoc long_f_dot_vio; + allow_coq_overwrite = opts.boot; iload_path; require_libs; stm_options; } in @@ -168,7 +173,7 @@ let compile opts copts ~echo ~f_in ~f_out = let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in let doc = Stm.finish ~doc:state.doc in check_pending_proofs (); - let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in + let () = ignore (Stm.snapshot_vio ~doc ~output_native_objects ldir long_f_dot_vio) in Stm.reset_task_queue () | Vio2Vo -> diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 74c016101a..c110f3831e 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -13,6 +13,9 @@ let fatal_error exn = let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in exit exit_code +let error_wrong_arg msg = + prerr_endline msg; exit 1 + let error_missing_arg s = prerr_endline ("Error: extra argument expected after option "^s); prerr_endline "See -help for the syntax of supported options"; @@ -33,8 +36,12 @@ let set_type_in_type () = type color = [`ON | `AUTO | `OFF] +type native_compiler = NativeOff | NativeOn of { ondemand : bool } + type t = { + boot : bool; + load_init : bool; load_rcfile : bool; rcfile : string option; @@ -54,7 +61,7 @@ type t = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; enable_VM : bool; - enable_native_compiler : bool; + native_compiler : native_compiler; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; @@ -79,8 +86,15 @@ type t = { let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) +let default_native = + if Coq_config.native_compiler + then NativeOn {ondemand=true} + else NativeOff + let default = { + boot = false; + load_init = true; load_rcfile = true; rcfile = None; @@ -99,7 +113,8 @@ let default = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; enable_VM = true; - enable_native_compiler = Coq_config.native_compiler; + native_compiler = default_native; + stm_flags = Stm.AsyncOpts.default_opts; debug = false; diffs_set = false; @@ -157,7 +172,8 @@ let set_color opts = function | "yes" | "on" -> { opts with color = `ON } | "no" | "off" -> { opts with color = `OFF } | "auto" -> { opts with color = `AUTO } -| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1 +| _ -> + error_wrong_arg ("Error: on/off/auto expected after option color") let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" @@ -175,26 +191,26 @@ let exitcode opts = if opts.filter_opts then 2 else 0 let get_bool opt = function | "yes" | "on" -> true | "no" | "off" -> false - | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1 + | _ -> + error_wrong_arg ("Error: yes/no expected after option "^opt) let get_int opt n = try int_of_string n with Failure _ -> - prerr_endline ("Error: integer expected after option "^opt); exit 1 + error_wrong_arg ("Error: integer expected after option "^opt) let get_float opt n = try float_of_string n with Failure _ -> - prerr_endline ("Error: float expected after option "^opt); exit 1 + error_wrong_arg ("Error: float expected after option "^opt) let get_host_port opt s = match String.split_on_char ':' s with | [host; portr; portw] -> - Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) + Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) | ["stdfds"] -> Some Spawned.AnonPipe | _ -> - prerr_endline ("Error: host:portr:portw or stdfds expected after option "^opt); - exit 1 + error_wrong_arg ("Error: host:portr:portw or stdfds expected after option "^opt) let get_error_resilience opt = function | "on" | "all" | "yes" -> `All @@ -204,17 +220,20 @@ let get_error_resilience opt = function let get_priority opt s = try CoqworkmgrApi.priority_of_string s with Invalid_argument _ -> - prerr_endline ("Error: low/high expected after "^opt); exit 1 + error_wrong_arg ("Error: low/high expected after "^opt) let get_async_proofs_mode opt = let open Stm.AsyncOpts in function | "no" | "off" -> APoff | "yes" | "on" -> APon | "lazy" -> APonLazy - | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1 + | _ -> + error_wrong_arg ("Error: on/off/lazy expected after "^opt) let get_cache opt = function | "force" -> Some Stm.AsyncOpts.Force - | _ -> prerr_endline ("Error: force expected after "^opt); exit 1 + | _ -> + error_wrong_arg ("Error: force expected after "^opt) + let get_native_name s = (* We ignore even critical errors because this mode has to be super silent *) @@ -232,9 +251,9 @@ let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesy exception NoCoqLib -let usage help = +let usage ~boot help = begin - try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib) + try Envars.set_coqlib ~boot ~fail:(fun x -> raise NoCoqLib) with NoCoqLib -> usage_no_coqlib () end; let lp = Coqinit.toplevel_init_load_path () in @@ -299,8 +318,12 @@ let parse_args ~help ~init arglist : t * string list = }} |"-async-proofs-tac-j" -> + let j = get_int opt (next ()) in + if j <= 0 then begin + error_wrong_arg ("Error: -async-proofs-tac-j only accepts values greater than or equal to 1") + end; { oval with stm_flags = { oval.stm_flags with - Stm.AsyncOpts.async_proofs_n_tacworkers = (get_int opt (next ())) + Stm.AsyncOpts.async_proofs_n_tacworkers = j }} |"-async-proofs-worker-priority" -> @@ -414,15 +437,15 @@ let parse_args ~help ~init arglist : t * string list = produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by a separate flag, and the "ondemand" value removed. Once this is done, use [get_bool] here. *) - let (enable,precompile) = + let native_compiler = match (next ()) with - | ("yes" | "on") -> true, true - | "ondemand" -> true, false - | ("no" | "off") -> false, false - | _ -> prerr_endline ("Error: (yes|no|ondemand) expected after option -native-compiler"); exit 1 + | ("yes" | "on") -> NativeOn {ondemand=false} + | "ondemand" -> NativeOn {ondemand=true} + | ("no" | "off") -> NativeOff + | _ -> + error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in - Flags.output_native_objects := precompile; - { oval with enable_native_compiler = enable } + { oval with native_compiler } (* Options with zero arg *) |"-async-queries-always-delegate" @@ -436,7 +459,7 @@ let parse_args ~help ~init arglist : t * string list = { oval with batch = true } |"-test-mode" -> Flags.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-boot" -> Flags.boot := true; { oval with load_rcfile = false; } + |"-boot" -> { oval with boot = true; load_rcfile = false; } |"-bt" -> Backtrace.record_backtrace true; oval |"-color" -> set_color oval (next ()) |"-config"|"--config" -> { oval with print_config = true } @@ -445,7 +468,7 @@ let parse_args ~help ~init arglist : t * string list = if List.exists (fun x -> opt = x) ["off"; "on"; "removed"] then Proof_diffs.write_diffs_option opt else - (prerr_endline ("Error: on|off|removed expected after -diffs"); exit 1); + error_wrong_arg "Error: on|off|removed expected after -diffs"; { oval with diffs_set = true } |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval @@ -468,7 +491,7 @@ let parse_args ~help ~init arglist : t * string list = |"-type-in-type" -> set_type_in_type (); oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> { oval with print_where = true } - |"-h"|"-H"|"-?"|"-help"|"--help" -> usage help; oval + |"-h"|"-H"|"-?"|"-help"|"--help" -> usage ~boot:oval.boot help; oval |"-v"|"--version" -> Usage.version (exitcode oval) |"-print-version"|"--print-version" -> Usage.machine_readable_version (exitcode oval) diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index c9a7a0fd56..9cc846edea 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -12,8 +12,12 @@ type color = [`ON | `AUTO | `OFF] val default_toplevel : Names.DirPath.t +type native_compiler = NativeOff | NativeOn of { ondemand : bool } + type t = { + boot : bool; + load_init : bool; load_rcfile : bool; rcfile : string option; @@ -32,7 +36,8 @@ type t = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; enable_VM : bool; - enable_native_compiler : bool; + native_compiler : native_compiler; + stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diffs_set : bool; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index cdbe444e5b..e933f08735 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -256,7 +256,7 @@ let rec discard_to_dot () = try Pcoq.Entry.parse parse_to_dot top_buffer.tokens with - | Gramlib.Plexing.Error _ | CLexer.Error.E _ -> discard_to_dot () + | CLexer.Error.E _ -> discard_to_dot () | e when CErrors.noncritical e -> () let read_sentence ~state input = diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 6ef0aa390d..c2c538edea 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -162,7 +162,7 @@ let init_toplevel ~help ~init custom_init arglist = (* If we have been spawned by the Spawn module, this has to be done * early since the master waits us to connect back *) Spawned.init_channels (); - Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + Envars.set_coqlib ~boot:opts.boot ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); if opts.print_where then begin print_endline (Envars.coqlib ()); exit (exitcode opts) @@ -188,7 +188,7 @@ let init_toplevel ~help ~init custom_init arglist = Global.set_engagement opts.impredicative_set; Global.set_indices_matter opts.indices_matter; Global.set_VM opts.enable_VM; - Global.set_native_compiler opts.enable_native_compiler; + Global.set_native_compiler (match opts.native_compiler with NativeOff -> false | NativeOn _ -> true); (* Allow the user to load an arbitrary state here *) inputstate opts; @@ -221,6 +221,7 @@ let init_toploop opts = let doc, sid = Stm.(new_doc { doc_type = Interactive opts.toplevel_name; + allow_coq_overwrite = true; (* irrelevant *) iload_path; require_libs; stm_options; }) in let state = { doc; sid; proof = None; time = opts.time } in diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index 7f1cca277e..f2025858d7 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -41,7 +41,7 @@ GRAMMAR EXTEND Gram | cmd = Pvernac.Vernac_.main_entry -> { match cmd with | None -> None - | Some (loc,c) -> Some (CAst.make ~loc (VernacControl c)) } + | Some {CAst.loc; v} -> Some (CAst.make ?loc (VernacControl v)) } ] ] ; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 277f8b7367..0d17218a56 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -62,7 +62,7 @@ let print_usage_common co command = \n\ \n -q skip loading of rcfile\ \n -init-file f set the rcfile to f\ -\n -boot boot mode (allows to overload the `Coq` library prefix)\ +\n -boot boot mode (allows to overload the `Coq` library prefix, implies -q)\ \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ \n -diffs (on|off|removed) highlight differences between proof steps\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 45ca658857..ef1dc6993b 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -101,20 +101,18 @@ let load_vernac_core ~echo ~check ~interactive ~state file = ~doc:state.doc ~entry:Pvernac.main_entry state.sid in_pa with | None -> - input_cleanup (); - state, ids, Pcoq.Parsable.comment_state in_pa - | Some (loc, ast) -> - let ast = CAst.make ~loc ast in + input_cleanup (); + state, ids, Pcoq.Parsable.comment_state in_pa + | Some ast -> + (* Printing of AST for -compile-verbose *) + Option.iter (vernac_echo ?loc:ast.CAst.loc) in_echo; - (* Printing of AST for -compile-verbose *) - Option.iter (vernac_echo ~loc) in_echo; + checknav_simple ast; - checknav_simple ast; + let state = + Flags.silently (interp_vernac ~check ~interactive ~state) ast in - let state = - Flags.silently (interp_vernac ~check ~interactive ~state) ast in - - loop state (state.sid :: ids) + loop state (state.sid :: ids) in try loop state [] with any -> (* whatever the exception *) diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 4f238f38e6..9b8c4efb37 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -125,11 +125,25 @@ let qualify_attribute qual (parser:'a attribute) : 'a attribute = let extra = if rem = [] then extra else (qual, VernacFlagList rem) :: extra in extra, v +(** [program_mode] tells that Program mode has been activated, either + globally via [Set Program] or locally via the Program command prefix. *) + +let program_mode_option_name = ["Program";"Mode"] +let program_mode = ref false + +let () = let open Goptions in + declare_bool_option + { optdepr = false; + optname = "use of the program extension"; + optkey = program_mode_option_name; + optread = (fun () -> !program_mode); + optwrite = (fun b -> program_mode:=b) } + let program_opt = bool_attribute ~name:"Program mode" ~on:"program" ~off:"noprogram" let program = program_opt >>= function | Some b -> return b - | None -> return (Flags.is_program_mode()) + | None -> return (!program_mode) let locality = bool_attribute ~name:"Locality" ~on:"local" ~off:"global" diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 66e10f94cd..3cb4d69ca0 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -53,7 +53,7 @@ val template : bool option attribute val locality : bool option attribute val deprecation : deprecation option attribute -val program_opt : bool option attribute +val program_mode_option_name : string list (** For internal use when messing with the global option. *) val only_locality : vernac_flags -> bool option diff --git a/vernac/classes.ml b/vernac/classes.ml index dd49f09d35..ea434dbc4f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -82,14 +82,14 @@ let mismatched_props env n m = Implicit_quantifiers.mismatched_ctx_inst_err env (* Declare everything in the parameters as implicit, and the class instance as well *) -let type_ctx_instance env sigma ctx inst subst = +let type_ctx_instance ~program_mode env sigma ctx inst subst = let open Vars in let rec aux (sigma, subst, instctx) l = function decl :: ctx -> let t' = substl subst (RelDecl.get_type decl) in let (sigma, c'), l = match decl with - | LocalAssum _ -> interp_casted_constr_evars env sigma (List.hd l) t', List.tl l + | LocalAssum _ -> interp_casted_constr_evars ~program_mode env sigma (List.hd l) t', List.tl l | LocalDef (_,b,_) -> (sigma, substl subst b), l in let d = RelDecl.get_name decl, Some c', t' in @@ -206,7 +206,7 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct | None -> (if List.is_empty k.cl_props then Some (Inl subst) else None), sigma | Some (Inr term) -> - let sigma, c = interp_casted_constr_evars env' sigma term cty in + let sigma, c = interp_casted_constr_evars ~program_mode env' sigma term cty in Some (Inr (c, subst)), sigma | Some (Inl props) -> let get_id qid = CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid in @@ -237,7 +237,7 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct unbound_method env' k.cl_impl (get_id n) | _ -> let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in - let sigma, res = type_ctx_instance (push_rel_context ctx' env') sigma kcl_props props subst in + let sigma, res = type_ctx_instance ~program_mode (push_rel_context ctx' env') sigma kcl_props props subst in Some (Inl res), sigma in let term, termtype = @@ -276,7 +276,7 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct else CErrors.user_err Pp.(str "Unsolved obligations remaining."); id -let interp_instance_context env ctx ?(generalize=false) pl bk cl = +let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass, ids = match bk with @@ -295,8 +295,8 @@ let interp_instance_context env ctx ?(generalize=false) pl bk cl = if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) else tclass in - let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in - let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in + let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in + let sigma, (c', imps') = interp_type_evars_impls ~program_mode ~impls env' sigma tclass in let len = Context.Rel.nhyps ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum sigma c' in @@ -324,7 +324,7 @@ let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode let env = Global.env() in let ({CAst.loc;v=instid}, pl) = instid in let sigma, k, u, cty, ctx', ctx, imps, subst, decl = - interp_instance_context env ~generalize ctx pl bk cl + interp_instance_context ~program_mode env ~generalize ctx pl bk cl in let id = match instid with @@ -337,11 +337,11 @@ let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props -let declare_new_instance ?(global=false) poly ctx (instid, bk, cl) pri = +let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) pri = let env = Global.env() in let ({CAst.loc;v=instid}, pl) = instid in let sigma, k, u, cty, ctx', ctx, imps, subst, decl = - interp_instance_context env ctx pl 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 @@ -361,7 +361,7 @@ let named_of_rel_context l = let context poly l = let env = Global.env() in let sigma = Evd.from_env env in - let sigma, (_, ((env', fullctx), impls)) = interp_context_evars env sigma l 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 diff --git a/vernac/classes.mli b/vernac/classes.mli index 6f61da66cf..7e0ec42625 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -55,6 +55,7 @@ val new_instance : val declare_new_instance : ?global:bool (** Not global by default. *) -> + program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> ident_decl * Decl_kinds.binding_kind * constr_expr -> diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 7301e1fff7..73d0be04df 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -84,8 +84,8 @@ match local with in (gr,inst,Lib.is_modtype_strict ()) -let interp_assumption sigma env impls c = - let sigma, (ty, impls) = interp_type_evars_impls env sigma ~impls c in +let interp_assumption ~program_mode sigma env impls c = + let sigma, (ty, impls) = interp_type_evars_impls ~program_mode env sigma ~impls c in sigma, (ty, impls) (* When monomorphic the universe constraints are declared with the first declaration only. *) @@ -131,7 +131,7 @@ let process_assumptions_udecls kind l = in udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l -let do_assumptions kind nl l = +let do_assumptions ~program_mode kind nl l = let open Context.Named.Declaration in let env = Global.env () in let udecl, l = process_assumptions_udecls kind l in @@ -147,7 +147,7 @@ let do_assumptions kind nl l = in (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> - let sigma,(t,imps) = interp_assumption sigma env ienv c in + let sigma,(t,imps) = interp_assumption ~program_mode sigma env ienv c in let env = EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (id,t)) idl) env in let ienv = List.fold_right (fun {CAst.v=id} ienv -> diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index c5bf3725a9..385ec33bea 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -17,7 +17,7 @@ open Decl_kinds (** {6 Parameters/Assumptions} *) -val do_assumptions : locality * polymorphic * assumption_object_kind -> +val do_assumptions : program_mode:bool -> locality * polymorphic * assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool (************************************************************************) diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 79d45880fc..5e74114a86 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -41,26 +41,26 @@ let check_imps ~impsty ~impsbody = in if not b then warn_implicits_in_term () -let interp_definition pl bl poly red_option c ctypopt = +let interp_definition ~program_mode pl bl poly red_option c ctypopt = let open EConstr in let env = Global.env() in (* Explicitly bound universes and constraints *) let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in (* Build the parameters *) - let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars env evd bl in + let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) let evd, tyopt = Option.fold_left_map - (interp_type_evars_impls ~impls env_bl) + (interp_type_evars_impls ~program_mode ~impls env_bl) evd ctypopt in (* Build the body, and merge implicits from parameters and from type/body *) let evd, c, imps, tyopt = match tyopt with | None -> - let evd, (c, impsbody) = interp_constr_evars_impls ~impls env_bl evd c in + let evd, (c, impsbody) = interp_constr_evars_impls ~program_mode ~impls env_bl evd c in evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsbody, None | Some (ty, impsty) -> - let evd, (c, impsbody) = interp_casted_constr_evars_impls ~impls env_bl evd c ty in + let evd, (c, impsbody) = interp_casted_constr_evars_impls ~program_mode ~impls env_bl evd c ty in check_imps ~impsty ~impsbody; evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsty, Some ty in @@ -85,14 +85,14 @@ let interp_definition pl bl poly red_option c ctypopt = let ce = definition_entry ?types:tyopt ~univs:uctx c in (ce, evd, decl, imps) -let check_definition (ce, evd, _, imps) = +let check_definition ~program_mode (ce, evd, _, imps) = let env = Global.env () in - check_evars_are_solved env evd; + check_evars_are_solved ~program_mode env evd; ce let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = - interp_definition univdecl bl (pi2 k) red_option c ctypopt + interp_definition ~program_mode univdecl bl (pi2 k) red_option c ctypopt in if program_mode then let env = Global.env () in @@ -111,5 +111,5 @@ let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let univ_hook = Obligations.mk_univ_hook (fun _ _ l r -> Lemmas.call_hook ?hook l r) in ignore(Obligations.add_definition ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~univ_hook obls) - else let ce = check_definition def in + else let ce = check_definition ~program_mode def in ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps ?hook) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 0ac5762f71..9cb6190fcc 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -27,7 +27,7 @@ val do_definition : program_mode:bool -> (************************************************************************) (** Not used anywhere. *) -val interp_definition : +val interp_definition : program_mode:bool -> universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * UState.universe_decl * Impargs.manual_implicits diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 77227b64e6..5229d9e8e8 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -116,21 +116,23 @@ type structured_fixpoint_expr = { fix_type : constr_expr } -let interp_fix_context ~cofix env sigma fix = +let interp_fix_context ~program_mode ~cofix env sigma fix = let before, after = if not cofix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in - let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars env sigma before in - let sigma, (impl_env', ((env'', ctx'), imps')) = interp_context_evars ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after in + let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in + let sigma, (impl_env', ((env'', ctx'), imps')) = + interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after + in let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) -let interp_fix_ccl sigma impls (env,_) fix = - interp_type_evars_impls ~impls env sigma fix.fix_type +let interp_fix_ccl ~program_mode sigma impls (env,_) fix = + interp_type_evars_impls ~program_mode ~impls env sigma fix.fix_type -let interp_fix_body env_rec sigma impls (_,ctx) fix ccl = +let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let open EConstr in Option.cata (fun body -> let env = push_rel_context ctx env_rec in - let sigma, body = interp_casted_constr_evars env sigma ~impls body ccl in + let sigma, body = interp_casted_constr_evars ~program_mode env sigma ~impls body ccl in sigma, Some (it_mkLambda_or_LetIn body ctx)) (sigma, None) fix.fix_body let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx @@ -184,11 +186,11 @@ let interp_recursive ~program_mode ~cofix fixl notations = let sigma, decl = interp_univ_decl_opt env all_universes in let sigma, (fixctxs, fiximppairs, fixannots) = on_snd List.split3 @@ - List.fold_left_map (fun sigma -> interp_fix_context env sigma ~cofix) sigma fixl in + List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in let fixctximpenvs, fixctximps = List.split fiximppairs in let sigma, (fixccls,fixcclimps) = on_snd List.split @@ - List.fold_left3_map interp_fix_ccl sigma fixctximpenvs fixctxs fixl in + List.fold_left3_map (interp_fix_ccl ~program_mode) sigma fixctximpenvs fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in let fiximps = List.map3 @@ -220,7 +222,7 @@ let interp_recursive ~program_mode ~cofix fixl notations = Metasyntax.with_syntax_protection (fun () -> List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; List.fold_left4_map - (fun sigma fixctximpenv -> interp_fix_body env_rec sigma (Id.Map.fold Id.Map.add fixctximpenv impls)) + (fun sigma fixctximpenv -> interp_fix_body ~program_mode env_rec sigma (Id.Map.fold Id.Map.add fixctximpenv impls)) sigma fixctximpenvs fixctxs fixl fixccls) () in @@ -239,7 +241,7 @@ let check_recursive isfix env evd (fixnames,fixdefs,_) = end let ground_fixpoint env evd (fixnames,fixdefs,fixtypes) = - check_evars_are_solved env evd; + check_evars_are_solved ~program_mode:false env evd; let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixdefs,fixtypes) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index afee2a5868..68ad276113 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -162,7 +162,7 @@ let interp_cstrs env sigma impls mldata arity ind = let sigma, (ctyps'', cimpls) = on_snd List.split @@ List.fold_left_map (fun sigma l -> - interp_type_evars_impls env sigma ~impls l) sigma ctyps' in + interp_type_evars_impls ~program_mode:false env sigma ~impls l) sigma ctyps' in sigma, (cnames, ctyps'', cimpls) let sign_level env evd sign = @@ -358,9 +358,9 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not then user_err (str "Inductives with uniform parameters may not have attached notations."); let sigma, udecl = interp_univ_decl_opt env0 udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = - interp_context_evars env0 sigma uparamsl in + interp_context_evars ~program_mode:false env0 sigma uparamsl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = - interp_context_evars ~impl_env:uimpls env_uparams sigma paramsl + interp_context_evars ~program_mode:false ~impl_env:uimpls env_uparams sigma paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index edce8e255c..a30313d37c 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -91,17 +91,17 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in - let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars env sigma bl in + let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars ~program_mode:true env sigma bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in - let sigma, top_arity = interp_type_evars top_env sigma arityc in + let sigma, top_arity = interp_type_evars ~program_mode:true top_env sigma arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let sigma, argtyp, letbinders, make = telescope sigma binders_rel in let argname = Id.of_string "recarg" in let arg = LocalAssum (Name argname, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in - let sigma, (rel, _) = interp_constr_evars_impls env sigma r in + let sigma, (rel, _) = interp_constr_evars_impls ~program_mode:true env sigma r in let relty = Typing.unsafe_type_of env sigma rel in let relargty = let error () = @@ -117,7 +117,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = | _, _ -> error () with e when CErrors.noncritical e -> error () in - let sigma, measure = interp_casted_constr_evars binders_env sigma measure relargty in + let sigma, measure = interp_casted_constr_evars ~program_mode:true binders_env sigma measure relargty in let sigma, wf_rel, wf_rel_fun, measure_fn = let measure_body, measure = it_mkLambda_or_LetIn measure letbinders, @@ -176,7 +176,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let newimpls = Id.Map.singleton recname (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], scopes @ [None]) in - interp_casted_constr_evars (push_rel_context ctx env) sigma + interp_casted_constr_evars ~program_mode:true (push_rel_context ctx env) sigma ~impls:newimpls body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 41057f8ab2..361ed1a737 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -57,7 +57,7 @@ let declare_fix ?(opaque = false) (_,poly,_ as kind) pl univs f ((def,_),eff) t let check_definition_evars ~allow_evars sigma = let env = Global.env () in - if not allow_evars then Pretyping.check_evars_are_solved env sigma + if not allow_evars then Pretyping.check_evars_are_solved ~program_mode:false env sigma let prepare_definition ~allow_evars ?opaque ?inline ~poly sigma udecl ~types ~body = check_definition_evars ~allow_evars sigma; diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 71770a21ca..42b313f200 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -28,7 +28,6 @@ exception EvaluatedError of Pp.t * exn option let explain_exn_default = function (* Basic interaction exceptions *) | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Gramlib.Plexing.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) | Out_of_memory -> hov 0 (str "Out of memory.") diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 0dfbba0e83..79182a3f9d 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -417,14 +417,14 @@ let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = | None -> p,(true,[]) | Some tac -> Proof.run_tactic Global.(env ()) tac p)) -let start_proof_com ?inference_hook ?hook kind thms = +let start_proof_com ~program_mode ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) -> - let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in - let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in - let flags = all_and_fail_flags in + let evd, (impls, ((env, ctx), imps)) = interp_context_evars ~program_mode env0 evd bl in + let evd, (t', imps') = interp_type_evars_impls ~program_mode ~impls env evd t in + let flags = { all_and_fail_flags with program_mode } in let hook = inference_hook in let evd = solve_remaining_evars ?hook flags env evd in let ids = List.map RelDecl.get_name ctx in @@ -481,7 +481,14 @@ let save_proof ?proof = function Admitted(id, k, (sec_vars, (typ, ctx), None), universes) | None -> let pftree = Proof_global.give_me_the_proof () in - let id, k, typ = Pfedit.current_proof_statement () in + let gk = Proof_global.get_current_persistence () in + let Proof.{ name; poly; entry } = Proof.data pftree in + let typ = match Proofview.initial_goals entry with + | [typ] -> snd typ + | _ -> + CErrors.anomaly + ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") + in let typ = EConstr.Unsafe.to_constr typ in let universes = Proof.((data pftree).initial_euctx) in (* This will warn if the proof is complete *) @@ -491,16 +498,15 @@ let save_proof ?proof = function if not !keep_admitted_vars then None else match Proof_global.get_used_variables(), pproofs with | Some _ as x, _ -> x - | None, (pproof, _) :: _ -> + | None, (pproof, _) :: _ -> let env = Global.env () in let ids_typ = Environ.global_vars_set env typ in let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) | _ -> None in let decl = Proof_global.get_universe_decl () in - let poly = pi2 k in let ctx = UState.check_univ_decl ~poly universes decl in - Admitted(id,k,(sec_vars, (typ, ctx), None), universes) + Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (opaque,idopt) -> diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 3ac12d3b0b..a9a10a6e38 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -31,7 +31,7 @@ val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.eva ?univ_hook:(UState.t option -> declaration_hook) -> EConstr.types -> unit val start_proof_com : - ?inference_hook:Pretyping.inference_hook -> + program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index b4dd7d06b5..b20758dac5 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -1197,15 +1197,7 @@ let next_obligation n tac = in solve_obligation prg i tac -let init_program () = +let check_program_libraries () = Coqlib.check_required_library Coqlib.datatypes_module_name; Coqlib.check_required_library ["Coq";"Init";"Specif"]; Coqlib.check_required_library ["Coq";"Program";"Tactics"] - -let set_program_mode c = - if c then - if !Flags.program_mode then () - else begin - init_program (); - Flags.program_mode := true; - end diff --git a/vernac/obligations.mli b/vernac/obligations.mli index c670e3a3b5..4eef668f56 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -110,7 +110,7 @@ exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t -val set_program_mode : bool -> unit +val check_program_libraries : unit -> unit type program_info val program_tcc_summary_tag : program_info Id.Map.t Summary.Dyn.tag diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 0e46df2320..994fad85f0 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,7 +52,7 @@ module Vernac_ = let () = let open Extend in - let act_vernac v loc = Some (loc, v) in + let act_vernac v loc = Some CAst.(make ~loc v) in let act_eoi _ loc = None in let rule = [ Rule (Next (Stop, Atoken Tok.EOI), act_eoi); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index fa251281dc..4bf7c9f7bd 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -26,7 +26,7 @@ module Vernac_ : val rec_definition : (fixpoint_expr * decl_notation list) Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t - val main_entry : (Loc.t * vernac_control) option Entry.t + val main_entry : vernac_control CAst.t option Entry.t val red_expr : raw_red_expr Entry.t val hint_info : Hints.hint_info_expr Entry.t end @@ -40,7 +40,7 @@ module Unsafe : sig end (** The main entry: reads an optional vernac command *) -val main_entry : proof_mode option -> (Loc.t * vernac_control) option Entry.t +val main_entry : proof_mode option -> vernac_control CAst.t option Entry.t (** Grammar entry for tactics: proof mode(s). By default Coq's grammar has an empty entry (non-terminal) for diff --git a/vernac/record.ml b/vernac/record.ml index ed5edb7e3b..6b9a564b9e 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -65,10 +65,10 @@ let () = let interp_fields_evars env sigma impls_env nots l = List.fold_left2 (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> - let sigma, (t', impl) = interp_type_evars_impls env sigma ~impls t in + let sigma, (t', impl) = interp_type_evars_impls ~program_mode:false env sigma ~impls t in let sigma, b' = Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ - interp_casted_constr_evars_impls env sigma ~impls x t') (sigma,None) b in + interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in let impls = match i with | Anonymous -> impls @@ -116,14 +116,14 @@ let typecheck_params_and_fields finite def poly pl ps records = | CLocalPattern {CAst.loc} -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps in - let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars env0 sigma ps in + let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars ~program_mode:false env0 sigma ps in let fold (sigma, template) (_, t, _, _) = match t with | Some t -> let env = EConstr.push_rel_context newps env0 in let poly = match t with | { CAst.v = CSort (Glob_term.GType []) } -> true | _ -> false in - let sigma, s = interp_type_evars env sigma ~impls:empty_internalization_env t in + let sigma, s = interp_type_evars ~program_mode:false env sigma ~impls:empty_internalization_env t in let sred = Reductionops.whd_allnolet env sigma s in (match EConstr.kind sigma sred with | Sort s' -> diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 7611355100..fcb96401ee 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -514,9 +514,9 @@ let () = (***********) (* Gallina *) -let start_proof_and_print ?hook k l = +let start_proof_and_print ~program_mode ?hook k l = let inference_hook = - if Flags.is_program_mode () then + if program_mode then let hook env sigma ev = let tac = !Obligations.default_tactic in let evi = Evd.find sigma ev in @@ -536,7 +536,7 @@ let start_proof_and_print ?hook k l = in Some hook else None in - start_proof_com ?inference_hook ?hook k l + start_proof_com ~program_mode ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> @@ -549,7 +549,6 @@ let vernac_definition_hook p = function let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = let open DefAttributes in - let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in let () = @@ -560,7 +559,7 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = | Discharge -> Dumpglob.dump_definition lid true "var" | Local | Global -> Dumpglob.dump_definition lid false "def" in - let program_mode = Flags.is_program_mode () in + let program_mode = atts.program in let name = match id with | Anonymous -> fresh_name_for_anonymous_theorem () @@ -568,7 +567,7 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local, atts.polymorphic, DefinitionBody kind) + start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) ?hook [(CAst.make ?loc name, pl), (bl, t)] | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with @@ -581,11 +580,10 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = let vernac_start_proof ~atts kind l = let open DefAttributes in - let atts = parse atts in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_proof_and_print (local, atts.polymorphic, Proof kind) l + start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l let vernac_end_proof ?proof = function | Admitted -> save_proof ?proof Admitted @@ -600,7 +598,6 @@ let vernac_exact_proof c = let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in - let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in let kind = local, atts.polymorphic, kind in @@ -609,7 +606,7 @@ let vernac_assumption ~atts discharge kind l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions kind nl l in + let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let should_treat_as_cumulative cum poly = @@ -675,9 +672,7 @@ let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = indicates whether the type is inductive, co-inductive or neither. *) let vernac_inductive ~atts cum lo finite indl = - let open DefAttributes in - let atts, template = Attributes.(parse_with_extra template atts) in - let atts = parse atts in + let template, poly = Attributes.(parse Notations.(template ++ polymorphic) atts) in let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then @@ -708,7 +703,7 @@ let vernac_inductive ~atts cum lo finite indl = let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in - vernac_record ~template udecl cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] + vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) let check_kind ((_, _, _, kind, _), _) = match kind with @@ -731,7 +726,7 @@ let vernac_inductive ~atts cum lo finite indl = let ((_, _, _, kind, _), _) = List.hd indl in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in - vernac_record ~template udecl cum kind atts.polymorphic finite recordl + vernac_record ~template udecl cum kind poly finite recordl else if List.for_all is_constructor indl then (* Mutual inductive case *) let check_kind ((_, _, _, kind, _), _) = match kind with @@ -755,9 +750,9 @@ let vernac_inductive ~atts cum lo finite indl = | RecordDecl _ -> assert false (* ruled out above *) in let indl = List.map unpack indl in - let is_cumulative = should_treat_as_cumulative cum atts.polymorphic in + let is_cumulative = should_treat_as_cumulative cum poly in let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive ~template udecl indl is_cumulative atts.polymorphic lo ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl is_cumulative poly lo ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") (* @@ -773,12 +768,11 @@ let vernac_inductive ~atts cum lo finite indl = let vernac_fixpoint ~atts discharge l = let open DefAttributes in - let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; (* XXX: Switch to the attribute system and match on ~atts *) - let do_fixpoint = if Flags.is_program_mode () then + let do_fixpoint = if atts.program then ComProgramFixpoint.do_fixpoint else ComFixpoint.do_fixpoint @@ -787,11 +781,10 @@ let vernac_fixpoint ~atts discharge l = let vernac_cofixpoint ~atts discharge l = let open DefAttributes in - let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - let do_cofixpoint = if Flags.is_program_mode () then + let do_cofixpoint = if atts.program then ComProgramFixpoint.do_cofixpoint else ComFixpoint.do_cofixpoint @@ -1029,18 +1022,16 @@ let vernac_identity_coercion ~atts id qids qidt = let vernac_instance ~atts sup inst props pri = let open DefAttributes in - let atts = parse atts in let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; - let program_mode = Flags.is_program_mode () in + let program_mode = atts.program in ignore(Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri) let vernac_declare_instance ~atts sup inst pri = let open DefAttributes in - let atts = parse atts in let global = not (make_section_locality atts.locality) in Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; - Classes.declare_new_instance ~global atts.polymorphic sup inst pri + Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri let vernac_context ~poly l = if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom @@ -1575,14 +1566,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "use of the program extension"; - optkey = ["Program";"Mode"]; - optread = (fun () -> !Flags.program_mode); - optwrite = (fun b -> Flags.program_mode:=b) } - -let () = - declare_bool_option - { optdepr = false; optname = "Polymorphic inductive cumulativity"; optkey = ["Polymorphic"; "Inductive"; "Cumulativity"]; optread = Flags.is_polymorphic_inductive_cumulativity; @@ -2167,7 +2150,7 @@ let vernac_load interp fname = else None in - interp (snd (parse_sentence proof_mode input)); + interp (parse_sentence proof_mode input).CAst.v; done with End_of_input -> () end; @@ -2189,6 +2172,11 @@ let with_module_locality ~atts f = let module_local = make_module_locality local in f ~module_local +let with_def_attributes ~atts f = + let atts = DefAttributes.parse atts in + if atts.DefAttributes.program then Obligations.check_program_libraries (); + f ~atts + (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. @@ -2232,15 +2220,15 @@ let interp ?proof ~atts ~st c = (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> - vernac_definition ~atts discharge kind lid d - | VernacStartTheoremProof (k,l) -> vernac_start_proof ~atts k l + with_def_attributes ~atts vernac_definition discharge kind lid d + | VernacStartTheoremProof (k,l) -> with_def_attributes vernac_start_proof ~atts k l | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof e | VernacExactProof c -> unsupported_attributes atts; vernac_exact_proof c | VernacAssumption ((discharge,kind),nl,l) -> - vernac_assumption ~atts discharge kind l nl + with_def_attributes vernac_assumption ~atts discharge kind l nl | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l - | VernacFixpoint (discharge, l) -> vernac_fixpoint ~atts discharge l - | VernacCoFixpoint (discharge, l) -> vernac_cofixpoint ~atts discharge l + | VernacFixpoint (discharge, l) -> with_def_attributes vernac_fixpoint ~atts discharge l + | VernacCoFixpoint (discharge, l) -> with_def_attributes vernac_cofixpoint ~atts discharge l | VernacScheme l -> unsupported_attributes atts; vernac_scheme l | VernacCombinedScheme (id, l) -> unsupported_attributes atts; vernac_combined_scheme id l | VernacUniverse l -> vernac_universe ~poly:(only_polymorphism atts) l @@ -2271,9 +2259,9 @@ let interp ?proof ~atts ~st c = (* Type classes *) | VernacInstance (sup, inst, props, info) -> - vernac_instance ~atts sup inst props info + with_def_attributes vernac_instance ~atts sup inst props info | VernacDeclareInstance (sup, inst, info) -> - vernac_declare_instance ~atts sup inst info + with_def_attributes vernac_declare_instance ~atts sup inst info | VernacContext sup -> vernac_context ~poly:(only_polymorphism atts) sup | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts | VernacExistingClass id -> unsupported_attributes atts; vernac_existing_class id @@ -2423,7 +2411,6 @@ let with_fail st b f = end let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = - let orig_program_mode = Flags.is_program_mode () in let rec control = function | VernacExpr (atts, v) -> aux ~atts v @@ -2445,21 +2432,13 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = vernac_load control fname | c -> - let program = let open Attributes in - parse_drop_extra program_opt atts - in (* NB: we keep polymorphism and program in the attributes, we're just parsing them to do our option magic. *) - Option.iter Obligations.set_program_mode program; try vernac_timeout begin fun () -> if verbosely then Flags.verbosely (interp ?proof ~atts ~st) c else Flags.silently (interp ?proof ~atts ~st) c; - (* If the command is `(Un)Set Program Mode` or `(Un)Set Universe Polymorphism`, - we should not restore the previous state of the flag... *) - if Option.has_some program then - Flags.program_mode := orig_program_mode; end with | reraise when @@ -2470,7 +2449,6 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = let e = CErrors.push reraise in let e = locate_if_not_already ?loc e in let () = restore_timeout () in - Flags.program_mode := orig_program_mode; iraise e in if verbosely |