diff options
536 files changed, 13962 insertions, 10210 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/.github/CODEOWNERS b/.github/CODEOWNERS index 275d6c1ff5..f802040a1d 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -30,8 +30,6 @@ # Trick to avoid getting review requests # each time someone adds an overlay -/appveyor.yml @coq/ci-maintainers -/dev/ci/appveyor.* @coq/ci-maintainers /dev/ci/*.bat @coq/ci-maintainers *.nix @coq/nix-maintainers diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md index c9cb516cd3..aec6cd0a21 100644 --- a/.github/ISSUE_TEMPLATE.md +++ b/.github/ISSUE_TEMPLATE.md @@ -1,18 +1,11 @@ -<!-- Thank you for your contribution. - Please complete the following information when reporting a bug. --> +<!-- Thank you for reporting a bug to Coq! --> -#### Version - -<!-- You can get this information by running `coqtop -v`. --> - - -#### Operating system +#### Description of the problem +<!-- If you can, it's helpful to provide self-contained example of some code +that reproduces the bug. If not, a link to a larger example is also helpful. --> -#### Description of the problem +#### Coq Version -<!-- It is helpful to provide enough information so that we can reproduce the bug. - In particular, please include a code example which produces it. - If the example is small, you can include it here between ``` ```. - Otherwise, please provide a link to a repository, a gist (https://gist.github.com) - or drag-and-drop a `.zip` archive. --> +<!-- You can get this information by running `coqtop -v`. If relevant, please +also include your operating system. --> diff --git a/.gitignore b/.gitignore index 2e5529ccfb..c30fd850a1 100644 --- a/.gitignore +++ b/.gitignore @@ -147,6 +147,7 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_jumptbl.h kernel/copcodes.ml +kernel/uint63.ml ide/index_urls.txt .lia.cache .nia.cache diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a6858c6802..b3dc1fa896 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -4,12 +4,13 @@ stages: - docker - build - test + - deploy # some default values variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2018-12-14-V1" + CACHEKEY: "bionic_coq-V2019-02-17-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -99,6 +100,7 @@ after_script: - set +e variables: OPAM_SWITCH: edge + OPAM_VARIANT: "+flambda" artifacts: name: "$CI_JOB_NAME" paths: @@ -108,7 +110,7 @@ after_script: .dune-ci-template: &dune-ci-template stage: test dependencies: - - build:egde:dune:dev + - build:edge+flambda:dune:dev script: - set -e - echo 'start:coq.test' @@ -117,6 +119,7 @@ after_script: - set +e variables: &dune-ci-template-vars OPAM_SWITCH: edge + OPAM_VARIANT: "+flambda" artifacts: &dune-ci-template-artifacts name: "$CI_JOB_NAME" expire_in: 1 month @@ -131,7 +134,7 @@ after_script: dependencies: - not-a-real-job script: - - SPHINXENV='COQBIN="'"$PWD"'/_install_ci/bin/" COQBOOT=no' + - SPHINXENV='COQBIN="'"$PWD"'/_install_ci/bin/"' - make -j "$NJOBS" SPHINXENV="$SPHINXENV" SPHINX_DEPS= refman - make install-doc-sphinx artifacts: @@ -221,12 +224,6 @@ build:base+32bit: OPAM_VARIANT: "+32bit" COQ_EXTRA_CONF: "-native-compiler yes" -build:edge: - <<: *build-template - variables: - OPAM_SWITCH: edge - COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" - build:edge+flambda: <<: *build-template variables: @@ -235,7 +232,7 @@ build:edge+flambda: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt -flambda-opts " COQ_EXTRA_CONF_QUOTE: "-O3 -unbox-closures" -build:egde:dune:dev: +build:edge+flambda:dune:dev: <<: *dune-template build:base+async: @@ -281,12 +278,14 @@ pkg:opam: dependencies: [] script: - set -e - - opam pin add coq . - - opam pin add coqide-server . - - opam pin add coqide . + - opam pin add --kind=path coq.$COQ_VERSION . + - opam pin add --kind=path coqide-server.$COQ_VERSION . + - opam pin add --kind=path coqide.$COQ_VERSION . - set +e variables: - OPAM_SWITCH: edge + COQ_VERSION: "8.10" + OPAM_SWITCH: "edge" + OPAM_VARIANT: "+flambda" .nix-template: &nix-template image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git @@ -321,7 +320,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 +346,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: @@ -369,13 +399,6 @@ test-suite:base+32bit: variables: OPAM_VARIANT: "+32bit" -test-suite:edge: - <<: *test-suite-template - dependencies: - - build:edge - variables: - OPAM_SWITCH: edge - test-suite:edge+flambda: <<: *test-suite-template dependencies: @@ -387,10 +410,11 @@ test-suite:edge+flambda: test-suite:egde:dune:dev: stage: test dependencies: - - build:egde:dune:dev + - build:edge+flambda:dune:dev script: make -f Makefile.dune test-suite variables: OPAM_SWITCH: edge + OPAM_VARIANT: "+flambda" artifacts: name: "$CI_JOB_NAME.logs" when: on_failure @@ -412,7 +436,7 @@ test-suite:edge+trunk+make: - make -j "$NJOBS" world - make -j "$NJOBS" test-suite UNIT_TESTS= variables: - OPAM_SWITCH: edge + OPAM_SWITCH: base artifacts: name: "$CI_JOB_NAME.logs" when: always @@ -438,7 +462,7 @@ test-suite:edge+trunk+dune: - export COQ_UNIT_TEST=noop - dune runtest --profile=ocaml409 variables: - OPAM_SWITCH: edge + OPAM_SWITCH: base artifacts: name: "$CI_JOB_NAME.logs" when: always @@ -467,13 +491,6 @@ validate:base+32bit: variables: OPAM_VARIANT: "+32bit" -validate:edge: - <<: *validate-template - dependencies: - - build:edge - variables: - OPAM_SWITCH: edge - validate:edge+flambda: <<: *validate-template dependencies: @@ -492,7 +509,6 @@ validate:quick: library:ci-bedrock2: <<: *ci-template - allow_failure: true library:ci-color: <<: *ci-template-flambda @@ -565,7 +581,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 03f991566e..38c197d8cc 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -22,6 +22,11 @@ Coqide Coqtop +- the use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use. (@ejgallego #9095) + - new option -topfile filename, which will set the current module name (à la -top) based on the filename passed, taking into account the proper -R/-Q options. For example, given -R Foo foolib using @@ -39,6 +44,10 @@ Specification language, type inference solved by writing an explicit `return` clause, sometimes even simply an explicit `return _` clause. +Kernel + +- Added primitive integers + Notations - New command `Declare Scope` to explicitly declare a scope name @@ -78,6 +87,16 @@ Tactics foo : database`). When the database name is omitted, the hint is added to the core database (as previously), but a deprecation warning is emitted. +- There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms. + +- Ltac backtraces can be turned on using the "Ltac Backtrace" option. + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -109,6 +128,13 @@ 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. + +- The algorithm computing implicit arguments now behaves uniformly for primitive + projection and application nodes (bug #9508). + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -142,6 +168,8 @@ Standard Library - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an ordered type (using lexical order). +- The `Coq.Numbers.Cyclic.Int31` library is deprecated. + Universes - Added `Print Universes Subgraph` variant of `Print Universes`. @@ -166,6 +194,8 @@ Misc - Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. +- Removed option "Printing Primitive Projection Compatibility" + SSReflect - New intro patterns: diff --git a/META.coq.in b/META.coq.in index 159984d87a..ab142ccc43 100644 --- a/META.coq.in +++ b/META.coq.in @@ -411,30 +411,6 @@ package "plugins" ( archive(native) = "nsatz_plugin.cmx" ) - package "natsyntax" ( - - description = "Coq natsyntax plugin" - version = "8.10" - - requires = "" - directory = "syntax" - - archive(byte) = "nat_syntax_plugin.cmo" - archive(native) = "nat_syntax_plugin.cmx" - ) - - package "zsyntax" ( - - description = "Coq zsyntax plugin" - version = "8.10" - - requires = "" - directory = "syntax" - - archive(byte) = "z_syntax_plugin.cmo" - archive(native) = "z_syntax_plugin.cmx" - ) - package "rsyntax" ( description = "Coq rsyntax plugin" @@ -447,16 +423,16 @@ package "plugins" ( archive(native) = "r_syntax_plugin.cmx" ) - package "int31syntax" ( + package "int63syntax" ( - description = "Coq int31syntax plugin" + description = "Coq int63syntax plugin" version = "8.10" requires = "" directory = "syntax" - archive(byte) = "int31_syntax_plugin.cmo" - archive(native) = "int31_syntax_plugin.cmx" + archive(byte) = "int63_syntax_plugin.cmo" + archive(native) = "int63_syntax_plugin.cmx" ) package "string_notation" ( @@ -100,7 +100,7 @@ GENMLGFILES:= $(MLGFILES:.mlg=.ml) export GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) export GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) export GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml -export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml +export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml export GENHFILES:=kernel/byterun/coq_jumptbl.h export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) diff --git a/Makefile.build b/Makefile.build index e683a6bda8..8afb498a63 100644 --- a/Makefile.build +++ b/Makefile.build @@ -198,7 +198,10 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # TIME="%C (%U user, %S sys, %e total, %M maxres)" COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) -BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile +# Beware this depends on the makefile being in a particular dir, we +# should pass an absolute path here but windows is tricky +# c.f. https://github.com/coq/coq/pull/9560 +BOOTCOQC=$(TIMER) $(COQC) -coqlib . -boot $(COQOPTS) LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) MLINCLUDES=$(LOCALINCLUDES) @@ -239,6 +242,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 @@ -281,7 +288,7 @@ ifndef ORDER_ONLY_SEP $(error This Makefile needs GNU Make 3.81 or later (that is a version that supports the order-only dependency feature without major bugs.)) endif -VO_TOOLS_DEP := $(COQTOPBEST) +VO_TOOLS_DEP := $(COQC) ifdef VALIDATE VO_TOOLS_DEP += $(CHICKEN) endif @@ -338,17 +345,27 @@ $(COQPP): $(COQPPCMO) coqpp/coqpp_main.ml $(HIDE)$(OCAMLC) -I coqpp $^ -linkall -o $@ ########################################################################### +# Specific rules for Uint63 +########################################################################### +kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_x86.ml kernel/uint63_amd64.ml + $(SHOW)'WRITE $@' + $(HIDE)(cd kernel && ocaml unix.cma $(shell basename $<)) + +########################################################################### # Main targets (coqtop.opt, coqtop.byte) ########################################################################### .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)) rm -f $@ && cp $< $@ bin/%.opt$(EXE): topbin/%_bin.ml $(LINKCMX) $(LIBCOQRUN) @@ -370,23 +387,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 $@ - -# For coqc -COQCCMO:=config/config.cma clib/clib.cma lib/lib.cma toplevel/usage.cmo tools/coqc.cmo - -$(COQC): $(call bestobj, $(COQCCMO)) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(SYSMOD)) - -$(COQCBYTE): $(COQCCMO) - $(SHOW)'OCAMLC -o $@' - $(HIDE)$(call ocamlbyte, $(SYSMOD)) + $(LINKCMO) $(BYTEFLAGS) $< -o $@ ########################################################################### # other tools @@ -502,7 +508,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) @@ -512,7 +518,7 @@ $(FAKEIDEBYTE): $(FAKEIDECMO) | $(IDETOPBYTE) # votour: a small vo explorer (based on the checker) -VOTOURCMO:=clib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo +VOTOURCMO:=clib/cObj.cmo kernel/uint63.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo bin/votour: $(call bestobj, $(VOTOURCMO)) $(SHOW)'OCAMLBEST -o $@' @@ -784,8 +790,7 @@ $(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $( coqlib: theories plugins ifdef QUICK $(SHOW)'COQC -schedule-vio2vo $(NJOBS) theories/**.vio plugins/**.vio' - $(HIDE)$(BOOTCOQC:-compile=-schedule-vio2vo) $(NJOBS) \ - $(THEORIESVO) $(PLUGINSVO) + $(HIDE)$(BOOTCOQC) -schedule-vio2vo $(NJOBS) $(THEORIESVO) $(PLUGINSVO) endif coqlib.timing.diff: theories.timing.diff plugins.timing.diff 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 2dced04967..bd0e19cd00 100644 --- a/Makefile.common +++ b/Makefile.common @@ -32,6 +32,7 @@ COQWCBYTE:=bin/coqwc.byte$(EXE) COQDOC:=bin/coqdoc$(EXE) COQDOCBYTE:=bin/coqdoc.byte$(EXE) COQC:=bin/coqc$(EXE) +COQCOPT:=bin/coqc.opt$(EXE) COQCBYTE:=bin/coqc.byte$(EXE) COQWORKMGR:=bin/coqworkmgr$(EXE) COQWORKMGRBYTE:=bin/coqworkmgr.byte$(EXE) @@ -74,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 @@ -139,7 +142,7 @@ BTAUTOCMO:=plugins/btauto/btauto_plugin.cmo RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ r_syntax_plugin.cmo \ - int31_syntax_plugin.cmo \ + int63_syntax_plugin.cmo \ numeral_notation_plugin.cmo \ string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo diff --git a/Makefile.doc b/Makefile.doc index 7ac710b8c9..912738cd00 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -31,7 +31,7 @@ DVIPS:=dvips HTMLSTYLE:=coqremote # Sphinx-related variables -SPHINXENV:=COQBIN="$(CURDIR)/bin/" +SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(CURDIR)" SPHINXOPTS= -j4 SPHINXWARNERROR ?= 1 ifeq ($(SPHINXWARNERROR),1) @@ -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 ee3e2d6cb7..e3a8a30bc2 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -40,7 +40,7 @@ help: voboot: dune build $(DUNEOPT) @vodeps - dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d + dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d states: voboot dune build $(DUNEOPT) theories/Init/Prelude.vo @@ -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: @@ -2,7 +2,6 @@ [![GitLab][gitlab-badge]][gitlab-link] [![Azure Pipelines][azure-badge]][azure-link] -[![Appveyor][appveyor-badge]][appveyor-link] [![Gitter][gitter-badge]][gitter-link] [![DOI][doi-badge]][doi-link] @@ -12,9 +11,6 @@ [azure-badge]: https://dev.azure.com/coq/coq/_apis/build/status/coq.coq?branchName=master [azure-link]: https://dev.azure.com/coq/coq/_build/latest?definitionId=1?branchName=master -[appveyor-badge]: https://ci.appveyor.com/api/projects/status/eln43k05pa2vm908/branch/master?svg=true -[appveyor-link]: https://ci.appveyor.com/project/coq/coq/branch/master - [gitter-badge]: https://badges.gitter.im/coq/coq.svg [gitter-link]: https://gitter.im/coq/coq @@ -97,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/appveyor.yml b/appveyor.yml deleted file mode 100644 index 7420856214..0000000000 --- a/appveyor.yml +++ /dev/null @@ -1,22 +0,0 @@ -version: '{branch}~{build}' -clone_depth: 10 - -cache: - - C:\cygwin64 -> dev\ci\appveyor.bat, dev\ci\appveyor.sh - -platform: -- x64 - -image: -- Visual Studio 2017 - -environment: - CYGMIRROR: http://ftp.inf.tu-dresden.de/software/windows/cygwin32 - matrix: - - USEOPAM: true - ARCH: 64 - -build_script: -- cmd: 'call %APPVEYOR_BUILD_FOLDER%\dev\ci\appveyor.bat' - -test: off diff --git a/checker/analyze.ml b/checker/analyze.ml index 63324bff20..77e70318dd 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -106,6 +106,7 @@ end type repr = | RInt of int +| RInt63 of Uint63.t | RBlock of (int * int) (* tag × len *) | RString of string | RPointer of int @@ -119,6 +120,7 @@ type data = type obj = | Struct of int * data array (* tag × data *) +| Int63 of Uint63.t (* Primitive integer *) | String of string module type Input = @@ -255,6 +257,28 @@ let input_header64 chan = in (tag, len) +let input_cstring chan : string = + let buff = Buffer.create 17 in + let rec loop () = + match input_char chan with + | '\o000' -> Buffer.contents buff + | c -> Buffer.add_char buff c |> loop + in loop () + +let input_intL chan : int64 = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let m = input_byte chan in + let n = input_byte chan in + let o = input_byte chan in + let p = input_byte chan in + let ( lsl ) x y = Int64.(shift_left (of_int x) y) in + let ( lor ) = Int64.logor in + (i lsl 56) lor (j lsl 48) lor (k lsl 40) lor (l lsl 32) lor + (m lsl 24) lor (n lsl 16) lor (o lsl 8) lor (Int64.of_int p) + let parse_object chan = let data = input_byte chan in if prefix_small_block <= data then @@ -297,6 +321,11 @@ let parse_object chan = let addr = input_int32u chan in for _i = 0 to 15 do ignore (input_byte chan); done; RCode addr + | CODE_CUSTOM -> + begin match input_cstring chan with + | "_j" -> RInt63 (Uint63.of_int64 (input_intL chan)) + | s -> Printf.eprintf "Unhandled custom code: %s" s; assert false + end | CODE_DOUBLE_ARRAY32_LITTLE | CODE_DOUBLE_BIG | CODE_DOUBLE_LITTLE @@ -304,8 +333,7 @@ let parse_object chan = | CODE_DOUBLE_ARRAY8_LITTLE | CODE_DOUBLE_ARRAY32_BIG | CODE_INFIXPOINTER - | CODE_CUSTOM -> - Printf.eprintf "Unhandled code %04x\n%!" data; assert false + -> Printf.eprintf "Unhandled code %04x\n%!" data; assert false let parse chan = let (magic, len, _, _, size) = parse_header chan in @@ -337,6 +365,11 @@ let parse chan = | RCode addr -> let data = Fun addr in data, None + | RInt63 i -> + let data = Ptr !current_object in + let () = LargeArray.set memory !current_object (Int63 i) in + let () = incr current_object in + data, None in let rec fill block off accu = @@ -400,6 +433,7 @@ let instantiate (p, mem) = for i = 0 to len - 1 do let obj = match LargeArray.get mem i with | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) + | Int63 i -> Obj.repr i | String str -> Obj.repr str in LargeArray.set ans i obj @@ -418,6 +452,7 @@ let instantiate (p, mem) = for k = 0 to Array.length blk - 1 do Obj.set_field obj k (get_data blk.(k)) done + | Int63 _ | String _ -> () done; get_data p diff --git a/checker/analyze.mli b/checker/analyze.mli index d7770539df..029f595959 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -1,3 +1,4 @@ +(** Representation of data allocated on the OCaml heap. *) type data = | Int of int | Ptr of int @@ -6,6 +7,7 @@ type data = type obj = | Struct of int * data array (* tag × data *) +| Int63 of Uint63.t (* Primitive integer *) | String of string module LargeArray : diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index c823db956d..4329b2d743 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -28,11 +28,8 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = | PrimRecord data -> Some (Some (Array.map pi1 data)) in let mind_entry_universes = match mb.mind_universes with - | Monomorphic_ind univs -> Monomorphic_ind_entry univs - | Polymorphic_ind auctx -> Polymorphic_ind_entry (AUContext.names auctx, AUContext.repr auctx) - | Cumulative_ind auctx -> - Cumulative_ind_entry (AUContext.names (ACumulativityInfo.univ_context auctx), - ACumulativityInfo.repr auctx) + | Monomorphic univs -> Monomorphic_entry univs + | Polymorphic auctx -> Polymorphic_entry (AUContext.names auctx, AUContext.repr auctx) in let mind_entry_inds = Array.map_to_list (fun ind -> let mind_entry_arity, mind_entry_template = match ind.mind_arity with @@ -64,6 +61,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = mind_entry_params = mb.mind_params_ctxt; mind_entry_inds; mind_entry_universes; + mind_entry_variance = mb.mind_variance; mind_entry_private = mb.mind_private; } @@ -77,6 +75,9 @@ let check_arity env ar1 ar2 = match ar1, ar2 with (* template_level is inferred by indtypes, so functor application can produce a smaller one *) | (RegularArity _ | TemplateArity _), _ -> false +let check_kelim k1 k2 = + List.for_all (fun x -> List.mem_f Sorts.family_equal x k2) k1 + (* Use [eq_ind_chk] because when we rebuild the recargs we have lost the knowledge of who is the canonical version. Try with to see test-suite/coqchk/include.v *) @@ -102,7 +103,7 @@ let check_packet env mind ind check "mind_user_lc" (Array.equal Constr.equal ind.mind_user_lc mind_user_lc); check "mind_nrealargs" Int.(equal ind.mind_nrealargs mind_nrealargs); check "mind_nrealdecls" Int.(equal ind.mind_nrealdecls mind_nrealdecls); - check "mind_kelim" (List.equal Sorts.family_equal ind.mind_kelim mind_kelim); + check "mind_kelim" (check_kelim ind.mind_kelim mind_kelim); check "mind_nf_lc" (Array.equal Constr.equal ind.mind_nf_lc mind_nf_lc); (* NB: here syntactic equality is not just an optimisation, we also @@ -132,7 +133,8 @@ let check_same_record r1 r2 = match r1, r2 with let check_inductive env mind mb = let entry = to_entry mb in let { mind_packets; mind_record; mind_finite; mind_ntypes; mind_hyps; - mind_nparams; mind_nparams_rec; mind_params_ctxt; mind_universes; + mind_nparams; mind_nparams_rec; mind_params_ctxt; + mind_universes; mind_variance; mind_private; mind_typing_flags; } = (* Locally set the oracle for further typechecking *) @@ -154,6 +156,7 @@ let check_inductive env mind mb = check "mind_params_ctxt" (Context.Rel.equal Constr.equal mb.mind_params_ctxt mind_params_ctxt); ignore mind_universes; (* Indtypes did the necessary checking *) + ignore mind_variance; (* Indtypes did the necessary checking *) ignore mind_private; (* passed through Indtypes *) ignore mind_typing_flags; diff --git a/checker/checker.ml b/checker/checker.ml index d97ab5409e..3db7ccdcae 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)); - print_endline (Envars.coqlib ()); - exit 0 + Envars.set_coqlib ~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 diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 086dd17e39..b86d491d72 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -16,8 +16,8 @@ let check_constant_declaration env kn cb = (* [env'] contains De Bruijn universe variables *) let poly, env' = match cb.const_universes with - | Monomorphic_const ctx -> false, push_context_set ~strict:true ctx env - | Polymorphic_const auctx -> + | Monomorphic ctx -> false, push_context_set ~strict:true ctx env + | Polymorphic auctx -> let ctx = Univ.AUContext.repr auctx in let env = push_context ~strict:false ctx env in true, env @@ -66,6 +66,7 @@ let mk_mtb mp sign delta = let rec check_module env mp mb = Flags.if_verbose Feedback.msg_notice (str " checking module: " ++ str (ModPath.to_string mp)); + let env = Modops.add_retroknowledge mb.mod_retroknowledge env in let (_:module_signature) = check_signature env mb.mod_type mb.mod_mp mb.mod_delta in diff --git a/checker/safe_checking.ml b/checker/safe_checking.ml index 6dc2953060..4a64039e30 100644 --- a/checker/safe_checking.ml +++ b/checker/safe_checking.ml @@ -16,6 +16,7 @@ let import senv clib univs digest = let env = Safe_typing.env_of_safe_env senv in let env = push_context_set ~strict:true mb.mod_constraints env in let env = push_context_set ~strict:true univs env in + let env = Modops.add_retroknowledge mb.mod_retroknowledge env in Mod_checking.check_module env mb.mod_mp mb; let (_,senv) = Safe_typing.import clib univs digest senv in senv diff --git a/checker/validate.ml b/checker/validate.ml index b85944f94f..72cf38ebe6 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -86,6 +86,7 @@ let rec val_gen v ctx o = match v with | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o | Dyn -> val_dyn ctx o | Proxy { contents = v } -> val_gen v ctx o + | Uint63 -> val_uint63 ctx o (* Check that an object is a tuple (or a record). vs is an array of value representation for each field. Its size corresponds to the @@ -133,6 +134,10 @@ and val_array v ctx o = val_gen v ctx (Obj.field o i) done +and val_uint63 ctx o = + if not (Uint63.is_uint63 o) then + fail ctx o "not a 63-bit unsigned integer" + let print_frame = function | CtxType t -> t | CtxAnnot t -> t diff --git a/checker/values.ml b/checker/values.ml index 1afe764ca4..66467fa8f5 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -34,6 +34,7 @@ type value = | Dyn | Proxy of value ref + | Uint63 let fix (f : value -> value) : value = let self = ref Any in @@ -111,7 +112,6 @@ let v_variance = v_enum "variance" 3 let v_instance = Annot ("instance", Array v_level) let v_abs_context = v_tuple "abstract_universe_context" [|Array v_name; v_cstrs|] -let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; Array v_variance|] let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|] (** kernel/term *) @@ -151,7 +151,8 @@ let rec v_constr = [|v_caseinfo;v_constr;v_constr;Array v_constr|]; (* Case *) [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) - [|v_proj;v_constr|] (* Proj *) + [|v_proj;v_constr|]; (* Proj *) + [|Uint63|] (* Int *) |]) and v_prec = Tuple ("prec_declaration", @@ -214,21 +215,24 @@ let v_oracle = let v_pol_arity = v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|] +let v_primitive = + v_enum "primitive" 25 + let v_cst_def = v_sum "constant_def" 0 - [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] + [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]; [|v_primitive|]|] let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] -let v_const_univs = v_sum "constant_universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] +let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] let v_cb = v_tuple "constant_body" [|v_section_ctxt; v_cst_def; v_constr; Any; - v_const_univs; + v_univs; Opt v_context_set; v_bool; v_typing_flags|] @@ -271,10 +275,6 @@ let v_record_info = v_sum "record_info" 2 [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_constr |]) |] |] -let v_ind_pack_univs = - v_sum "abstract_inductive_universes" 0 - [|[|v_context_set|]; [|v_abs_context|]; [|v_abs_cum_info|]|] - let v_ind_pack = v_tuple "mutual_inductive_body" [|Array v_one_ind; v_record_info; @@ -284,10 +284,25 @@ let v_ind_pack = v_tuple "mutual_inductive_body" Int; Int; v_rctxt; - v_ind_pack_univs; (* universes *) + v_univs; (* universes *) + Opt (Array v_variance); Opt v_bool; v_typing_flags|] +let v_prim_ind = v_enum "prim_ind" 4 + +let v_prim_type = v_enum "prim_type" 1 + +let v_retro_action = + v_sum "retro_action" 0 [| + [|v_prim_ind; v_ind|]; + [|v_prim_type; v_cst|]; + [|v_cst|]; + |] + +let v_retroknowledge = + v_sum "module_retroknowledge" 1 [|[|List v_retro_action|]|] + let rec v_mae = Sum ("module_alg_expr",0, [|[|v_mp|]; (* SEBident *) @@ -318,7 +333,7 @@ and v_impl = and v_noimpl = v_unit and v_module = Tuple ("module_body", - [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) + [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;v_retroknowledge|]) and v_modtype = Tuple ("module_type_body", [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;v_unit|]) diff --git a/checker/values.mli b/checker/values.mli index 616b69907f..2ab8da1928 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -38,6 +38,8 @@ type value = | Proxy of value ref (** Same as the inner value, used to define recursive types *) + | Uint63 + (** NB: List and Opt have their own constructors to make it easy to define eg [let rec foo = List foo]. *) diff --git a/checker/votour.ml b/checker/votour.ml index 3c088b59b5..36014cde73 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -100,6 +100,7 @@ struct init_size seen (fun n -> fold (succ i) (accu + 1 + n) k) os.(i) in fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size) + | Int63 _ -> k 0 | String s -> let size = 2 + (String.length s / ws) in let () = LargeArray.set !sizes p size in @@ -116,6 +117,7 @@ struct | Ptr p -> match LargeArray.get !memory p with | Struct (tag, os) -> BLOCK (tag, os) + | Int63 _ -> OTHER (* TODO: pretty-print int63 values *) | String s -> STRING s let input ch = @@ -153,6 +155,7 @@ let rec get_name ?(extra=false) = function |Annot (s,v) -> s^"/"^get_name ~extra v |Dyn -> "<dynamic>" | Proxy v -> get_name ~extra !v + | Uint63 -> "Uint63" (** For tuples, its quite handy to display the inner 1st string (if any). Cf. [structure_body] for instance *) @@ -257,6 +260,7 @@ let rec get_children v o pos = match v with end |Fail s -> raise Forbidden | Proxy v -> get_children !v o pos + | Uint63 -> raise Exit let get_children v o pos = try get_children v o pos diff --git a/clib/cList.ml b/clib/cList.ml index aba3e46bd5..524945ef23 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -780,7 +780,7 @@ let share_tails l1 l2 = (** {6 Association lists} *) -let map_assoc f = List.map (fun (x,a) -> (x,f a)) +let map_assoc f = map (fun (x,a) -> (x,f a)) let rec assoc_f f a = function | (x, e) :: xs -> if f a x then e else assoc_f f a xs @@ -979,7 +979,7 @@ let rec duplicates cmp = function and so on if there are more elements in the lists. *) let cartesian op l1 l2 = - map_append (fun x -> List.map (op x) l2) l1 + map_append (fun x -> map (op x) l2) l1 (* [cartesians] is an n-ary cartesian product: it iterates [cartesian] over a list of lists. *) @@ -1006,7 +1006,7 @@ let cartesians_filter op init ll = let rec factorize_left cmp = function | (a,b) :: l -> let al,l' = partition (fun (a',_) -> cmp a a') l in - (a,(b :: List.map snd al)) :: factorize_left cmp l' + (a,(b :: map snd al)) :: factorize_left cmp l' | [] -> [] module Smart = diff --git a/configure.ml b/configure.ml index 6f5ade3b9a..ef38651a4d 100644 --- a/configure.ml +++ b/configure.ml @@ -19,7 +19,7 @@ let vo_magic = 8991 let state_magic = 58991 let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; - "coqc";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] + "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] let verbose = ref false (* for debugging this script *) diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 10b4f9b044..98ea594366 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -16,12 +16,9 @@ We are currently running tests on the following platforms: `./configure`. It should allow complying with this discipline without pain. -- AppVeyor is used to test the compilation of Coq and run the test-suite on - Windows. - - Azure Pipelines is used to test the compilation of Coq and run the - test-suite on Windows and on macOS. It is expected to replace - appveyor eventually. + test-suite on Windows and on macOS. It is expected to be used to build + macOS and Windows packages eventually. You can anticipate the results of most of these tests prior to submitting your PR by running GitLab CI on your private branches. To do so follow these steps: diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat deleted file mode 100644 index 341b875edc..0000000000 --- a/dev/ci/appveyor.bat +++ /dev/null @@ -1,42 +0,0 @@ -REM This script either runs the test suite with OPAM (if USEOPAM is true) or
-REM builds the Coq binary packages for windows (if USEOPAM is false).
-
-if %ARCH% == 32 (
- SET ARCHLONG=i686
- SET CYGROOT=C:\cygwin
- SET SETUP=setup-x86.exe
-)
-
-if %ARCH% == 64 (
- SET ARCHLONG=x86_64
- SET CYGROOT=C:\cygwin64
- SET SETUP=setup-x86_64.exe
-)
-
-SET CYGCACHE=%CYGROOT%\var\cache\setup
-SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/%
-SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/%
-SET DESTCOQ=C:\coq%ARCH%_inst
-SET COQREGTESTING=Y
-
-if %USEOPAM% == false (
- call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
- -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^
- -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
- -addon=bignums -make=N ^
- -setup %CYGROOT%\%SETUP% || GOTO ErrorExit
- copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit
- 7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit
-)
-
-if %USEOPAM% == true (
- %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^
- -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time
- %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh || GOTO ErrorExit
-)
-
-GOTO :EOF
-
-:ErrorExit
- ECHO ERROR %0 failed
- EXIT /b 1
diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8dee465cf4..74e8d3bbaa 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -35,7 +35,7 @@ : "${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq}" : "${unicoq_CI_ARCHIVEURL:=${unicoq_CI_GITURL}/archive}" -: "${mtac2_CI_REF:=master-sync}" +: "${mtac2_CI_REF:=master}" : "${mtac2_CI_GITURL:=https://github.com/Mtac2/Mtac2}" : "${mtac2_CI_ARCHIVEURL:=${mtac2_CI_GITURL}/archive}" 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-common.sh b/dev/ci/ci-common.sh index a5aa54144c..b4d2a9ca4e 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -62,27 +62,30 @@ git_download() { local PROJECT=$1 local DEST="$CI_BUILD_DIR/$PROJECT" + local GITURL_VAR="${PROJECT}_CI_GITURL" + local GITURL="${!GITURL_VAR}" + local REF_VAR="${PROJECT}_CI_REF" + local REF="${!REF_VAR}" if [ -d "$DEST" ]; then echo "Warning: download and unpacking of $PROJECT skipped because $DEST already exists." elif [ "$FORCE_GIT" = "1" ] || [ "$CI" = "" ]; then - local GITURL_VAR="${PROJECT}_CI_GITURL" - local GITURL="${!GITURL_VAR}" - local REF_VAR="${PROJECT}_CI_REF" - local REF="${!REF_VAR}" git clone "$GITURL" "$DEST" cd "$DEST" git checkout "$REF" else # When possible, we download tarballs to reduce bandwidth and latency local ARCHIVEURL_VAR="${PROJECT}_CI_ARCHIVEURL" local ARCHIVEURL="${!ARCHIVEURL_VAR}" - local REF_VAR="${PROJECT}_CI_REF" - local REF="${!REF_VAR}" mkdir -p "$DEST" cd "$DEST" - wget "$ARCHIVEURL/$REF.tar.gz" - tar xvfz "$REF.tar.gz" --strip-components=1 - rm -f "$REF.tar.gz" + local COMMIT=$(git ls-remote "$GITURL" "refs/heads/$REF" | cut -f 1) + if [[ "$COMMIT" == "" ]]; then + # $REF must have been a tag or hash, not a branch + COMMIT="$REF" + fi + wget "$ARCHIVEURL/$COMMIT.tar.gz" + tar xvfz "$COMMIT.tar.gz" --strip-components=1 + rm -f "$COMMIT.tar.gz" fi } 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/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index baf470e021..43278c37b1 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-12-14-V1" +# CACHEKEY: "bionic_coq-V2019-02-17-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -38,7 +38,7 @@ ENV COMPILER="4.05.0" # `num` does not have a version number as the right version to install varies # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.3.0" \ - CI_OPAM="menhir.20180530 elpi.1.1.0 ocamlgraph.1.8.8" + CI_OPAM="menhir.20181113 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" @@ -56,9 +56,6 @@ ENV COMPILER_EDGE="4.07.1" \ COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ BASE_OPAM_EDGE="dune-release.1.1.0" -RUN opam switch create $COMPILER_EDGE && eval $(opam env) && \ - opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM_EDGE - # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ 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/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/ci/user-overlays/09439-sep-variance.sh b/dev/ci/user-overlays/09439-sep-variance.sh new file mode 100644 index 0000000000..cca85a2f68 --- /dev/null +++ b/dev/ci/user-overlays/09439-sep-variance.sh @@ -0,0 +1,14 @@ + +if [ "$CI_PULL_REQUEST" = "9439" ] || [ "$CI_BRANCH" = "sep-variance" ]; then + elpi_CI_REF=sep-variance + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=sep-variance + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + mtac2_CI_REF=sep-variance + mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 + + paramcoq_CI_REF=sep-variance + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq +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/profiling.txt b/dev/doc/profiling.txt index 29e87df6b8..8455d13377 100644 --- a/dev/doc/profiling.txt +++ b/dev/doc/profiling.txt @@ -10,7 +10,7 @@ In Coq source folder: opam switch 4.05.0+trunk+fp ./configure -local -debug make -perf record -g bin/coqtop -compile file.v +perf record -g bin/coqc file.v perf report -g fractal,callee --no-children To profile only part of a file, first load it using @@ -96,7 +96,7 @@ https://github.com/mshinwell/opam-repo-dev ### For memory dump: -CAMLRUNPARAM=T,mj bin/coqtop -compile file.v +CAMLRUNPARAM=T,mj bin/coqc file.v In another terminal: @@ -112,7 +112,7 @@ number of objects and third is the place where the objects where allocated. ### For complete memory graph: -CAMLRUNPARAM=T,gr bin/coqtop -compile file.v +CAMLRUNPARAM=T,gr bin/coqc file.v In another terminal: 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/include b/dev/include index b982f4c9fa..c5de83b900 100644 --- a/dev/include +++ b/dev/include @@ -41,8 +41,6 @@ #install_printer (* univ context *) ppuniverse_context;; #install_printer (* univ context future *) ppuniverse_context_future;; #install_printer (* univ context set *) ppuniverse_context_set;; -#install_printer (* cumulativity info *) ppcumulativity_info;; -#install_printer (* abstract cumulativity info *) ppabstract_cumulativity_info;; #install_printer (* univ set *) ppuniverse_set;; #install_printer (* univ instance *) ppuniverse_instance;; #install_printer (* univ subst *) ppuniverse_subst;; diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index f588c20d02..2e8a7455de 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -9,10 +9,17 @@ CODE=0 -# We assume that all merge commits are from the main branch +if [[ $(git log -n 1 --pretty='format:%s') == "Bot merge"* ]]; then + # The FIRST parent of bot merges is from the PR, the second is + # current master + head=$(git rev-parse HEAD~) +else + head=$(git rev-parse HEAD) +fi + +# We assume that all non-bot merge commits are from the main branch # For Coq it is extremely rare for this assumption to be broken -read -r base < <(git log -n 1 --merges --pretty='format:%H') -head=$(git rev-parse HEAD) +read -r base < <(git log -n 1 --merges --pretty='format:%H' "$head") dev/lint-commits.sh "$base" "$head" || CODE=1 diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index 72e2930386..813ad71be9 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -143,7 +143,7 @@ fi # Sanity check: PR has an outdated version of CI BASE_COMMIT=$(echo "$PRDATA" | jq -r '.base.sha') -CI_FILES=(".gitlab-ci.yml" "appveyor.yml") +CI_FILES=(".gitlab-ci.yml" "azure-pipelines.yml") if ! git diff --quiet "$BASE_COMMIT" "$LOCAL_BRANCH_COMMIT" -- "${CI_FILES[@]}" then diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index eab88c7290..a6ecec7e33 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -70,8 +70,6 @@ install_printer Top_printers.ppevar_universe_context install_printer Top_printers.ppconstraints install_printer Top_printers.ppuniverseconstraints install_printer Top_printers.ppuniverse_context_future -install_printer Top_printers.ppcumulativity_info -install_printer Top_printers.ppabstract_cumulativity_info install_printer Top_printers.ppuniverses install_printer Top_printers.ppnamedcontextval install_printer Top_printers.ppenv diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 8f207d1e0a..a3d2f33216 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -222,8 +222,6 @@ let ppuniverseconstraints c = pp (UnivProblem.Set.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx -let ppcumulativity_info c = pp (Univ.pr_cumulativity_info Univ.Level.pr c) -let ppabstract_cumulativity_info c = pp (Univ.pr_abstract_cumulativity_info Univ.Level.pr c) let ppuniverses u = pp (UGraph.pr_universes Level.pr u) let ppnamedcontextval e = let env = Global.env () in @@ -292,6 +290,8 @@ let constr_display csr = ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"," ^(array_display bl)^")" + | Int i -> + "Int("^(Uint63.to_string i)^")" and array_display v = "[|"^ @@ -421,6 +421,8 @@ let print_pure_constr csr = print_cut(); done in print_string"{"; print_fix (); print_string"}" + | Int i -> + print_string ("Int("^(Uint63.to_string i)^")") and box_display c = open_hovbox 1; term_display c; close_box() diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 5eac3e2b9c..cb32d2294c 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -145,8 +145,6 @@ val ppevar_universe_context : UState.t -> unit val ppconstraints : Univ.Constraint.t -> unit val ppuniverseconstraints : UnivProblem.Set.t -> unit val ppuniverse_context_future : Univ.UContext.t Future.computation -> unit -val ppcumulativity_info : Univ.CumulativityInfo.t -> unit -val ppabstract_cumulativity_info : Univ.ACumulativityInfo.t -> unit val ppuniverses : UGraph.t -> unit val ppnamedcontextval : Environ.named_context_val -> unit @@ -161,6 +159,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/dev/vm_printers.ml b/dev/vm_printers.ml index ea126e2756..dc30793a6e 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -82,6 +82,7 @@ and ppwhd whd = | Vcofix _ -> print_string "cofix" | Vconstr_const i -> print_string "C(";print_int i;print_string")" | Vconstr_block b -> ppvblock b + | Vint64 i -> printf "int64(%LiL)" i | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s 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) @@ -13,7 +13,7 @@ (source_tree tools) (env_var SPHINXWARNOPT)) (action - (run sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) + (run env COQLIB=%{project_root} sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) (alias (name refman-html) diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.ml b/doc/plugin_tutorial/tuto1/src/simple_check.ml index 1f636c531a..2949adde73 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_check.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_check.ml @@ -6,7 +6,7 @@ let simple_check1 value_with_constraints = (* The point of renaming is to make sure the bound names printed by Check can be re-used in `apply with` tactics that use bound names to refer to arguments. *) - let j = Termops.on_judgment EConstr.of_constr + let j = Environ.on_judgment EConstr.of_constr (Arguments_renaming.rename_typing (Global.env()) (EConstr.to_constr evd evalue)) in let {Environ.uj_type=x}=j in x diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index e4f078c1d6..fac0035de1 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -214,17 +214,17 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo Example:: - .. coqtop:: in reset undo + .. coqtop:: in reset Print nat. Definition a := 1. The blank line after the directive is required. If you begin a proof, - include an ``Abort`` afterwards to reset coqtop for the next example. + use the ``abort`` option to reset coqtop for the next example. Here is a list of permissible options: - - Display options + - Display options (choose exactly one) - ``all``: Display input and output - ``in``: Display only input @@ -234,8 +234,9 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo - 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 + - ``fail``: Don't die if a command fails + - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) + - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) ``coqtop``\ 's state is preserved across consecutive ``.. coqtop::`` blocks of the same document (``coqrst`` creates a single ``coqtop`` process per @@ -509,7 +510,7 @@ Tips and tricks Nested lemmas ------------- -The ``.. coqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas:: +The ``.. coqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas (which by default results in a failure):: .. coqtop:: all @@ -519,7 +520,7 @@ The ``.. coqtop::`` directive does *not* reset Coq after running its contents. Lemma l2: 2 + 2 <> 1. -Add either ``undo`` to the first block or ``reset`` to the second block to avoid nesting lemmas. +Add either ``abort`` to the first block or ``reset`` to the second block to avoid nesting lemmas. Abbreviations and macros ------------------------ diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index 81f25bf274..78803a927f 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -265,7 +265,7 @@ Tips and tricks Nested lemmas ------------- -The ``.. coqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas:: +The ``.. coqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas (which by default results in a failure):: .. coqtop:: all @@ -275,7 +275,7 @@ The ``.. coqtop::`` directive does *not* reset Coq after running its contents. Lemma l2: 2 + 2 <> 1. -Add either ``undo`` to the first block or ``reset`` to the second block to avoid nesting lemmas. +Add either ``abort`` to the first block or ``reset`` to the second block to avoid nesting lemmas. Abbreviations and macros ------------------------ diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 7b8a86d1ab..3ec6c118af 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. @@ -291,7 +295,7 @@ By default, implicit arguments are omitted in patterns. So we write: end). But the possibility to use all the arguments is given by “``@``” implicit -explicitations (as for terms 2.7.11). +explicitations (as for terms, see :ref:`explicit-applications`). .. coqtop:: all @@ -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..b474c51f17 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,12 +618,16 @@ 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) : Proper (pointwise_relation A iff ==> iff) (@all A). -.. coqtop:: all +.. coqtop:: all abort Proof. simpl_relation. @@ -650,7 +649,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 e799677c59..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 -> @@ -145,7 +145,7 @@ weakness, the :tacn:`lia` tactic is using recursively a combination of: + linear *positivstellensatz* refutations; + cutting plane proofs; + case split. - + Cutting plane proofs ~~~~~~~~~~~~~~~~~~~~~~ @@ -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. @@ -250,6 +251,16 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. .. [#] Support for :g:`nat` and :g:`N` is obtained by pre-processing the goal with the ``zify`` tactic. +.. [#] Support for :g:`Z.div` and :g:`Z.modulo` may be obtained by + pre-processing the goal with the ``Z.div_mod_to_equations`` tactic (you may + need to manually run ``zify`` first). +.. [#] Support for :g:`Z.quot` and :g:`Z.rem` may be obtained by pre-processing + the goal with the ``Z.quot_rem_to_equations`` tactic (you may need to manually + run ``zify`` first). +.. [#] Note that support for :g:`Z.div`, :g:`Z.modulo`, :g:`Z.quot`, and + :g:`Z.rem` may be simultaneously obtained by pre-processing the goal with the + ``Z.to_euclidean_division_equations`` tactic (you may need to manually run + ``zify`` first). .. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#] Variants deal with equalities and strict inequalities. .. [#] In practice, the oracle might fail to produce such a refutation. diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 8b7214e2ab..903ee115c9 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -52,7 +52,7 @@ in interactive mode. It is not strictly mandatory in batch mode if it is not the first time the file is compiled and if the file itself did not change. When the proof does not begin with Proof using, the system records in an -auxiliary file, produced along with the `.vo` file, the list of section +auxiliary file, produced along with the ``.vo`` file, the list of section variables used. Automatic suggestion of proof annotations @@ -154,22 +154,22 @@ to a worker process. The threshold can be configured with Batch mode --------------- -When |Coq| is used as a batch compiler by running `coqc` or `coqtop` --compile, it produces a `.vo` file for each `.v` file. A `.vo` file contains, -among other things, theorem statements and proofs. Hence to produce a -.vo |Coq| need to process all the proofs of the `.v` file. +When |Coq| is used as a batch compiler by running ``coqc``, it produces +a ``.vo`` file for each ``.v`` file. A ``.vo`` file contains, among other +things, theorem statements and proofs. Hence to produce a .vo |Coq| +need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a -compiled file (like the `.vo` one) that can be loaded by ``Require`` from the +compiled file (like the ``.vo`` one) that can be loaded by ``Require`` from the generation and checking of the proof objects. The ``-quick`` flag can be -passed to `coqc` or `coqtop` to produce, quickly, `.vio` files. -Alternatively, when using a Makefile produced by `coq_makefile`, +passed to ``coqc`` or ``coqtop`` to produce, quickly, ``.vio`` files. +Alternatively, when using a Makefile produced by ``coq_makefile``, the ``quick`` target can be used to compile all files using the ``-quick`` flag. -A `.vio` file can be loaded using ``Require`` exactly as a `.vo` file but +A ``.vio`` file can be loaded using ``Require`` exactly as a ``.vo`` file but proofs will not be available (the Print command produces an error). Moreover, some universe constraints might be missing, so universes -inconsistencies might go unnoticed. A `.vio` file does not contain proof +inconsistencies might go unnoticed. A ``.vio`` file does not contain proof objects, but proof tasks, i.e. what a worker process can transform into a proof object. @@ -177,52 +177,52 @@ Compiling a set of files with the ``-quick`` flag allows one to work, interactively, on any file without waiting for all the proofs to be checked. -When working interactively, one can fully check all the `.v` files by -running `coqc` as usual. +When working interactively, one can fully check all the ``.v`` files by +running ``coqc`` as usual. -Alternatively one can turn each `.vio` into the corresponding `.vo`. All +Alternatively one can turn each ``.vio`` into the corresponding ``.vo``. All .vio files can be processed in parallel, hence this alternative might be faster. The command ``coqtop -schedule-vio2vo 2 a b c`` can be used to -obtain a good scheduling for two workers to produce `a.vo`, `b.vo`, and -`c.vo`. When using a Makefile produced by `coq_makefile`, the ``vio2vo`` target -can be used for that purpose. Variable `J` should be set to the number +obtain a good scheduling for two workers to produce ``a.vo``, ``b.vo``, and +``c.vo``. When using a Makefile produced by ``coq_makefile``, the ``vio2vo`` target +can be used for that purpose. Variable ``J`` should be set to the number of workers, e.g. ``make vio2vo J=2``. The only caveat is that, while the -.vo files obtained from `.vio` files are complete (they contain all proof +.vo files obtained from ``.vio`` files are complete (they contain all proof terms and universe constraints), the satisfiability of all universe constraints has not been checked globally (they are checked to be consistent for every single proof). Constraints will be checked when -these `.vo` files are (recursively) loaded with ``Require``. +these ``.vo`` files are (recursively) loaded with ``Require``. There is an extra, possibly even faster, alternative: just check the -proof tasks stored in `.vio` files without producing the `.vo` files. This +proof tasks stored in ``.vio`` files without producing the ``.vo`` files. This is possibly faster because all the proof tasks are independent, hence one can further partition the job to be done between workers. The ``coqtop -schedule-vio-checking 6 a b c`` command can be used to obtain a -good scheduling for 6 workers to check all the proof tasks of `a.vio`, -`b.vio`, and `c.vio`. Auxiliary files are used to predict how long a proof +good scheduling for 6 workers to check all the proof tasks of ``a.vio``, +``b.vio``, and ``c.vio``. Auxiliary files are used to predict how long a proof task will take, assuming it will take the same amount of time it took last time. When using a Makefile produced by coq_makefile, the -``checkproofs`` target can be used to check all `.vio` files. Variable `J` +``checkproofs`` target can be used to check all ``.vio`` files. Variable ``J`` should be set to the number of workers, e.g. ``make checkproofs J=6``. As -when converting `.vio` files to `.vo` files, universe constraints are not +when converting ``.vio`` files to ``.vo`` files, universe constraints are not checked to be globally consistent. Hence this compilation mode is only useful for quick regression testing and on developments not making -heavy use of the `Type` hierarchy. +heavy use of the ``Type`` hierarchy. Limiting the number of parallel workers -------------------------------------------- Many |Coq| processes may run on the same computer, and each of them may -start many additional worker processes. The `coqworkmgr` utility lets +start many additional worker processes. The ``coqworkmgr`` utility lets one limit the number of workers, globally. The utility accepts the ``-j`` argument to specify the maximum number of -workers (defaults to 2). `coqworkmgr` automatically starts in the +workers (defaults to 2). ``coqworkmgr`` automatically starts in the background and prints an environment variable assignment like ``COQWORKMGR_SOCKET=localhost:45634``. The user must set this variable in all the shells from which |Coq| processes will be started. If one uses just one terminal running the bash shell, then ``export ‘coqworkmgr -j 4‘`` will do the job. -After that, all |Coq| processes, e.g. `coqide` and `coqc`, will respect the +After that, all |Coq| processes, e.g. ``coqide`` and ``coqc``, will respect the limit, globally. 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/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 43d302114e..c7ea7e326f 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -44,25 +44,20 @@ Leibniz equality on some type. An example implementation is: eqb_leibniz x y H := match x, y return x = y with tt, tt => eq_refl tt end }. -If one does not give all the members in the Instance declaration, Coq -enters the proof-mode and the user is asked to build inhabitants of -the remaining fields, e.g.: +Using :cmd:`Program Instance`, if one does not give all the members in +the Instance declaration, Coq generates obligations for the remaining +fields, e.g.: .. coqtop:: in - Instance eq_bool : EqDec bool := + Require Import Program.Tactics. + Program Instance eq_bool : EqDec bool := { eqb x y := if x then y else negb y }. .. coqtop:: all - Proof. intros x y H. - -.. coqtop:: all - - destruct x ; destruct y ; (discriminate || reflexivity). - -.. coqtop:: all - + Next Obligation. + destruct x ; destruct y ; (discriminate || reflexivity). Defined. One has to take care that the transparency of every field is @@ -131,14 +126,14 @@ the constraints as a binding context before the instance, e.g.: .. coqtop:: in - Instance prod_eqb `(EA : EqDec A, EB : EqDec B) : EqDec (A * B) := + Program Instance prod_eqb `(EA : EqDec A, EB : EqDec B) : EqDec (A * B) := { eqb x y := match x, y with | (la, ra), (lb, rb) => andb (eqb la lb) (eqb ra rb) end }. .. coqtop:: none - Abort. + Admit Obligations. These instances are used just as well as lemmas in the instance hint database. @@ -157,13 +152,13 @@ vernacular, except it accepts any binding context as argument. For example: Context `{EA : EqDec A}. - Global Instance option_eqb : EqDec (option A) := + Global Program Instance option_eqb : EqDec (option A) := { eqb x y := match x, y with | Some x, Some y => eqb x y | None, None => true | _, _ => false end }. - Admitted. + Admit Obligations. End EqDec_defs. @@ -564,12 +559,12 @@ Settings This flag allows to switch the behavior of instance declarations made through the Instance command. - + When it is on (the default), instances that have unsolved holes in + + When it is off (the default), they fail with an error instead. + + + When it is on, instances that have unsolved holes in their proof-term silently open the proof mode with the remaining obligations to prove. - + When it is off, they fail with an error instead. - Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ 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..48ad60c6dd 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 @@ -142,6 +142,7 @@ exclude_patterns = [ 'introduction.rst', 'refman-preamble.rst', 'README.rst', + 'README.gen.rst', 'README.template.rst' ] + ["*.{}.rst".format(fmt) for fmt in SUPPORTED_FORMATS] diff --git a/doc/sphinx/dune b/doc/sphinx/dune index fff025c919..353d58c676 100644 --- a/doc/sphinx/dune +++ b/doc/sphinx/dune @@ -1 +1,8 @@ (dirs :standard _static) + +(rule (targets README.gen.rst) + (deps (source_tree ../tools/coqrst) README.template.rst) + (action (run ../tools/coqrst/regen_readme.py %{targets}))) + +(alias (name refman-html) + (action (diff README.rst README.gen.rst))) diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 775fc76cfe..e05df65c63 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -20,9 +20,9 @@ There are types for functions (or programs), there are atomic types (especially datatypes)... but also types for proofs and types for the types themselves. Especially, any object handled in the formalism must belong to a type. For instance, universal quantification is relative -to a type and takes the form "*for all x of type T, P* ". The expression -“x of type T” is written :g:`x:T`. Informally, :g:`x:T` can be thought as -“x belongs to T”. +to a type and takes the form “*for all x of type* :math:`T`, :math:`P`”. The expression +“:math:`x` *of type* :math:`T`” is written “:math:`x:T`”. Informally, “:math:`x:T`” can be thought as +“:math:`x` *belongs to* :math:`T`”. The types of types are *sorts*. Types and sorts are themselves terms so that terms, types and sorts are all components of a common @@ -51,7 +51,7 @@ function types over these data types. Consequently they also have a type. Because assuming simply that :math:`\Set` has type :math:`\Set` leads to an inconsistent theory :cite:`Coq86`, the language of |Cic| has infinitely many sorts. There are, in addition to :math:`\Set` and :math:`\Prop` -a hierarchy of universes :math:`\Type(i)` for any integer :math:`i`. +a hierarchy of universes :math:`\Type(i)` for any integer :math:`i ≥ 1`. Like :math:`\Set`, all of the sorts :math:`\Type(i)` contain small sets such as booleans, natural numbers, as well as products, subsets and function @@ -132,7 +132,7 @@ the following rules. which maps elements of :math:`T` to the expression :math:`u`. #. if :math:`t` and :math:`u` are terms then :math:`(t~u)` is a term (:g:`t u` in |Coq| concrete - syntax). The term :math:`(t~u)` reads as “t applied to u”. + syntax). The term :math:`(t~u)` reads as “:math:`t` applied to :math:`u`”. #. if :math:`x` is a variable, and :math:`t`, :math:`T` and :math:`u` are terms then :math:`\letin{x}{t:T}{u}` is a term which denotes the term :math:`u` where the variable :math:`x` is locally bound @@ -216,7 +216,7 @@ For the rest of the chapter, :math:`Γ::(y:T)` denotes the local context :math:` enriched with the local assumption :math:`y:T`. Similarly, :math:`Γ::(y:=t:T)` denotes the local context :math:`Γ` enriched with the local definition :math:`(y:=t:T)`. The notation :math:`[]` denotes the empty local context. By :math:`Γ_1 ; Γ_2` we mean -concatenation of the local context :math:`Γ_1` and the local context :math:`Γ_2` . +concatenation of the local context :math:`Γ_1` and the local context :math:`Γ_2`. .. _Global-environment: @@ -542,10 +542,10 @@ exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangle … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and :math:`u_2` are identical, or they are convertible up to η-expansion, i.e. :math:`u_1` is :math:`λ x:T.~u_1'` and :math:`u_2 x` is -recursively convertible to :math:`u_1'` , or, symmetrically, +recursively convertible to :math:`u_1'`, or, symmetrically, :math:`u_2` is :math:`λx:T.~u_2'` and :math:`u_1 x` is recursively convertible to :math:`u_2'`. We then write -:math:`E[Γ] ⊢ t_1 =_{βδιζη} t_2` . +:math:`E[Γ] ⊢ t_1 =_{βδιζη} t_2`. Apart from this we consider two instances of polymorphic and cumulative (see Chapter :ref:`polymorphicuniverses`) inductive types @@ -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). @@ -793,7 +793,7 @@ Types of inductive objects ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have to give the type of constants in a global environment :math:`E` which -contains an inductive declaration. +contains an inductive definition. .. inference:: Ind @@ -833,7 +833,7 @@ contains an inductive declaration. Well-formed inductive definitions ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot accept any inductive declaration because some of them lead +We cannot accept any inductive definition because some of them lead to inconsistent systems. We restrict ourselves to definitions which satisfy a syntactic criterion of positivity. Before giving the formal rules, we need a few definitions: @@ -898,7 +898,7 @@ cases: + :math:`T` converts to :math:`∀ x:U,~V` and :math:`X` does not occur in type :math:`U` but occurs strictly positively in type :math:`V` + :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an - inductive declaration of the form + inductive definition of the form .. math:: \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} @@ -914,7 +914,7 @@ Nested Positivity The type of constructor :math:`T` of :math:`I` *satisfies the nested positivity condition* for a constant :math:`X` in the following cases: -+ :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive definition with :math:`m` ++ :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive type with :math:`m` parameters and :math:`X` does not occur in any :math:`u_i` + :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the nested positivity condition for :math:`X` @@ -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) @@ -980,8 +980,8 @@ provided that the following side conditions hold: One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its constructors which will always be satisfied for the impredicative -sort :math:`\Prop` but may fail to define inductive definition on sort :math:`\Set` and -generate constraints between universes for inductive definitions in +sort :math:`\Prop` but may fail to define inductive type on sort :math:`\Set` and +generate constraints between universes for inductive types in the Type hierarchy. @@ -1061,9 +1061,9 @@ longest prefix of parameters such that the :math:`m` first arguments of all occurrences of all :math:`I_j` in all :math:`C_k` (even the occurrences in the hypotheses of :math:`C_k`) are exactly applied to :math:`p_1 … p_m` (:math:`m` is the number of *recursively uniform parameters* and the :math:`p−m` remaining parameters -are the *recursively non-uniform parameters*). Let :math:`q_1 , …, q_r` , with +are the *recursively non-uniform parameters*). Let :math:`q_1 , …, q_r`, with :math:`0≤ r≤ m`, be a (possibly) partial instantiation of the recursively -uniform parameters of :math:`Γ_P` . We have: +uniform parameters of :math:`Γ_P`. We have: .. inference:: Ind-Family @@ -1082,7 +1082,7 @@ provided that the following side conditions hold: + :math:`Γ_{P′}` is the context obtained from :math:`Γ_P` by replacing each :math:`P_l` that is an arity with :math:`P_l'` for :math:`1≤ l ≤ r` (notice that :math:`P_l` arity implies :math:`P_l'` arity since :math:`E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}`); - + there are sorts :math:`s_i` , for :math:`1 ≤ i ≤ k` such that, for + + there are sorts :math:`s_i`, for :math:`1 ≤ i ≤ k` such that, for :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; + the sorts :math:`s_i` are such that all eliminations, to @@ -1213,7 +1213,7 @@ recognized implicitly and taken into account in the conversion rule. From the logical point of view, we have built a type family by giving a set of constructors. We want to capture the fact that we do not have any other way to build an object in this type. So when trying to prove -a property about an object :math:`m` in an inductive definition it is enough +a property about an object :math:`m` in an inductive type it is enough to enumerate all the cases where :math:`m` starts with a different constructor. @@ -1319,7 +1319,7 @@ and :math:`I:A` and :math:`λ a x . P : B` then by :math:`[I:A|B]` we mean that **Notations.** The :math:`[I:A|B]` is defined as the smallest relation satisfying the following rules: We write :math:`[I|B]` for :math:`[I:A|B]` where :math:`A` is the type of :math:`I`. -The case of inductive definitions in sorts :math:`\Set` or :math:`\Type` is simple. +The case of inductive types in sorts :math:`\Set` or :math:`\Type` is simple. There is no restriction on the sort of the predicate to be eliminated. .. inference:: Prod @@ -1395,7 +1395,7 @@ proof-irrelevance property which is sometimes a useful axiom: Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. -The elimination of an inductive definition of type :math:`\Prop` on a predicate +The elimination of an inductive type of sort :math:`\Prop` on a predicate :math:`P` of type :math:`I→ \Type` leads to a paradox when applied to impredicative inductive definition like the second-order existential quantifier :g:`exProp` defined above, because it gives access to the two projections on @@ -1440,7 +1440,7 @@ elimination on any sort is allowed. **Type of branches.** Let :math:`c` be a term of type :math:`C`, we assume :math:`C` is a type of constructor for an inductive type :math:`I`. Let :math:`P` be a term that represents the property to be -proved. We assume :math:`r` is the number of parameters and :math:`p` is the number of +proved. We assume :math:`r` is the number of parameters and :math:`s` is the number of arguments. We define a new type :math:`\{c:C\}^P` which represents the type of the branch @@ -1448,7 +1448,7 @@ corresponding to the :math:`c:C` constructor. .. math:: \begin{array}{ll} - \{c:(I~p_1\ldots p_r\ t_1 \ldots t_p)\}^P &\equiv (P~t_1\ldots ~t_p~c) \\ + \{c:(I~q_1\ldots q_r\ t_1 \ldots t_s)\}^P &\equiv (P~t_1\ldots ~t_s~c) \\ \{c:∀ x:T,~C\}^P &\equiv ∀ x:T,~\{(c~x):C\}^P \end{array} @@ -1495,7 +1495,7 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: & ≡∀ n:\nat,~∀ l:\List~\nat,~(P~(\cons~\nat~n~l)). \end{array} - Given some :math:`P` then :math:`\{(\Nil~\nat)\}^P` represents the expected type of :math:`f_1` , + Given some :math:`P` then :math:`\{(\Nil~\nat)\}^P` represents the expected type of :math:`f_1`, and :math:`\{(\cons~\nat)\}^P` represents the expected type of :math:`f_2`. @@ -1627,15 +1627,15 @@ Before accepting a fixpoint definition as being correctly typed, we check that the definition is “guarded”. A precise analysis of this notion can be found in :cite:`Gim94`. The first stage is to precise on which argument the fixpoint will be decreasing. The type of this argument -should be an inductive definition. For doing this, the syntax of +should be an inductive type. For doing this, the syntax of fixpoints is extended and becomes .. math:: - \Fix~f_i\{f_1/k_1 :A_1':=t_1' … f_n/k_n :A_n':=t_n'\} + \Fix~f_i\{f_1/k_1 :A_1:=t_1 … f_n/k_n :A_n:=t_n\} where :math:`k_i` are positive integers. Each :math:`k_i` represents the index of -parameter of :math:`f_i` , on which :math:`f_i` is decreasing. Each :math:`A_i` should be a +parameter of :math:`f_i`, on which :math:`f_i` is decreasing. Each :math:`A_i` should be a type (reducible to a term) starting with at least :math:`k_i` products :math:`∀ y_1 :B_1 ,~… ∀ y_{k_i} :B_{k_i} ,~A_i'` and :math:`B_{k_i}` an inductive type. @@ -1647,7 +1647,7 @@ The definition of being structurally smaller is a bit technical. One needs first to define the notion of *recursive arguments of a constructor*. For an inductive definition :math:`\ind{r}{Γ_I}{Γ_C}`, if the type of a constructor :math:`c` has the form -:math:`∀ p_1 :P_1 ,~… ∀ p_r :P_r,~∀ x_1:T_1,~… ∀ x_r :T_r,~(I_j~p_1 … p_r~t_1 … t_s )`, +:math:`∀ p_1 :P_1 ,~… ∀ p_r :P_r,~∀ x_1:T_1,~… ∀ x_m :T_m,~(I_j~p_1 … p_r~t_1 … t_s )`, then the recursive arguments will correspond to :math:`T_i` in which one of the :math:`I_l` occurs. @@ -1660,13 +1660,13 @@ Given a variable :math:`y` of an inductively defined type in a declaration + :math:`(t~u)` and :math:`λ x:U .~t` when :math:`t` is structurally smaller than :math:`y`. + :math:`\case(c,P,f_1 … f_n)` when each :math:`f_i` is structurally smaller than :math:`y`. If :math:`c` is :math:`y` or is structurally smaller than :math:`y`, its type is an inductive - definition :math:`I_p` part of the inductive declaration corresponding to :math:`y`. + type :math:`I_p` part of the inductive definition corresponding to :math:`y`. Each :math:`f_i` corresponds to a type of constructor - :math:`C_q ≡ ∀ p_1 :P_1 ,~…,∀ p_r :P_r ,~∀ y_1 :B_1 ,~… ∀ y_k :B_k ,~(I~a_1 … a_k )` - and can consequently be written :math:`λ y_1 :B_1' .~… λ y_k :B_k'.~g_i`. (:math:`B_i'` is + :math:`C_q ≡ ∀ p_1 :P_1 ,~…,∀ p_r :P_r ,~∀ y_1 :B_1 ,~… ∀ y_m :B_m ,~(I_p~p_1 … p_r~t_1 … t_s )` + and can consequently be written :math:`λ y_1 :B_1' .~… λ y_m :B_m'.~g_i`. (:math:`B_i'` is obtained from :math:`B_i` by substituting parameters for variables) the variables :math:`y_j` occurring in :math:`g_i` corresponding to recursive arguments :math:`B_i` (the - ones in which one of the :math:`I_l` occurs) are structurally smaller than y. + ones in which one of the :math:`I_l` occurs) are structurally smaller than :math:`y`. The following definitions are correct, we enter them using the :cmd:`Fixpoint` @@ -1749,7 +1749,7 @@ One can modify a global declaration by generalizing it over a previously assumed constant :math:`c`. For doing that, we need to modify the reference to the global declaration in the subsequent global environment and local context by explicitly applying this constant to -the constant :math:`c'`. +the constant :math:`c`. Below, if :math:`Γ` is a context of the form :math:`[y_1 :A_1 ;~…;~y_n :A_n]`, we write :math:`∀x:U,~\subst{Γ}{c}{x}` to mean @@ -1779,7 +1779,7 @@ and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution {\subst{Γ}{|Γ_I ;Γ_C|}{|Γ_I ;Γ_C | c}}} One can similarly modify a global declaration by generalizing it over -a previously defined constant :math:`c′`. Below, if :math:`Γ` is a context of the form +a previously defined constant :math:`c`. Below, if :math:`Γ` is a context of the form :math:`[y_1 :A_1 ;~…;~y_n :A_n]`, we write :math:`\subst{Γ}{c}{u}` to mean :math:`[y_1 :\subst{A_1} {c}{u};~…;~y_n:\subst{A_n} {c}{u}]`. diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index b82b3b0e80..c1eab8a970 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. @@ -264,7 +264,7 @@ arguments. The theorem are names ``f_equal2``, ``f_equal3``, ``f_equal4`` and ``f_equal5``. For instance ``f_equal3`` is defined the following way. -.. coqtop:: in +.. coqtop:: in abort Theorem f_equal3 : forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) @@ -465,7 +465,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 +506,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 +531,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 +558,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 +610,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 +625,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 +652,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 +681,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 +715,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..25f983ac1e 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -247,11 +247,6 @@ Primitive Projections printing time (even though they are absent in the actual AST manipulated by the kernel). -.. flag:: Printing Primitive Projection Compatibility - - This compatibility option (on by default) governs the - printing of pattern matching over primitive records. - Primitive Record Types ++++++++++++++++++++++ @@ -297,8 +292,8 @@ the folded version delta-reduces to the unfolded version. This allows to precisely mimic the usual unfolding rules of constants. Projections obey the usual ``simpl`` flags of the ``Arguments`` command in particular. There is currently no way to input unfolded primitive projections at the -user-level, and one must use the :flag:`Printing Primitive Projection Compatibility` -to display unfolded primitive projections as matches and distinguish them from folded ones. +user-level, and there is no way to display unfolded projections differently +from folded ones. Compatibility Projections and :g:`match` @@ -1924,9 +1919,10 @@ applied to an unknown structure instance (an implicit argument) and a value. The complete documentation of canonical structures can be found in :ref:`canonicalstructures`; here only a simple example is given. -.. cmd:: Canonical Structure @qualid +.. cmd:: Canonical {? Structure } @qualid - This command declares :token:`qualid` as a canonical structure. + This command declares :token:`qualid` as a canonical instance of a + structure (a record). Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the structure :g:`struct` of which the fields are |x_1|, …, |x_n|. @@ -1961,12 +1957,12 @@ in :ref:`canonicalstructures`; here only a simple example is given. Definition nat_setoid : Setoid := Build_Setoid eq_nat_equiv. - Canonical Structure nat_setoid. + Canonical nat_setoid. Thanks to :g:`nat_setoid` declared as canonical, the implicit arguments :g:`A` and :g:`B` can be synthesized in the next statement. - .. coqtop:: all + .. coqtop:: all abort Lemma is_law_S : is_law S. @@ -1974,11 +1970,10 @@ in :ref:`canonicalstructures`; here only a simple example is given. If a same field occurs in several canonical structures, then only the structure declared first as canonical is considered. - .. cmdv:: Canonical Structure @ident {? : @type } := @term + .. cmdv:: Canonical {? Structure } @ident {? : @type } := @term This is equivalent to a regular definition of :token:`ident` followed by the - declaration :n:`Canonical Structure @ident`. - + declaration :n:`Canonical @ident`. .. cmd:: Print Canonical Projections @@ -2019,10 +2014,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/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 9bc67147f7..eebf1f11e1 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -34,6 +34,11 @@ allow dynamic linking of tactics). You can switch to the OCaml toplevel with the command ``Drop.``, and come back to the |Coq| toplevel with the command ``Coqloop.loop();;``. +.. flag:: Coqtop Exit On Error + + This option, off by default, causes coqtop to exit with status code + ``1`` if a command produces an error instead of recovering from it. + Batch compilation (coqc) ------------------------ @@ -163,14 +168,14 @@ and ``coqtop``, unless stated otherwise: is equivalent to runningRequire dirpath. :-require dirpath: Load |Coq| compiled library dirpath and import it. This is equivalent to running Require Import dirpath. -:-batch: Exit just after argument parsing. Available for `coqtop` only. -:-compile *file.v*: Compile file *file.v* into *file.vo*. This option +:-batch: Exit just after argument parsing. Available for ``coqtop`` only. +:-compile *file.v*: Deprecated; use ``coqc`` instead. Compile file *file.v* into *file.vo*. This option implies -batch (exit just after argument parsing). It is available only - for `coqtop`, as this behavior is the purpose of `coqc`. -:-compile-verbose *file.v*: Same as -compile but also output the + for `coqtop`, as this behavior is the purpose of ``coqc``. +:-compile-verbose *file.v*: Deprecated. Use ``coqc -verbose``. Same as -compile but also output the content of *file.v* as it is compiled. :-verbose: Output the content of the input file as it is compiled. - This option is available for `coqc` only; it is the counterpart of + This option is available for ``coqc`` only; it is the counterpart of -compile-verbose. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This option expects all, none or a comma-separated list of warning names or @@ -211,11 +216,11 @@ and ``coqtop``, unless stated otherwise: (to be used by coqdoc, see :ref:`coqdoc`). By default, if *file.v* is being compiled, *file.glob* is used. :-no-glob: Disable the dumping of references for global names. -:-image *file*: Set the binary image to be used by `coqc` to be *file* +:-image *file*: Set the binary image to be used by ``coqc`` to be *file* instead of the standard one. Not of general use. :-bindir *directory*: Set the directory containing |Coq| binaries to be - used by `coqc`. It is equivalent to doing export COQBIN= *directory* - before launching `coqc`. + used by ``coqc``. It is equivalent to doing export COQBIN= *directory* + before launching ``coqc``. :-where: Print the location of |Coq|’s standard library and exit. :-config: Print the locations of |Coq|’s binaries, dependencies, and libraries, then exit. 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/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index bd16b70d02..63d6a229ed 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -53,7 +53,7 @@ rule of thumb, all the variables that appear inside constructors in the indices of the hypothesis should be generalized. This is exactly what the ``generalize_eqs_vars`` variant does: -.. coqtop:: all +.. coqtop:: all abort generalize_eqs_vars H. induction H. @@ -65,7 +65,7 @@ as well in this case, e.g.: .. coqtop:: none - Abort. + Require Import Coq.Program.Equality. .. coqtop:: in @@ -88,11 +88,7 @@ automatically do such simplifications (which may involve the axiom K). This is what the ``simplify_dep_elim`` tactic from ``Coq.Program.Equality`` does. For example, we might simplify the previous goals considerably: -.. coqtop:: all - - Require Import Coq.Program.Equality. - -.. coqtop:: all +.. coqtop:: all abort induction p ; simplify_dep_elim. @@ -105,10 +101,6 @@ are ``dependent induction`` and ``dependent destruction`` that do induction or simply case analysis on the generalized hypothesis. For example we can redo what we’ve done manually with dependent destruction: -.. coqtop:: none - - Abort. - .. coqtop:: in Lemma ex : forall n m:nat, Le (S n) m -> P n m. @@ -117,7 +109,7 @@ redo what we’ve done manually with dependent destruction: intros n m H. -.. coqtop:: all +.. coqtop:: all abort dependent destruction H. @@ -126,10 +118,6 @@ destructed hypothesis actually appeared in the goal, the tactic would still be able to invert it, contrary to dependent inversion. Consider the following example on vectors: -.. coqtop:: none - - Abort. - .. coqtop:: in Set Implicit Arguments. @@ -230,29 +218,21 @@ name. A term is either an application of: Once we have this datatype we want to do proofs on it, like weakening: -.. coqtop:: in +.. coqtop:: in abort Lemma weakening : forall G D tau, term (G ; D) tau -> forall tau', term (G , tau' ; D) tau. -.. coqtop:: none - - Abort. - The problem here is that we can’t just use induction on the typing derivation because it will forget about the ``G ; D`` constraint appearing in the instance. A solution would be to rewrite the goal as: -.. coqtop:: in +.. coqtop:: in abort Lemma weakening' : forall G' tau, term G' tau -> forall G D, (G ; D) = G' -> forall tau', term (G, tau' ; D) tau. -.. coqtop:: none - - Abort. - With this proper separation of the index from the instance and the right induction loading (putting ``G`` and ``D`` after the inducted-on hypothesis), the proof will go through, but it is a very tedious diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 442077616f..3e87e8acd8 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -602,7 +602,7 @@ Failing .. example:: - .. coqtop:: all + .. coqtop:: all fail Goal True. Proof. fail. Abort. @@ -701,7 +701,7 @@ tactic .. example:: - .. coqtop:: all + .. coqtop:: all abort Ltac time_constr1 tac := let eval_early := match goal with _ => restart_timer "(depth 1)" end in @@ -716,7 +716,6 @@ tactic let y := time_constr1 ltac:(fun _ => eval compute in x) in y) in pose v. - Abort. Local definitions ~~~~~~~~~~~~~~~~~ @@ -847,7 +846,7 @@ We can carry out pattern matching on terms with: .. example:: - .. coqtop:: all + .. coqtop:: all abort Ltac f x := match x with @@ -1022,7 +1021,7 @@ Counting the goals Goal True /\ True /\ True. split;[|split]. - .. coqtop:: all + .. coqtop:: all abort all:pr_numgoals. @@ -1154,6 +1153,15 @@ Printing |Ltac| tactics Debugging |Ltac| tactics ------------------------ +Backtraces +~~~~~~~~~~ + +.. flag:: Ltac Backtrace + + Setting this flag displays a backtrace on Ltac failures that can be useful + to find out what went wrong. It is disabled by default for performance + reasons. + Info trace ~~~~~~~~~~ @@ -1301,10 +1309,10 @@ performance issue. .. coqtop:: all - Set Ltac Profiling. - tac. - Show Ltac Profile. - Show Ltac Profile "omega". + Set Ltac Profiling. + tac. + Show Ltac Profile. + Show Ltac Profile "omega". .. coqtop:: in diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 590d71b5f3..2300a317f1 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -346,11 +346,46 @@ Navigation in the proof tree Goals are just existential variables and existential variables do not get a name by default. You can give a name to a goal by using :n:`refine ?[@ident]`. + You may also wrap this in an Ltac-definition like: + + .. coqtop:: in + + Ltac name_goal name := refine ?[name]. .. seealso:: :ref:`existential-variables` .. example:: + This first example uses the Ltac definition above, and the named goals + only serve for documentation. + + .. coqtop:: all + + Goal forall n, n + 0 = n. + Proof. + induction n; [ name_goal base | name_goal step ]. + [base]: { + + .. coqtop:: all + + reflexivity. + + .. coqtop:: in + + } + + .. coqtop:: all + + [step]: { + + .. coqtop:: all + + simpl. + f_equal. + assumption. + } + Qed. + This can also be a way of focusing on a shelved goal, for instance: .. coqtop:: all @@ -494,16 +529,12 @@ Requesting information .. example:: - .. coqtop:: all + .. coqtop:: all abort Goal exists n, n = 0. eexists ?[n]. Show n. - .. coqtop:: none - - Abort. - .. cmdv:: Show Script :name: Show Script @@ -704,14 +735,10 @@ Notes: split. - .. coqtop:: all + .. coqtop:: all abort 2: split. - .. coqtop:: none - - Abort. - .. .. coqtop:: none @@ -724,14 +751,10 @@ Notes: intros n. - .. coqtop:: all + .. coqtop:: all abort intros m. - .. coqtop:: none - - Abort. - This screen shot shows the result of applying a :tacn:`split` tactic that replaces one goal with 2 goals. Notice that the goal ``P 1`` is not highlighted at all after the split because it has not changed. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 483dbd311d..237b534d67 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -215,7 +215,7 @@ construct differs from the latter in that .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -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 @@ -275,7 +275,7 @@ example, the null and all list function(al)s can be defined as follows: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -376,7 +376,7 @@ expressions such as .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -401,7 +401,7 @@ each point of use, e.g., the above definition can be written: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -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. @@ -464,7 +464,7 @@ defined by the following declaration: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -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. @@ -518,7 +518,7 @@ For example, the tactic :tacn:`pose <pose (ssreflect)>` supoprts parameters: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -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). @@ -639,7 +639,7 @@ The tactic: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -652,11 +652,7 @@ The tactic: Lemma test x : f x + f x = f x. set t := f _. - .. coqtop:: none - - Undo. - - .. coqtop:: all + .. coqtop:: all restart set t := {2}(f _). @@ -694,7 +690,7 @@ conditions: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -715,7 +711,7 @@ conditions: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -736,7 +732,7 @@ Moreover: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -756,7 +752,7 @@ Moreover: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -766,7 +762,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. @@ -789,7 +785,7 @@ An *occurrence switch* can be: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -810,7 +806,7 @@ An *occurrence switch* can be: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -831,7 +827,7 @@ An *occurrence switch* can be: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -862,7 +858,7 @@ selection. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -879,7 +875,7 @@ only one occurrence of the selected term. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -889,7 +885,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: @@ -910,7 +906,7 @@ context of a goal thanks to the ``in`` tactical. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. @@ -926,7 +922,7 @@ context of a goal thanks to the ``in`` tactical. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. @@ -1042,7 +1038,7 @@ constants to the goal. For example, the proof of [#3]_ - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1079,7 +1075,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. @@ -1104,7 +1100,7 @@ The ``:`` tactical is used to operate on an element in the context. to encapsulate the inductive step in a single command: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1139,7 +1135,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 +1146,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 +1159,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. @@ -1257,7 +1253,7 @@ The elim tactic .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1297,7 +1293,7 @@ existential metavariables of sort :g:`Prop`. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1398,7 +1394,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 +1405,7 @@ For example, the tactic: Therefore this tactic changes any goal ``G`` into -.. coqtop:: +.. coqdoc:: forall n n0 : nat, n = n0 -> G. @@ -1477,7 +1473,7 @@ context to interpret wildcards; in particular it can accommodate the .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1752,7 +1748,7 @@ Clears are deferred until the end of the intro pattern. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -1813,7 +1809,7 @@ Block introduction .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1843,7 +1839,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 +1847,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). @@ -1866,7 +1862,7 @@ deal with the possible parameters of the constants introduced. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1885,7 +1881,7 @@ under fresh |SSR| names. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1936,7 +1932,7 @@ be substituted. inferred looking at the type of the top assumption. This allows for the compact syntax: - .. coqtop:: in + .. coqdoc:: case: {2}_ / eqP. @@ -1952,7 +1948,7 @@ be substituted. Here is a small example on lists. We define first a function which adds an element at the end of a given list. - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -1989,19 +1985,17 @@ be substituted. Lemma test l : (length l) * 2 = length (l ++ l). case: (lastP l). - Applied to the same goal, the command: - ``case: l / (lastP l).`` - generates the same subgoals but ``l`` has been cleared from both contexts. + Applied to the same goal, the tactc ``case: l / (lastP l)`` + generates the same subgoals but ``l`` has been cleared from both contexts: - Again applied to the same goal, the command. + .. coqtop:: all restart - .. coqtop:: none + case: l / (lastP l). - Abort. + Again applied to the same goal: - .. coqtop:: all + .. coqtop:: all restart abort - Lemma test l : (length l) * 2 = length (l ++ l). case: {1 3}l / (lastP l). Note that selected occurrences on the left of the ``/`` @@ -2015,10 +2009,6 @@ be substituted. .. example:: - .. coqtop:: none - - Abort. - .. coqtop:: all Lemma test l : (length l) * 2 = length (l ++ l). @@ -2112,7 +2102,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 +2137,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 +2151,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 +2169,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 +2237,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. @@ -2260,9 +2250,8 @@ to the others. Here is a small example on lists. We define first a function which adds an element at the end of a given list. - .. coqtop:: reset + .. coqtop:: reset none - Abort. From Coq Require Import ssreflect. Set Implicit Arguments. Unset Strict Implicit. @@ -2296,13 +2285,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 +2316,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. @@ -2380,7 +2369,7 @@ between standard Ltac in and the |SSR| tactical in. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2455,7 +2444,7 @@ the holes are abstracted in term. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2469,7 +2458,7 @@ the holes are abstracted in term. The invokation of ``have`` is equivalent to: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2487,7 +2476,7 @@ tactic: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2518,7 +2507,7 @@ tactics of the form: which behave like: -.. coqtop:: in +.. coqdoc:: have: term ; first by tactic. move=> clear_switch i_item. @@ -2531,7 +2520,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. @@ -2540,7 +2529,7 @@ the further use of the intermediate step. For instance, .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2559,7 +2548,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. @@ -2568,7 +2557,7 @@ destruction of existential assumptions like in the tactic: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2595,7 +2584,7 @@ term for the intermediate lemma, using tactics of the form: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2616,7 +2605,7 @@ After the :token:`i_pattern`, a list of binders is allowed. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. From Coq Require Import Omega. @@ -2635,7 +2624,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 +.. coqtop:: all restart have (x) : 2 * x = x + x by omega. @@ -2649,13 +2638,8 @@ copying the goal itself. .. example:: - .. coqtop:: none - - Abort All. - - .. coqtop:: all + .. coqtop:: all restart abort - Lemma test : True. have suff H : 2 + 2 = 3; last first. Note that H is introduced in the second goal. @@ -2676,10 +2660,9 @@ context entry name. .. coqtop:: none - Abort All. Set Printing Depth 15. - .. coqtop:: all + .. coqtop:: all abort Inductive Ord n := Sub x of x < n. Notation "'I_ n" := (Ord n) (at level 8, n at level 2, format "''I_' n"). @@ -2695,11 +2678,7 @@ For this purpose the ``[: name ]`` intro pattern and the tactic .. example:: - .. coqtop:: none - - Abort All. - - .. coqtop:: all + .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. have [:pm] @i : 'I_n by apply: (Sub m); abstract: pm; omega. @@ -2712,11 +2691,7 @@ with have and an explicit term, they must be used as follows: .. example:: - .. coqtop:: none - - Abort All. - - .. coqtop:: all + .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. have [:pm] @i : 'I_n := Sub m pm. @@ -2735,11 +2710,7 @@ makes use of it). .. example:: - .. coqtop:: none - - Abort All. - - .. coqtop:: all + .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. have [:pm] @i k : 'I_(n+k) by apply: (Sub m); abstract: pm k; omega. @@ -2756,21 +2727,21 @@ typeclass inference. .. coqtop:: none - Abort All. - Axiom ty : Type. Axiom t : ty. Goal True. -+ .. coqtop:: in undo + .. coqtop:: all have foo : ty. Full inference for ``ty``. The first subgoal demands a proof of such instantiated statement. -+ .. coqdoc:: + .. A strange bug prevents using the coqtop directive here + + .. coqdoc:: have foo : ty := . @@ -2779,13 +2750,13 @@ typeclass inference. statement. Note that no proof term follows ``:=``, hence two subgoals are generated. -+ .. coqtop:: in undo + .. coqtop:: all restart have foo : ty := t. No inference for ``ty`` and ``t``. -+ .. coqtop:: in undo + .. coqtop:: all restart abort have foo := t. @@ -2816,7 +2787,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. @@ -2834,10 +2805,9 @@ The ``have`` modifier can follow the ``suff`` tactic. .. coqtop:: none - Abort All. Axioms G P : Prop. - .. coqtop:: all + .. coqtop:: all abort Lemma test : G. suff have H : P. @@ -2888,7 +2858,7 @@ name of the local definition with the ``@`` character. In the second subgoal, the tactic: -.. coqtop:: in +.. coqdoc:: move=> clear_switch i_item. @@ -2902,10 +2872,6 @@ are unique. .. example:: - .. coqtop:: none - - Abort All. - .. coqtop:: all Lemma quo_rem_unicity d q1 q2 r1 r2 : @@ -2927,7 +2893,7 @@ pattern will be used to process its instance. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrfun ssrbool. Set Implicit Arguments. @@ -2976,7 +2942,7 @@ illustrated in the following example. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -2995,10 +2961,13 @@ illustrated in the following example. the pattern ``id (addx x)``, that would produce the following first subgoal - .. coqtop:: none + .. coqtop:: reset none + + 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. @@ -3126,14 +3095,14 @@ An :token:`r_item` can be: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. - .. coqtop:: all + .. coqtop:: all abort Definition double x := x + x. Definition ddouble x := double (double x). @@ -3145,21 +3114,16 @@ An :token:`r_item` can be: The |SSR| terms containing holes are *not* typed as abstractions in this context. Hence the following script fails. - .. coqtop:: none - - Abort. - .. coqtop:: all Definition f := fun x y => x + y. Lemma test x y : x + y = f y x. - rewrite -[f y]/(y + _). - but the following script succeeds + .. coqtop:: all fail - .. coqtop:: none + rewrite -[f y]/(y + _). - Restart. + but the following script succeeds .. coqtop:: all @@ -3192,7 +3156,7 @@ tactics. In a rewrite tactic of the form: -.. coqtop:: in +.. coqdoc:: rewrite occ_switch [term1]term2. @@ -3235,7 +3199,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 //=. @@ -3250,7 +3214,7 @@ proof of basic results on natural numbers arithmetic. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3286,7 +3250,7 @@ side of the equality the user wants to rewrite. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3306,7 +3270,7 @@ the equality. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3316,7 +3280,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``. @@ -3329,7 +3293,7 @@ Occurrence switches and redex switches .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3358,7 +3322,7 @@ repetition. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3388,7 +3352,7 @@ rewrite operations prescribed by the rules on the current goal. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3397,7 +3361,7 @@ rewrite operations prescribed by the rules on the current goal. Section Test. - .. coqtop:: all + .. coqtop:: all abort Variables (a b c : nat). Hypothesis eqab : a = b. @@ -3411,10 +3375,6 @@ rewrite operations prescribed by the rules on the current goal. ``(eqab, eqac)`` is actually a |Coq| term and we can name it with a definition: - .. coqtop:: none - - Abort. - .. coqtop:: all Definition multi1 := (eqab, eqac). @@ -3431,7 +3391,7 @@ literal matches have priority. .. example:: - .. coqtop:: all + .. coqtop:: all abort Definition d := a. Hypotheses eqd0 : d = 0. @@ -3448,11 +3408,7 @@ repeated anew. .. example:: - .. coqtop:: none - - Abort. - - .. coqtop:: all + .. coqtop:: all abort Hypothesis eq_adda_b : forall x, x + a = b. Hypothesis eq_adda_c : forall x, x + a = c. @@ -3475,10 +3431,6 @@ tactic rewrite ``(=~ multi1)`` is equivalent to ``rewrite multi1_rev``. .. example:: - .. coqtop:: none - - Abort. - .. coqtop:: all Hypothesis eqba : b = a. @@ -3498,7 +3450,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 +3466,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))). @@ -3534,7 +3486,7 @@ Anyway this tactic is *not* equivalent to .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3550,11 +3502,7 @@ Anyway this tactic is *not* equivalent to while the other tactic results in - .. coqtop:: none - - Undo. - - .. coqtop:: all + .. coqtop:: all restart abort rewrite (_ : forall x, x * 0 = 0). @@ -3572,14 +3520,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. @@ -3588,7 +3536,7 @@ cases: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3611,11 +3559,7 @@ cases: there is no occurrence of the head symbol ``f`` of the rewrite rule in the goal. - .. coqtop:: none - - Undo. - - .. coqtop:: all + .. coqtop:: all restart fail rewrite H. @@ -3625,21 +3569,13 @@ cases: occurrence), using tactic ``rewrite /f`` (for a global replacement of f by g) or ``rewrite pattern/f``, for a finer selection. - .. coqtop:: none - - Undo. - - .. coqtop:: all + .. coqtop:: all restart rewrite /f H. alternatively one can override the pattern inferred from ``H`` - .. coqtop:: none - - Undo. - - .. coqtop:: all + .. coqtop:: all restart rewrite [f _]H. @@ -3658,7 +3594,7 @@ corresponding new goals will be generated. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrfun ssrbool. Set Implicit Arguments. @@ -3666,7 +3602,7 @@ corresponding new goals will be generated. Unset Printing Implicit Defensive. Set Warnings "-notation-overridden". - .. coqtop:: all + .. coqtop:: all abort Axiom leq : nat -> nat -> bool. Notation "m <= n" := (leq m n) : nat_scope. @@ -3689,10 +3625,6 @@ corresponding new goals will be generated. As in :ref:`apply_ssr`, the ``ssrautoprop`` tactic is used to try to solve the existential variable. - .. coqtop:: none - - Abort. - .. coqtop:: all Lemma test (x : 'I_2) y (H : y < 2) : Some x = insub 2 y. @@ -3729,7 +3661,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. @@ -3741,7 +3673,7 @@ selective rewriting, blocking on the fly the reduction in the term ``t``. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrfun ssrbool. From Coq Require Import List. @@ -3765,7 +3697,7 @@ definition. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3793,14 +3725,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 +3748,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 +3756,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 +3783,7 @@ Congruence Because of the way matching interferes with parameters of type families, the tactic: -.. coqtop:: in +.. coqdoc:: apply: my_congr_property. @@ -3875,7 +3807,7 @@ which the function is supplied: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3902,7 +3834,7 @@ which the function is supplied: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3925,7 +3857,7 @@ which the function is supplied: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -3946,7 +3878,7 @@ which the function is supplied: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4047,7 +3979,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. @@ -4126,7 +4058,7 @@ parentheses are required around more complex patterns. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4148,14 +4080,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). @@ -4165,7 +4097,7 @@ Contextual patterns in rewrite .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4246,7 +4178,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 +4186,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 +4219,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 +4235,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. @@ -4329,7 +4261,7 @@ generation (see section :ref:`generation_of_equations_ssr`). The following script illustrates a toy example of this feature. Let us define a function adding an element at the end of a list: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect List. Set Implicit Arguments. @@ -4367,13 +4299,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. @@ -4404,7 +4336,7 @@ Here is an example of a regular, but nontrivial, eliminator. Here is a toy example illustrating this feature. - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect FunInd. Set Implicit Arguments. @@ -4424,14 +4356,14 @@ 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). elim/plus_ind: {z}_. elim/plus_ind: z / _. - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect FunInd. Set Implicit Arguments. @@ -4456,7 +4388,7 @@ Here is an example of a regular, but nontrivial, eliminator. ``plus (plus x y) z`` thus instantiating the last ``_`` with ``z``. Note that the tactic: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect FunInd. Set Implicit Arguments. @@ -4473,7 +4405,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 @@ -4486,7 +4418,7 @@ Here is an example of a truncated eliminator: Consider the goal: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect FunInd. Set Implicit Arguments. @@ -4494,7 +4426,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 +4437,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 +4450,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 @@ -4550,7 +4482,7 @@ disjunction. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4571,7 +4503,7 @@ disjunction. This operation is so common that the tactic shell has specific syntax for it. The following scripts: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4584,13 +4516,13 @@ disjunction. Lemma test a : P (a || a) -> True. - .. coqtop:: all undo + .. coqtop:: all move=> HPa; move/P2Q: HPa => HQa. or more directly: - .. coqtop:: all undo + .. coqtop:: all restart move/P2Q=> HQa. @@ -4606,7 +4538,7 @@ equation name generation mechanism (see section :ref:`generation_of_equations_ss .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4624,7 +4556,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]. @@ -4639,7 +4571,7 @@ relevant for the current goal. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4661,14 +4593,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. @@ -4683,7 +4615,7 @@ assumption to some given arguments. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4712,7 +4644,7 @@ bookkeeping steps. The following example use the ``~~`` prenex notation for boolean negation: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -4768,7 +4700,7 @@ analysis: .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect. Set Implicit Arguments. @@ -4785,7 +4717,7 @@ analysis .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -4810,7 +4742,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 +4759,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,9 +4770,9 @@ logically equivalent propositions. For instance, the following lemma: -.. coqtop:: in +.. coqdoc:: - Lemma andP: forall b1 b2, reflect (b1 /\ b2) (b1 && b2). + Lemma andP: forall b1 b2, reflect (b1 /\ b2) (b1 && b2). relates the boolean conjunction to the logical one ``/\``. Note that in ``andP``, ``b1`` and ``b2`` are two boolean variables and the @@ -4853,20 +4785,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). @@ -4875,7 +4807,7 @@ Let us compare the respective behaviors of ``andE`` and ``andP``. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -4888,11 +4820,15 @@ Let us compare the respective behaviors of ``andE`` and ``andP``. Lemma test (b1 b2 : bool) : if (b1 && b2) then b1 else ~~(b1||b2). - .. coqtop:: all undo + .. coqtop:: all case: (@andE b1 b2). - .. coqtop:: all undo + .. coqtop:: none + + Restart. + + .. coqtop:: all case: (@andP b1 b2). @@ -4912,7 +4848,7 @@ The view mechanism is compatible with reflect predicates. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -4920,17 +4856,13 @@ The view mechanism is compatible with reflect predicates. Unset Printing Implicit Defensive. Section Test. - .. coqtop:: all + .. coqtop:: all abort Lemma test (a b : bool) (Ha : a) (Hb : b) : a /\ b. apply/andP. Conversely - .. coqtop:: none - - Abort. - .. coqtop:: all Lemma test (a b : bool) : a /\ b -> a. @@ -4950,13 +4882,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 +4945,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. @@ -5034,7 +4966,7 @@ but they also allow complex transformation, involving negations. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -5067,7 +4999,7 @@ actually uses its propositional interpretation. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -5123,13 +5055,13 @@ 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. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -5145,7 +5077,7 @@ In this context, the identity view can be used when no view has to be applied: The same goal can be decomposed in several ways, and the user may choose the most convenient interpretation. - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -5198,7 +5130,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 +5142,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. @@ -5221,7 +5153,7 @@ pass a given hypothesis to a lemma. .. example:: - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. @@ -5280,7 +5212,7 @@ equivalences are indeed taken into account, otherwise only single looks for any notation that contains fragment as a substring. If the ``ssrbool.v`` library is imported, the command: ``Search "~~".`` answers : - .. coqtop:: reset + .. coqtop:: reset none From Coq Require Import ssreflect ssrbool. Set Implicit Arguments. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 7eef504ea9..b5e9a902c6 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -749,39 +749,39 @@ Applying theorems The direct application of ``Rtrans`` with ``apply`` fails because no value for ``y`` in ``Rtrans`` is found by ``apply``: - .. coqtop:: all + .. coqtop:: all fail - Fail apply Rtrans. + apply Rtrans. A solution is to ``apply (Rtrans n m p)`` or ``(Rtrans n m)``. - .. coqtop:: all undo + .. coqtop:: all apply (Rtrans n m p). Note that ``n`` can be inferred from the goal, so the following would work too. - .. coqtop:: in undo + .. coqtop:: in restart apply (Rtrans _ m). More elegantly, ``apply Rtrans with (y:=m)`` allows only mentioning the unknown m: - .. coqtop:: in undo + .. coqtop:: in restart apply Rtrans with (y := m). Another solution is to mention the proof of ``(R x y)`` in ``Rtrans`` - .. coqtop:: all undo + .. coqtop:: all restart apply Rtrans with (1 := Rnm). ... or the proof of ``(R y z)``. - .. coqtop:: all undo + .. coqtop:: all restart apply Rtrans with (2 := Rmp). @@ -789,7 +789,7 @@ Applying theorems finding ``m``. Then one can apply the hypotheses ``Rnm`` and ``Rmp``. This instantiates the existential variable and completes the proof. - .. coqtop:: all + .. coqtop:: all restart abort eapply Rtrans. @@ -2332,6 +2332,7 @@ and an explanation of the underlying technique. where :n:`@ident` is the identifier for the last introduced hypothesis. .. tacv:: inversion_clear @ident + :name: inversion_clear This behaves as :n:`inversion` and then erases :n:`@ident` from the context. @@ -2490,47 +2491,51 @@ and an explanation of the underlying technique. *Non-dependent inversion*. - Let us consider the relation Le over natural numbers and the following - variables: + Let us consider the relation :g:`Le` over natural numbers: - .. coqtop:: all + .. coqtop:: reset in Inductive Le : nat -> nat -> Set := | LeO : forall n:nat, Le 0 n | LeS : forall n m:nat, Le n m -> Le (S n) (S m). - Variable P : nat -> nat -> Prop. - Variable Q : forall n m:nat, Le n m -> Prop. + Let us consider the following goal: .. coqtop:: none + Section Section. + Variable P : nat -> nat -> Prop. + Variable Q : forall n m:nat, Le n m -> Prop. Goal forall n m, Le (S n) m -> P n m. - intros. - .. coqtop:: all + .. coqtop:: out - Show. + intros. - To prove the goal, we may need to reason by cases on H and to derive - that m is necessarily of the form (S m 0 ) for certain m 0 and that - (Le n m 0 ). Deriving these conditions corresponds to proving that the - only possible constructor of (Le (S n) m) isLeS and that we can invert - the-> in the type of LeS. This inversion is possible because Le is the - smallest set closed by the constructors LeO and LeS. + To prove the goal, we may need to reason by cases on :g:`H` and to derive + that :g:`m` is necessarily of the form :g:`(S m0)` for certain :g:`m0` and that + :g:`(Le n m0)`. Deriving these conditions corresponds to proving that the only + possible constructor of :g:`(Le (S n) m)` is :g:`LeS` and that we can invert + the arrow in the type of :g:`LeS`. This inversion is possible because :g:`Le` + is the smallest set closed by the constructors :g:`LeO` and :g:`LeS`. - .. coqtop:: undo all + .. coqtop:: all inversion_clear H. - Note that m has been substituted in the goal for (S m0) and that the - hypothesis (Le n m0) has been added to the context. + Note that :g:`m` has been substituted in the goal for :g:`(S m0)` and that the + hypothesis :g:`(Le n m0)` has been added to the context. - Sometimes it is interesting to have the equality m=(S m0) in the - context to use it after. In that case we can use inversion that does + Sometimes it is interesting to have the equality :g:`m = (S m0)` in the + context to use it after. In that case we can use :tacn:`inversion` that does not clear the equalities: - .. coqtop:: undo all + .. coqtop:: none restart + + intros. + + .. coqtop:: all inversion H. @@ -2540,31 +2545,26 @@ and an explanation of the underlying technique. Let us consider the following goal: - .. coqtop:: reset none + .. coqtop:: none - Inductive Le : nat -> nat -> Set := - | LeO : forall n:nat, Le 0 n - | LeS : forall n m:nat, Le n m -> Le (S n) (S m). - Variable P : nat -> nat -> Prop. - Variable Q : forall n m:nat, Le n m -> Prop. + Abort. Goal forall n m (H:Le (S n) m), Q (S n) m H. - intros. - .. coqtop:: all + .. coqtop:: out - Show. + intros. - As H occurs in the goal, we may want to reason by cases on its - structure and so, we would like inversion tactics to substitute H by + As :g:`H` occurs in the goal, we may want to reason by cases on its + structure and so, we would like inversion tactics to substitute :g:`H` by the corresponding @term in constructor form. Neither :tacn:`inversion` nor - :n:`inversion_clear` do such a substitution. To have such a behavior we + :tacn:`inversion_clear` do such a substitution. To have such a behavior we use the dependent inversion tactics: .. coqtop:: all dependent inversion_clear H. - Note that H has been substituted by (LeS n m0 l) andm by (S m0). + Note that :g:`H` has been substituted by :g:`(LeS n m0 l)` and :g:`m` by :g:`(S m0)`. .. example:: @@ -2933,6 +2933,12 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. + .. tacv:: now_show @term + + This is a synonym of :n:`change @term`. It can be used to + make some proof steps explicit when refactoring a proof script + to make it readable. + .. seealso:: :ref:`Performing computations <performingcomputations>` .. _performingcomputations: @@ -3307,12 +3313,25 @@ the conversion in hypotheses :n:`{+ @ident}`. :name: fold This tactic applies to any goal. The term :n:`@term` is reduced using the - ``red`` tactic. Every occurrence of the resulting :n:`@term` in the goal is - then replaced by :n:`@term`. + :tacn:`red` tactic. Every occurrence of the resulting :n:`@term` in the goal is + then replaced by :n:`@term`. This tactic is particularly useful when a fixpoint + definition has been wrongfully unfolded, making the goal very hard to read. + On the other hand, when an unfolded function applied to its argument has been + reduced, the :tacn:`fold` tactic won't do anything. + + .. example:: + + .. coqtop:: all abort -.. tacv:: fold {+ @term} + Goal ~0=0. + unfold not. + Fail progress fold not. + pattern (0 = 0). + fold not. - Equivalent to :n:`fold @term ; ... ; fold @term`. + .. tacv:: fold {+ @term} + + Equivalent to :n:`fold @term ; ... ; fold @term`. .. tacn:: pattern @term :name: pattern @@ -3389,129 +3408,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:: -.. tacv:: auto @num + :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. - Forces the search depth to be :token:`num`. The maximal search depth - is 5 by default. + .. tacv:: auto @num -.. tacv:: auto with {+ @ident} + Forces the search depth to be :token:`num`. The maximal search depth + is 5 by default. - Uses the hint databases :n:`{+ @ident}` in addition to the database core. + .. tacv:: auto with {+ @ident} + + Uses the hint databases :n:`{+ @ident}` in addition to the database ``core``. + + .. note:: + + Use the fake database `nocore` if you want to *not* use the `core` + database. + + .. tacv:: auto with * + + 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 ae66791b0c..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. @@ -1497,12 +1497,12 @@ Numeral notations for only non-negative integers, and the given numeral is negative. - .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first). + .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first). The parsing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. - .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first). + .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first). The printing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index c33df52038..7b21b67eea 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -259,7 +259,7 @@ through the <tt>Require Import</tt> command.</p> </dd> <dt> <b> Cyclic</b>: - Abstract and 31-bits-based cyclic arithmetic + Abstract and 63-bits-based cyclic arithmetic </dt> <dd> theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -268,11 +268,14 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/Cyclic/Int31/Cyclic31.v theories/Numbers/Cyclic/Int31/Ring31.v theories/Numbers/Cyclic/Int31/Int31.v + theories/Numbers/Cyclic/Int63/Cyclic63.v + theories/Numbers/Cyclic/Int63/Int63.v + theories/Numbers/Cyclic/Int63/Ring63.v theories/Numbers/Cyclic/ZModulo/ZModulo.v </dd> <dt> <b> Natural</b>: - Abstract and 31-bits-words-based natural arithmetic + Abstract and 63-bits-words-based natural arithmetic </dt> <dd> theories/Numbers/Natural/Abstract/NAdd.v @@ -300,7 +303,7 @@ through the <tt>Require Import</tt> command.</p> </dd> <dt> <b> Integer</b>: - Abstract and concrete (especially 31-bits-words-based) integer + Abstract and concrete (especially 63-bits-words-based) integer arithmetic </dt> <dd> diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 067af954ad..8df0f2be97 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -30,7 +30,7 @@ from sphinx import addnodes from sphinx.roles import XRefRole from sphinx.errors import ExtensionError from sphinx.util.nodes import set_source_info, set_role_source_info, make_refnode -from sphinx.util.logging import getLogger +from sphinx.util.logging import getLogger, get_node_location from sphinx.directives import ObjectDescription from sphinx.domains import Domain, ObjType, Index from sphinx.domains.std import token_xrefs @@ -38,7 +38,7 @@ from sphinx.ext import mathbase from . import coqdoc from .repl import ansicolors -from .repl.coqtop import CoqTop +from .repl.coqtop import CoqTop, CoqTopError from .notations.sphinx import sphinxify from .notations.plain import stringify_with_ellipses @@ -560,17 +560,17 @@ class CoqtopDirective(Directive): Example:: - .. coqtop:: in reset undo + .. coqtop:: in reset Print nat. Definition a := 1. The blank line after the directive is required. If you begin a proof, - include an ``Abort`` afterwards to reset coqtop for the next example. + use the ``abort`` option to reset coqtop for the next example. Here is a list of permissible options: - - Display options + - Display options (choose exactly one) - ``all``: Display input and output - ``in``: Display only input @@ -580,16 +580,17 @@ 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 + - ``fail``: Don't die if a command fails + - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) + - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) ``coqtop``\ 's state is preserved across consecutive ``.. coqtop::`` blocks of the same document (``coqrst`` creates a single ``coqtop`` process per reST source file). Use the ``reset`` option to reset Coq's state. """ has_content = True - required_arguments = 0 - optional_arguments = 1 + required_arguments = 1 + optional_arguments = 0 final_argument_whitespace = True option_spec = { 'name': directives.unchanged } directive_name = "coqtop" @@ -598,10 +599,8 @@ class CoqtopDirective(Directive): # Uses a ‘container’ instead of a ‘literal_block’ to disable # Pygments-based post-processing (we could also set rawsource to '') content = '\n'.join(self.content) - args = self.arguments[0].split() if self.arguments else ['in'] - if 'all' in args: - args.extend(['in', 'out']) - node = nodes.container(content, coqtop_options = list(set(args)), + args = self.arguments[0].split() + node = nodes.container(content, coqtop_options = set(args), classes=['coqtop', 'literal-block']) self.add_name(node) return [node] @@ -828,22 +827,41 @@ class CoqtopBlocksTransform(Transform): return re.split(r"(?<=(?<!\.)\.)\s+", source) @staticmethod - def parse_options(options): + def parse_options(node): """Parse options according to the description in CoqtopDirective.""" - opt_undo = 'undo' in options + + options = node['coqtop_options'] + + # Behavior options opt_reset = 'reset' in options - opt_all, opt_none = 'all' in options, 'none' in options - opt_input, opt_output = opt_all or 'in' in options, opt_all or 'out' in options + opt_fail = 'fail' in options + opt_restart = 'restart' in options + opt_abort = 'abort' in options + options = options - set(('reset', 'fail', 'restart', 'abort')) - unexpected_options = list(set(options) - set(('reset', 'undo', 'all', 'none', 'in', 'out'))) + unexpected_options = list(options - set(('all', 'none', 'in', 'out'))) if unexpected_options: - raise ValueError("Unexpected options for .. coqtop:: {}".format(unexpected_options)) - elif (opt_input or opt_output) and opt_none: - raise ValueError("Inconsistent options for .. coqtop:: ‘none’ with ‘in’, ‘out’, or ‘all’") - elif opt_reset and opt_undo: - raise ValueError("Inconsistent options for .. coqtop:: ‘undo’ with ‘reset’") - - return opt_undo, opt_reset, opt_input and not opt_none, opt_output and not opt_none + loc = get_node_location(node) + raise ExtensionError("{}: Unexpected options for .. coqtop:: {}".format(loc,unexpected_options)) + + # Display options + if len(options) != 1: + loc = get_node_location(node) + raise ExtensionError("{}: Exactly one display option must be passed to .. coqtop::".format(loc)) + + opt_all = 'all' in options + opt_none = 'none' in options + opt_input = 'in' in options + opt_output = 'out' in options + + return { + 'reset': opt_reset, + 'fail': opt_fail, + 'restart': opt_restart, + 'abort': opt_abort, + 'input': opt_input or opt_all, + 'output': opt_output or opt_all + } @staticmethod def block_classes(should_show, contents=None): @@ -867,36 +885,59 @@ class CoqtopBlocksTransform(Transform): blocks.append(re.sub("^", " ", output, flags=re.MULTILINE) + "\n") return '\n'.join(blocks) + def add_coq_output_1(self, repl, node): + options = self.parse_options(node) + + pairs = [] + + if options['restart']: + repl.sendone("Restart.") + if options['reset']: + repl.sendone("Reset Initial.") + repl.sendone("Set Coqtop Exit On Error.") + if options['fail']: + repl.sendone("Unset Coqtop Exit On Error.") + for sentence in self.split_sentences(node.rawsource): + pairs.append((sentence, repl.sendone(sentence))) + if options['abort']: + repl.sendone("Abort All.") + if options['fail']: + repl.sendone("Set Coqtop Exit On Error.") + + dli = nodes.definition_list_item() + for sentence, output in pairs: + # Use Coqdoc to highlight input + in_chunks = highlight_using_coqdoc(sentence) + dli += nodes.term(sentence, '', *in_chunks, classes=self.block_classes(options['input'])) + # Parse ANSI sequences to highlight output + out_chunks = AnsiColorsParser().colorize_str(output) + dli += nodes.definition(output, *out_chunks, classes=self.block_classes(options['output'], output)) + node.clear() + node.rawsource = self.make_rawsource(pairs, options['input'], options['output']) + node['classes'].extend(self.block_classes(options['input'] or options['output'])) + node += nodes.inline('', '', classes=['coqtop-reset'] * options['reset']) + node += nodes.definition_list(node.rawsource, dli) + def add_coqtop_output(self): """Add coqtop's responses to a Sphinx AST Finds nodes to process using is_coqtop_block.""" with CoqTop(color=True) as repl: + repl.sendone("Set Coqtop Exit On Error.") for node in self.document.traverse(CoqtopBlocksTransform.is_coqtop_block): - options = node['coqtop_options'] - opt_undo, opt_reset, opt_input, opt_output = self.parse_options(options) - - if opt_reset: - repl.sendone("Reset Initial.") - pairs = [] - for sentence in self.split_sentences(node.rawsource): - pairs.append((sentence, repl.sendone(sentence))) - if opt_undo: - repl.sendone("Undo {}.".format(len(pairs))) - - dli = nodes.definition_list_item() - for sentence, output in pairs: - # Use Coqdoq to highlight input - in_chunks = highlight_using_coqdoc(sentence) - dli += nodes.term(sentence, '', *in_chunks, classes=self.block_classes(opt_input)) - # Parse ANSI sequences to highlight output - out_chunks = AnsiColorsParser().colorize_str(output) - dli += nodes.definition(output, *out_chunks, classes=self.block_classes(opt_output, output)) - node.clear() - node.rawsource = self.make_rawsource(pairs, opt_input, opt_output) - node['classes'].extend(self.block_classes(opt_input or opt_output)) - node += nodes.inline('', '', classes=['coqtop-reset'] * opt_reset) - node += nodes.definition_list(node.rawsource, dli) + try: + self.add_coq_output_1(repl, node) + except CoqTopError as err: + import textwrap + MSG = ("{}: Error while sending the following to coqtop:\n{}" + + "\n coqtop output:\n{}" + + "\n Full error text:\n{}") + indent = " " + loc = get_node_location(node) + le = textwrap.indent(str(err.last_sentence), indent) + bef = textwrap.indent(str(err.before), indent) + fe = textwrap.indent(str(err.err), indent) + raise ExtensionError(MSG.format(loc, le, bef, fe)) @staticmethod def merge_coqtop_classes(kept_node, discarded_node): diff --git a/doc/tools/coqrst/regen_readme.py b/doc/tools/coqrst/regen_readme.py index e56882a521..0c15d7334c 100755 --- a/doc/tools/coqrst/regen_readme.py +++ b/doc/tools/coqrst/regen_readme.py @@ -10,6 +10,17 @@ SCRIPT_DIR = path.dirname(path.abspath(__file__)) if __name__ == "__main__" and __package__ is None: sys.path.append(path.dirname(SCRIPT_DIR)) +SPHINX_DIR = path.join(SCRIPT_DIR, "../../sphinx/") +README_TEMPLATE_PATH = path.join(SPHINX_DIR, "README.template.rst") + +if len(sys.argv) == 1: + README_PATH = path.join(SPHINX_DIR, "README.rst") +elif len(sys.argv) == 2: + README_PATH = sys.argv[1] +else: + print ("usage: {} [FILE]".format(sys.argv[0])) + sys.exit(1) + import sphinx from coqrst import coqdomain @@ -23,10 +34,6 @@ def format_docstring(template, obj, *strs): strs = strs + (FIRST_LINE_BLANKS.sub(r"\1\n", docstring),) return template.format(*strs) -SPHINX_DIR = path.join(SCRIPT_DIR, "../../sphinx/") -README_PATH = path.join(SPHINX_DIR, "README.rst") -README_TEMPLATE_PATH = path.join(SPHINX_DIR, "README.template.rst") - def notation_symbol(d): return " :black_nib:" if issubclass(d, coqdomain.NotationObject) else "" diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index 3ff00eaaf3..ddba2edd4a 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -20,6 +20,14 @@ import re import pexpect + +class CoqTopError(Exception): + def __init__(self, err, last_sentence, before): + super().__init__() + self.err = err + self.before = before + self.last_sentence = last_sentence + class CoqTop: """Create an instance of coqtop. @@ -41,13 +49,10 @@ class CoqTop: the ansicolors module) :param args: Additional arugments to coqtop. """ - BOOT = True - if os.getenv('COQBOOT') == "no": - BOOT = False self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN', ""), "coqtop") if not pexpect.utils.which(self.coqtop_bin): raise ValueError("coqtop binary not found: '{}'".format(self.coqtop_bin)) - self.args = (args or []) + ["-boot"] * BOOT + ["-color", "on"] * color + self.args = (args or []) + ["-color", "on"] * color self.coqtop = None def __enter__(self): @@ -63,7 +68,7 @@ class CoqTop: self.coqtop.kill(9) def next_prompt(self): - "Wait for the next coqtop prompt, and return the output preceeding it." + """Wait for the next coqtop prompt, and return the output preceeding it.""" self.coqtop.expect(CoqTop.COQTOP_PROMPT, timeout = 10) return self.coqtop.before @@ -75,13 +80,11 @@ class CoqTop: """ # Suppress newlines, but not spaces: they are significant in notations sentence = re.sub(r"[\r\n]+", " ", sentence).strip() - self.coqtop.sendline(sentence) try: + self.coqtop.sendline(sentence) output = self.next_prompt() - except: - print("Error while sending the following sentence to coqtop: {}".format(sentence)) - raise - # print("Got {}".format(repr(output))) + except Exception as err: + raise CoqTopError(err, sentence, self.coqtop.before) return output def sendmany(*sentences): @@ -19,7 +19,7 @@ (deps (source_tree theories) (source_tree plugins)) - (action (with-stdout-to .vfiles.d (system "%{bin:coqdep} -dyndep opt -noglob -boot `find theories plugins -type f -name *.v`")))) + (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep opt -noglob -boot `find theories plugins -type f -name *.v`")))) (alias (name vodeps) @@ -35,7 +35,7 @@ (rule (targets revision) (deps (:rev-script dev/tools/make_git_revision.sh)) - (action (with-stdout-to revision (run %{rev-script})))) + (action (with-stdout-to revision (bash %{rev-script})))) ; Use summary.log as the target (alias diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 24d161d00a..8756ebfdf2 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -73,6 +73,7 @@ let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) let mkArrow t1 t2 = of_kind (Prod (Anonymous, t1, t2)) +let mkInt i = of_kind (Int i) let mkRef (gr,u) = let open GlobRef in match gr with | ConstRef c -> mkConstU (c,u) @@ -81,6 +82,7 @@ let mkRef (gr,u) = let open GlobRef in match gr with | VarRef x -> mkVar x let applist (f, arg) = mkApp (f, Array.of_list arg) +let applistc f arg = mkApp (f, Array.of_list arg) let isRel sigma c = match kind sigma c with Rel _ -> true | _ -> false let isVar sigma c = match kind sigma c with Var _ -> true | _ -> false @@ -328,7 +330,7 @@ let iter_with_full_binders sigma g f n c = let open Context.Rel.Declaration in match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () + | Construct _ | Int _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c @@ -403,25 +405,17 @@ let compare_cumulative_instances cv_pb nargs_ok variances u u' cstrs = let cmp_inductives cv_pb (mind,ind as spec) nargs u1 u2 cstrs = let open UnivProblem in - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); - cstrs - | Declarations.Polymorphic_ind _ -> - enforce_eq_instances_univs false u1 u2 cstrs - | Declarations.Cumulative_ind cumi -> + match mind.Declarations.mind_variance with + | None -> enforce_eq_instances_univs false u1 u2 cstrs + | Some variances -> let num_param_arity = Reduction.inductive_cumulativity_arguments spec in - let variances = Univ.ACumulativityInfo.variance cumi in compare_cumulative_instances cv_pb (Int.equal num_param_arity nargs) variances u1 u2 cstrs let cmp_constructors (mind, ind, cns as spec) nargs u1 u2 cstrs = let open UnivProblem in - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - cstrs - | Declarations.Polymorphic_ind _ -> - enforce_eq_instances_univs false u1 u2 cstrs - | Declarations.Cumulative_ind cumi -> + match mind.Declarations.mind_variance with + | None -> enforce_eq_instances_univs false u1 u2 cstrs + | Some _ -> let num_cnstr_args = Reduction.constructor_cumulativity_arguments spec in if not (Int.equal num_cnstr_args nargs) then enforce_eq_instances_univs false u1 u2 cstrs diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 49cbc4d7e5..2f4cf7d5d0 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -124,10 +124,12 @@ val mkCase : case_info * t * t * t array -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t val mkArrow : t -> t -> t +val mkInt : Uint63.t -> t val mkRef : GlobRef.t * EInstance.t -> t val applist : t * t list -> t +val applistc : t -> t list -> t val mkProd_or_LetIn : rel_declaration -> t -> t val mkLambda_or_LetIn : rel_declaration -> t -> t 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/evd.ml b/engine/evd.ml index eee2cb700c..f0433d3387 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -852,8 +852,9 @@ let universe_context_set d = UState.context_set d.universes let to_universe_context evd = UState.context evd.universes -let const_univ_entry ~poly evd = UState.const_univ_entry ~poly evd.universes -let ind_univ_entry ~poly evd = UState.ind_univ_entry ~poly evd.universes +let univ_entry ~poly evd = UState.univ_entry ~poly evd.universes + +let const_univ_entry = univ_entry let check_univ_decl ~poly evd decl = UState.check_univ_decl ~poly evd.universes decl diff --git a/engine/evd.mli b/engine/evd.mli index de73144895..d2d18ca486 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -597,12 +597,12 @@ val universes : evar_map -> UGraph.t [Univ.ContextSet.to_context]. *) val to_universe_context : evar_map -> Univ.UContext.t -val const_univ_entry : poly:bool -> evar_map -> Entries.constant_universes_entry +val univ_entry : poly:bool -> evar_map -> Entries.universes_entry -(** NB: [ind_univ_entry] cannot create cumulative entries. *) -val ind_univ_entry : poly:bool -> evar_map -> Entries.inductive_universes +val const_univ_entry : poly:bool -> evar_map -> Entries.universes_entry +[@@ocaml.deprecated "Use [univ_entry]."] -val check_univ_decl : poly:bool -> evar_map -> UState.universe_decl -> Entries.constant_universes_entry +val check_univ_decl : poly:bool -> evar_map -> UState.universe_decl -> Entries.universes_entry val merge_universe_context : evar_map -> UState.t -> evar_map val set_universe_context : evar_map -> UState.t -> evar_map diff --git a/engine/namegen.ml b/engine/namegen.ml index 018eca1ba2..294b61fd3d 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -118,7 +118,7 @@ let head_name sigma c = (* Find the head constant of a constr if any *) Some (Nametab.basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> Some (match lna.(i) with Name id -> id | _ -> assert false) - | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) -> None + | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) | Int _ -> None in hdrec c @@ -163,6 +163,7 @@ let hdchar env sigma c = lowercase_first_char id | Evar _ (* We could do better... *) | Meta _ | Case (_, _, _, _) -> "y" + | Int _ -> "i" in hdrec 0 c diff --git a/engine/proofview.ml b/engine/proofview.ml index cf4224bbdb..a725444e81 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -39,7 +39,7 @@ let proofview p = let compact el ({ solution } as pv) = let nf c = Evarutil.nf_evar solution c in - let nf0 c = EConstr.(to_constr solution (of_constr c)) in + let nf0 c = EConstr.(to_constr ~abort_on_undefined_evars:false solution (of_constr c)) in let size = Evd.fold (fun _ _ i -> i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in let pruned_solution = Evd.drop_all_defined solution in @@ -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/engine/termops.ml b/engine/termops.ml index 137770d8f0..2f766afaa6 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -38,7 +38,7 @@ let set_print_constr f = term_printer := f module EvMap = Evar.Map -let pr_evar_suggested_name evk sigma = +let evar_suggested_name evk sigma = let open Evd in let base_id evk' evi = match evar_ident evk' sigma with @@ -67,7 +67,7 @@ let pr_existential_key sigma evk = let open Evd in match evar_ident evk sigma with | None -> - str "?" ++ Id.print (pr_evar_suggested_name evk sigma) + str "?" ++ Id.print (evar_suggested_name evk sigma) | Some id -> str "?" ++ Id.print id @@ -600,7 +600,7 @@ let map_constr_with_binders_left_to_right sigma g f l c = let open EConstr in match EConstr.kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c + | Construct _ | Int _) -> c | Cast (b,k,t) -> let b' = f l b in let t' = f l t in @@ -681,7 +681,7 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let open EConstr in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> cstr + | Construct _ | Int _) -> cstr | Cast (c,k, t) -> let c' = f l c in let t' = f l t in @@ -1417,11 +1417,9 @@ let prod_applist_assum sigma n c l = | _ -> anomaly (Pp.str "Not enough prod/let's.") in app n [] c l -(* Combinators on judgments *) - -let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } -let on_judgment_value f j = { j with uj_val = f j.uj_val } -let on_judgment_type f j = { j with uj_type = f j.uj_type } +let on_judgment = Environ.on_judgment +let on_judgment_value = Environ.on_judgment_value +let on_judgment_type = Environ.on_judgment_type (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in variables skips let-in's; let-in's in the middle are put in ctx2 *) diff --git a/engine/termops.mli b/engine/termops.mli index 7920af8e0e..dea59e9efc 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -295,8 +295,11 @@ val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.qualid option (** Combinators on judgments *) val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment +[@@ocaml.deprecated "Use [Environ.on_judgment]."] val on_judgment_value : ('c -> 'c) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment +[@@ocaml.deprecated "Use [Environ.on_judgment_value]."] val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment +[@@ocaml.deprecated "Use [Environ.on_judgment_type]."] (** {5 Debug pretty-printers} *) @@ -304,7 +307,7 @@ open Evd val pr_existential_key : evar_map -> Evar.t -> Pp.t -val pr_evar_suggested_name : Evar.t -> evar_map -> Id.t +val evar_suggested_name : Evar.t -> evar_map -> Id.t val pr_evar_info : env -> evar_map -> evar_info -> Pp.t val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.t diff --git a/engine/uState.ml b/engine/uState.ml index 6969d2ba44..77d1896683 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Names +open Univ module UNameMap = Names.Id.Map @@ -24,12 +25,12 @@ module UPairSet = UnivMinim.UPairSet (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : UnivNames.universe_binders * uinfo Univ.LMap.t; - uctx_local : Univ.ContextSet.t; (** The local context of variables *) - uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *) + { uctx_names : UnivNames.universe_binders * uinfo LMap.t; + uctx_local : ContextSet.t; (** The local context of variables *) + uctx_seff_univs : LSet.t; (** Local universes used through private constants *) uctx_univ_variables : UnivSubst.universe_opt_subst; (** The local universes that are unification variables *) - uctx_univ_algebraic : Univ.LSet.t; + uctx_univ_algebraic : LSet.t; (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) @@ -38,11 +39,11 @@ type t = } let empty = - { uctx_names = UNameMap.empty, Univ.LMap.empty; - uctx_local = Univ.ContextSet.empty; - uctx_seff_univs = Univ.LSet.empty; - uctx_univ_variables = Univ.LMap.empty; - uctx_univ_algebraic = Univ.LSet.empty; + { uctx_names = UNameMap.empty, LMap.empty; + uctx_local = ContextSet.empty; + uctx_seff_univs = LSet.empty; + uctx_univ_variables = LMap.empty; + uctx_univ_algebraic = LSet.empty; uctx_universes = UGraph.initial_universes; uctx_initial_universes = UGraph.initial_universes; uctx_weak_constraints = UPairSet.empty; } @@ -52,8 +53,8 @@ let make u = uctx_universes = u; uctx_initial_universes = u} let is_empty ctx = - Univ.ContextSet.is_empty ctx.uctx_local && - Univ.LMap.is_empty ctx.uctx_univ_variables + ContextSet.is_empty ctx.uctx_local && + LMap.is_empty ctx.uctx_univ_variables let uname_union s t = if s == t then s @@ -67,29 +68,29 @@ let union ctx ctx' = if ctx == ctx' then ctx else if is_empty ctx' then ctx else - let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in - let seff = Univ.LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in + let local = ContextSet.union ctx.uctx_local ctx'.uctx_local in + let seff = LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in let names = uname_union (fst ctx.uctx_names) (fst ctx'.uctx_names) in - let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) - (Univ.ContextSet.levels ctx.uctx_local) in - let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in + let newus = LSet.diff (ContextSet.levels ctx'.uctx_local) + (ContextSet.levels ctx.uctx_local) in + let newus = LSet.diff newus (LMap.domain ctx.uctx_univ_variables) in let weak = UPairSet.union ctx.uctx_weak_constraints ctx'.uctx_weak_constraints in let declarenew g = - Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g + LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in - let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + let names_rev = LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; uctx_univ_variables = - Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = - Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; uctx_initial_universes = declarenew ctx.uctx_initial_universes; uctx_universes = (if local == ctx.uctx_local then ctx.uctx_universes else - let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + let cstrsr = ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes)); uctx_weak_constraints = weak} @@ -97,26 +98,18 @@ let context_set ctx = ctx.uctx_local let constraints ctx = snd ctx.uctx_local -let context ctx = Univ.ContextSet.to_context ctx.uctx_local +let context ctx = ContextSet.to_context ctx.uctx_local -let const_univ_entry ~poly uctx = +let univ_entry ~poly uctx = let open Entries in if poly then let (binders, _) = uctx.uctx_names in let uctx = context uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in - Polymorphic_const_entry (nas, uctx) - else Monomorphic_const_entry (context_set uctx) + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in + Polymorphic_entry (nas, uctx) + else Monomorphic_entry (context_set uctx) -(* does not support cumulativity since you need more info *) -let ind_univ_entry ~poly uctx = - let open Entries in - if poly then - let (binders, _) = uctx.uctx_names in - let uctx = context uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in - Polymorphic_ind_entry (nas, uctx) - else Monomorphic_ind_entry (context_set uctx) +let const_univ_entry = univ_entry let of_context_set ctx = { empty with uctx_local = ctx } @@ -132,19 +125,19 @@ let add_uctx_names ?loc s l (names, names_rev) = if UNameMap.mem s names then user_err ?loc ~hdr:"add_uctx_names" Pp.(str "Universe " ++ Names.Id.print s ++ str" already bound."); - (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) + (UNameMap.add s l names, LMap.add l { uname = Some s; uloc = loc } names_rev) let add_uctx_loc l loc (names, names_rev) = match loc with | None -> (names, names_rev) - | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev) + | Some _ -> (names, LMap.add l { uname = None; uloc = loc } names_rev) let of_binders b = let ctx = empty in let rmap = UNameMap.fold (fun id l rmap -> - Univ.LMap.add l { uname = Some id; uloc = None } rmap) - b Univ.LMap.empty + LMap.add l { uname = Some id; uloc = None } rmap) + b LMap.empty in { ctx with uctx_names = b, rmap } @@ -157,7 +150,6 @@ let invent_name (named,cnt) u = aux cnt let universe_binders ctx = - let open Univ in let named, rev = ctx.uctx_names in let named, _ = LSet.fold (fun u named -> match LMap.find u rev with @@ -169,7 +161,7 @@ let universe_binders ctx = named let instantiate_variable l b v = - try v := Univ.LMap.set l (Some b) !v + try v := LMap.set l (Some b) !v with Not_found -> assert false exception UniversesDiffer @@ -177,7 +169,6 @@ exception UniversesDiffer let drop_weak_constraints = ref false let process_universe_constraints ctx cstrs = - let open Univ in let open UnivSubst in let open UnivProblem in let univs = ctx.uctx_universes in @@ -190,9 +181,9 @@ let process_universe_constraints ctx cstrs = | UEq (u, v) -> UEq (subst_univs_universe normalize u, subst_univs_universe normalize v) | ULe (u, v) -> ULe (subst_univs_universe normalize u, subst_univs_universe normalize v) in - let is_local l = Univ.LMap.mem l !vars in + let is_local l = LMap.mem l !vars in let varinfo x = - match Univ.Universe.level x with + match Universe.level x with | None -> Inl x | Some l -> Inr l in @@ -206,27 +197,27 @@ let process_universe_constraints ctx cstrs = else if not (UGraph.check_eq_level univs l' r') then (* Two rigid/global levels, none of them being local, one of them being Prop/Set, disallow *) - if Univ.Level.is_small l' || Univ.Level.is_small r' then - raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + if Level.is_small l' || Level.is_small r' then + raise (UniverseInconsistency (Eq, l, r, None)) else if fo then raise UniversesDiffer in - Univ.enforce_eq_level l' r' local + enforce_eq_level l' r' local in let equalize_universes l r local = match varinfo l, varinfo r with | Inr l', Inr r' -> equalize_variables false l l' r r' local | Inr l, Inl r | Inl r, Inr l -> - let alg = Univ.LSet.mem l ctx.uctx_univ_algebraic in - let inst = Univ.univ_level_rem l r r in + let alg = LSet.mem l ctx.uctx_univ_algebraic in + let inst = univ_level_rem l r r in if alg then (instantiate_variable l inst vars; local) else - let lu = Univ.Universe.make l in - if Univ.univ_level_mem l r then - Univ.enforce_leq inst lu local - else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) + let lu = Universe.make l in + if univ_level_mem l r then + enforce_leq inst lu local + else raise (UniverseInconsistency (Eq, lu, r, None)) | Inl _, Inl _ (* both are algebraic *) -> if UGraph.check_eq univs l r then local - else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + else raise (UniverseInconsistency (Eq, l, r, None)) in let unify_universes cst local = let cst = nf_constraint cst in @@ -237,29 +228,29 @@ let process_universe_constraints ctx cstrs = if UGraph.check_leq univs l r then (* Keep Prop/Set <= var around if var might be instantiated by prop or set later. *) - match Univ.Universe.level l, Univ.Universe.level r with + match Universe.level l, Universe.level r with | Some l, Some r -> - Univ.Constraint.add (l, Univ.Le, r) local + Constraint.add (l, Le, r) local | _ -> local else - begin match Univ.Universe.level r with + begin match Universe.level r with | None -> user_err Pp.(str "Algebraic universe on the right") | Some r' -> - if Univ.Level.is_small r' then - if not (Univ.Universe.is_levels l) + if Level.is_small r' then + if not (Universe.is_levels l) then - raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + raise (UniverseInconsistency (Le, l, r, None)) else - let levels = Univ.Universe.levels l in + let levels = Universe.levels l in let fold l' local = - let l = Univ.Universe.make l' in - if Univ.Level.is_small l' || is_local l' then + let l = Universe.make l' in + if Level.is_small l' || is_local l' then equalize_variables false l l' r r' local - else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + else raise (UniverseInconsistency (Le, l, r, None)) in - Univ.LSet.fold fold levels local + LSet.fold fold levels local else - Univ.enforce_leq l r local + enforce_leq l r local end | ULub (l, r) -> equalize_variables true (Universe.make l) l (Universe.make r) r local @@ -268,26 +259,26 @@ let process_universe_constraints ctx cstrs = | UEq (l, r) -> equalize_universes l r local in let local = - UnivProblem.Set.fold unify_universes cstrs Univ.Constraint.empty + UnivProblem.Set.fold unify_universes cstrs Constraint.empty in !vars, !weak, local let add_constraints ctx cstrs = let univs, local = ctx.uctx_local in - let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> - let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstrs' = Constraint.fold (fun (l,d,r) acc -> + let l = Universe.make l and r = Universe.make r in let cstr' = let open UnivProblem in match d with - | Univ.Lt -> - ULe (Univ.Universe.super l, r) - | Univ.Le -> ULe (l, r) - | Univ.Eq -> UEq (l, r) + | Lt -> + ULe (Universe.super l, r) + | Le -> ULe (l, r) + | Eq -> UEq (l, r) in UnivProblem.Set.add cstr' acc) cstrs UnivProblem.Set.empty in let vars, weak, local' = process_universe_constraints ctx cstrs' in { ctx with - uctx_local = (univs, Univ.Constraint.union local local'); + uctx_local = (univs, Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes; uctx_weak_constraints = weak; } @@ -299,7 +290,7 @@ let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in let vars, weak, local' = process_universe_constraints ctx cstrs in { ctx with - uctx_local = (univs, Univ.Constraint.union local local'); + uctx_local = (univs, Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes; uctx_weak_constraints = weak; } @@ -307,14 +298,14 @@ let add_universe_constraints ctx cstrs = let constrain_variables diff ctx = let univs, local = ctx.uctx_local in let univs, vars, local = - Univ.LSet.fold + LSet.fold (fun l (univs, vars, cstrs) -> try - match Univ.LMap.find l vars with + match LMap.find l vars with | Some u -> - (Univ.LSet.add l univs, - Univ.LMap.remove l vars, - Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs) + (LSet.add l univs, + LMap.remove l vars, + Constraint.add (l, Eq, Option.get (Universe.level u)) cstrs) | None -> (univs, vars, cstrs) with Not_found | Option.IsNone -> (univs, vars, cstrs)) diff (univs, ctx.uctx_univ_variables, local) @@ -324,14 +315,14 @@ let constrain_variables diff ctx = let qualid_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try Some (Libnames.qualid_of_ident (Option.get (Univ.LMap.find l map_rev).uname)) + try Some (Libnames.qualid_of_ident (Option.get (LMap.find l map_rev).uname)) with Not_found | Option.IsNone -> UnivNames.qualid_of_level l let pr_uctx_level uctx l = match qualid_of_level uctx l with | Some qid -> Libnames.pr_qualid qid - | None -> Univ.Level.pr l + | None -> Level.pr l type ('a, 'b) gen_universe_decl = { univdecl_instance : 'a; (* Declared universes *) @@ -340,16 +331,15 @@ type ('a, 'b) gen_universe_decl = { univdecl_extensible_constraints : bool (* Can new constraints be added *) } type universe_decl = - (lident list, Univ.Constraint.t) gen_universe_decl + (lident list, Constraint.t) gen_universe_decl let default_univ_decl = { univdecl_instance = []; univdecl_extensible_instance = true; - univdecl_constraints = Univ.Constraint.empty; + univdecl_constraints = Constraint.empty; univdecl_extensible_constraints = true } let error_unbound_universes left uctx = - let open Univ in let n = LSet.cardinal left in let loc = try @@ -365,7 +355,6 @@ let error_unbound_universes left uctx = str" unbound.")) let universe_context ~names ~extensible uctx = - let open Univ in let levels = ContextSet.levels uctx.uctx_local in let newinst, left = List.fold_right @@ -388,7 +377,6 @@ let universe_context ~names ~extensible uctx = let check_universe_context_set ~names ~extensible uctx = if extensible then () else - let open Univ in let left = List.fold_left (fun left { CAst.loc; v = id } -> let l = try UNameMap.find id (fst uctx.uctx_names) @@ -415,7 +403,7 @@ let check_mono_univ_decl uctx decl = if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints - (Univ.ContextSet.constraints uctx.uctx_local); + (ContextSet.constraints uctx.uctx_local); uctx.uctx_local let check_univ_decl ~poly uctx decl = @@ -425,20 +413,19 @@ let check_univ_decl ~poly uctx decl = if poly then let (binders, _) = uctx.uctx_names in let uctx = universe_context ~names ~extensible uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in - Entries.Polymorphic_const_entry (nas, uctx) + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in + Entries.Polymorphic_entry (nas, uctx) else let () = check_universe_context_set ~names ~extensible uctx in - Entries.Monomorphic_const_entry uctx.uctx_local + Entries.Monomorphic_entry uctx.uctx_local in if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints - (Univ.ContextSet.constraints uctx.uctx_local); + (ContextSet.constraints uctx.uctx_local); ctx let restrict_universe_context (univs, csts) keep = - let open Univ in let removed = LSet.diff univs keep in if LSet.is_empty removed then univs, csts else @@ -453,8 +440,8 @@ let restrict_universe_context (univs, csts) keep = (LSet.inter univs keep, csts) let restrict ctx vars = - let vars = Univ.LSet.union vars ctx.uctx_seff_univs in - let vars = Names.Id.Map.fold (fun na l vars -> Univ.LSet.add l vars) + let vars = LSet.union vars ctx.uctx_seff_univs in + let vars = Names.Id.Map.fold (fun na l vars -> LSet.add l vars) (fst ctx.uctx_names) vars in let uctx' = restrict_universe_context ctx.uctx_local vars in @@ -463,9 +450,9 @@ let restrict ctx vars = let demote_seff_univs entry uctx = let open Entries in match entry.const_entry_universes with - | Polymorphic_const_entry _ -> uctx - | Monomorphic_const_entry (univs, _) -> - let seff = Univ.LSet.union uctx.uctx_seff_univs univs in + | Polymorphic_entry _ -> uctx + | Monomorphic_entry (univs, _) -> + let seff = LSet.union uctx.uctx_seff_univs univs in { uctx with uctx_seff_univs = seff } type rigid = @@ -483,7 +470,6 @@ let univ_flexible_alg = UnivFlexible true or defined separately. In the later case, there is no extension, see [emit_side_effects] for example. *) let merge ?loc ~sideff ~extend rigid uctx ctx' = - let open Univ in let levels = ContextSet.levels ctx' in let uctx = if not extend then uctx else @@ -527,7 +513,7 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = uctx_initial_universes = initial } let merge_subst uctx s = - { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } + { uctx with uctx_univ_variables = LMap.subst_union uctx.uctx_univ_variables s } let emit_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in @@ -536,14 +522,14 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = UnivGen.fresh_level () in - let ctx' = Univ.ContextSet.add_universe u ctx in + let ctx' = ContextSet.add_universe u ctx in let uctx', pred = match rigid with | UnivRigid -> uctx, true | UnivFlexible b -> - let uvars' = Univ.LMap.add u None uvars in + let uvars' = LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = Univ.LSet.add u avars}, false + uctx_univ_algebraic = LSet.add u avars}, false else {uctx with uctx_univ_variables = uvars'}, false in let names = @@ -574,12 +560,11 @@ let add_global_univ uctx u = let univs = UGraph.add_universe u true uctx.uctx_universes in - { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; + { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; uctx_universes = univs } let make_flexible_variable ctx ~algebraic u = - let open Univ in let {uctx_local = cstrs; uctx_univ_variables = uvars; uctx_univ_algebraic = avars; uctx_universes=g; } = ctx in assert (try LMap.find u uvars == None with Not_found -> true); @@ -608,48 +593,47 @@ let make_flexible_variable ctx ~algebraic u = uctx_univ_algebraic = avars'} let make_nonalgebraic_variable ctx u = - { ctx with uctx_univ_algebraic = Univ.LSet.remove u ctx.uctx_univ_algebraic } + { ctx with uctx_univ_algebraic = LSet.remove u ctx.uctx_univ_algebraic } let make_flexible_nonalgebraic ctx = - {ctx with uctx_univ_algebraic = Univ.LSet.empty} + {ctx with uctx_univ_algebraic = LSet.empty} let is_sort_variable uctx s = match s with | Sorts.Type u -> - (match Univ.universe_level u with + (match universe_level u with | Some l as x -> - if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x + if LSet.mem l (ContextSet.levels uctx.uctx_local) then x else None | None -> None) | _ -> None let subst_univs_context_with_def def usubst (ctx, cst) = - (Univ.LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) + (LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) let is_trivial_leq (l,d,r) = - Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) + Level.is_prop l && (d == Le || (d == Lt && Level.is_set r)) (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = - let open Univ in - if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then + if Level.equal Level.prop l && d == Lt && not (Level.equal Level.set r) then (Level.set, d, r) else cstr let refresh_constraints univs (ctx, cstrs) = let cstrs', univs' = - Univ.Constraint.fold (fun c (cstrs', univs as acc) -> + Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in if is_trivial_leq c then acc - else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) - cstrs (Univ.Constraint.empty, univs) + else (Constraint.add c cstrs', UGraph.enforce_constraint c univs)) + cstrs (Constraint.empty, univs) in ((ctx, cstrs'), univs') let normalize_variables uctx = let normalized_variables, def, subst = UnivSubst.normalize_univ_variables uctx.uctx_univ_variables in - let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + let ctx_local = subst_univs_context_with_def def (make_subst subst) uctx.uctx_local in let ctx_local', univs = refresh_constraints uctx.uctx_initial_universes ctx_local in subst, { uctx with uctx_local = ctx_local'; uctx_univ_variables = normalized_variables; @@ -657,17 +641,17 @@ let normalize_variables uctx = let abstract_undefined_variables uctx = let vars' = - Univ.LMap.fold (fun u v acc -> - if v == None then Univ.LSet.remove u acc + LMap.fold (fun u v acc -> + if v == None then LSet.remove u acc else acc) uctx.uctx_univ_variables uctx.uctx_univ_algebraic - in { uctx with uctx_local = Univ.ContextSet.empty; + in { uctx with uctx_local = ContextSet.empty; uctx_univ_algebraic = vars' } let fix_undefined_variables uctx = let algs', vars' = - Univ.LMap.fold (fun u v (algs, vars as acc) -> - if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) + LMap.fold (fun u v (algs, vars as acc) -> + if v == None then (LSet.remove u algs, LMap.remove u vars) else acc) uctx.uctx_univ_variables (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) @@ -677,20 +661,20 @@ let fix_undefined_variables uctx = let refresh_undefined_univ_variables uctx = let subst, ctx' = UnivGen.fresh_universe_context_set_instance uctx.uctx_local in - let subst_fn u = Univ.subst_univs_level_level subst u in - let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (subst_fn u) acc) - uctx.uctx_univ_algebraic Univ.LSet.empty + let subst_fn u = subst_univs_level_level subst u in + let alg = LSet.fold (fun u acc -> LSet.add (subst_fn u) acc) + uctx.uctx_univ_algebraic LSet.empty in let vars = - Univ.LMap.fold + LMap.fold (fun u v acc -> - Univ.LMap.add (subst_fn u) - (Option.map (Univ.subst_univs_level_universe subst) v) acc) - uctx.uctx_univ_variables Univ.LMap.empty + LMap.add (subst_fn u) + (Option.map (subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables LMap.empty in let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.uctx_weak_constraints UPairSet.empty in - let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) - (Univ.ContextSet.levels ctx') g in + let declare g = LSet.fold (fun u g -> UGraph.add_universe u false g) + (ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; @@ -708,7 +692,7 @@ let minimize uctx = normalize_context_set uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic uctx.uctx_weak_constraints in - if Univ.ContextSet.equal us' uctx.uctx_local then uctx + if ContextSet.equal us' uctx.uctx_local then uctx else let us', universes = refresh_constraints uctx.uctx_initial_universes us' diff --git a/engine/uState.mli b/engine/uState.mli index 5170184ef4..a358813825 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -64,12 +64,11 @@ val constraints : t -> Univ.Constraint.t val context : t -> Univ.UContext.t (** Shorthand for {!context_set} with {!Context_set.to_context}. *) -val const_univ_entry : poly:bool -> t -> Entries.constant_universes_entry +val univ_entry : poly:bool -> t -> Entries.universes_entry (** Pick from {!context} or {!context_set} based on [poly]. *) -val ind_univ_entry : poly:bool -> t -> Entries.inductive_universes -(** Pick from {!context} or {!context_set} based on [poly]. - Cannot create cumulative entries. *) +val const_univ_entry : poly:bool -> t -> Entries.universes_entry +[@@ocaml.deprecated "Use [univ_entry]."] (** {5 Constraints handling} *) @@ -177,7 +176,7 @@ val default_univ_decl : universe_decl When polymorphic, the universes corresponding to [decl.univdecl_instance] come first in the order defined by that list. *) -val check_univ_decl : poly:bool -> t -> universe_decl -> Entries.constant_universes_entry +val check_univ_decl : poly:bool -> t -> universe_decl -> Entries.universes_entry val check_mono_univ_decl : t -> universe_decl -> Univ.ContextSet.t 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..f46ddffd6e 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 = @@ -719,6 +1368,9 @@ let parse_parsable entry p = let get_loc () = try let cnt = Stream.count ts in + (* Ensure that the token at location cnt has been peeked so that + the location function knows about it *) + let _ = Stream.peek ts in let loc = fun_loc cnt in if !token_count - 1 <= cnt then loc else Loc.merge loc (fun_loc (!token_count - 1)) @@ -746,95 +1398,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 +1432,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 205f4455a3..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 *) @@ -546,5 +545,5 @@ let islave_init ~opts extra_args = let () = let open Coqtop in - let custom = { init = islave_init; run = loop; opts = Coqargs.default_opts } in + let custom = { init = islave_init; run = loop; opts = Coqargs.default } in start_coq custom diff --git a/ide/session.ml b/ide/session.ml index 805e1d38a7..e2427a9b51 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -145,10 +145,12 @@ let set_buffer_handlers buffer#apply_tag Tags.Script.edit_zone ~start:(get_start()) ~stop:(get_stop()) end in - let backto_before_error it = + let processed_sentence_just_before_error it = let rec aux old it = - if it#is_start || not(it#has_tag Tags.Script.error_bg) then old - else aux it it#backward_char in + if it#is_start then None + else if it#has_tag Tags.Script.processed then Some old + else if it#has_tag Tags.Script.error_bg then aux it it#backward_char + else None in aux it it in let insert_cb it s = if String.length s = 0 then () else begin Minilib.log ("insert_cb " ^ string_of_int it#offset); @@ -156,12 +158,16 @@ let set_buffer_handlers let () = update_prev it in if it#has_tag Tags.Script.to_process then cancel_signal "Altering the script being processed in not implemented" + else if it#has_tag Tags.Script.incomplete then + cancel_signal "Altering the script being processed in not implemented" else if it#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if it#has_tag Tags.Script.error_bg then begin - let prev_sentence_end = backto_before_error it in - let text_mark = add_mark prev_sentence_end in - call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) + match processed_sentence_just_before_error it with + | None -> () + | Some prev_sentence_end -> + let text_mark = add_mark prev_sentence_end in + call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) end end in let delete_cb ~start ~stop = Minilib.log (Printf.sprintf "delete_cb %d %d" start#offset stop#offset); @@ -171,14 +177,18 @@ let set_buffer_handlers let text_mark = add_mark min_iter in let rec aux min_iter = if min_iter#equal max_iter then () + else if min_iter#has_tag Tags.Script.incomplete then + cancel_signal "Altering the script being processed in not implemented" else if min_iter#has_tag Tags.Script.to_process then cancel_signal "Altering the script being processed in not implemented" else if min_iter#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if min_iter#has_tag Tags.Script.error_bg then - let prev_sentence_end = backto_before_error min_iter in - let text_mark = add_mark prev_sentence_end in - call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) + match processed_sentence_just_before_error min_iter with + | None -> () + | Some prev_sentence_end -> + let text_mark = add_mark prev_sentence_end in + call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else aux min_iter#forward_char in aux min_iter in let begin_action_cb () = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 13078840ef..8e49800982 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -967,6 +967,8 @@ let rec extern inctx (custom,scopes as allscopes) vars r = | GCast (c, c') -> CCast (sub_extern true scopes vars c, map_cast_type (extern_typ scopes vars) c') + | GInt i -> + CPrim(Numeral (Uint63.to_string i,true)) in insert_coercion coercion (CAst.make ?loc c) @@ -1312,6 +1314,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) | PSort s -> GSort s + | PInt i -> GInt i let extern_constr_pattern env sigma pat = extern true (InConstrEntrySomeLevel,(None,[])) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) 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/interp/declare.ml b/interp/declare.ml index 6778fa1e7a..175f9c66df 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -143,7 +143,7 @@ let declare_constant_common id cst = update_tables c; c -let default_univ_entry = Monomorphic_const_entry Univ.ContextSet.empty +let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); @@ -156,8 +156,8 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = let is_poly de = match de.const_entry_universes with - | Monomorphic_const_entry _ -> false - | Polymorphic_const_entry _ -> true + | Monomorphic_entry _ -> false + | Polymorphic_entry _ -> true in let in_section = Lib.sections_are_opened () in let export, decl = (* We deal with side effects *) @@ -217,8 +217,8 @@ let cache_variable ((sp,_),o) = section-local definition, but it's not enforced by typing *) let (body, uctx), () = Future.force de.const_entry_body in let poly, univs = match de.const_entry_universes with - | Monomorphic_const_entry uctx -> false, uctx - | Polymorphic_const_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx + | Monomorphic_entry uctx -> false, uctx + | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx in let univs = Univ.ContextSet.union uctx univs in (* We must declare the universe constraints before type-checking the @@ -328,21 +328,15 @@ let dummy_inductive_entry m = { mind_entry_record = None; mind_entry_finite = Declarations.BiFinite; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; - mind_entry_universes = Monomorphic_ind_entry Univ.ContextSet.empty; + mind_entry_universes = default_univ_entry; + mind_entry_variance = None; mind_entry_private = None; } (* reinfer subtyping constraints for inductive after section is dischared. *) -let infer_inductive_subtyping mind_ent = - match mind_ent.mind_entry_universes with - | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ -> - mind_ent - | Cumulative_ind_entry (_, cumi) -> - begin - let env = Global.env () in - (* let (env'', typed_params) = Typeops.infer_local_decls env' (mind_ent.mind_entry_params) in *) - InferCumulativity.infer_inductive env mind_ent - end +let rebuild_inductive mind_ent = + let env = Global.env () in + InferCumulativity.infer_inductive env mind_ent let inInductive : mutual_inductive_entry -> obj = declare_object {(default_object "INDUCTIVE") with @@ -352,25 +346,19 @@ let inInductive : mutual_inductive_entry -> obj = classify_function = (fun a -> Substitute (dummy_inductive_entry a)); subst_function = ident_subst_function; discharge_function = discharge_inductive; - rebuild_function = infer_inductive_subtyping } + rebuild_function = rebuild_inductive } let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = let id = Label.to_id label in - let univs = match univs with - | Monomorphic_ind_entry _ -> + let univs, u = match univs with + | Monomorphic_entry _ -> (* Global constraints already defined through the inductive *) - Monomorphic_const_entry Univ.ContextSet.empty - | Polymorphic_ind_entry (nas, ctx) -> - Polymorphic_const_entry (nas, ctx) - | Cumulative_ind_entry (nas, ctx) -> - Polymorphic_const_entry (nas, Univ.CumulativityInfo.univ_context ctx) - in - let term, types = match univs with - | Monomorphic_const_entry _ -> term, types - | Polymorphic_const_entry (_, ctx) -> - let u = Univ.UContext.instance ctx in - Vars.subst_instance_constr u term, Vars.subst_instance_constr u types + default_univ_entry, Univ.Instance.empty + | Polymorphic_entry (nas, ctx) -> + Polymorphic_entry (nas, ctx), Univ.UContext.instance ctx in + let term = Vars.subst_instance_constr u term in + let types = Vars.subst_instance_constr u types in let entry = definition_entry ~types ~univs term in let cst = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in @@ -442,6 +430,9 @@ let assumption_message id = discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") +let register_message id = + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is registered") + (** Monomorphic universes need to survive sections. *) let input_universe_context : Univ.ContextSet.t -> Libobject.obj = diff --git a/interp/declare.mli b/interp/declare.mli index 468e056909..6f53d6872b 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -43,7 +43,7 @@ type internal_flag = (* Defaut definition entries, transparent with no secctx or proj information *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> - ?univs:Entries.constant_universes_entry -> + ?univs:Entries.universes_entry -> ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry (** [declare_constant id cd] declares a global declaration @@ -58,7 +58,7 @@ val declare_constant : val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> ?local:bool -> Id.t -> ?types:constr -> - constr Entries.in_constant_universes_entry -> Constant.t + constr Entries.in_universes_entry -> Constant.t (** Since transparent constants' side effects are globally declared, we * need that *) @@ -74,6 +74,7 @@ val declare_mind : mutual_inductive_entry -> Libobject.object_name * bool val definition_message : Id.t -> unit val assumption_message : Id.t -> unit +val register_message : Id.t -> unit val fixpoint_message : int array option -> Id.t list -> unit val cofixpoint_message : Id.t list -> unit val recursive_message : bool (** true = fixpoint *) -> diff --git a/interp/discharge.ml b/interp/discharge.ml index eeda5a6867..353b0f6057 100644 --- a/interp/discharge.ml +++ b/interp/discharge.ml @@ -76,18 +76,16 @@ let process_inductive info modlist mib = let nparamdecls = Context.Rel.length mib.mind_params_ctxt in let subst, ind_univs = match mib.mind_universes with - | Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx - | Polymorphic_ind auctx -> + | Monomorphic ctx -> Univ.empty_level_subst, Monomorphic_entry ctx + | Polymorphic auctx -> let subst, auctx = Lib.discharge_abstract_universe_context info auctx in let nas = Univ.AUContext.names auctx in let auctx = Univ.AUContext.repr auctx in - subst, Polymorphic_ind_entry (nas, auctx) - | Cumulative_ind cumi -> - let auctx = Univ.ACumulativityInfo.univ_context cumi in - let subst, auctx = Lib.discharge_abstract_universe_context info auctx in - let nas = Univ.AUContext.names auctx in - let auctx = Univ.AUContext.repr auctx in - subst, Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context auctx) + subst, Polymorphic_entry (nas, auctx) + in + let variance = match mib.mind_variance with + | None -> None + | Some _ -> Some (InferCumulativity.dummy_variance ind_univs) in let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in let inds = @@ -114,6 +112,7 @@ let process_inductive info modlist mib = mind_entry_params = params'; mind_entry_inds = inds'; mind_entry_private = mib.mind_private; + mind_entry_variance = variance; mind_entry_universes = ind_univs } diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index f5be0ddbae..a537b4848c 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -101,6 +101,7 @@ let type_of_logical_kind = function | Property | Proposition | Corollary -> "thm") + | IsPrimitive -> "prim" let type_of_global_ref gr = if Typeclasses.is_class gr then diff --git a/interp/impargs.ml b/interp/impargs.ml index 8a89bcdf26..6fd52d98dd 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -120,12 +120,7 @@ let argument_position_eq p1 p2 = match p1, p2 with | Hyp h1, Hyp h2 -> Int.equal h1 h2 | _ -> false -let explicitation_eq ex1 ex2 = match ex1, ex2 with -| ExplByPos (i1, id1), ExplByPos (i2, id2) -> - Int.equal i1 i2 && Option.equal Id.equal id1 id2 -| ExplByName id1, ExplByName id2 -> - Id.equal id1 id2 -| _ -> false +let explicitation_eq = Constrexpr_ops.explicitation_eq type implicit_explanation = | DepRigid of argument_position @@ -200,7 +195,7 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> if strict then () else iter_with_full_binders sigma push_lift (frec false) ed c - | Proj (p,c) when rig -> + | Proj (p, _) when rig -> if strict then () else iter_with_full_binders sigma push_lift (frec false) ed c | Case _ when rig -> @@ -225,7 +220,7 @@ let rec is_rigid_head sigma t = match kind sigma t with | Fix ((fi,i),_) -> is_rigid_head sigma (args.(fi.(i))) | _ -> is_rigid_head sigma f) | Lambda _ | LetIn _ | Construct _ | CoFix _ | Fix _ - | Prod _ | Meta _ | Cast _ -> assert false + | Prod _ | Meta _ | Cast _ | Int _ -> assert false let is_rigid env sigma t = let open Context.Rel.Declaration in @@ -380,7 +375,7 @@ let flatten_explicitations l autoimps = | (Name id,_)::imps -> let value, l' = try - let eq = explicitation_eq in + let eq = Constrexpr_ops.explicitation_eq in let flags = List.assoc_f eq (ExplByName id) l in Some (Some id, flags), List.remove_assoc_f eq (ExplByName id) l with Not_found -> assoc_by_pos k l diff --git a/interp/impargs.mli b/interp/impargs.mli index 4afc2af5e9..43c26b024f 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -138,4 +138,5 @@ val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool + [@@ocaml.deprecated "Use Constrexpr_ops.explicitation_eq instead (since 8.10)"] (** Equality on [explicitation]. *) diff --git a/interp/modintern.ml b/interp/modintern.ml index 60056dfd90..2f516f4f3c 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -107,12 +107,12 @@ let transl_with_decl env base kind = function let c, ectx = interp_constr env sigma c in let poly = lookup_polymorphism env base kind fqid in begin match UState.check_univ_decl ~poly ectx udecl with - | Entries.Polymorphic_const_entry (nas, ctx) -> + | Entries.Polymorphic_entry (nas, ctx) -> let inst, ctx = Univ.abstract_universes nas ctx in let c = EConstr.Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in let c = EConstr.to_constr sigma c in WithDef (fqid,(c, Some ctx)), Univ.ContextSet.empty - | Entries.Monomorphic_const_entry ctx -> + | Entries.Monomorphic_entry ctx -> let c = EConstr.to_constr sigma c in WithDef (fqid,(c, None)), ctx end diff --git a/interp/notation.ml b/interp/notation.ml index ca27d439fb..bc68d97bb8 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -574,6 +574,7 @@ type target_kind = | Int of int_ty (* Coq.Init.Decimal.int + uint *) | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) type string_target_kind = | ListByte @@ -637,6 +638,7 @@ let rec constr_of_glob env sigma g = match DAst.get g with let sigma,c = constr_of_glob env sigma gc in let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in sigma,mkApp (c, Array.of_list cl) + | Glob_term.GInt i -> sigma, mkInt i | _ -> raise NotAValidPrimToken @@ -649,6 +651,7 @@ let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | Int i -> DAst.make ?loc (Glob_term.GInt i) | _ -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedTerm c)) let no_such_prim_token uninterpreted_token_kind ?loc ty = @@ -683,6 +686,16 @@ let uninterp to_raw o (Glob_term.AnyGlobConstr n) = end +(** Conversion from bigint to int63 *) +let rec int63_of_pos_bigint i = + let open Bigint in + if equal i zero then Uint63.of_int 0 + else + let (quo,rem) = div2_with_rest i in + if rem then Uint63.add (Uint63.of_int 1) + (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) + else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) + module Numeral = struct (** * Numeral notation *) open PrimTokenNotation @@ -838,6 +851,32 @@ let bigint_of_z z = match Constr.kind z with end | _ -> raise NotAValidPrimToken +(** Now, [Int63] from/to bigint *) + +let int63_of_pos_bigint ?loc n = + let i = int63_of_pos_bigint n in + mkInt i + +let error_negative ?loc = + CErrors.user_err ?loc ~hdr:"interp_int63" (Pp.str "int63 are only non-negative numbers.") + +let error_overflow ?loc n = + CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Bigint.to_string n)) + +let interp_int63 ?loc n = + let open Bigint in + if is_pos_or_zero n + then + if less_than n (pow two 63) + then int63_of_pos_bigint ?loc n + else error_overflow ?loc n + else error_negative ?loc + +let bigint_of_int63 c = + match Constr.kind c with + | Int i -> Bigint.of_string (Uint63.to_string i) + | _ -> raise NotAValidPrimToken + let big2raw n = if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) else (Bigint.to_string (Bigint.neg n), false) @@ -856,6 +895,7 @@ let interp o ?loc n = | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) | UInt _ (* n <= 0 *) -> no_such_prim_token "number" ?loc o.ty_name | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) + | Int63 -> interp_int63 ?loc (raw2big n) in let env = Global.env () in let sigma = Evd.from_env env in @@ -877,6 +917,7 @@ let uninterp o n = | (Int _, c) -> rawnum_of_coqint c | (UInt _, c) -> (rawnum_of_coquint c, true) | (Z _, c) -> big2raw (bigint_of_z c) + | (Int63, c) -> big2raw (bigint_of_int63 c) end o n end diff --git a/interp/notation.mli b/interp/notation.mli index a482e00e81..5dcc96dc29 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -127,6 +127,7 @@ type target_kind = | Int of int_ty (* Coq.Init.Decimal.int + uint *) | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) type string_target_kind = | ListByte @@ -320,3 +321,6 @@ val entry_has_ident : notation_entry_level -> bool (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b + +(** Conversion from bigint to int63 *) +val int63_of_pos_bigint : Bigint.bigint -> Uint63.t diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 8d225fe683..7d7e10a05b 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -89,9 +89,11 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with glob_sort_eq s1 s2 | NCast (t1, c1), NCast (t2, c2) -> (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2 +| NInt i1, NInt i2 -> + Uint63.equal i1 i2 | (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NCast _ ), _ -> false + | NRec _ | NSort _ | NCast _ | NInt _), _ -> false (**********************************************************************) (* Re-interpret a notation as a glob_constr, taking care of binders *) @@ -220,6 +222,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) | NRef x -> GRef (x,None) + | NInt i -> GInt i let glob_constr_of_notation_constr ?loc x = let rec aux () x = @@ -435,6 +438,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) | GCast (c,k) -> NCast (aux c,map_cast_type aux k) | GSort s -> NSort s + | GInt i -> NInt i | GHole (w,naming,arg) -> if arg != None then has_ltac := true; NHole (w, naming, arg) @@ -623,6 +627,7 @@ let rec subst_notation_constr subst bound raw = NRec (fk,idl,dll',tl',bl') | NSort _ -> raw + | NInt _ -> raw | NHole (knd, naming, solve) -> let nknd = match knd with @@ -903,11 +908,8 @@ let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) (* TODO: look at the consequences for alp *) alp, add_env alp sigma var (DAst.make @@ GVar id) -let force_cases_pattern c = - DAst.make ?loc:c.CAst.loc (DAst.get c) - let bind_binding_as_term_env alp (terms,termlists,binders,binderlists as sigma) var c = - let pat = try force_cases_pattern (cases_pattern_of_glob_constr Anonymous c) with Not_found -> raise No_match in + let pat = try cases_pattern_of_glob_constr Anonymous c with Not_found -> raise No_match in try (* If already bound to a binder, unify the term and the binder *) let patl' = Id.List.assoc var binders in @@ -1189,6 +1191,7 @@ let rec match_ inner u alp metas sigma a1 a2 = match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 | GSort (GType _), NSort (GType _) when not u -> sigma | GSort s1, NSort s2 when glob_sort_eq s1 s2 -> sigma + | GInt i1, NInt i2 when Uint63.equal i1 i2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, NHole _ -> sigma @@ -1216,7 +1219,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ - | GCast _ ), _ -> raise No_match + | GCast _ | GInt _ ), _ -> raise No_match and match_in u = match_ true u diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 0ef1f267f6..6fe20486dc 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -43,6 +43,7 @@ type notation_constr = notation_constr array * notation_constr array | NSort of glob_sort | NCast of notation_constr * notation_constr cast_type + | NInt of Uint63.t (** Note concerning NList: first constr is iterator, second is terminator; first id is where each argument of the list has to be substituted diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index be2b05da8d..0865487c98 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -36,20 +36,15 @@ void init_arity () { arity[PUSHACC6]=arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]= arity[ENVACC3]=arity[ENVACC4]=arity[PUSHENVACC1]=arity[PUSHENVACC2]= arity[PUSHENVACC3]=arity[PUSHENVACC4]=arity[APPLY1]=arity[APPLY2]= - arity[APPLY3]=arity[RESTART]=arity[OFFSETCLOSUREM2]= + arity[APPLY3]=arity[APPLY4]=arity[RESTART]=arity[OFFSETCLOSUREM2]= arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]= arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]= arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= - arity[ADDINT31]=arity[ADDCINT31]=arity[ADDCARRYCINT31]= - arity[SUBINT31]=arity[SUBCINT31]=arity[SUBCARRYCINT31]= - arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]= - arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]= - arity[HEAD0INT31]=arity[TAIL0INT31]= - arity[COMPINT31]=arity[DECOMPINT31]= - arity[ORINT31]=arity[ANDINT31]=arity[XORINT31]=0; + arity[ADDINT63]=arity[SUBINT63]=arity[LTINT63]=arity[LEINT63]= + arity[ISINT]=arity[AREINT2]=0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= @@ -58,10 +53,20 @@ void init_arity () { arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ISCONST]=arity[ENSURESTACKCAPACITY]=1; + arity[BRANCH]=arity[ENSURESTACKCAPACITY]= + arity[CHECKADDINT63]=arity[CHECKADDCINT63]=arity[CHECKADDCARRYCINT63]= + arity[CHECKSUBINT63]=arity[CHECKSUBCINT63]=arity[CHECKSUBCARRYCINT63]= + arity[CHECKMULINT63]=arity[CHECKMULCINT63]= + arity[CHECKDIVINT63]=arity[CHECKMODINT63]=arity[CHECKDIVEUCLINT63]= + arity[CHECKDIV21INT63]= + arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= + arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= + arity[CHECKLSLINT63CONST1]=arity[CHECKLSRINT63CONST1]= + arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= + arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[ARECONST]=arity[PROJ]=2; + arity[PROJ]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 638d6b5ab5..5a233e6178 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -29,6 +29,7 @@ void init_arity(); value coq_tcode_of_code(value code); value coq_makeaccu (value i); value coq_pushpop (value i); +value coq_accucond (value i); value coq_is_accumulate_code(value code); #endif /* _COQ_FIX_CODE_ */ diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h index d92e85fdf8..c7abedaed6 100644 --- a/kernel/byterun/coq_instruct.h +++ b/kernel/byterun/coq_instruct.h @@ -26,7 +26,7 @@ enum instructions { ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, PUSH_RETADDR, - APPLY, APPLY1, APPLY2, APPLY3, + APPLY, APPLY1, APPLY2, APPLY3, APPLY4, APPTERM, APPTERM1, APPTERM2, APPTERM3, RETURN, RESTART, GRAB, GRABREC, CLOSURE, CLOSUREREC, CLOSURECOFIX, @@ -46,15 +46,21 @@ enum instructions { MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, /* spiwack: */ BRANCH, - ADDINT31, ADDCINT31, ADDCARRYCINT31, - SUBINT31, SUBCINT31, SUBCARRYCINT31, - MULCINT31, MULINT31, DIV21INT31, DIVINT31, - ADDMULDIVINT31, COMPAREINT31, - HEAD0INT31, TAIL0INT31, - ISCONST, ARECONST, - COMPINT31, DECOMPINT31, - ORINT31, ANDINT31, XORINT31, -/* /spiwack */ + CHECKADDINT63, ADDINT63, CHECKADDCINT63, CHECKADDCARRYCINT63, + CHECKSUBINT63, SUBINT63, CHECKSUBCINT63, CHECKSUBCARRYCINT63, + CHECKMULINT63, CHECKMULCINT63, + CHECKDIVINT63, CHECKMODINT63, CHECKDIVEUCLINT63, CHECKDIV21INT63, + CHECKLXORINT63, CHECKLORINT63, CHECKLANDINT63, + CHECKLSLINT63, CHECKLSRINT63, CHECKADDMULDIVINT63, + CHECKLSLINT63CONST1, CHECKLSRINT63CONST1, + + CHECKEQINT63, CHECKLTINT63, LTINT63, CHECKLEINT63, LEINT63, + CHECKCOMPAREINT63, + + CHECKHEAD0INT63, CHECKTAIL0INT63, + + ISINT, AREINT2, + STOP }; diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a944dbb06c..d2c88bffcc 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -23,6 +23,12 @@ #include "coq_memory.h" #include "coq_values.h" +#ifdef ARCH_SIXTYFOUR +#include "coq_uint63_native.h" +#else +#include "coq_uint63_emul.h" +#endif + /* spiwack: I append here a few macros for value/number manipulation */ #define uint32_of_value(val) (((uint32_t)(val)) >> 1) #define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) @@ -155,6 +161,38 @@ if (sp - num_args < coq_stack_threshold) { \ #endif #endif +#define CheckInt1() do{ \ + if (Is_uint63(accu)) pc++; \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ + goto apply1; \ + } \ + }while(0) + +#define CheckInt2() do{ \ + if (Is_uint63(accu) && Is_uint63(sp[0])) pc++; \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ + goto apply2; \ + } \ + }while(0) + + + +#define CheckInt3() do{ \ + if (Is_uint63(accu) && Is_uint63(sp[0]) && Is_uint63(sp[1]) ) pc++; \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ + goto apply3; \ + } \ + }while(0) + +#define AllocCarry(cond) Alloc_small(accu, 1, (cond)? coq_tag_C1 : coq_tag_C0) +#define AllocPair() Alloc_small(accu, 2, coq_tag_pair) + /* For signal handling, we hijack some code from the caml runtime */ extern intnat caml_signals_are_pending; @@ -372,8 +410,10 @@ value coq_interprete goto check_stack; } Instruct(APPLY1) { - value arg1 = sp[0]; + value arg1; + apply1: print_instr("APPLY1"); + arg1 = sp[0]; sp -= 3; sp[0] = arg1; sp[1] = (value)pc; @@ -388,10 +428,14 @@ value coq_interprete coq_extra_args = 0; goto check_stack; } + Instruct(APPLY2) { - value arg1 = sp[0]; - value arg2 = sp[1]; + value arg1; + value arg2; + apply2: print_instr("APPLY2"); + arg1 = sp[0]; + arg2 = sp[1]; sp -= 3; sp[0] = arg1; sp[1] = arg2; @@ -403,11 +447,16 @@ value coq_interprete coq_extra_args = 1; goto check_stack; } + Instruct(APPLY3) { - value arg1 = sp[0]; - value arg2 = sp[1]; - value arg3 = sp[2]; + value arg1; + value arg2; + value arg3; + apply3: print_instr("APPLY3"); + arg1 = sp[0]; + arg2 = sp[1]; + arg3 = sp[2]; sp -= 3; sp[0] = arg1; sp[1] = arg2; @@ -420,7 +469,28 @@ value coq_interprete coq_extra_args = 2; goto check_stack; } - /* Stack checks */ + + Instruct(APPLY4) { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + value arg4 = sp[3]; + print_instr("APPLY4"); + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = arg4; + sp[4] = (value)pc; + sp[5] = coq_env; + sp[6] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 3; + goto check_stack; + } + + /* Stack checks */ check_stack: print_instr("check_stack"); @@ -1127,7 +1197,6 @@ value coq_interprete Next; } - /* spiwack: code for interpreting compiled integers */ Instruct(BRANCH) { /* unconditional branching */ print_instr("BRANCH"); @@ -1136,338 +1205,339 @@ value coq_interprete Next; } - Instruct(ADDINT31) { + Instruct(CHECKADDINT63){ + print_instr("CHECKADDINT63"); + CheckInt2(); + } + Instruct(ADDINT63) { /* Adds the integer in the accumulator with the one ontop of the stack (which is poped)*/ - print_instr("ADDINT31"); - accu = - (value)((uint32_t) accu + (uint32_t) *sp++ - 1); - /* nota,unlike CaML we don't want - to have a different behavior depending on the - architecture. Thus we cast the operand to uint32 */ + print_instr("ADDINT63"); + accu = uint63_add(accu, *sp++); Next; } - Instruct (ADDCINT31) { - print_instr("ADDCINT31"); + Instruct (CHECKADDCINT63) { + print_instr("CHECKADDCINT63"); + CheckInt2(); /* returns the sum with a carry */ - uint32_t s; - s = (uint32_t)accu + (uint32_t)*sp++ - 1; - if( (uint32_t)s < (uint32_t)accu ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value s; + s = uint63_add(accu, *sp++); + AllocCarry(uint63_lt(s,accu)); + Field(accu, 0) = s; Next; } - Instruct (ADDCARRYCINT31) { - print_instr("ADDCARRYCINT31"); + Instruct (CHECKADDCARRYCINT63) { + print_instr("ADDCARRYCINT63"); + CheckInt2(); /* returns the sum plus one with a carry */ - uint32_t s; - s = (uint32_t)accu + (uint32_t)*sp++ + 1; - if( (uint32_t)s <= (uint32_t)accu ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value s; + s = uint63_addcarry(accu, *sp++); + AllocCarry(uint63_leq(s, accu)); + Field(accu, 0) = s; Next; } - Instruct (SUBINT31) { - print_instr("SUBINT31"); + Instruct (CHECKSUBINT63) { + print_instr("CHECKSUBINT63"); + CheckInt2(); + } + Instruct (SUBINT63) { + print_instr("SUBINT63"); /* returns the subtraction */ - accu = - (value)((uint32_t) accu - (uint32_t) *sp++ + 1); + accu = uint63_sub(accu, *sp++); Next; } - Instruct (SUBCINT31) { - print_instr("SUBCINT31"); + Instruct (CHECKSUBCINT63) { + print_instr("SUBCINT63"); + CheckInt2(); /* returns the subtraction with a carry */ - uint32_t b; - uint32_t s; - b = (uint32_t)*sp++; - s = (uint32_t)accu - b + 1; - if( (uint32_t)accu < b ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value b; + value s; + b = *sp++; + s = uint63_sub(accu,b); + AllocCarry(uint63_lt(accu,b)); + Field(accu, 0) = s; Next; } - Instruct (SUBCARRYCINT31) { - print_instr("SUBCARRYCINT31"); + Instruct (CHECKSUBCARRYCINT63) { + print_instr("SUBCARRYCINT63"); + CheckInt2(); /* returns the subtraction minus one with a carry */ - uint32_t b; - uint32_t s; - b = (uint32_t)*sp++; - s = (value)((uint32_t)accu - b - 1); - if( (uint32_t)accu <= b ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value b; + value s; + b = *sp++; + s = uint63_subcarry(accu,b); + AllocCarry(uint63_leq(accu,b)); + Field(accu, 0) = s; Next; } - Instruct (MULINT31) { + Instruct (CHECKMULINT63) { + print_instr("MULINT63"); + CheckInt2(); /* returns the multiplication */ - print_instr("MULINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) * (uint32_of_value(*sp++))); + accu = uint63_mul(accu,*sp++); Next; } - Instruct (MULCINT31) { - /*returns the multiplication on a double size word - (special case for 0) */ - print_instr("MULCINT31"); - uint64_t p; + Instruct (CHECKMULCINT63) { + /*returns the multiplication on a pair */ + print_instr("MULCINT63"); + CheckInt2(); /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - p = UI64_of_value (accu) * UI64_of_uint32 ((*sp++)^1); - if (p == 0) { - accu = (value)1; + /* TODO: implement + p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); + AllocPair(); */ + /* Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; */ /*higher part*/ + /* Field(accu, 1) = (value)(I64_to_int32(p)|1); */ /*lower part*/ + value x = accu; + AllocPair(); + Field(accu, 1) = uint63_mulc(x, *sp++, &Field(accu, 0)); + Next; + } + + Instruct(CHECKDIVINT63) { + print_instr("CHEKDIVINT63"); + CheckInt2(); + /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag + since it probably only concerns negative number. + needs to be checked at this point */ + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { + accu = divisor; } else { - /* the output type is supposed to have a constant constructor - and a non-constant constructor (in that order), the tag - of the non-constant constructor is then 1 */ - Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - /*unsigned shift*/ - Field(accu, 0) = (value)((p >> 31)|1) ; /*higher part*/ - Field(accu, 1) = (value)((uint32_t)p|1); /*lower part*/ - } + accu = uint63_div(accu, divisor); + } Next; } - Instruct (DIV21INT31) { - print_instr("DIV21INT31"); - /* spiwack: takes three int31 (the two first ones represent an - int62) and performs the euclidian division of the - int62 by the int31 */ - uint64_t bigint; - bigint = UI64_of_value(accu); - bigint = (bigint << 31) | UI64_of_value(*sp++); - uint64_t divisor; - divisor = UI64_of_value(*sp++); - Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - if (divisor == 0) { - Field(accu, 0) = 1; /* 2*0+1 */ - Field(accu, 1) = 1; /* 2*0+1 */ + Instruct(CHECKMODINT63) { + print_instr("CHEKMODINT63"); + CheckInt2(); + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { + accu = divisor; } - else { - uint64_t quo, mod; - quo = bigint / divisor; - mod = bigint % divisor; - Field(accu, 0) = value_of_uint32((uint32_t)(quo)); - Field(accu, 1) = value_of_uint32((uint32_t)(mod)); + else { + accu = uint63_mod(accu,divisor); } Next; } - Instruct (DIVINT31) { - print_instr("DIVINT31"); + Instruct (CHECKDIVEUCLINT63) { + print_instr("DIVEUCLINT63"); + CheckInt2(); /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ - uint32_t divisor; - divisor = uint32_of_value(*sp++); - if (divisor == 0) { + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - Field(accu, 0) = 1; /* 2*0+1 */ - Field(accu, 1) = 1; /* 2*0+1 */ + Field(accu, 0) = divisor; + Field(accu, 1) = divisor; } else { - uint32_t modulus; - modulus = uint32_of_value(accu); + value modulus; + modulus = accu; Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - Field(accu, 0) = value_of_uint32(modulus/divisor); - Field(accu, 1) = value_of_uint32(modulus%divisor); + Field(accu, 0) = uint63_div(modulus,divisor); + Field(accu, 1) = uint63_mod(modulus,divisor); } Next; } - Instruct (ADDMULDIVINT31) { - print_instr("ADDMULDIVINT31"); - /* higher level shift (does shifts and cycles and such) */ - uint32_t shiftby; - shiftby = uint32_of_value(accu); - if (shiftby > 31) { - if (shiftby < 62) { - sp++; - accu = (value)(((((uint32_t)*sp++)^1) << (shiftby - 31)) | 1); - } - else { - sp+=2; - accu = (value)(1); - } + Instruct (CHECKDIV21INT63) { + print_instr("DIV21INT63"); + CheckInt3(); + /* spiwack: takes three int31 (the two first ones represent an + int62) and performs the euclidian division of the + int62 by the int31 */ + /* TODO: implement this + bigint = UI64_of_value(accu); + bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); + uint64 divisor; + divisor = UI64_of_value(*sp++); + Alloc_small(accu, 2, 1); */ /* ( _ , arity, tag ) */ + /* if (I64_is_zero (divisor)) { + Field(accu, 0) = 1; */ /* 2*0+1 */ + /* Field(accu, 1) = 1; */ /* 2*0+1 */ + /* } + else { + uint64 quo, mod; + I64_udivmod(bigint, divisor, &quo, &mod); + Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); + Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); + } */ + value bigint; /* TODO: fix */ + bigint = *sp++; /* TODO: take accu into account */ + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { + Alloc_small(accu, 2, 1); + Field(accu, 0) = divisor; + Field(accu, 1) = divisor; } - else{ - /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ - accu = (value)((((uint32_t)*sp++)^1) << shiftby); - /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ - accu = (value)((accu | (((uint32_t)(*sp++)) >> (31-shiftby)))|1); + else { + value quo, mod; + mod = uint63_div21(accu, bigint, divisor, &quo); + Alloc_small(accu, 2, 1); + Field(accu, 0) = quo; + Field(accu, 1) = mod; } Next; } - Instruct (COMPAREINT31) { - /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ - /* assumes Inductive _ : _ := Eq | Lt | Gt */ - print_instr("COMPAREINT31"); - if ((uint32_t)accu == (uint32_t)*sp) { - accu = 1; /* 2*0+1 */ - sp++; - } - else{if ((uint32_t)accu < (uint32_t)(*sp++)) { - accu = 3; /* 2*1+1 */ - } - else{ - accu = 5; /* 2*2+1 */ - }} + Instruct(CHECKLXORINT63) { + print_instr("CHECKLXORINT63"); + CheckInt2(); + accu = uint63_lxor(accu,*sp++); Next; } - - Instruct (HEAD0INT31) { - int r = 0; - uint32_t x; - print_instr("HEAD0INT31"); - x = (uint32_t) accu; - if (!(x & 0xFFFF0000)) { x <<= 16; r += 16; } - if (!(x & 0xFF000000)) { x <<= 8; r += 8; } - if (!(x & 0xF0000000)) { x <<= 4; r += 4; } - if (!(x & 0xC0000000)) { x <<= 2; r += 2; } - if (!(x & 0x80000000)) { x <<=1; r += 1; } - if (!(x & 0x80000000)) { r += 1; } - accu = value_of_uint32(r); + + Instruct(CHECKLORINT63) { + print_instr("CHECKLORINT63"); + CheckInt2(); + accu = uint63_lor(accu,*sp++); Next; } - - Instruct (TAIL0INT31) { - int r = 0; - uint32_t x; - print_instr("TAIL0INT31"); - x = (((uint32_t) accu >> 1) | 0x80000000); - if (!(x & 0xFFFF)) { x >>= 16; r += 16; } - if (!(x & 0x00FF)) { x >>= 8; r += 8; } - if (!(x & 0x000F)) { x >>= 4; r += 4; } - if (!(x & 0x0003)) { x >>= 2; r += 2; } - if (!(x & 0x0001)) { x >>=1; r += 1; } - if (!(x & 0x0001)) { r += 1; } - accu = value_of_uint32(r); + + Instruct(CHECKLANDINT63) { + print_instr("CHECKLANDINT63"); + CheckInt2(); + accu = uint63_land(accu,*sp++); Next; } - Instruct (ISCONST) { - /* Branches if the accu does not contain a constant - (i.e., a non-block value) */ - print_instr("ISCONST"); - if ((accu & 1) == 0) /* last bit is 0 -> it is a block */ - pc += *pc; - else - pc++; + Instruct(CHECKLSLINT63) { + print_instr("CHECKLSLINT63"); + CheckInt2(); + value p = *sp++; + accu = uint63_lsl(accu,p); Next; + } + Instruct(CHECKLSRINT63) { + print_instr("CHECKLSRINT63"); + CheckInt2(); + value p = *sp++; + accu = uint63_lsr(accu,p); + Next; } - Instruct (ARECONST) { - /* Branches if the n first values on the stack are not - all constansts */ - print_instr("ARECONST"); - int i, n, ok; - ok = 1; - n = *pc++; - for(i=0; i < n; i++) { - if ((sp[i] & 1) == 0) { - ok = 0; - break; - } + Instruct(CHECKLSLINT63CONST1) { + print_instr("CHECKLSLINT63CONST1"); + if (Is_uint63(accu)) { + pc++; + accu = uint63_lsl1(accu); + Next; + } else { + *--sp = uint63_one(); + *--sp = accu; + accu = Field(coq_global_data, *pc++); + goto apply2; } - if(ok) pc++; else pc += *pc; + } + + Instruct(CHECKLSRINT63CONST1) { + print_instr("CHECKLSRINT63CONST1"); + if (Is_uint63(accu)) { + pc++; + accu = uint63_lsr1(accu); + Next; + } else { + *--sp = uint63_one(); + *--sp = accu; + accu = Field(coq_global_data, *pc++); + goto apply2; + } + } + + Instruct (CHECKADDMULDIVINT63) { + print_instr("CHECKADDMULDIVINT63"); + CheckInt3(); + value x; + value y; + x = *sp++; + y = *sp++; + accu = uint63_addmuldiv(accu,x,y); Next; } - Instruct (COMPINT31) { - /* makes an 31-bit integer out of the accumulator and - the 30 first values of the stack - and put it in the accumulator (the accumulator then the - topmost get to be the heavier bits) */ - print_instr("COMPINT31"); - int i; - /*accu=accu or accu = (value)((unsigned long)1-accu) if bool - is used for the bits */ - for(i=0; i < 30; i++) { - accu = (value) ((((uint32_t)accu-1) << 1) | *sp++); - /* -1 removes the tag bit, << 1 multiplies the value by 2, - | *sp++ pops the last value and add it (no carry involved) - not that it reintroduces a tag bit */ - /* alternative, if bool is used for the bits : - accu = (value) ((((unsigned long)accu) << 1) & !*sp++); */ + Instruct (CHECKEQINT63) { + print_instr("CHECKEQINT63"); + CheckInt2(); + accu = uint63_eq(accu,*sp++) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLTINT63) { + print_instr("CHECKLTINT63"); + CheckInt2(); + } + Instruct (LTINT63) { + print_instr("LTINT63"); + accu = uint63_lt(accu,*sp++) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLEINT63) { + print_instr("CHECKLEINT63"); + CheckInt2(); + } + Instruct (LEINT63) { + print_instr("LEINT63"); + accu = uint63_leq(accu,*sp++) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKCOMPAREINT63) { + /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ + /* assumes Inductive _ : _ := Eq | Lt | Gt */ + print_instr("CHECKCOMPAREINT63"); + CheckInt2(); + if (uint63_eq(accu,*sp)) { + accu = coq_Eq; + sp++; } + else accu = uint63_lt(accu,*sp++) ? coq_Lt : coq_Gt; Next; } - Instruct (DECOMPINT31) { - /* builds a block out of a 31-bit integer (from the accumulator), - used before cases */ - int i; - value block; - print_instr("DECOMPINT31"); - Alloc_small(block, 31, 1); // Alloc_small(*, size, tag) - for(i = 30; i >= 0; i--) { - Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */ - //Field(block, i) = 3; - accu = (value) ((uint32_t)accu >> 1) | 1; /* last bit must be a one */ - }; - accu = block; + Instruct (CHECKHEAD0INT63) { + print_instr("CHECKHEAD0INT63"); + CheckInt1(); + accu = uint63_head0(accu); Next; } - Instruct (ORINT31) { - /* returns the bitwise or */ - print_instr("ORINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) | (uint32_of_value(*sp++))); - Next; + Instruct (CHECKTAIL0INT63) { + print_instr("CHECKTAIL0INT63"); + CheckInt1(); + accu = uint63_tail0(accu); + Next; } - Instruct (ANDINT31) { - /* returns the bitwise and */ - print_instr("ANDINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) & (uint32_of_value(*sp++))); + Instruct (ISINT){ + print_instr("ISINT"); + accu = (Is_uint63(accu)) ? coq_true : coq_false; Next; } - Instruct (XORINT31) { - /* returns the bitwise xor */ - print_instr("XORINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) ^ (uint32_of_value(*sp++))); + Instruct (AREINT2){ + print_instr("AREINT2"); + accu = (Is_uint63(accu) && Is_uint63(sp[0])) ? coq_true : coq_false; + sp++; Next; } - /* /spiwack */ - - /* Debugging and machine control */ diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h new file mode 100644 index 0000000000..5499f124a2 --- /dev/null +++ b/kernel/byterun/coq_uint63_emul.h @@ -0,0 +1,97 @@ +# pragma once + +# include <caml/callback.h> +# include <caml/stack.h> + + +#define Is_uint63(v) (Tag_val(v) == Custom_tag) + +# define DECLARE_NULLOP(name) \ +value uint63_##name() { \ + static value* cb = 0; \ + CAMLparam0(); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(*cb); \ + } + +# define DECLARE_UNOP(name) \ +value uint63_##name(value x) { \ + static value* cb = 0; \ + CAMLparam1(x); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(caml_callback(*cb, x)); \ + } + +# define DECLARE_PREDICATE(name) \ +value uint63_##name(value x) { \ + static value* cb = 0; \ + CAMLparam1(x); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(Int_val(caml_callback(*cb, x))); \ + } + +# define DECLARE_BINOP(name) \ +value uint63_##name(value x, value y) { \ + static value* cb = 0; \ + CAMLparam2(x, y); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(caml_callback2(*cb, x, y)); \ + } + +# define DECLARE_RELATION(name) \ +value uint63_##name(value x, value y) { \ + static value* cb = 0; \ + CAMLparam2(x, y); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(Int_val(caml_callback2(*cb, x, y))); \ + } + +# define DECLARE_TEROP(name) \ +value uint63_##name(value x, value y, value z) { \ + static value* cb = 0; \ + CAMLparam3(x, y, z); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(caml_callback3(*cb, x, y, z)); \ + } + + +DECLARE_NULLOP(one) +DECLARE_BINOP(add) +DECLARE_BINOP(addcarry) +DECLARE_TEROP(addmuldiv) +DECLARE_BINOP(div) +DECLARE_TEROP(div21_ml) +DECLARE_RELATION(eq) +DECLARE_PREDICATE(eq0) +DECLARE_UNOP(head0) +DECLARE_BINOP(land) +DECLARE_RELATION(leq) +DECLARE_BINOP(lor) +DECLARE_BINOP(lsl) +DECLARE_UNOP(lsl1) +DECLARE_BINOP(lsr) +DECLARE_UNOP(lsr1) +DECLARE_RELATION(lt) +DECLARE_BINOP(lxor) +DECLARE_BINOP(mod) +DECLARE_BINOP(mul) +DECLARE_BINOP(mulc_ml) +DECLARE_BINOP(sub) +DECLARE_BINOP(subcarry) +DECLARE_UNOP(tail0) + +value uint63_div21(value x, value y, value z, value* q) { + CAMLparam3(x, y, z); + CAMLlocal1(qr); + qr = uint63_div21_ml(x, y, z); + *q = Field(qr, 0); + CAMLreturn(Field(qr, 1)); +} + +value uint63_mulc(value x, value y, value* h) { + CAMLparam2(x, y); + CAMLlocal1(hl); + hl = uint63_mulc_ml(x, y); + *h = Field(hl, 0); + CAMLreturn(Field(hl, 1)); +} diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h new file mode 100644 index 0000000000..92f4dc79bc --- /dev/null +++ b/kernel/byterun/coq_uint63_native.h @@ -0,0 +1,125 @@ +#define Is_uint63(v) (Is_long(v)) + +#define uint63_of_value(val) ((uint64_t)(val) >> 1) + +/* 2^63 * y + x as a value */ +//#define Val_intint(x,y) ((value)(((uint64_t)(x)) << 1 + ((uint64_t)(y) << 64))) + +#define uint63_zero ((value) 1) /* 2*0 + 1 */ +#define uint63_one() ((value) 3) /* 2*1 + 1 */ + +#define uint63_eq(x,y) ((x) == (y)) +#define uint63_eq0(x) ((x) == (uint64_t)1) +#define uint63_lt(x,y) ((uint64_t) (x) < (uint64_t) (y)) +#define uint63_leq(x,y) ((uint64_t) (x) <= (uint64_t) (y)) + +#define uint63_add(x,y) ((value)((uint64_t) (x) + (uint64_t) (y) - 1)) +#define uint63_addcarry(x,y) ((value)((uint64_t) (x) + (uint64_t) (y) + 1)) +#define uint63_sub(x,y) ((value)((uint64_t) (x) - (uint64_t) (y) + 1)) +#define uint63_subcarry(x,y) ((value)((uint64_t) (x) - (uint64_t) (y) - 1)) +#define uint63_mul(x,y) (Val_long(uint63_of_value(x) * uint63_of_value(y))) +#define uint63_div(x,y) (Val_long(uint63_of_value(x) / uint63_of_value(y))) +#define uint63_mod(x,y) (Val_long(uint63_of_value(x) % uint63_of_value(y))) + +#define uint63_lxor(x,y) ((value)(((uint64_t)(x) ^ (uint64_t)(y)) | 1)) +#define uint63_lor(x,y) ((value)((uint64_t)(x) | (uint64_t)(y))) +#define uint63_land(x,y) ((value)((uint64_t)(x) & (uint64_t)(y))) + +/* TODO: is + or | better? OCAML uses + */ +/* TODO: is - or ^ better? */ +#define uint63_lsl(x,y) ((y) < (uint64_t) 127 ? ((value)((((uint64_t)(x)-1) << (uint63_of_value(y))) | 1)) : uint63_zero) +#define uint63_lsr(x,y) ((y) < (uint64_t) 127 ? ((value)(((uint64_t)(x) >> (uint63_of_value(y))) | 1)) : uint63_zero) +#define uint63_lsl1(x) ((value)((((uint64_t)(x)-1) << 1) +1)) +#define uint63_lsr1(x) ((value)(((uint64_t)(x) >> 1) |1)) + +/* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ +/* (modulo 2^63) for p <= 63 */ +value uint63_addmuldiv(uint64_t p, uint64_t x, uint64_t y) { + uint64_t shiftby = uint63_of_value(p); + value r = (value)((uint64_t)(x^1) << shiftby); + r |= ((uint64_t)y >> (63-shiftby)) | 1; + return r; +} + +value uint63_head0(uint64_t x) { + int r = 0; + if (!(x & 0xFFFFFFFF00000000)) { x <<= 32; r += 32; } + if (!(x & 0xFFFF000000000000)) { x <<= 16; r += 16; } + if (!(x & 0xFF00000000000000)) { x <<= 8; r += 8; } + if (!(x & 0xF000000000000000)) { x <<= 4; r += 4; } + if (!(x & 0xC000000000000000)) { x <<= 2; r += 2; } + if (!(x & 0x8000000000000000)) { x <<=1; r += 1; } + return Val_int(r); +} + +value uint63_tail0(value x) { + int r = 0; + x = (uint64_t)x >> 1; + if (!(x & 0xFFFFFFFF)) { x >>= 32; r += 32; } + if (!(x & 0x0000FFFF)) { x >>= 16; r += 16; } + if (!(x & 0x000000FF)) { x >>= 8; r += 8; } + if (!(x & 0x0000000F)) { x >>= 4; r += 4; } + if (!(x & 0x00000003)) { x >>= 2; r += 2; } + if (!(x & 0x00000001)) { x >>=1; r += 1; } + return Val_int(r); +} + +value uint63_mulc(value x, value y, value* h) { + x = (uint64_t)x >> 1; + y = (uint64_t)y >> 1; + uint64_t lx = x & 0xFFFFFFFF; + uint64_t ly = y & 0xFFFFFFFF; + uint64_t hx = x >> 32; + uint64_t hy = y >> 32; + uint64_t hr = hx * hy; + uint64_t lr = lx * ly; + lx *= hy; + ly *= hx; + hr += (lx >> 32) + (ly >> 32); + lx <<= 32; + lr += lx; + if (lr < lx) { hr++; } + ly <<= 32; + lr += ly; + if (lr < ly) { hr++; } + hr = (hr << 1) | (lr >> 63); + *h = Val_int(hr); + return Val_int(lr); +} + +#define lt128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_lt(xl,yl))) +#define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) + +value uint63_div21(value xh, value xl, value y, value* q) { + xh = (uint64_t)xh >> 1; + xl = ((uint64_t)xl >> 1) | ((uint64_t)xh << 63); + xh = (uint64_t)xh >> 1; + uint64_t maskh = 0; + uint64_t maskl = 1; + uint64_t dh = 0; + uint64_t dl = (uint64_t)y >> 1; + int cmp = 1; + while (dh >= 0 && cmp) { + cmp = lt128(dh,dl,xh,xl); + dh = (dh << 1) | (dl >> 63); + dl = dl << 1; + maskh = (maskh << 1) | (maskl >> 63); + maskl = maskl << 1; + } + uint64_t remh = xh; + uint64_t reml = xl; + uint64_t quotient = 0; + while (maskh | maskl) { + if (le128(dh,dl,remh,reml)) { + quotient = quotient | maskl; + if (uint63_lt(reml,dl)) {remh = remh - dh - 1;} else {remh = remh - dh;} + reml = reml - dl; + } + maskl = (maskl >> 1) | (maskh << 63); + maskh = maskh >> 1; + dl = (dl >> 1) | (dh << 63); + dh = dh >> 1; + } + *q = Val_int(quotient); + return Val_int(reml); +} diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index bb0f0eb5e4..0cf6ccf532 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -28,6 +28,16 @@ /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) - #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) + +/* */ +#define coq_tag_C1 2 +#define coq_tag_C0 1 +#define coq_tag_pair 1 +#define coq_true Val_int(0) +#define coq_false Val_int(1) +#define coq_Eq Val_int(0) +#define coq_Lt Val_int(1) +#define coq_Gt Val_int(2) + #endif /* _COQ_VALUES_ */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index 3a714a8a59..c3c44670be 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -6,5 +6,5 @@ (rule (targets coq_jumptbl.h) - (deps (:h-file coq_instruct.h)) - (action (run ./make_jumptbl.sh %{h-file} %{targets}))) + (deps (:h-file coq_instruct.h) make_jumptbl.sh) + (action (bash "./make_jumptbl.sh %{h-file} %{targets}"))) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 196bb16f32..5fec55fea1 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -28,8 +28,9 @@ open Util open Pp open Names open Constr -open Vars +open Declarations open Environ +open Vars open Esubst let stats = ref false @@ -303,6 +304,7 @@ and fterm = | FProd of Name.t * fconstr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs + | FInt of Uint63.t | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED @@ -335,19 +337,22 @@ type clos_infos = { i_flags : reds; i_cache : infos_cache } -type clos_tab = fconstr KeyTable.t +type clos_tab = fconstr constant_def KeyTable.t let info_flags info = info.i_flags let info_env info = info.i_cache.i_env (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack + | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args + (* operator, constr def, arguments already seen (in rev order), next arguments *) | Zshift of int | Zupdate of fconstr @@ -358,7 +363,7 @@ let append_stack v s = if Int.equal (Array.length v) 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _ | Zprimitive _) :: _ | [] -> Zapp v :: s (* Collapse the shifts in the stack *) @@ -366,20 +371,20 @@ let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s - | (_,(ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zupdate _) :: _) | _,[] -> Zshift(n)::s + | (_,(ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zupdate _ | Zprimitive _) :: _) | _,[] -> Zshift(n)::s let rec stack_args_size = function | Zapp v :: s -> Array.length v + stack_args_size s | Zshift(_)::s -> stack_args_size s | Zupdate(_)::s -> stack_args_size s - | (ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> 0 + | (ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | [] -> 0 (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with - | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft + | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _) -> ft | FRel i -> {norm=Norm;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} @@ -411,7 +416,7 @@ let compact_stack head stk = (** The stack contains [Zupdate] marks only if in sharing mode *) let _ = update ~share:true m h'.norm h'.term in strip_rec depth s - | ((ZcaseT _ | Zproj _ | Zfix _ | Zapp _) :: _ | []) as stk -> zshift depth stk + | ((ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zprimitive _) :: _ | []) as stk -> zshift depth stk in strip_rec 0 stk @@ -447,6 +452,7 @@ let mk_clos e t = | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } + | Int i -> {norm = Cstr; term = FInt i} | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} @@ -465,32 +471,34 @@ let mk_clos_vect env v = match v with let ref_value_cache ({ i_cache = cache; _ }) tab ref = try - Some (KeyTable.find tab ref) + KeyTable.find tab ref with Not_found -> - try - let body = - match ref with - | RelKey n -> - let open! Context.Rel.Declaration in - let i = n - 1 in - let (d, _) = - try Range.get cache.i_env.env_rel_context.env_rel_map i - with Invalid_argument _ -> raise Not_found - in - begin match d with - | LocalAssum _ -> raise Not_found - | LocalDef (_, t, _) -> lift n t - end - | VarKey id -> assoc_defined id cache.i_env - | ConstKey cst -> constant_value_in cache.i_env cst + let v = + try + let body = + match ref with + | RelKey n -> + let open! Context.Rel.Declaration in + let i = n - 1 in + let (d, _) = + try Range.get cache.i_env.env_rel_context.env_rel_map i + with Invalid_argument _ -> raise Not_found + in + begin match d with + | LocalAssum _ -> raise Not_found + | LocalDef (_, t, _) -> lift n t + end + | VarKey id -> assoc_defined id cache.i_env + | ConstKey cst -> constant_value_in cache.i_env cst + in + Def (inject body) + with + | NotEvaluableConst (IsPrimitive op) (* Const *) -> Primitive op + | Not_found (* List.assoc *) + | NotEvaluableConst _ (* Const *) + -> Undef None in - let v = inject body in - KeyTable.add tab ref v; - Some v - with - | Not_found (* List.assoc *) - | NotEvaluableConst _ (* Const *) - -> None + KeyTable.add tab ref v; v (* The inverse of mk_clos: move back to constr *) let rec to_constr lfts v = @@ -559,6 +567,10 @@ let rec to_constr lfts v = let subs = comp_subs lfts env in mkEvar(ev,Array.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a + + | FInt i -> + Constr.mkInt i + | FCLOS (t,env) -> if is_subs_id env && is_lift_id lfts then t else @@ -607,6 +619,10 @@ let rec zip m stk = | Zupdate(rf)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) zip (update ~share:true rf m.norm m.term) s + | Zprimitive(_op,c,rargs,kargs)::s -> + let args = List.rev_append rargs (m::List.map snd kargs) in + let f = {norm = Red;term = FFlex (ConstKey c)} in + zip {norm=neutr m.norm; term = FApp (f, Array.of_list args)} s let fapp_stack (m,stk) = zip m stk @@ -628,7 +644,7 @@ let strip_update_shift_app_red head stk = | Zupdate(m)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) strip_rec rstk (update ~share:true m h.norm h.term) depth s - | ((ZcaseT _ | Zproj _ | Zfix _) :: _ | []) as stk -> + | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk @@ -656,7 +672,7 @@ let get_nth_arg head n stk = | Zupdate(m)::s -> (** The stack contains [Zupdate] mark only if in sharing mode *) strip_rec rstk (update ~share:true m h.norm h.term) n s - | ((ZcaseT _ | Zproj _ | Zfix _) :: _ | []) as s -> (None, List.rev rstk @ s) in + | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. @@ -678,24 +694,70 @@ let rec get_args n tys f e = function else (* more lambdas *) let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s - | ((ZcaseT _ | Zproj _ | Zfix _) :: _ | []) as stk -> + | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _ - | Zshift _ | Zupdate _ as e) :: s -> + | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] +(* Get the arguments of a native operator *) +let rec skip_native_args rargs nargs = + match nargs with + | (kd, a) :: nargs' -> + if kd = CPrimitives.Kwhnf then rargs, nargs + else skip_native_args (a::rargs) nargs' + | [] -> rargs, [] + +let get_native_args op c stk = + let kargs = CPrimitives.kind op in + let rec get_args rnargs kargs args = + match kargs, args with + | kd::kargs, a::args -> get_args ((kd,a)::rnargs) kargs args + | _, _ -> rnargs, kargs, args in + let rec strip_rec rnargs h depth kargs = function + | Zshift k :: s -> + strip_rec (List.map (fun (kd,f) -> kd,lift_fconstr k f) rnargs) + (lift_fconstr k h) (depth+k) kargs s + | Zapp args :: s' -> + begin match get_args rnargs kargs (Array.to_list args) with + | rnargs, [], [] -> + (skip_native_args [] (List.rev rnargs), s') + | rnargs, [], eargs -> + (skip_native_args [] (List.rev rnargs), + Zapp (Array.of_list eargs) :: s') + | rnargs, kargs, _ -> + strip_rec rnargs {norm = h.norm;term=FApp(h, args)} depth kargs s' + end + | Zupdate(m) :: s -> + strip_rec rnargs (update ~share:true m h.norm h.term) depth kargs s + | (Zprimitive _ | ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> assert false + in strip_rec [] {norm = Red;term = FFlex(ConstKey c)} 0 kargs stk + +let get_native_args1 op c stk = + match get_native_args op c stk with + | ((rargs, (kd,a):: nargs), stk) -> + assert (kd = CPrimitives.Kwhnf); + (rargs, a, nargs, stk) + | _ -> assert false + +let check_native_args op stk = + let nargs = CPrimitives.arity op in + let rargs = stack_args_size stk in + nargs <= rargs + + (* Iota reduction: extract the arguments to be passed to the Case branches *) let rec reloc_rargs_rec depth = function | Zapp args :: s -> Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s - | ((ZcaseT _ | Zproj _ | Zfix _ | Zupdate _) :: _ | []) as stk -> stk + | ((ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ | []) as stk -> stk let reloc_rargs depth stk = if Int.equal depth 0 then stk else reloc_rargs_rec depth stk @@ -712,7 +774,7 @@ let rec try_drop_parameters depth n = function | [] -> if Int.equal n 0 then [] else raise Not_found - | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _) :: _ -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) let drop_parameters depth n argstk = @@ -757,7 +819,7 @@ let rec project_nth_arg n = function let q = Array.length args in if n >= q then project_nth_arg (n - q) s else (* n < q *) args.(n) - | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _) :: _ | [] -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _ | Zprimitive _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) @@ -814,7 +876,7 @@ let rec knh info m stk = (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| - FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> + FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _|FInt _) -> (m, stk) (* The same for pure terms *) @@ -828,7 +890,7 @@ and knht info e t stk = | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk | Proj (p, c) -> knh info { norm = Red; term = FProj (p, mk_clos e c) } stk - | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> (mk_clos e t, stk) + | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _ | Int _) -> (mk_clos e t, stk) | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk | Prod (n, t, c) -> @@ -837,6 +899,162 @@ and knht info e t stk = { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk +let inject c = mk_clos (subs_id 0) c + +(************************************************************************) +(* Reduction of Native operators *) + +open Primred + +module FNativeEntries = + struct + type elem = fconstr + type args = fconstr array + type evd = unit + + let get = Array.get + + let get_int () e = + match [@ocaml.warning "-4"] e.term with + | FInt i -> i + | _ -> raise Primred.NativeDestKO + + let dummy = {norm = Norm; term = FRel 0} + + let current_retro = ref Retroknowledge.empty + let defined_int = ref false + let fint = ref dummy + + let init_int retro = + match retro.Retroknowledge.retro_int63 with + | Some c -> + defined_int := true; + fint := { norm = Norm; term = FFlex (ConstKey (Univ.in_punivs c)) } + | None -> defined_int := false + + let defined_bool = ref false + let ftrue = ref dummy + let ffalse = ref dummy + + let init_bool retro = + match retro.Retroknowledge.retro_bool with + | Some (ct,cf) -> + defined_bool := true; + ftrue := { norm = Cstr; term = FConstruct (Univ.in_punivs ct) }; + ffalse := { norm = Cstr; term = FConstruct (Univ.in_punivs cf) } + | None -> defined_bool :=false + + let defined_carry = ref false + let fC0 = ref dummy + let fC1 = ref dummy + + let init_carry retro = + match retro.Retroknowledge.retro_carry with + | Some(c0,c1) -> + defined_carry := true; + fC0 := { norm = Cstr; term = FConstruct (Univ.in_punivs c0) }; + fC1 := { norm = Cstr; term = FConstruct (Univ.in_punivs c1) } + | None -> defined_carry := false + + let defined_pair = ref false + let fPair = ref dummy + + let init_pair retro = + match retro.Retroknowledge.retro_pair with + | Some c -> + defined_pair := true; + fPair := { norm = Cstr; term = FConstruct (Univ.in_punivs c) } + | None -> defined_pair := false + + let defined_cmp = ref false + let fEq = ref dummy + let fLt = ref dummy + let fGt = ref dummy + + let init_cmp retro = + match retro.Retroknowledge.retro_cmp with + | Some (cEq, cLt, cGt) -> + defined_cmp := true; + fEq := { norm = Cstr; term = FConstruct (Univ.in_punivs cEq) }; + fLt := { norm = Cstr; term = FConstruct (Univ.in_punivs cLt) }; + fGt := { norm = Cstr; term = FConstruct (Univ.in_punivs cGt) } + | None -> defined_cmp := false + + let defined_refl = ref false + + let frefl = ref dummy + + let init_refl retro = + match retro.Retroknowledge.retro_refl with + | Some crefl -> + defined_refl := true; + frefl := { norm = Cstr; term = FConstruct (Univ.in_punivs crefl) } + | None -> defined_refl := false + + let init env = + current_retro := env.retroknowledge; + init_int !current_retro; + init_bool !current_retro; + init_carry !current_retro; + init_pair !current_retro; + init_cmp !current_retro; + init_refl !current_retro + + let check_env env = + if not (!current_retro == env.retroknowledge) then init env + + let check_int env = + check_env env; + assert (!defined_int) + + let check_bool env = + check_env env; + assert (!defined_bool) + + let check_carry env = + check_env env; + assert (!defined_carry && !defined_int) + + let check_pair env = + check_env env; + assert (!defined_pair && !defined_int) + + let check_cmp env = + check_env env; + assert (!defined_cmp) + + let mkInt env i = + check_int env; + { norm = Norm; term = FInt i } + + let mkBool env b = + check_bool env; + if b then !ftrue else !ffalse + + let mkCarry env b e = + check_carry env; + {norm = Cstr; + term = FApp ((if b then !fC1 else !fC0),[|!fint;e|])} + + let mkIntPair env e1 e2 = + check_pair env; + { norm = Cstr; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } + + let mkLt env = + check_cmp env; + !fLt + + let mkEq env = + check_cmp env; + !fEq + + let mkGt env = + check_cmp env; + !fGt + + end + +module FredNative = RedNative(FNativeEntries) (************************************************************************) @@ -849,16 +1067,21 @@ let rec knr info tab m stk = | Inr lam, s -> (lam,s)) | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info tab (ConstKey c) with - Some v -> kni info tab v stk - | None -> (set_norm m; (m,stk))) + | Def v -> kni info tab v stk + | Primitive op when check_native_args op stk -> + let rargs, a, nargs, stk = get_native_args1 op c stk in + kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) + | Undef _ | OpaqueDef _ | Primitive _ -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info tab (VarKey id) with - Some v -> kni info tab v stk - | None -> (set_norm m; (m,stk))) + | Def v -> kni info tab v stk + | Primitive _ -> assert false + | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info tab (RelKey k) with - Some v -> kni info tab v stk - | None -> (set_norm m; (m,stk))) + | Def v -> kni info tab v stk + | Primitive _ -> assert false + | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) | FConstruct((_ind,c),_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in @@ -884,13 +1107,32 @@ let rec knr info tab m stk = | (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info tab fxe fxbd (args@stk') - | (_,args, ((Zapp _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] as s)) -> (m,args@s)) + | (_,args, ((Zapp _ | Zfix _ | Zshift _ | Zupdate _ | Zprimitive _) :: _ | [] as s)) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info tab (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> (match info.i_cache.i_sigma ev with Some c -> knit info tab env c stk | None -> (m,stk)) + | FInt _ -> + (match [@ocaml.warning "-4"] strip_update_shift_app m stk with + | (_, _, Zprimitive(op,c,rargs,nargs)::s) -> + let (rargs, nargs) = skip_native_args (m::rargs) nargs in + begin match nargs with + | [] -> + let args = Array.of_list (List.rev rargs) in + begin match FredNative.red_prim (info_env info) () op args with + | Some m -> kni info tab m s + | None -> + let f = {norm = Whnf; term = FFlex (ConstKey c)} in + let m = {norm = Whnf; term = FApp(f,args)} in + (m,s) + end + | (kd,a)::nargs -> + assert (kd = CPrimitives.Kwhnf); + kni info tab a (Zprimitive(op,c,rargs,nargs)::s) + end + | (_, _, s) -> (m, s)) | FLOCKED | FRel _ | FAtom _ | FFlex (RelKey _ | ConstKey _ | VarKey _) | FInd _ | FApp _ | FProj _ | FFix _ | FCoFix _ | FCaseT _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ | FCLOS _ -> (m, stk) @@ -927,6 +1169,12 @@ let rec zip_term zfun m stk = zip_term zfun (lift n m) s | Zupdate(_rf)::s -> zip_term zfun m s + | Zprimitive(_,c,rargs, kargs)::s -> + let kargs = List.map (fun (_,a) -> zfun a) kargs in + let args = + List.fold_left (fun args a -> zfun a ::args) (m::kargs) rargs in + let h = mkApp (mkConstU c, Array.of_list args) in + zip_term zfun h s (* Computes the strong normal form of a term. 1- Calls kni @@ -972,7 +1220,7 @@ and norm_head info tab m = | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ - | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ -> term_of_fconstr m + | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ | FInt _ -> term_of_fconstr m (* Initialization and then normalization *) @@ -1015,9 +1263,9 @@ let unfold_reference info tab key = | ConstKey (kn,_) -> if red_set info.i_flags (fCONST kn) then ref_value_cache info tab key - else None + else Undef None | VarKey i -> if red_set info.i_flags (fVAR i) then ref_value_cache info tab key - else None + else Undef None | RelKey _ -> ref_value_cache info tab key diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 46be1bb279..bd04677374 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -10,6 +10,7 @@ open Names open Constr +open Declarations open Environ open Esubst @@ -117,6 +118,7 @@ type fterm = | FProd of Name.t * fconstr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs + | FInt of Uint63.t | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED @@ -124,12 +126,15 @@ type fterm = (*********************************************************************** s A [stack] is a context of arguments, arguments are pushed by [append_stack] one array at a time *) +type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack + | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args + (* operator, constr def, reduced arguments rev, next arguments *) | Zshift of int | Zupdate of fconstr @@ -138,6 +143,10 @@ and stack = stack_member list val empty_stack : stack val append_stack : fconstr array -> stack -> stack +val check_native_args : CPrimitives.t -> stack -> bool +val get_native_args1 : CPrimitives.t -> pconstant -> stack -> + fconstr list * fconstr * fconstr next_native_args * stack + val stack_args_size : stack -> int val eta_expand_stack : stack -> stack @@ -201,7 +210,7 @@ val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) -val unfold_reference : clos_infos -> clos_tab -> table_key -> fconstr option +val unfold_reference : clos_infos -> clos_tab -> table_key -> fconstr constant_def (*********************************************************************** i This is for lazy debug *) diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 5b91a9b572..da5c4fb07b 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -9,85 +9,147 @@ (************************************************************************) type t = - | Int31head0 - | Int31tail0 - | Int31add - | Int31sub - | Int31mul - | Int31div - | Int31mod -(* - | Int31lsr - | Int31lsl - *) - | Int31land - | Int31lor - | Int31lxor - | Int31addc - | Int31subc - | Int31addcarryc - | Int31subcarryc - | Int31mulc - | Int31diveucl - | Int31div21 - | Int31addmuldiv - | Int31eq - | Int31lt - | Int31le - | Int31compare + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC + | Int63mulc + | Int63diveucl + | Int63div21 + | Int63addMulDiv + | Int63eq + | Int63lt + | Int63le + | Int63compare + +let equal (p1 : t) (p2 : t) = + p1 == p2 let hash = function - | Int31head0 -> 1 - | Int31tail0 -> 2 - | Int31add -> 3 - | Int31sub -> 4 - | Int31mul -> 5 - | Int31div -> 6 - | Int31mod -> 7 -(* - | Int31lsr -> 8 - | Int31lsl -> 9 - *) - | Int31land -> 10 - | Int31lor -> 11 - | Int31lxor -> 12 - | Int31addc -> 13 - | Int31subc -> 14 - | Int31addcarryc -> 15 - | Int31subcarryc -> 16 - | Int31mulc -> 17 - | Int31diveucl -> 18 - | Int31div21 -> 19 - | Int31addmuldiv -> 20 - | Int31eq -> 21 - | Int31lt -> 22 - | Int31le -> 23 - | Int31compare -> 24 + | Int63head0 -> 1 + | Int63tail0 -> 2 + | Int63add -> 3 + | Int63sub -> 4 + | Int63mul -> 5 + | Int63div -> 6 + | Int63mod -> 7 + | Int63lsr -> 8 + | Int63lsl -> 9 + | Int63land -> 10 + | Int63lor -> 11 + | Int63lxor -> 12 + | Int63addc -> 13 + | Int63subc -> 14 + | Int63addCarryC -> 15 + | Int63subCarryC -> 16 + | Int63mulc -> 17 + | Int63diveucl -> 18 + | Int63div21 -> 19 + | Int63addMulDiv -> 20 + | Int63eq -> 21 + | Int63lt -> 22 + | Int63le -> 23 + | Int63compare -> 24 +(* Should match names in nativevalues.ml *) let to_string = function - | Int31head0 -> "head0" - | Int31tail0 -> "tail0" - | Int31add -> "add" - | Int31sub -> "sub" - | Int31mul -> "mul" - | Int31div -> "div" - | Int31mod -> "mod" -(* - | Int31lsr -> "l_sr" - | Int31lsl -> "l_sl" - *) - | Int31land -> "l_and" - | Int31lor -> "l_or" - | Int31lxor -> "l_xor" - | Int31addc -> "addc" - | Int31subc -> "subc" - | Int31addcarryc -> "addcarryc" - | Int31subcarryc -> "subcarryc" - | Int31mulc -> "mulc" - | Int31diveucl -> "diveucl" - | Int31div21 -> "div21" - | Int31addmuldiv -> "addmuldiv" - | Int31eq -> "eq" - | Int31lt -> "lt" - | Int31le -> "le" - | Int31compare -> "compare" + | Int63head0 -> "head0" + | Int63tail0 -> "tail0" + | Int63add -> "add" + | Int63sub -> "sub" + | Int63mul -> "mul" + | Int63div -> "div" + | Int63mod -> "rem" + | Int63lsr -> "l_sr" + | Int63lsl -> "l_sl" + | Int63land -> "l_and" + | Int63lor -> "l_or" + | Int63lxor -> "l_xor" + | Int63addc -> "addc" + | Int63subc -> "subc" + | Int63addCarryC -> "addCarryC" + | Int63subCarryC -> "subCarryC" + | Int63mulc -> "mulc" + | Int63diveucl -> "diveucl" + | Int63div21 -> "div21" + | Int63addMulDiv -> "addMulDiv" + | Int63eq -> "eq" + | Int63lt -> "lt" + | Int63le -> "le" + | Int63compare -> "compare" + +type arg_kind = + | Kparam (* not needed for the evaluation of the primitive when it reduces *) + | Kwhnf (* need to be reduced in whnf before reducing the primitive *) + | Karg (* no need to be reduced in whnf. example: [v] in [Array.set t i v] *) + +type args_red = arg_kind list + +(* Invariant only argument of type int63 or an inductive can + have kind Kwhnf *) + +let kind = function + | Int63head0 | Int63tail0 -> [Kwhnf] + + | Int63add | Int63sub | Int63mul + | Int63div | Int63mod + | Int63lsr | Int63lsl + | Int63land | Int63lor | Int63lxor + | Int63addc | Int63subc + | Int63addCarryC | Int63subCarryC | Int63mulc | Int63diveucl + | Int63eq | Int63lt | Int63le | Int63compare -> [Kwhnf; Kwhnf] + + | Int63div21 | Int63addMulDiv -> [Kwhnf; Kwhnf; Kwhnf] + +let arity = function + | Int63head0 | Int63tail0 -> 1 + | Int63add | Int63sub | Int63mul + | Int63div | Int63mod + | Int63lsr | Int63lsl + | Int63land | Int63lor | Int63lxor + | Int63addc | Int63subc + | Int63addCarryC | Int63subCarryC | Int63mulc | Int63diveucl + | Int63eq | Int63lt | Int63le + | Int63compare -> 2 + + | Int63div21 | Int63addMulDiv -> 3 + +(** Special Entries for Register **) + +type prim_ind = + | PIT_bool + | PIT_carry + | PIT_pair + | PIT_cmp + +type prim_type = + | PT_int63 + +type op_or_type = + | OT_op of t + | OT_type of prim_type + +let prim_ind_to_string = function + | PIT_bool -> "bool" + | PIT_carry -> "carry" + | PIT_pair -> "pair" + | PIT_cmp -> "cmp" + +let prim_type_to_string = function + | PT_int63 -> "int63" + +let op_or_type_to_string = function + | OT_op op -> to_string op + | OT_type t -> prim_type_to_string t diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index 1e99a69d2f..3f8174bd7b 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -9,33 +9,62 @@ (************************************************************************) type t = - | Int31head0 - | Int31tail0 - | Int31add - | Int31sub - | Int31mul - | Int31div - | Int31mod -(* - | Int31lsr - | Int31lsl - *) - | Int31land - | Int31lor - | Int31lxor - | Int31addc - | Int31subc - | Int31addcarryc - | Int31subcarryc - | Int31mulc - | Int31diveucl - | Int31div21 - | Int31addmuldiv - | Int31eq - | Int31lt - | Int31le - | Int31compare + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC + | Int63mulc + | Int63diveucl + | Int63div21 + | Int63addMulDiv + | Int63eq + | Int63lt + | Int63le + | Int63compare + +val equal : t -> t -> bool + +type arg_kind = + | Kparam (* not needed for the elavuation of the primitive*) + | Kwhnf (* need to be reduced in whnf before reducing the primitive *) + | Karg (* no need to be reduced in whnf *) + +type args_red = arg_kind list val hash : t -> int val to_string : t -> string + +val arity : t -> int + +val kind : t -> args_red + +(** Special Entries for Register **) + +type prim_ind = + | PIT_bool + | PIT_carry + | PIT_pair + | PIT_cmp + +type prim_type = + | PT_int63 + +type op_or_type = + | OT_op of t + | OT_type of prim_type + +val prim_ind_to_string : prim_ind -> string +val op_or_type_to_string : op_or_type -> string diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index c63795b295..7570004fe5 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -16,6 +16,7 @@ open Names open Vmvalues +open Constr module Label = struct @@ -26,7 +27,6 @@ module Label = let reset_label_counter () = counter := no end - type instruction = | Klabel of Label.t | Kacc of int @@ -59,46 +59,9 @@ type instruction = | Ksequence of bytecodes * bytecodes | Kproj of Projection.Repr.t | Kensurestackcapacity of int -(* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) - | Kaddint31 (* adds the int31 in the accu - and the one ontop of the stack *) - | Kaddcint31 (* makes the sum and keeps the carry *) - | Kaddcarrycint31 (* sum +1, keeps the carry *) - | Ksubint31 (* subtraction modulo *) - | Ksubcint31 (* subtraction, keeps the carry *) - | Ksubcarrycint31 (* subtraction -1, keeps the carry *) - | Kmulint31 (* multiplication modulo *) - | Kmulcint31 (* multiplication, result in two - int31, for exact computation *) - | Kdiv21int31 (* divides a double size integer - (represented by an int31 in the - accumulator and one on the top of - the stack) by an int31. The result - is a pair of the quotient and the - rest. - If the divisor is 0, it returns - 0. *) - | Kdivint31 (* euclidian division (returns a pair - quotient,rest) *) - | Kaddmuldivint31 (* generic operation for shifting and - cycling. Takes 3 int31 i j and s, - and returns x*2^s+y/(2^(31-s) *) - | Kcompareint31 (* unsigned comparison of int31 - cf COMPAREINT31 in - kernel/byterun/coq_interp.c - for more info *) - | Khead0int31 (* Give the numbers of 0 in head of a in31*) - | Ktail0int31 (* Give the numbers of 0 in tail of a in31 - ie low bits *) - | Kisconst of Label.t (* conditional jump *) - | Kareconst of int*Label.t (* conditional jump *) - | Kcompint31 (* dynamic compilation of int31 *) - | Kdecompint31 (* dynamic decompilation of int31 *) - | Klorint31 (* bitwise operations: or and xor *) - | Klandint31 - | Klxorint31 -(* /spiwack *) + | Kprim of CPrimitives.t * pconstant option + | Kareint of int and bytecodes = instruction list @@ -110,53 +73,6 @@ type fv_elem = type fv = fv_elem array -(* spiwack: this exception is expected to be raised by function expecting - closed terms. *) -exception NotClosed - - -module Fv_elem = -struct -type t = fv_elem - -let compare e1 e2 = match e1, e2 with -| FVnamed id1, FVnamed id2 -> Id.compare id1 id2 -| FVnamed _, (FVrel _ | FVuniv_var _ | FVevar _) -> -1 -| FVrel _, FVnamed _ -> 1 -| FVrel r1, FVrel r2 -> Int.compare r1 r2 -| FVrel _, (FVuniv_var _ | FVevar _) -> -1 -| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 -| FVuniv_var _i1, (FVnamed _ | FVrel _) -> 1 -| FVuniv_var _i1, FVevar _ -> -1 -| FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1 -| FVevar e1, FVevar e2 -> Evar.compare e1 e2 - -end - -module FvMap = Map.Make(Fv_elem) - -(*spiwack: both type have been moved from Cbytegen because I needed then - for the retroknowledge *) -type vm_env = { - size : int; (* longueur de la liste [n] *) - fv_rev : fv_elem list; (* [fvn; ... ;fv1] *) - fv_fwd : int FvMap.t; (* reverse mapping *) - } - - -type comp_env = { - arity : int; (* arity of the current function, 0 if none *) - nb_uni_stack : int ; (* number of universes on the stack, *) - (* universes are always at the bottom. *) - nb_stack : int; (* number of variables on the stack *) - in_stack : int list; (* position in the stack *) - nb_rec : int; (* number of mutually recursive functions *) - pos_rec : instruction list; (* instruction d'acces pour les variables *) - (* de point fix ou de cofix *) - offset : int; - in_env : vm_env ref (* The free variables of the expression *) - } - (* --- Pretty print *) open Pp open Util @@ -228,28 +144,10 @@ let rec pp_instr i = | Kensurestackcapacity size -> str "growstack " ++ int size - | Kaddint31 -> str "addint31" - | Kaddcint31 -> str "addcint31" - | Kaddcarrycint31 -> str "addcarrycint31" - | Ksubint31 -> str "subint31" - | Ksubcint31 -> str "subcint31" - | Ksubcarrycint31 -> str "subcarrycint31" - | Kmulint31 -> str "mulint31" - | Kmulcint31 -> str "mulcint31" - | Kdiv21int31 -> str "div21int31" - | Kdivint31 -> str "divint31" - | Kcompareint31 -> str "compareint31" - | Khead0int31 -> str "head0int31" - | Ktail0int31 -> str "tail0int31" - | Kaddmuldivint31 -> str "addmuldivint31" - | Kisconst lbl -> str "isconst " ++ int lbl - | Kareconst(n,lbl) -> str "areconst " ++ int n ++ spc () ++ int lbl - | Kcompint31 -> str "compint31" - | Kdecompint31 -> str "decompint" - | Klorint31 -> str "lorint31" - | Klandint31 -> str "landint31" - | Klxorint31 -> str "lxorint31" + | Kprim (op, id) -> str (CPrimitives.to_string op) ++ str " " ++ + (match id with Some (id,_u) -> Constant.print id | None -> str "") + | Kareint n -> str "areint " ++ int n and pp_bytecodes c = match c with diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 9c04c166a2..423e7bbe65 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -12,6 +12,7 @@ open Names open Vmvalues +open Constr module Label : sig @@ -57,48 +58,15 @@ type instruction = | Kproj of Projection.Repr.t | Kensurestackcapacity of int -(** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) - | Kaddint31 (** adds the int31 in the accu - and the one ontop of the stack *) - | Kaddcint31 (** makes the sum and keeps the carry *) - | Kaddcarrycint31 (** sum +1, keeps the carry *) - | Ksubint31 (** subtraction modulo *) - | Ksubcint31 (** subtraction, keeps the carry *) - | Ksubcarrycint31 (** subtraction -1, keeps the carry *) - | Kmulint31 (** multiplication modulo *) - | Kmulcint31 (** multiplication, result in two - int31, for exact computation *) - | Kdiv21int31 (** divides a double size integer - (represented by an int31 in the - accumulator and one on the top of - the stack) by an int31. The result - is a pair of the quotient and the - rest. - If the divisor is 0, it returns - 0. *) - | Kdivint31 (** euclidian division (returns a pair - quotient,rest) *) - | Kaddmuldivint31 (** generic operation for shifting and - cycling. Takes 3 int31 i j and s, - and returns x*2^s+y/(2^(31-s) *) - | Kcompareint31 (** unsigned comparison of int31 - cf COMPAREINT31 in - kernel/byterun/coq_interp.c - for more info *) - | Khead0int31 (** Give the numbers of 0 in head of a in31*) - | Ktail0int31 (** Give the numbers of 0 in tail of a in31 - ie low bits *) - | Kisconst of Label.t (** conditional jump *) - | Kareconst of int*Label.t (** conditional jump *) - | Kcompint31 (** dynamic compilation of int31 *) - | Kdecompint31 (** dynamix decompilation of int31 *) - | Klorint31 (** bitwise operations: or and xor *) - | Klandint31 - | Klxorint31 + | Kprim of CPrimitives.t * pconstant option + + | Kareint of int and bytecodes = instruction list +val pp_bytecodes : bytecodes -> Pp.t + type fv_elem = FVnamed of Id.t | FVrel of int @@ -107,34 +75,4 @@ type fv_elem = type fv = fv_elem array - -(** spiwack: this exception is expected to be raised by function expecting - closed terms. *) -exception NotClosed - -module FvMap : Map.S with type key = fv_elem - -(*spiwack: both type have been moved from Cbytegen because I needed them - for the retroknowledge *) -type vm_env = { - size : int; (** length of the list [n] *) - fv_rev : fv_elem list; (** [fvn; ... ;fv1] *) - fv_fwd : int FvMap.t; (** reverse mapping *) - } - - -type comp_env = { - arity : int; (* arity of the current function, 0 if none *) - nb_uni_stack : int ; (** number of universes on the stack *) - nb_stack : int; (** number of variables on the stack *) - in_stack : int list; (** position in the stack *) - nb_rec : int; (** number of mutually recursive functions *) - (** (= nbr) *) - pos_rec : instruction list; (** instruction d'acces pour les variables *) - (** de point fix ou de cofix *) - offset : int; - in_env : vm_env ref (** the variables that are accessed *) - } - -val pp_bytecodes : bytecodes -> Pp.t val pp_fv_elem : fv_elem -> Pp.t diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 73620ae578..718584b3d4 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -17,7 +17,6 @@ open Names open Vmvalues open Cbytecodes open Cemitcodes -open Cinstr open Clambda open Constr open Declarations @@ -97,6 +96,48 @@ open Environ (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) +module Fv_elem = +struct +type t = fv_elem + +let compare e1 e2 = match e1, e2 with +| FVnamed id1, FVnamed id2 -> Id.compare id1 id2 +| FVnamed _, (FVrel _ | FVuniv_var _ | FVevar _) -> -1 +| FVrel _, FVnamed _ -> 1 +| FVrel r1, FVrel r2 -> Int.compare r1 r2 +| FVrel _, (FVuniv_var _ | FVevar _) -> -1 +| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 +| FVuniv_var _, (FVnamed _ | FVrel _) -> 1 +| FVuniv_var _, FVevar _ -> -1 +| FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1 +| FVevar e1, FVevar e2 -> Evar.compare e1 e2 + +end + +module FvMap = Map.Make(Fv_elem) + +(*spiwack: both type have been moved from Cbytegen because I needed then + for the retroknowledge *) +type vm_env = { + size : int; (* longueur de la liste [n] *) + fv_rev : fv_elem list; (* [fvn; ... ;fv1] *) + fv_fwd : int FvMap.t; (* reverse mapping *) + } + + +type comp_env = { + arity : int; (* arity of the current function, 0 if none *) + nb_uni_stack : int ; (* number of universes on the stack, *) + (* universes are always at the bottom. *) + nb_stack : int; (* number of variables on the stack *) + in_stack : int list; (* position in the stack *) + nb_rec : int; (* number of mutually recursive functions *) + pos_rec : instruction list; (* instruction d'acces pour les variables *) + (* de point fix ou de cofix *) + offset : int; + in_env : vm_env ref (* The free variables of the expression *) + } + module Config = struct let stack_threshold = 256 (* see byterun/coq_memory.h *) let stack_safety_margin = 15 @@ -391,7 +432,6 @@ let init_fun_code () = fun_code := [] (* Compilation of constructors and inductive types *) -(* Inv: arity > 0 *) (* If [tag] hits the OCaml limitation for non constant constructors, we switch to @@ -437,7 +477,7 @@ let comp_app comp_fun comp_arg cenv f args sz cont = comp_fun cenv f (sz + nargs) (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> - if nargs < 4 then + if nargs <= 4 then comp_args comp_arg cenv args sz (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) else @@ -476,15 +516,6 @@ let rec get_alias env kn = | BCalias kn' -> get_alias env kn' | _ -> kn) -(* spiwack: additional function which allow different part of compilation of the - 31-bit integers *) - -let make_areconst n else_lbl cont = - if n <= 0 then - cont - else - Kareconst (n, else_lbl)::cont - (* sz is the size of the local stack *) let rec compile_lam env cenv lam sz cont = set_max_stack_size sz; @@ -495,6 +526,8 @@ let rec compile_lam env cenv lam sz cont = | Lval v -> compile_structured_constant cenv (Const_val v) sz cont + | Luint i -> compile_structured_constant cenv (Const_uint i) sz cont + | Lproj (p,arg) -> compile_lam env cenv arg sz (Kproj p :: cont) @@ -629,6 +662,17 @@ let rec compile_lam env cenv lam sz cont = compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) + | Lif(t, bt, bf) -> + let branch, cont = make_branch cont in + let lbl_true = Label.create() in + let lbl_false = Label.create() in + compile_lam env cenv t sz + (Kswitch([|lbl_true;lbl_false|],[||]) :: + Klabel lbl_false :: + compile_lam env cenv bf sz + (branch :: + Klabel lbl_true :: + compile_lam env cenv bt sz cont)) | Lcase(ci,rtbl,t,a,branches) -> let ind = ci.ci_ind in @@ -729,41 +773,9 @@ let rec compile_lam env cenv lam sz cont = let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args (compile_lam env) cenv args sz cont - | Lprim (kn, ar, op, args) -> - op_compilation env ar op kn cenv args sz cont - - | Luint v -> - (match v with - | UintVal i -> compile_structured_constant cenv (Const_b0 (Uint31.to_int i)) sz cont - | UintDigits ds -> - let nargs = Array.length ds in - if Int.equal nargs 31 then - let (escape,labeled_cont) = make_branch cont in - let else_lbl = Label.create() in - comp_args (compile_lam env) cenv ds sz - ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) - else - let code_construct cont = (* spiwack: variant of the global code_construct - which handles dynamic compilation of - integers *) - let f_cont = - let else_lbl = Label.create () in - [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); - Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] - in - let lbl = Label.create() in - fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; - Kclosure(lbl,0) :: cont - in - comp_app (fun _ _ _ cont -> code_construct cont) - (compile_lam env) cenv () ds sz cont - | UintDecomp t -> - let escape_lbl, labeled_cont = label_code cont in - compile_lam env cenv t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont)) - - -(* spiwack : compilation of constants with their arguments. - Makes a special treatment with 31-bit integer addition *) + | Lprim (kn, op, args) -> + comp_args (compile_lam env) cenv args sz (Kprim(op, kn)::cont) + and compile_get_global cenv (kn,u) sz cont = set_max_stack_size sz; if Univ.Instance.is_empty u then @@ -800,43 +812,6 @@ and compile_constant env cenv kn u args sz cont = comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) compile_arg cenv () all sz cont -(*template for n-ary operation, invariant: n>=1, - the operations does the following : - 1/ checks if all the arguments are constants (i.e. non-block values) - 2/ if they are, uses the "op" instruction to execute - 3/ if at least one is not, branches to the normal behavior: - Kgetglobal (get_alias !global_env kn) *) -and op_compilation env n op = - let code_construct cenv kn sz cont = - let f_cont = - let else_lbl = Label.create () in - Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: - op:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) - compile_get_global cenv kn sz ( - Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in - fun kn cenv args sz cont -> - let nargs = Array.length args in - if Int.equal nargs n then (*if it is a fully applied addition*) - let (escape, labeled_cont) = make_branch cont in - let else_lbl = Label.create () in - assert (n < 4); - comp_args (compile_lam env) cenv args sz - (Kisconst else_lbl::(make_areconst (n-1) else_lbl - (*Kaddint31::escape::Klabel else_lbl::Kpush::*) - (op::escape::Klabel else_lbl::Kpush:: - (* works as comp_app with nargs < 4 and non-tailcall cont*) - compile_get_global cenv kn (sz+n) (Kapply n::labeled_cont)))) - else - comp_app (fun cenv _ sz cont -> code_construct cenv kn sz cont) - (compile_lam env) cenv () args sz cont - - let is_univ_copy max u = let u = Univ.Instance.to_array u in if Array.length u = max then @@ -903,14 +878,10 @@ let compile ~fail_on_error ?universes:(universes=0) env c = fn msg; None let compile_constant_body ~fail_on_error env univs = function - | Undef _ | OpaqueDef _ -> Some BCconstant + | Undef _ | OpaqueDef _ | Primitive _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in - let instance_size = - match univs with - | Monomorphic_const _ -> 0 - | Polymorphic_const univ -> Univ.AUContext.size univ - in + let instance_size = Univ.AUContext.size (Declareops.universes_context univs) in match kind body with | Const (kn',u) when is_univ_copy instance_size u -> (* we use the canonical name of the constant*) @@ -923,41 +894,3 @@ let compile_constant_body ~fail_on_error env univs = function (* Shortcut of the previous function used during module strengthening *) let compile_alias kn = BCalias (Constant.make1 (Constant.canonical kn)) - -(*(* template compilation for 2ary operation, it probably possible - to make a generic such function with arity abstracted *) -let op2_compilation op = - let code_construct normal cont = (*kn cont =*) - let f_cont = - let else_lbl = Label.create () in - Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: - op:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) - (*Kgetglobal (get_alias !global_env kn):: *) - normal:: - Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in - fun normal fc _ cenv args sz cont -> - if not fc then raise Not_found else - let nargs = Array.length args in - if nargs=2 then (*if it is a fully applied addition*) - let (escape, labeled_cont) = make_branch cont in - let else_lbl = Label.create () in - comp_args compile_constr cenv args sz - (Kisconst else_lbl::(make_areconst 1 else_lbl - (*Kaddint31::escape::Klabel else_lbl::Kpush::*) - (op::escape::Klabel else_lbl::Kpush:: - (* works as comp_app with nargs = 2 and non-tailcall cont*) - (*Kgetglobal (get_alias !global_env kn):: *) - normal:: - Kapply 2::labeled_cont))) - else if nargs=0 then - code_construct normal cont - else - comp_app (fun _ _ _ cont -> code_construct normal cont) - compile_constr cenv () args sz cont *) - diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 57d3e6fc27..6a9550342c 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -20,7 +20,8 @@ val compile : fail_on_error:bool -> (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> - env -> constant_universes -> constant_def -> body_code option + env -> universes -> Constr.t Mod_subst.substituted constant_def -> + body_code option (** Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 50f5607e31..a84a7c0cf9 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -18,6 +18,7 @@ open Vmvalues open Cbytecodes open Copcodes open Mod_subst +open CPrimitives type emitcodes = String.t @@ -129,6 +130,8 @@ let out_word env b1 b2 b3 b4 = let out env opcode = out_word env opcode 0 0 0 +let is_immed i = Uint63.le (Uint63.of_int i) Uint63.maxuint31 + let out_int env n = out_word env n (n asr 8) (n asr 16) (n asr 24) @@ -198,6 +201,39 @@ let slot_for_proj_name env p = (* Emission of one instruction *) +let nocheck_prim_op = function + | Int63add -> opADDINT63 + | Int63sub -> opSUBINT63 + | Int63lt -> opLTINT63 + | Int63le -> opLEINT63 + | _ -> assert false + + +let check_prim_op = function + | Int63head0 -> opCHECKHEAD0INT63 + | Int63tail0 -> opCHECKTAIL0INT63 + | Int63add -> opCHECKADDINT63 + | Int63sub -> opCHECKSUBINT63 + | Int63mul -> opCHECKMULINT63 + | Int63div -> opCHECKDIVINT63 + | Int63mod -> opCHECKMODINT63 + | Int63lsr -> opCHECKLSRINT63 + | Int63lsl -> opCHECKLSLINT63 + | Int63land -> opCHECKLANDINT63 + | Int63lor -> opCHECKLORINT63 + | Int63lxor -> opCHECKLXORINT63 + | Int63addc -> opCHECKADDCINT63 + | Int63subc -> opCHECKSUBCINT63 + | Int63addCarryC -> opCHECKADDCARRYCINT63 + | Int63subCarryC -> opCHECKSUBCARRYCINT63 + | Int63mulc -> opCHECKMULCINT63 + | Int63diveucl -> opCHECKDIVEUCLINT63 + | Int63div21 -> opCHECKDIV21INT63 + | Int63addMulDiv -> opCHECKADDMULDIVINT63 + | Int63eq -> opCHECKEQINT63 + | Int63lt -> opCHECKLTINT63 + | Int63le -> opCHECKLEINT63 + | Int63compare -> opCHECKCOMPAREINT63 let emit_instr env = function | Klabel lbl -> define_label env lbl @@ -218,7 +254,7 @@ let emit_instr env = function | Kpush_retaddr lbl -> out env opPUSH_RETADDR; out_label env lbl | Kapply n -> - if n < 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) + if n <= 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) | Kappterm(n, sz) -> if n < 4 then (out env(opAPPTERM1 + n - 1); out_int env sz) else (out env opAPPTERM; out_int env n; out_int env sz) @@ -250,7 +286,7 @@ let emit_instr env = function Array.iter (out_label_with_orig env org) lbl_bodies | Kgetglobal q -> out env opGETGLOBAL; slot_for_getglobal env q - | Kconst (Const_b0 i) -> + | Kconst (Const_b0 i) when is_immed i -> if i >= 0 && i <= 3 then out env (opCONST0 + i) else (out env opCONSTINT; out_int env i) @@ -287,32 +323,20 @@ let emit_instr env = function | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size - (* spiwack *) | Kbranch lbl -> out env opBRANCH; out_label env lbl - | Kaddint31 -> out env opADDINT31 - | Kaddcint31 -> out env opADDCINT31 - | Kaddcarrycint31 -> out env opADDCARRYCINT31 - | Ksubint31 -> out env opSUBINT31 - | Ksubcint31 -> out env opSUBCINT31 - | Ksubcarrycint31 -> out env opSUBCARRYCINT31 - | Kmulint31 -> out env opMULINT31 - | Kmulcint31 -> out env opMULCINT31 - | Kdiv21int31 -> out env opDIV21INT31 - | Kdivint31 -> out env opDIVINT31 - | Kaddmuldivint31 -> out env opADDMULDIVINT31 - | Kcompareint31 -> out env opCOMPAREINT31 - | Khead0int31 -> out env opHEAD0INT31 - | Ktail0int31 -> out env opTAIL0INT31 - | Kisconst lbl -> out env opISCONST; out_label env lbl - | Kareconst(n,lbl) -> out env opARECONST; out_int env n; out_label env lbl - | Kcompint31 -> out env opCOMPINT31 - | Kdecompint31 -> out env opDECOMPINT31 - | Klorint31 -> out env opORINT31 - | Klandint31 -> out env opANDINT31 - | Klxorint31 -> out env opXORINT31 - (*/spiwack *) - | Kstop -> - out env opSTOP + | Kprim (op,None) -> + out env (nocheck_prim_op op) + + | Kprim(op,Some (q,_u)) -> + out env (check_prim_op op); + slot_for_getglobal env q + + | Kareint 1 -> out env opISINT + | Kareint 2 -> out env opAREINT2; + + | Kstop -> out env opSTOP + + | Kareint _ -> assert false (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) @@ -337,7 +361,7 @@ let rec emit env insns remaining = match insns with emit env c remaining | Kpush :: Kgetglobal id :: c -> out env opPUSHGETGLOBAL; slot_for_getglobal env id; emit env c remaining - | Kpush :: Kconst (Const_b0 i) :: c -> + | Kpush :: Kconst (Const_b0 i) :: c when is_immed i -> if i >= 0 && i <= 3 then out env (opPUSHCONST0 + i) else (out env opPUSHCONSTINT; out_int env i); @@ -360,7 +384,7 @@ type to_patch = emitcodes * patches * fv (* Substitution *) let subst_strcst s sc = match sc with - | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ -> sc + | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ | Const_uint _ -> sc | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_reloc s ri = diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 39ddf4a047..41cc641dc8 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -1,3 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) open Names open Vmvalues open Cbytecodes diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli deleted file mode 100644 index dca1757b7d..0000000000 --- a/kernel/cinstr.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -open Names -open Constr -open Vmvalues -open Cbytecodes - -(** This file defines the lambda code for the bytecode compiler. It has been -extracted from Clambda.ml because of the retroknowledge architecture. *) - -type uint = - | UintVal of Uint31.t - | UintDigits of lambda array - | UintDecomp of lambda - -and lambda = - | Lrel of Name.t * int - | Lvar of Id.t - | Levar of Evar.t * lambda array - | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda - | Lapp of lambda * lambda array - | Lconst of pconstant - | Lprim of pconstant * int (* arity *) * instruction * lambda array - | Lcase of case_info * reloc_table * lambda * lambda * lam_branches - | Lfix of (int array * int) * fix_decl - | Lcofix of int * fix_decl (* must be in eta-expanded form *) - | Lmakeblock of int * lambda array - | Lval of structured_values - | Lsort of Sorts.t - | Lind of pinductive - | Lproj of Projection.Repr.t * lambda - | Lint of int - | Luint of uint - -(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation -to be correct. Otherwise, memoization of previous evaluations will be applied -again to extra arguments (see #7333). *) - -and lam_branches = - { constant_branches : lambda array; - nonconstant_branches : (Name.t array * lambda) array } - -and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 1e4dbfd418..5c21a5ec25 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -5,13 +5,44 @@ open Term open Constr open Declarations open Vmvalues -open Cbytecodes -open Cinstr open Environ open Pp let pr_con sp = str(Names.Label.to_string (Constant.label sp)) +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Levar of Evar.t * lambda array + | Lprod of lambda * lambda + | Llam of Name.t array * lambda + | Llet of Name.t * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of pconstant + | Lprim of pconstant option * CPrimitives.t * lambda array + (* No check if None *) + | Lcase of case_info * reloc_table * lambda * lambda * lam_branches + | Lif of lambda * lambda * lambda + | Lfix of (int array * int) * fix_decl + | Lcofix of int * fix_decl + | Lint of int + | Lmakeblock of int * lambda array + | Luint of Uint63.t + | Lval of structured_values + | Lsort of Sorts.t + | Lind of pinductive + | Lproj of Projection.Repr.t * lambda + +(* We separate branches for constant and non-constant constructors. If the OCaml + limitation on non-constant constructors is reached, remaining branches are + stored in [extra_branches]. *) +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t array * lambda) array } +(* extra_branches : (name array * lambda) array } *) + +and fix_decl = Name.t array * lambda array * lambda array + (** Printing **) let pp_names ids = @@ -77,6 +108,10 @@ let rec pp_lam lam = pp_names ids ++ str " => " ++ pp_lam c) (Array.to_list branches.nonconstant_branches))) ++ cut() ++ str "end") + | Lif (t, bt, bf) -> + v 0 (str "(if " ++ pp_lam t ++ + cut () ++ str "then " ++ pp_lam bt ++ + cut() ++ str "else " ++ pp_lam bf ++ str ")") | Lfix((t,i),(lna,tl,bl)) -> let fixl = Array.mapi (fun i id -> (id,t.(i),tl.(i),bl.(i))) lna in hov 1 @@ -104,22 +139,26 @@ let rec pp_lam lam = (str "(makeblock " ++ int tag ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") + | Luint i -> str (Uint63.to_string i) | Lval _ -> str "values" | Lsort s -> pp_sort s | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i - | Lprim((kn,_u),_ar,_op,args) -> - hov 1 - (str "(PRIM " ++ pr_con kn ++ spc() ++ - prlist_with_sep spc pp_lam (Array.to_list args) ++ - str")") + | Lprim(Some (kn,_u),_op,args) -> + hov 1 + (str "(PRIM " ++ pr_con kn ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") + | Lprim(None,op,args) -> + hov 1 + (str "(PRIM_NC " ++ str (CPrimitives.to_string op) ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") | Lproj(p,arg) -> hov 1 (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg ++ str ")") | Lint i -> Pp.(str "(int:" ++ int i ++ str ")") - | Luint _ -> - str "(uint)" (*s Constructors *) @@ -151,9 +190,9 @@ let shift subst = subs_shft (1, subst) (* A generic map function *) -let rec map_lam_with_binders g f n lam = +let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> lam + | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ -> lam | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') @@ -192,6 +231,11 @@ let rec map_lam_with_binders g f n lam = in if t == t' && a == a' && branches == branches' then lam else Lcase(ci,rtbl,t',a',branches') + | Lif(t,bt,bf) -> + let t' = f n t in + let bt' = f n bt in + let bf' = f n bf in + if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> let ltypes' = Array.Smart.map (f n) ltypes in let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in @@ -205,25 +249,12 @@ let rec map_lam_with_binders g f n lam = | Lmakeblock(tag,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(tag,args') - | Lprim(kn,ar,op,args) -> + | Lprim(kn,op,args) -> let args' = Array.Smart.map (f n) args in - if args == args' then lam else Lprim(kn,ar,op,args') + if args == args' then lam else Lprim(kn,op,args') | Lproj(p,arg) -> let arg' = f n arg in if arg == arg' then lam else Lproj(p,arg') - | Luint u -> - let u' = map_uint g f n u in - if u == u' then lam else Luint u' - -and map_uint _g f n u = - match u with - | UintVal _ -> u - | UintDigits(args) -> - let args' = Array.Smart.map (f n) args in - if args == args' then u else UintDigits(args') - | UintDecomp(a) -> - let a' = f n a in - if a == a' then u else UintDecomp(a') (*s Lift and substitution *) @@ -271,28 +302,58 @@ let lam_subst_args subst args = let can_subst lam = match lam with - | Lrel _ | Lvar _ | Lconst _ + | Lrel _ | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ -> true | _ -> false + +let can_merge_if bt bf = + match bt, bf with + | Llam(_idst,_), Llam(_idsf,_) -> true + | _ -> false + +let merge_if t bt bf = + let (idst,bodyt) = decompose_Llam bt in + let (idsf,bodyf) = decompose_Llam bf in + let nt = Array.length idst in + let nf = Array.length idsf in + let common,idst,idsf = + if nt = nf then idst, [||], [||] + else + if nt < nf then idst,[||], Array.sub idsf nt (nf - nt) + else idsf, Array.sub idst nf (nt - nf), [||] in + Llam(common, + Lif(lam_lift (Array.length common) t, + mkLlam idst bodyt, + mkLlam idsf bodyf)) + + let rec simplify subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst | Llet(id,def,body) -> - let def' = simplify subst def in - if can_subst def' then simplify (cons def' subst) body - else - let body' = simplify (lift subst) body in - if def == def' && body == body' then lam - else Llet(id,def',body') + let def' = simplify subst def in + if can_subst def' then simplify (cons def' subst) body + else + let body' = simplify (lift subst) body in + if def == def' && body == body' then lam + else Llet(id,def',body') | Lapp(f,args) -> - begin match simplify_app subst f subst args with + begin match simplify_app subst f subst args with | Lapp(f',args') when f == f' && args == args' -> lam | lam' -> lam' - end + end + | Lif(t,bt,bf) -> + let t' = simplify subst t in + let bt' = simplify subst bt in + let bf' = simplify subst bf in + if can_merge_if bt' bf' then merge_if t' bt' bf' + else + if t == t' && bt == bt' && bf == bf' then lam + else Lif(t',bt',bf') | _ -> map_lam_with_binders liftn simplify subst lam and simplify_app substf f substa args = @@ -352,7 +413,7 @@ let rec occurrence k kind lam = if n = k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> kind + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ -> kind | Levar (_, args) -> occurrence_args k kind args | Lprod(dom, codom) -> @@ -363,7 +424,7 @@ let rec occurrence k kind lam = occurrence (k+1) (occurrence k kind def) body | Lapp(f, args) -> occurrence_args k (occurrence k kind f) args - | Lprim(_,_,_,args) | Lmakeblock(_,args) -> + | Lprim(_,_,args) | Lmakeblock(_,args) -> occurrence_args k kind args | Lcase(_ci,_rtbl,t,a,branches) -> let kind = occurrence k (occurrence k kind t) a in @@ -374,6 +435,9 @@ let rec occurrence k kind lam = in Array.iter on_b branches.nonconstant_branches; !r + | Lif (t, bt, bf) -> + let kind = occurrence k kind t in + kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> let kind = occurrence_args k kind ltypes in @@ -381,17 +445,10 @@ let rec occurrence k kind lam = kind | Lproj(_,arg) -> occurrence k kind arg - | Luint u -> occurrence_uint k kind u and occurrence_args k kind args = Array.fold_left (occurrence k) kind args -and occurrence_uint k kind u = - match u with - | UintVal _ -> kind - | UintDigits args -> occurrence_args k kind args - | UintDecomp t -> occurrence k kind t - let occur_once lam = try let _ = occurrence 1 true lam in true with Not_found -> false @@ -439,11 +496,12 @@ let check_compilable ib = let is_value lc = match lc with - | Lval _ | Lint _ -> true + | Lval _ | Lint _ | Luint _ -> true | _ -> false let get_value lc = match lc with + | Luint i -> val_of_uint i | Lval v -> v | Lint i -> val_of_int i | _ -> raise Not_found @@ -491,26 +549,18 @@ let rec get_alias env kn = (* Compilation of primitive *) -let _h = Name(Id.of_string "f") +let prim kn p args = + Lprim(Some kn, p, args) -(* let expand_prim kn op arity = let ids = Array.make arity Anonymous in let args = make_args arity 1 in Llam(ids, prim kn op args) -*) -let compile_prim n op kn fc args = - if not fc then raise Not_found - else - Lprim(kn, n, op, args) - - (* - let (nparams, arity) = CPrimitives.arity op in - let expected = nparams + arity in - if Array.length args >= expected then prim kn op args - else mkLapp (expand_prim kn op expected) args -*) +let lambda_of_prim kn op args = + let arity = CPrimitives.arity op in + if Array.length args >= arity then prim kn op args + else mkLapp (expand_prim kn op arity) args (*i Global environment *) @@ -661,13 +711,6 @@ let rec lambda_of_constr env c = (* translation of the argument *) let la = lambda_of_constr env a in - let gr = GlobRef.IndRef ind in - let la = - try - Retroknowledge.get_vm_before_match_info env.global_env.retroknowledge - gr la - with Not_found -> la - in (* translation of the type *) let lt = lambda_of_constr env t in (* translation of branches *) @@ -713,88 +756,30 @@ let rec lambda_of_constr env c = let lc = lambda_of_constr env c in Lproj (Projection.repr p,lc) + | Int i -> Luint i + and lambda_of_app env f args = match Constr.kind f with - | Const (kn,_u as c) -> - let kn = get_alias env.global_env kn in - (* spiwack: checks if there is a specific way to compile the constant - if there is not, Not_found is raised, and the function - falls back on its normal behavior *) - (try - (* We delay the compilation of arguments to avoid an exponential behavior *) - let f = Retroknowledge.get_vm_compiling_info env.global_env.retroknowledge - (GlobRef.ConstRef kn) in - let args = lambda_of_args env 0 args in - f args - with Not_found -> - let cb = lookup_constant kn env.global_env in - begin match cb.const_body with + | Const (kn,u as c) -> + let kn = get_alias env.global_env kn in + let cb = lookup_constant kn env.global_env in + begin match cb.const_body with + | Primitive op -> lambda_of_prim (kn,u) op (lambda_of_args env 0 args) | Def csubst when cb.const_inline_code -> - lambda_of_app env (Mod_subst.force_constr csubst) args + lambda_of_app env (Mod_subst.force_constr csubst) args | Def _ | OpaqueDef _ | Undef _ -> mkLapp (Lconst c) (lambda_of_args env 0 args) - end) + end | Construct (c,_) -> - let tag, nparams, arity = Renv.get_construct_info env c in - let nargs = Array.length args in - let gr = GlobRef.ConstructRef c in - if Int.equal (nparams + arity) nargs then (* fully applied *) - (* spiwack: *) - (* 1/ tries to compile the constructor in an optimal way, - it is supposed to work only if the arguments are - all fully constructed, fails with Cbytecodes.NotClosed. - it can also raise Not_found when there is no special - treatment for this constructor - for instance: tries to to compile an integer of the - form I31 D1 D2 ... D31 to [D1D2...D31] as - a processor number (a caml number actually) *) - try - try - Retroknowledge.get_vm_constant_static_info - env.global_env.retroknowledge - gr args - with NotClosed -> - (* 2/ if the arguments are not all closed (this is - expectingly (and it is currently the case) the only - reason why this exception is raised) tries to - give a clever, run-time behavior to the constructor. - Raises Not_found if there is no special treatment - for this integer. - this is done in a lazy fashion, using the constructor - Bspecial because it needs to know the continuation - and such, which can't be done at this time. - for instance, for int31: if one of the digit is - not closed, it's not impossible that the number - gets fully instantiated at run-time, thus to ensure - uniqueness of the representation in the vm - it is necessary to try and build a caml integer - during the execution *) - let rargs = Array.sub args nparams arity in - let args = lambda_of_args env nparams rargs in - Retroknowledge.get_vm_constant_dynamic_info - env.global_env.retroknowledge - gr args - with Not_found -> - (* 3/ if no special behavior is available, then the compiler - falls back to the normal behavior *) + let tag, nparams, arity = Renv.get_construct_info env c in + let nargs = Array.length args in + if nparams < nargs then (* got all parameters *) let args = lambda_of_args env nparams args in makeblock tag 0 arity args - else - let args = lambda_of_args env nparams args in - (* spiwack: tries first to apply the run-time compilation - behavior of the constructor, as in 2/ above *) - (try - (Retroknowledge.get_vm_constant_dynamic_info - env.global_env.retroknowledge - gr) args - with Not_found -> - if nparams <= nargs then (* got all parameters *) - makeblock tag 0 arity args - else (* still expecting some parameters *) - makeblock tag (nparams - nargs) arity empty_args) + else makeblock tag (nparams - nargs) arity empty_args | _ -> - let f = lambda_of_constr env f in - let args = lambda_of_args env 0 args in - mkLapp f args + let f = lambda_of_constr env f in + let args = lambda_of_args env 0 args in + mkLapp f args and lambda_of_args env start args = let nargs = Array.length args in @@ -822,43 +807,3 @@ let lambda_of_constr ~optimize genv c = if !dump_lambda then Feedback.msg_debug (pp_lam lam); lam - -(** Retroknowledge, to be removed once we move to primitive machine integers *) -let compile_structured_int31 fc args = - if not fc then raise Not_found else - Luint (UintVal - (Uint31.of_int (Array.fold_left - (fun temp_i -> fun t -> match kind t with - | Construct ((_,d),_) -> 2*temp_i+d-1 - | _ -> raise NotClosed) - 0 args))) - -let dynamic_int31_compilation fc args = - if not fc then raise Not_found else - Luint (UintDigits args) - -let d0 = Lint 0 -let d1 = Lint 1 - -(* We are relying here on the tags of digits constructors *) -let digits_from_uint i = - let digits = Array.make 31 d0 in - for k = 0 to 30 do - if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then - digits.(30-k) <- d1 - done; - digits - -let int31_escape_before_match fc t = - if not fc then - raise Not_found - else - match t with - | Luint (UintVal i) -> - let digits = digits_from_uint i in - Lmakeblock (1, digits) - | Luint (UintDigits args) -> - Lmakeblock (1,args) - | Luint (UintDecomp _) -> - assert false - | _ -> Luint (UintDecomp t) diff --git a/kernel/clambda.mli b/kernel/clambda.mli index 8ff10b4549..4d921fd45e 100644 --- a/kernel/clambda.mli +++ b/kernel/clambda.mli @@ -1,7 +1,37 @@ open Names -open Cinstr +open Constr +open Vmvalues open Environ +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Levar of Evar.t * lambda array + | Lprod of lambda * lambda + | Llam of Name.t array * lambda + | Llet of Name.t * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of pconstant + | Lprim of pconstant option * CPrimitives.t * lambda array + (* No check if None *) + | Lcase of case_info * reloc_table * lambda * lambda * lam_branches + | Lif of lambda * lambda * lambda + | Lfix of (int array * int) * fix_decl + | Lcofix of int * fix_decl + | Lint of int + | Lmakeblock of int * lambda array + | Luint of Uint63.t + | Lval of structured_values + | Lsort of Sorts.t + | Lind of pinductive + | Lproj of Projection.Repr.t * lambda + +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t array * lambda) array } + +and fix_decl = Name.t array * lambda array * lambda array + exception TooLargeInductive of Pp.t val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda @@ -10,22 +40,5 @@ val decompose_Llam : lambda -> Name.t array * lambda val get_alias : env -> Constant.t -> Constant.t -val compile_prim : int -> Cbytecodes.instruction -> Constr.pconstant -> bool -> lambda array -> lambda - -(** spiwack: this function contains the information needed to perform - the static compilation of int31 (trying and obtaining - a 31-bit integer in processor representation at compile time) *) -val compile_structured_int31 : bool -> Constr.t array -> lambda - -(** this function contains the information needed to perform - the dynamic compilation of int31 (trying and obtaining a - 31-bit integer in processor representation at runtime when - it failed at compile time *) -val dynamic_int31_compilation : bool -> lambda array -> lambda - -(*spiwack: compiling function to insert dynamic decompilation before - matching integers (in case they are in processor representation) *) -val int31_escape_before_match : bool -> lambda -> lambda - (** Dump the VM lambda code after compilation (for debugging purposes) *) val dump_lambda : bool ref diff --git a/kernel/constr.ml b/kernel/constr.ml index d67d15b23b..c392494e95 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -101,6 +101,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr + | Int of Uint63.t (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t, t, Sorts.t, Instance.t) kind_of_term @@ -233,6 +234,9 @@ let mkRef (gr,u) = let open GlobRef in match gr with | ConstructRef c -> mkConstructU (c,u) | VarRef x -> mkVar x +(* Constructs a primitive integer *) +let mkInt i = Int i + (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -438,7 +442,7 @@ let decompose_appvect c = let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc + | Construct _ | Int _) -> acc | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c @@ -458,7 +462,7 @@ let fold f acc c = match kind c with let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () + | Construct _ | Int _) -> () | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c @@ -478,7 +482,7 @@ let iter f c = match kind c with let iter_with_binders g f n c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () + | Construct _ | Int _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c @@ -504,7 +508,7 @@ let iter_with_binders g f n c = match kind c with let fold_constr_with_binders g f n acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc + | Construct _ | Int _) -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (_na,t,c) -> f (g n) (f n acc t) c | Lambda (_na,t,c) -> f (g n) (f n acc t) c @@ -600,7 +604,7 @@ let map_return_predicate_with_full_binders g f l ci p = let map_gen userview f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c + | Construct _ | Int _) -> c | Cast (b,k,t) -> let b' = f b in let t' = f t in @@ -665,7 +669,7 @@ let map = map_gen false let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> accu, c + | Construct _ | Int _) -> accu, c | Cast (b,k,t) -> let accu, b' = f accu b in let accu, t' = f accu t in @@ -725,7 +729,7 @@ let fold_map f accu c = match kind c with let map_with_binders g f l c0 = match kind c0 with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c0 + | Construct _ | Int _) -> c0 | Cast (c, k, t) -> let c' = f l c in let t' = f l t in @@ -802,7 +806,7 @@ let lift n = liftn n 1 let fold_with_full_binders g f n acc c = let open Context.Rel.Declaration in match kind c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ -> acc + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c @@ -843,6 +847,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 + | Int i1, Int i2 -> Uint63.equal i1 i2 | Sort s1, Sort s2 -> leq_sorts s1 s2 | Prod (_,t1,c1), Prod (_,t2,c2) -> eq 0 t1 t2 && leq 0 c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq 0 t1 t2 && eq 0 c1 c2 @@ -869,7 +874,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _), _ -> false + | CoFix _ | Int _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -1044,6 +1049,8 @@ let constr_ord_int f t1 t2 = ln1 ln2 tl1 tl2 bl1 bl2 | CoFix _, _ -> -1 | _, CoFix _ -> 1 | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 + | Proj _, _ -> -1 | _, Proj _ -> 1 + | Int i1, Int i2 -> Uint63.compare i1 i2 let rec compare m n= constr_ord_int compare m n @@ -1127,9 +1134,10 @@ let hasheq t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 + | Int i1, Int i2 -> i1 == i2 | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ - | Fix _ | CoFix _), _ -> false + | Fix _ | CoFix _ | Int _), _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) @@ -1190,10 +1198,6 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Evar (e,l) -> let l, hl = hash_term_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) - | Proj (p,c) -> - let c, hc = sh_rec c in - let p' = Projection.hcons p in - (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) | Const (c,u) -> let c' = sh_con c in let u', hu = sh_instance u in @@ -1232,6 +1236,13 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = (t, combinesmall 15 n) | Rel n -> (t, combinesmall 16 n) + | Proj (p,c) -> + let c, hc = sh_rec c in + let p' = Projection.hcons p in + (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) + | Int i -> + let (h,l) = Uint63.to_int2 i in + (t, combinesmall 18 (combine h l)) and sh_rec t = let (y, h) = hash_term t in @@ -1277,8 +1288,6 @@ let rec hash t = | App (Cast(c, _, _),l) -> hash (mkApp (c,l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) - | Proj (p,c) -> - combinesmall 17 (combine (Projection.hash p) (hash c)) | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) | Const (c,u) -> @@ -1295,6 +1304,9 @@ let rec hash t = combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl)) | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n + | Proj (p,c) -> + combinesmall 17 (combine (Projection.hash p) (hash c)) + | Int i -> combinesmall 18 (Uint63.hash i) and hash_term_array t = Array.fold_left (fun acc t -> combine (hash t) acc) 0 t @@ -1425,3 +1437,4 @@ let rec debug_print c = Name.print na ++ str":" ++ debug_print ty ++ cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ str"}") + | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index f2cedcdabb..fdc3296a6a 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -72,6 +72,9 @@ val mkRel : int -> constr (** Constructs a Variable *) val mkVar : Id.t -> constr +(** Constructs a machine integer *) +val mkInt : Uint63.t -> constr + (** Constructs an patvar named "?n" *) val mkMeta : metavariable -> constr @@ -228,6 +231,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr + | Int of Uint63.t (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative diff --git a/kernel/context.ml b/kernel/context.ml index 3d98381fbb..1cc6e79485 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -134,6 +134,15 @@ struct let ty' = f ty in if v == v' && ty == ty' then decl else LocalDef (na, v', ty') + let map_constr_het f = function + | LocalAssum (na, ty) -> + let ty' = f ty in + LocalAssum (na, ty') + | LocalDef (na, v, ty) -> + let v' = f v in + let ty' = f ty in + LocalDef (na, v', ty') + (** Perform a given action on all terms in a given declaration. *) let iter_constr f = function | LocalAssum (_,ty) -> f ty diff --git a/kernel/context.mli b/kernel/context.mli index 2b0d36cb8c..8acae73680 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -78,6 +78,9 @@ sig (** Map all terms in a given declaration. *) val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt + (** Map all terms, with an heterogeneous function. *) + val map_constr_het : ('a -> 'b) -> ('a, 'a) pt -> ('b, 'b) pt + (** Perform a given action on all terms in a given declaration. *) val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit diff --git a/kernel/cooking.ml b/kernel/cooking.ml index f4b4834d98..22de9bfad5 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -155,9 +155,9 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { - cook_body : constant_def; + cook_body : constr Mod_subst.substituted constant_def; cook_type : types; - cook_universes : constant_universes; + cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; cook_inline : inline; cook_context : Constr.named_context option; @@ -169,6 +169,7 @@ let on_body ml hy f = function | OpaqueDef o -> OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f { Opaqueproof.modlist = ml; abstract = hy } o) + | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") let expmod_constr_subst cache modlist subst c = let subst = Univ.make_instance_subst subst in @@ -184,10 +185,10 @@ let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c = let lift_univs cb subst auctx0 = match cb.const_universes with - | Monomorphic_const ctx -> + | Monomorphic ctx -> assert (AUContext.is_empty auctx0); - subst, (Monomorphic_const ctx) - | Polymorphic_const auctx -> + subst, (Monomorphic ctx) + | Polymorphic auctx -> (** Given a named instance [subst := u₀ ... uₙ₋₁] together with an abstract context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length, and another abstract context relative to the former context @@ -201,13 +202,13 @@ let lift_univs cb subst auctx0 = *) if (Univ.Instance.is_empty subst) then (** Still need to take the union for the constraints between globals *) - subst, (Polymorphic_const (AUContext.union auctx0 auctx)) + subst, (Polymorphic (AUContext.union auctx0 auctx)) else let ainst = Univ.make_abstract_instance auctx in let subst = Instance.append subst ainst in let substf = Univ.make_instance_subst subst in let auctx' = Univ.subst_univs_level_abstract_universe_context substf auctx in - subst, (Polymorphic_const (AUContext.union auctx0 auctx')) + subst, (Polymorphic (AUContext.union auctx0 auctx')) let cook_constant ~hcons { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 7ff4b657d3..89b5c60ad5 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -18,9 +18,9 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { - cook_body : constant_def; + cook_body : constr Mod_subst.substituted constant_def; cook_type : types; - cook_universes : constant_universes; + cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; cook_inline : inline; cook_context : Constr.named_context option; diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 016b63be09..6777e0c223 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -47,14 +47,15 @@ type inline = int option transparent body, or an opaque one *) (* Global declarations (i.e. constants) can be either: *) -type constant_def = +type 'a constant_def = | Undef of inline (** a global assumption *) - | Def of constr Mod_subst.substituted (** or a transparent global definition *) + | Def of 'a (** or a transparent global definition *) | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) + | Primitive of CPrimitives.t (** or a primitive operation *) -type constant_universes = - | Monomorphic_const of Univ.ContextSet.t - | Polymorphic_const of Univ.AUContext.t +type universes = + | Monomorphic of Univ.ContextSet.t + | Polymorphic of Univ.AUContext.t (** The [typing_flags] are instructions to the type-checker which modify its behaviour. The typing flags used in the type-checking @@ -88,10 +89,10 @@ type typing_flags = { * the OpaqueDef *) type constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) - const_body : constant_def; + const_body : Constr.t Mod_subst.substituted constant_def; const_type : types; const_body_code : Cemitcodes.to_patch_substituted option; - const_universes : constant_universes; + const_universes : universes; const_private_poly_univs : Univ.ContextSet.t option; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which @@ -184,11 +185,6 @@ type one_inductive_body = { mind_reloc_tbl : Vmvalues.reloc_table; } -type abstract_inductive_universes = - | Monomorphic_ind of Univ.ContextSet.t - | Polymorphic_ind of Univ.AUContext.t - | Cumulative_ind of Univ.ACumulativityInfo.t - type recursivity_kind = | Finite (** = inductive *) | CoFinite (** = coinductive *) @@ -212,7 +208,9 @@ type mutual_inductive_body = { mind_params_ctxt : Constr.rel_context; (** The context of parameters (includes let-in declaration) *) - mind_universes : abstract_inductive_universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) + mind_universes : universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) + + mind_variance : Univ.Variance.t array option; (** Variance info, [None] when non-cumulative. *) mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 707c46048b..9e0230c3ba 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -49,25 +49,36 @@ let hcons_template_arity ar = (* List.Smart.map (Option.Smart.map Univ.hcons_univ_level) ar.template_param_levels; *) template_level = Univ.hcons_univ ar.template_level } +let universes_context = function + | Monomorphic _ -> Univ.AUContext.empty + | Polymorphic ctx -> ctx + +let abstract_universes = function + | Entries.Monomorphic_entry ctx -> + Univ.empty_level_subst, Monomorphic ctx + | Entries.Polymorphic_entry (nas, ctx) -> + let (inst, auctx) = Univ.abstract_universes nas ctx in + let inst = Univ.make_instance_subst inst in + (inst, Polymorphic auctx) + (** {6 Constants } *) let constant_is_polymorphic cb = match cb.const_universes with - | Monomorphic_const _ -> false - | Polymorphic_const _ -> true + | Monomorphic _ -> false + | Polymorphic _ -> true + let constant_has_body cb = match cb.const_body with - | Undef _ -> false + | Undef _ | Primitive _ -> false | Def _ | OpaqueDef _ -> true let constant_polymorphic_context cb = - match cb.const_universes with - | Monomorphic_const _ -> Univ.AUContext.empty - | Polymorphic_const ctx -> ctx + universes_context cb.const_universes let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true - | Undef _ | Def _ -> false + | Undef _ | Def _ | Primitive _ -> false (** {7 Constant substitutions } *) @@ -83,7 +94,7 @@ let subst_const_type sub arity = (** No need here to check for physical equality after substitution, at least for Def due to the delayed substitution [subst_constr_subst]. *) let subst_const_def sub def = match def with - | Undef _ -> def + | Undef _ | Primitive _ -> def | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) @@ -119,17 +130,18 @@ let hcons_rel_context l = List.Smart.map hcons_rel_decl l let hcons_const_def = function | Undef inl -> Undef inl + | Primitive p -> Primitive p | Def l_constr -> let constr = force_constr l_constr in Def (from_val (Constr.hcons constr)) | OpaqueDef _ as x -> x (* hashconsed when turned indirect *) -let hcons_const_universes cbu = +let hcons_universes cbu = match cbu with - | Monomorphic_const ctx -> - Monomorphic_const (Univ.hcons_universe_context_set ctx) - | Polymorphic_const ctx -> - Polymorphic_const (Univ.hcons_abstract_universe_context ctx) + | Monomorphic ctx -> + Monomorphic (Univ.hcons_universe_context_set ctx) + | Polymorphic ctx -> + Polymorphic (Univ.hcons_abstract_universe_context ctx) let hcons_const_private_univs = function | None -> None @@ -139,7 +151,7 @@ let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = Constr.hcons cb.const_type; - const_universes = hcons_const_universes cb.const_universes; + const_universes = hcons_universes cb.const_universes; const_private_poly_univs = hcons_const_private_univs cb.const_private_poly_univs; } @@ -237,27 +249,21 @@ let subst_mind_body sub mib = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; + mind_variance = mib.mind_variance; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } let inductive_polymorphic_context mib = - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.AUContext.empty - | Polymorphic_ind ctx -> ctx - | Cumulative_ind cumi -> Univ.ACumulativityInfo.univ_context cumi + universes_context mib.mind_universes let inductive_is_polymorphic mib = match mib.mind_universes with - | Monomorphic_ind _ -> false - | Polymorphic_ind _ctx -> true - | Cumulative_ind _cumi -> true + | Monomorphic _ -> false + | Polymorphic _ctx -> true let inductive_is_cumulative mib = - match mib.mind_universes with - | Monomorphic_ind _ -> false - | Polymorphic_ind _ctx -> false - | Cumulative_ind _cumi -> true + Option.has_some mib.mind_variance let inductive_make_projection ind mib ~proj_arg = match mib.mind_record with @@ -304,17 +310,11 @@ let hcons_mind_packet oib = mind_user_lc = user; mind_nf_lc = nf } -let hcons_mind_universes miu = - match miu with - | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context_set ctx) - | Polymorphic_ind ctx -> Polymorphic_ind (Univ.hcons_abstract_universe_context ctx) - | Cumulative_ind cui -> Cumulative_ind (Univ.hcons_abstract_cumulativity_info cui) - let hcons_mind mib = { mib with mind_packets = Array.Smart.map hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; - mind_universes = hcons_mind_universes mib.mind_universes } + mind_universes = hcons_universes mib.mind_universes } (** Hashconsing of modules *) diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 35490ceef9..23a44433b3 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -15,6 +15,10 @@ open Univ (** Operations concerning types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) +val universes_context : universes -> AUContext.t + +val abstract_universes : Entries.universes_entry -> Univ.universe_level_subst * universes + (** {6 Arities} *) val map_decl_arity : ('a -> 'c) -> ('b -> 'd) -> diff --git a/kernel/dune b/kernel/dune index 01abdb8f67..1f2d696a36 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,13 +3,23 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules_without_implementation cinstr nativeinstr) + (modules (:standard \ uint63_x86 uint63_amd64 write_uint63)) (libraries lib byterun)) (rule (targets copcodes.ml) - (deps (:h-file byterun/coq_instruct.h) make-opcodes) - (action (run ./make_opcodes.sh %{h-file} %{targets}))) + (deps (:h-file byterun/coq_instruct.h) make-opcodes make_opcodes.sh) + (action (bash "./make_opcodes.sh %{h-file} %{targets}"))) + +(executable + (name write_uint63) + (modules write_uint63) + (libraries unix)) + +(rule + (targets uint63.ml) + (deps (:gen ./write_uint63.exe) uint63_x86.ml uint63_amd64.ml) + (action (run %{gen}))) (documentation (package coq)) diff --git a/kernel/entries.ml b/kernel/entries.ml index 58bb782f15..a3d32267a7 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -16,6 +16,12 @@ open Constr constants/axioms, mutual inductive definitions, modules and module types *) +type universes_entry = + | Monomorphic_entry of Univ.ContextSet.t + | Polymorphic_entry of Name.t array * Univ.UContext.t + +type 'a in_universes_entry = 'a * universes_entry + (** {6 Declaration of inductive types. } *) (** Assume the following definition in concrete syntax: @@ -28,11 +34,6 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; [mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]]. *) -type inductive_universes = - | Monomorphic_ind_entry of Univ.ContextSet.t - | Polymorphic_ind_entry of Name.t array * Univ.UContext.t - | Cumulative_ind_entry of Name.t array * Univ.CumulativityInfo.t - type one_inductive_entry = { mind_entry_typename : Id.t; mind_entry_arity : constr; @@ -48,7 +49,8 @@ type mutual_inductive_entry = { mind_entry_finite : Declarations.recursivity_kind; mind_entry_params : Constr.rel_context; mind_entry_inds : one_inductive_entry list; - mind_entry_universes : inductive_universes; + mind_entry_universes : universes_entry; + mind_entry_variance : Univ.Variance.t array option; (* universe constraints and the constraints for subtyping of inductive types in the block. *) mind_entry_private : bool option; @@ -58,12 +60,6 @@ type mutual_inductive_entry = { type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation -type constant_universes_entry = - | Monomorphic_const_entry of Univ.ContextSet.t - | Polymorphic_const_entry of Name.t array * Univ.UContext.t - -type 'a in_constant_universes_entry = 'a * constant_universes_entry - type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) @@ -71,7 +67,7 @@ type 'a definition_entry = { (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; - const_entry_universes : constant_universes_entry; + const_entry_universes : universes_entry; const_entry_opaque : bool; const_entry_inline_code : bool } @@ -85,11 +81,18 @@ type section_def_entry = { type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Constr.named_context option * types in_constant_universes_entry * inline + Constr.named_context option * types in_universes_entry * inline + +type primitive_entry = { + prim_entry_type : types option; + prim_entry_univs : Univ.ContextSet.t; (* always monomorphic *) + prim_entry_content : CPrimitives.op_or_type; +} type 'a constant_entry = | DefinitionEntry of 'a definition_entry | ParameterEntry of parameter_entry + | PrimitiveEntry of primitive_entry (** {6 Modules } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 77820a301e..ab046f02f7 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -119,7 +119,7 @@ let empty_env = { env_universes = UGraph.initial_universes; env_engagement = PredicativeSet }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; - retroknowledge = Retroknowledge.initial_retroknowledge; + retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab } @@ -222,6 +222,10 @@ let lookup_constant kn env = let lookup_mind kn env = fst (Mindmap_env.find kn env.env_globals.env_inductives) +let mind_context env mind = + let mib = lookup_mind mind env in + Declareops.inductive_polymorphic_context mib + let lookup_mind_key kn env = Mindmap_env.find kn env.env_globals.env_inductives @@ -450,7 +454,10 @@ let constant_type env (kn,u) = let csts = Univ.AUContext.instantiate u uctx in (subst_instance_constr u cb.const_type, csts) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = + | NoBody + | Opaque + | IsPrimitive of CPrimitives.t exception NotEvaluableConst of const_evaluation_result @@ -461,14 +468,14 @@ let constant_value_and_type env (kn, u) = let b' = match cb.const_body with | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) | OpaqueDef _ -> None - | Undef _ -> None + | Undef _ | Primitive _ -> None in b', subst_instance_constr u cb.const_type, cst let body_of_constant_body env cb = let otab = opaque_tables env in match cb.const_body with - | Undef _ -> + | Undef _ | Primitive _ -> None | Def c -> Some (Mod_subst.force_constr c, Declareops.constant_polymorphic_context cb) @@ -492,6 +499,7 @@ let constant_value_in env (kn,u) = subst_instance_constr u b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) + | Primitive p -> raise (NotEvaluableConst (IsPrimitive p)) let constant_opt_value_in env cst = try Some (constant_value_in env cst) @@ -503,7 +511,13 @@ let evaluable_constant kn env = match cb.const_body with | Def _ -> true | OpaqueDef _ -> false - | Undef _ -> false + | Undef _ | Primitive _ -> false + +let is_primitive env c = + let cb = lookup_constant c env in + match cb.Declarations.const_body with + | Declarations.Primitive _ -> true + | _ -> false let polymorphic_constant cst env = Declareops.constant_is_polymorphic (lookup_constant cst env) @@ -668,6 +682,10 @@ type ('constr, 'types) punsafe_judgment = { uj_val : 'constr; uj_type : 'types } +let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } +let on_judgment_value f j = { j with uj_val = f j.uj_val } +let on_judgment_type f j = { j with uj_type = f j.uj_type } + type unsafe_judgment = (constr, types) punsafe_judgment let make_judge v tj = @@ -743,29 +761,4 @@ let is_type_in_type env r = | IndRef ind -> type_in_type_ind ind env | ConstructRef cstr -> type_in_type_ind (inductive_of_constructor cstr) env -(*spiwack: the following functions assemble the pieces of the retroknowledge - note that the "consistent" register function is available in the module - Safetyping, Environ only synchronizes the proactive and the reactive parts*) - -open Retroknowledge - -(* lifting of the "get" functions works also for "mem"*) -let retroknowledge f env = - f env.retroknowledge - -let registered env field = - retroknowledge mem env field - -let register_one env field entry = - { env with retroknowledge = Retroknowledge.add_field env.retroknowledge field entry } - -(* [register env field entry] may register several fields when needed *) -let register env field gr = - match field with - | KInt31 Int31Type -> - let i31c = match gr with - | GlobRef.IndRef i31t -> GlobRef.ConstructRef (i31t, 1) - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") - in - register_one (register_one env (KInt31 Int31Constructor) i31c) field gr - | field -> register_one env field gr +let set_retroknowledge env r = { env with retroknowledge = r } diff --git a/kernel/environ.mli b/kernel/environ.mli index 6d4d3b282b..0df9b91c4a 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -195,11 +195,15 @@ val type_in_type_constant : Constant.t -> env -> bool (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if - [c] is opaque and [NotEvaluableConst NoBody] if it has no - body and [NotEvaluableConst IsProj] if [c] is a projection + [c] is opaque, [NotEvaluableConst NoBody] if it has no + body, [NotEvaluableConst IsProj] if [c] is a projection, + [NotEvaluableConst (IsPrimitive p)] if [c] is primitive [p] and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = + | NoBody + | Opaque + | IsPrimitive of CPrimitives.t exception NotEvaluableConst of const_evaluation_result val constant_type : env -> Constant.t puniverses -> types constrained @@ -223,6 +227,8 @@ val constant_value_in : env -> Constant.t puniverses -> constr val constant_type_in : env -> Constant.t puniverses -> types val constant_opt_value_in : env -> Constant.t puniverses -> constr option +val is_primitive : env -> Constant.t -> bool + (** {6 Primitive projections} *) (** Checks that the number of parameters is correct. *) @@ -240,6 +246,10 @@ val add_mind : MutInd.t -> mutual_inductive_body -> env -> env raises [Not_found] if the required path is not found *) val lookup_mind : MutInd.t -> env -> mutual_inductive_body +(** The universe context associated to the inductive, empty if not + polymorphic *) +val mind_context : env -> MutInd.t -> Univ.AUContext.t + (** New-style polymorphism *) val polymorphic_ind : inductive -> env -> bool val polymorphic_pind : pinductive -> env -> bool @@ -307,6 +317,10 @@ type ('constr, 'types) punsafe_judgment = { uj_val : 'constr; uj_type : 'types } +val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment +val on_judgment_value : ('c -> 'c) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment +val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment + type unsafe_judgment = (constr, types) punsafe_judgment val make_judge : 'constr -> 'types -> ('constr, 'types) punsafe_judgment @@ -334,13 +348,8 @@ val is_polymorphic : env -> Names.GlobRef.t -> bool val is_template_polymorphic : env -> GlobRef.t -> bool val is_type_in_type : env -> GlobRef.t -> bool -open Retroknowledge -(** functions manipulating the retroknowledge - @author spiwack *) - -val registered : env -> field -> bool - -val register : env -> field -> GlobRef.t -> env - (** Native compiler *) val no_link_info : link_info + +(** Primitives *) +val set_retroknowledge : env -> Retroknowledge.retroknowledge -> env diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index 6976b2019d..a5dafc5ab5 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -87,23 +87,28 @@ let check_subtyping_arity_constructor env subst arcn numparams is_arity = let last_env = Context.Rel.fold_outside check_typ typs ~init:env in if not is_arity then basic_check last_env codom else () -let check_cumulativity univs env_ar params data = +let check_cumulativity univs variances env_ar params data = + let uctx = match univs with + | Monomorphic_entry _ -> raise (InductiveError BadUnivs) + | Polymorphic_entry (_,uctx) -> uctx + in + let instance = UContext.instance uctx in + if Instance.length instance != Array.length variances then raise (InductiveError BadUnivs); let numparams = Context.Rel.nhyps params in - let uctx = CumulativityInfo.univ_context univs in - let new_levels = Array.init (UContext.size uctx) + let new_levels = Array.init (Instance.length instance) (fun i -> Level.(make (UGlobal.make DirPath.empty i))) in let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) - LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels + LMap.empty (Instance.to_array instance) new_levels in let dosubst = Vars.subst_univs_level_constr lmap in let instance_other = Instance.of_array new_levels in - let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in + let constraints_other = Univ.subst_univs_level_constraints lmap (UContext.constraints uctx) in let uctx_other = Univ.UContext.make (instance_other, constraints_other) in let env = Environ.push_context uctx_other env_ar in let subtyp_constraints = - CumulativityInfo.leq_constraints univs - (UContext.instance uctx) instance_other + Univ.enforce_leq_variance_instances variances + instance instance_other Constraint.empty in let env = Environ.add_constraints subtyp_constraints env in @@ -236,8 +241,8 @@ let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_i | None -> RegularArity {mind_user_arity=arity;mind_sort=Sorts.sort_of_univ ind_univ} | Some min_univ -> ((match univs with - | Monomorphic_ind _ -> () - | Polymorphic_ind _ | Cumulative_ind _ -> + | Monomorphic _ -> () + | Polymorphic _ -> CErrors.anomaly ~label:"polymorphic_template_ind" Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.")); TemplateArity {template_param_levels=param_ccls params; template_level=min_univ}) @@ -246,17 +251,6 @@ let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_i let kelim = allowed_sorts univ_info in (arity,lc), (indices,splayed_lc), kelim -let abstract_inductive_universes = function - | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) - | Polymorphic_ind_entry (nas, ctx) -> - let (inst, auctx) = Univ.abstract_universes nas ctx in - let inst = Univ.make_instance_subst inst in - (inst, Polymorphic_ind auctx) - | Cumulative_ind_entry (nas, cumi) -> - let (inst, acumi) = Univ.abstract_cumulativity_info nas cumi in - let inst = Univ.make_instance_subst inst in - (inst, Cumulative_ind acumi) - let typecheck_inductive env (mie:mutual_inductive_entry) = let () = match mie.mind_entry_inds with | [] -> CErrors.anomaly Pp.(str "empty inductive types declaration.") @@ -269,9 +263,8 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = (* universes *) let env_univs = match mie.mind_entry_universes with - | Monomorphic_ind_entry ctx -> push_context_set ctx env - | Polymorphic_ind_entry (_, ctx) -> push_context ctx env - | Cumulative_ind_entry (_, cumi) -> push_context (Univ.CumulativityInfo.univ_context cumi) env + | Monomorphic_entry ctx -> push_context_set ctx env + | Polymorphic_entry (_, ctx) -> push_context ctx env in (* Params *) @@ -287,13 +280,14 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = mie.mind_entry_inds data in - let () = match mie.mind_entry_universes with - | Cumulative_ind_entry (_,univs) -> check_cumulativity univs env_ar params (List.map pi1 data) - | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ -> () + let () = match mie.mind_entry_variance with + | None -> () + | Some variances -> + check_cumulativity mie.mind_entry_universes variances env_ar params (List.map pi1 data) in (* Abstract universes *) - let usubst, univs = abstract_inductive_universes mie.mind_entry_universes in + let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in let params = Vars.subst_univs_level_context usubst params in let data = List.map (abstract_packets univs usubst params) data in @@ -304,4 +298,4 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = Environ.push_rel_context ctx env in - env_ar_par, univs, params, Array.of_list data + env_ar_par, univs, mie.mind_entry_variance, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 8841e38636..2598548f3f 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -16,6 +16,7 @@ open Declarations Returns: - environment with inductives + parameters in rel context - abstracted universes + - checked variance info - parameters - for each inductive, (arity * constructors) (with params) @@ -24,7 +25,7 @@ open Declarations *) val typecheck_inductive : env -> mutual_inductive_entry -> env - * abstract_inductive_universes + * universes * Univ.Variance.t array option * Constr.rel_context * ((inductive_arity * Constr.types array) * (Constr.rel_context * (Constr.rel_context * Constr.types) array) * diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 9bb848c6a4..8f06e1e4b8 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -414,11 +414,7 @@ exception UndefinableExpansion a substitution of the form [params, x : ind params] *) let compute_projections (kn, i as ind) mib = let pkt = mib.mind_packets.(i) in - let u = match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind auctx -> Univ.make_abstract_instance auctx - | Cumulative_ind acumi -> Univ.make_abstract_instance (Univ.ACumulativityInfo.univ_context acumi) - in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in @@ -471,7 +467,7 @@ let compute_projections (kn, i as ind) mib = Array.of_list (List.rev labs), Array.of_list (List.rev pbs) -let build_inductive env names prv univs paramsctxt kn isrecord isfinite inds nmr recargs = +let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in @@ -529,6 +525,7 @@ let build_inductive env names prv univs paramsctxt kn isrecord isfinite inds nmr mind_params_ctxt = paramsctxt; mind_packets = packets; mind_universes = univs; + mind_variance = variance; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } @@ -536,9 +533,13 @@ let build_inductive env names prv univs paramsctxt kn isrecord isfinite inds nmr let record_info = match isrecord with | Some (Some rid) -> let is_record pkt = - List.exists (Sorts.family_equal Sorts.InType) pkt.mind_kelim - && Array.length pkt.mind_consnames == 1 - && pkt.mind_consnrealargs.(0) > 0 + if Array.length pkt.mind_consnames != 1 then + user_err ~hdr:"build_inductive" + Pp.(str "Primitive records must have exactly one constructor.") + else if pkt.mind_consnrealargs.(0) = 0 then + user_err ~hdr:"build_inductive" + Pp.(str "Primitive records must have at least one constructor argument.") + else List.exists (Sorts.family_equal Sorts.InType) pkt.mind_kelim in (** The elimination criterion ensures that all projections can be defined. *) if Array.for_all is_record packets then @@ -559,7 +560,7 @@ let build_inductive env names prv univs paramsctxt kn isrecord isfinite inds nmr let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar_par, univs, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in + let (env_ar_par, univs, variance, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_guarded in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) @@ -570,6 +571,6 @@ let check_inductive env kn mie = (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) in (* Build the inductive packets *) - build_inductive env names mie.mind_entry_private univs + build_inductive env names mie.mind_entry_private univs variance paramsctxt kn mie.mind_entry_record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 05c5c0e821..848ae65c51 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -56,12 +56,7 @@ let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = - let process auctx = Univ.AUContext.instantiate u auctx in - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Constraint.empty - | Polymorphic_ind auctx -> process auctx - | Cumulative_ind cumi -> process (Univ.ACumulativityInfo.univ_context cumi) - + Univ.AUContext.instantiate u (Declareops.inductive_polymorphic_context mib) (************************************************************************) @@ -804,7 +799,7 @@ let rec subterm_specif renv stack t = | Not_subterm -> Not_subterm) | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ - | Construct _ | CoFix _ -> Not_subterm + | Construct _ | CoFix _ | Int _ -> Not_subterm (* Other terms are not subterms *) @@ -1008,7 +1003,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(c,l)) end - | Sort _ -> + | Sort _ | Int _ -> assert (List.is_empty l) (* l is not checked because it is considered as the meta's context *) @@ -1194,7 +1189,8 @@ let check_one_cofix env nbfix def deftype = | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ - | Ind _ | Fix _ | Proj _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + | Ind _ | Fix _ | Proj _ | Int _ -> + raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0b10e788b6..5108744bde 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,6 +1,7 @@ Names TransparentState -Uint31 +Uint63 +CPrimitives Univ UGraph Esubst @@ -19,11 +20,11 @@ Opaqueproof Declarations Entries Nativevalues -CPrimitives Declareops Retroknowledge Conv_oracle Environ +Primred CClosure Reduction Clambda diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 52fb39e1d0..cd675653cb 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -330,6 +330,19 @@ let subst_proj_repr sub p = let subst_proj sub p = Projection.map (subst_mind sub) p +let subst_retro_action subst action = + let open Retroknowledge in + match action with + | Register_ind(prim,ind) -> + let ind' = subst_ind subst ind in + if ind == ind' then action else Register_ind(prim, ind') + | Register_type(prim,c) -> + let c' = subst_constant subst c in + if c == c' then action else Register_type(prim, c') + | Register_inline(c) -> + let c' = subst_constant subst c in + if c == c' then action else Register_inline(c') + (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index ea391b3de7..8ab3d04402 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -144,6 +144,8 @@ val subst_constant : val subst_proj_repr : substitution -> Projection.Repr.t -> Projection.Repr.t val subst_proj : substitution -> Projection.t -> Projection.t +val subst_retro_action : substitution -> Retroknowledge.action -> Retroknowledge.action + (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index d63dc057b4..421d932d9a 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -68,15 +68,15 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = if List.is_empty idl then (* Toplevel definition *) let cb = match spec with - | SFBconst cb -> cb - | _ -> error_not_a_constant lab + | SFBconst cb -> cb + | _ -> error_not_a_constant lab in (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, - as long as they have the right type *) + as long as they have the right type *) let c', univs, ctx' = match cb.const_universes, ctx with - | Monomorphic_const _, None -> + | Monomorphic _, None -> let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in @@ -87,60 +87,64 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = | Def cs -> let c' = Mod_subst.force_constr cs in c, Reduction.infer_conv env' (Environ.universes env') c c' + | Primitive _ -> + error_incorrect_with_constraint lab in - c', Monomorphic_const Univ.ContextSet.empty, cst - | Polymorphic_const uctx, Some ctx -> + c', Monomorphic Univ.ContextSet.empty, cst + | Polymorphic uctx, Some ctx -> let () = if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then error_incorrect_with_constraint lab in (** Terms are compared in a context with De Bruijn universe indices *) - let env' = Environ.push_context ~strict:false (Univ.AUContext.repr uctx) env in - let cst = match cb.const_body with - | Undef _ | OpaqueDef _ -> - let j = Typeops.infer env' c in - let typ = cb.const_type in - let cst' = Reduction.infer_conv_leq env' (Environ.universes env') - j.uj_type typ in - cst' - | Def cs -> - let c' = Mod_subst.force_constr cs in - let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in - cst' - in - if not (Univ.Constraint.is_empty cst) then - error_incorrect_with_constraint lab; - c, Polymorphic_const ctx, Univ.Constraint.empty + let env' = Environ.push_context ~strict:false (Univ.AUContext.repr uctx) env in + let cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + cst' + | Def cs -> + let c' = Mod_subst.force_constr cs in + let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in + cst' + | Primitive _ -> + error_incorrect_with_constraint lab + in + if not (Univ.Constraint.is_empty cst) then + error_incorrect_with_constraint lab; + c, Polymorphic ctx, Univ.Constraint.empty | _ -> error_incorrect_with_constraint lab in let def = Def (Mod_subst.from_val c') in -(* let ctx' = Univ.UContext.make (newus, cst) in *) + (* let ctx' = Univ.UContext.make (newus, cst) in *) let cb' = - { cb with - const_body = def; + { cb with + const_body = def; const_universes = univs ; - const_body_code = Option.map Cemitcodes.from_val - (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } + const_body_code = Option.map Cemitcodes.from_val + (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else (* Definition inside a sub-module *) let mb = match spec with - | SFBmodule mb -> mb - | _ -> error_not_a_module (Label.to_string lab) + | SFBmodule mb -> mb + | _ -> error_not_a_module (Label.to_string lab) in begin match mb.mod_expr with - | Abstract -> - let struc = Modops.destr_nofunctor mb.mod_type in - let struc',c',cst = - check_with_def env' struc (idl,(c,ctx)) (MPdot(mp,lab)) mb.mod_delta - in - let mb' = { mb with - mod_type = NoFunctor struc'; - mod_type_alg = None } - in - before@(lab,SFBmodule mb')::after, c', cst - | _ -> error_generative_module_expected lab + | Abstract -> + let struc = Modops.destr_nofunctor mb.mod_type in + let struc',c',cst = + check_with_def env' struc (idl,(c,ctx)) (MPdot(mp,lab)) mb.mod_delta + in + let mb' = { mb with + mod_type = NoFunctor struc'; + mod_type_alg = None } + in + before@(lab,SFBmodule mb')::after, c', cst + | _ -> error_generative_module_expected lab end with | Not_found -> error_no_such_label lab diff --git a/kernel/modops.ml b/kernel/modops.ml index 97ac3cdebb..4f992d3972 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -50,6 +50,7 @@ type signature_mismatch_error = | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } + | IncompatibleVariance type module_typing_error = | SignatureMismatch of @@ -197,9 +198,18 @@ let rec subst_structure sub do_delta sign = in List.Smart.map subst_body sign +and subst_retro : type a. Mod_subst.substitution -> a module_retroknowledge -> a module_retroknowledge = + fun subst retro -> + match retro with + | ModTypeRK as r -> r + | ModBodyRK l as r -> + let l' = List.Smart.map (subst_retro_action subst) l in + if l == l' then r else ModBodyRK l + and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = fun is_mod sub subst_impl do_delta mb -> - let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty; _ } = mb in + let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty; + mod_retroknowledge=retro; _ } = mb in let mp' = subst_mp sub mp in let sub = if ModPath.equal mp mp' then sub @@ -209,8 +219,10 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> let ty' = subst_signature sub do_delta ty in let me' = subst_impl sub me in let aty' = Option.Smart.map (subst_expression sub id_delta) aty in + let retro' = subst_retro sub retro in let delta' = do_delta mb.mod_delta sub in - if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta + if mp==mp' && me==me' && ty==ty' && aty==aty' + && retro==retro' && delta'==mb.mod_delta then mb else { mb with @@ -218,7 +230,9 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> mod_expr = me'; mod_type = ty'; mod_type_alg = aty'; - mod_delta = delta' } + mod_retroknowledge = retro'; + mod_delta = delta'; + } and subst_module sub do_delta mb = subst_body true sub subst_impl do_delta mb @@ -259,32 +273,12 @@ let do_delta_dom_codom reso sub = subst_dom_codom_delta_resolver sub reso let subst_signature subst = subst_signature subst do_delta_codom let subst_structure subst = subst_structure subst do_delta_codom -(** {6 Retroknowledge } *) - -(* spiwack: here comes the function which takes care of importing - the retroknowledge declared in the library *) -(* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) -let add_retroknowledge = - let perform rkaction env = match rkaction with - | Retroknowledge.RKRegister (f, ((GlobRef.ConstRef _ | GlobRef.IndRef _) as e)) -> - Environ.register env f e - | _ -> - CErrors.anomaly ~label:"Modops.add_retroknowledge" - (Pp.str "had to import an unsupported kind of term.") - in - fun (ModBodyRK lclrk) env -> - (* The order of the declaration matters, for instance (and it's at the - time this comment is being written, the only relevent instance) the - int31 type registration absolutely needs int31 bits to be registered. - Since the local_retroknowledge is stored in reverse order (each new - registration is added at the top of the list) we need a fold_right - for things to go right (the pun is not intented). So we lose - tail recursivity, but the world will have exploded before any module - imports 10 000 retroknowledge registration.*) - List.fold_right perform lclrk env - (** {6 Adding a module in the environment } *) +let add_retroknowledge r env = + match r with + | ModBodyRK l -> List.fold_left Primred.add_retroknowledge env l + let rec add_structure mp sign resolver linkinfo env = let add_one env (l,elem) = match elem with |SFBconst cb -> @@ -332,11 +326,7 @@ let strengthen_const mp_from l cb resolver = |_ -> let kn = KerName.make mp_from l in let con = constant_of_delta_kn resolver kn in - let u = - match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.make_abstract_instance ctx - in + let u = Univ.make_abstract_instance (Declareops.constant_polymorphic_context cb) in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); const_private_poly_univs = None; @@ -399,7 +389,7 @@ let inline_delta_resolver env inl mp mbid mtb delta = let constant = lookup_constant con env in let l = make_inline delta r in match constant.const_body with - | Undef _ | OpaqueDef _ -> l + | Undef _ | OpaqueDef _ | Primitive _ -> l | Def body -> let constr = Mod_subst.force_constr body in let ctx = Declareops.constant_polymorphic_context constant in diff --git a/kernel/modops.mli b/kernel/modops.mli index 0acd09fb12..119ce2b359 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -57,6 +57,8 @@ val add_linked_module : module_body -> link_info -> env -> env (** same, for a module type *) val add_module_type : ModPath.t -> module_type_body -> env -> env +val add_retroknowledge : module_implementation module_retroknowledge -> env -> env + (** {6 Strengthening } *) val strengthen : module_type_body -> ModPath.t -> module_type_body @@ -109,6 +111,7 @@ type signature_mismatch_error = | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } + | IncompatibleVariance type module_typing_error = | SignatureMismatch of diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 482a2f3a3c..df60899b95 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -14,7 +14,6 @@ open Constr open Declarations open Util open Nativevalues -open Nativeinstr open Nativelambda open Environ @@ -286,8 +285,6 @@ type primitive = | Mk_int | Mk_bool | Val_to_int - | Mk_I31_accu - | Decomp_uint | Mk_meta | Mk_evar | MLand @@ -305,7 +302,7 @@ type primitive = | MLmagic | MLarrayget | Mk_empty_instance - | Coq_primitive of CPrimitives.t * (prefix * Constant.t) option + | Coq_primitive of CPrimitives.t * (prefix * pconstant) option let eq_primitive p1 p2 = match p1, p2 with @@ -351,29 +348,27 @@ let primitive_hash = function | Mk_int -> 16 | Mk_bool -> 17 | Val_to_int -> 18 - | Mk_I31_accu -> 19 - | Decomp_uint -> 20 - | Mk_meta -> 21 - | Mk_evar -> 22 - | MLand -> 23 - | MLle -> 24 - | MLlt -> 25 - | MLinteq -> 26 - | MLlsl -> 27 - | MLlsr -> 28 - | MLland -> 29 - | MLlor -> 30 - | MLlxor -> 31 - | MLadd -> 32 - | MLsub -> 33 - | MLmul -> 34 - | MLmagic -> 35 - | Coq_primitive (prim, None) -> combinesmall 36 (CPrimitives.hash prim) - | Coq_primitive (prim, Some (prefix,kn)) -> - combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) - | Mk_proj -> 38 - | MLarrayget -> 39 - | Mk_empty_instance -> 40 + | Mk_meta -> 19 + | Mk_evar -> 20 + | MLand -> 21 + | MLle -> 22 + | MLlt -> 23 + | MLinteq -> 24 + | MLlsl -> 25 + | MLlsr -> 26 + | MLland -> 27 + | MLlor -> 28 + | MLlxor -> 29 + | MLadd -> 30 + | MLsub -> 31 + | MLmul -> 32 + | MLmagic -> 33 + | Coq_primitive (prim, None) -> combinesmall 34 (CPrimitives.hash prim) + | Coq_primitive (prim, Some (prefix,(kn,_))) -> + combinesmall 35 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) + | Mk_proj -> 36 + | MLarrayget -> 37 + | Mk_empty_instance -> 38 type mllambda = | MLlocal of lname @@ -389,7 +384,7 @@ type mllambda = | MLconstruct of string * constructor * mllambda array (* prefix, constructor name, arguments *) | MLint of int - | MLuint of Uint31.t + | MLuint of Uint63.t | MLsetref of string * mllambda | MLsequence of mllambda * mllambda | MLarray of mllambda array @@ -455,7 +450,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = | MLint i1, MLint i2 -> Int.equal i1 i2 | MLuint i1, MLuint i2 -> - Uint31.equal i1 i2 + Uint63.equal i1 i2 | MLsetref (id1, ml1), MLsetref (id2, ml2) -> String.equal id1 id2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 @@ -534,7 +529,7 @@ let rec hash_mllambda gn n env t = | MLint i -> combinesmall 11 i | MLuint i -> - combinesmall 12 (Uint31.to_int i) + combinesmall 12 (Uint63.hash i) | MLsetref (id, ml) -> let hid = String.hash id in let hml = hash_mllambda gn n env ml in @@ -947,9 +942,10 @@ let merge_branches t = Array.iter (fun (c,args,body) -> insert (c,args) body newt) t; Array.of_list (to_list newt) +let app_prim p args = MLapp(MLprimitive p, args) -type prim_aux = - | PAprim of string * Constant.t * CPrimitives.t * prim_aux array +type prim_aux = + | PAprim of string * pconstant * CPrimitives.t * prim_aux array | PAml of mllambda let add_check cond args = @@ -962,97 +958,67 @@ let add_check cond args = | _ -> cond in Array.fold_left aux cond args - + let extract_prim ml_of l = let decl = ref [] in let cond = ref [] in - let rec aux l = + let rec aux l = match l with | Lprim(prefix,kn,p,args) -> - let args = Array.map aux args in - cond := add_check !cond args; - PAprim(prefix,kn,p,args) + let args = Array.map aux args in + cond := add_check !cond args; + PAprim(prefix,kn,p,args) | Lrel _ | Lvar _ | Luint _ | Lval _ | Lconst _ -> PAml (ml_of l) - | _ -> - let x = fresh_lname Anonymous in - decl := (x,ml_of l)::!decl; - PAml (MLlocal x) in + | _ -> + let x = fresh_lname Anonymous in + decl := (x,ml_of l)::!decl; + PAml (MLlocal x) in let res = aux l in (!decl, !cond, res) -let app_prim p args = MLapp(MLprimitive p, args) - -let to_int v = +let cast_to_int v = match v with - | MLapp(MLprimitive Mk_uint, t) -> - begin match t.(0) with - | MLuint i -> MLint (Uint31.to_int i) - | _ -> MLapp(MLprimitive Val_to_int, [|v|]) - end - | MLapp(MLprimitive Mk_int, t) -> t.(0) - | _ -> MLapp(MLprimitive Val_to_int, [|v|]) - -let of_int v = - match v with - | MLapp(MLprimitive Val_to_int, t) -> t.(0) - | _ -> MLapp(MLprimitive Mk_int,[|v|]) + | MLint _ -> v + | _ -> MLapp(MLprimitive Val_to_int, [|v|]) let compile_prim decl cond paux = -(* - let args_to_int args = - for i = 0 to Array.length args - 1 do - args.(i) <- to_int args.(i) - done; - args in - *) + let rec opt_prim_aux paux = match paux with | PAprim(_prefix, _kn, op, args) -> - let args = Array.map opt_prim_aux args in - app_prim (Coq_primitive(op,None)) args -(* - TODO: check if this inlining was useful - begin match op with - | Int31lt -> - if Sys.word_size = 64 then - app_prim Mk_bool [|(app_prim MLlt (args_to_int args))|] - else app_prim (Coq_primitive (CPrimitives.Int31lt,None)) args - | Int31le -> - if Sys.word_size = 64 then - app_prim Mk_bool [|(app_prim MLle (args_to_int args))|] - else app_prim (Coq_primitive (CPrimitives.Int31le, None)) args - | Int31lsl -> of_int (mk_lsl (args_to_int args)) - | Int31lsr -> of_int (mk_lsr (args_to_int args)) - | Int31land -> of_int (mk_land (args_to_int args)) - | Int31lor -> of_int (mk_lor (args_to_int args)) - | Int31lxor -> of_int (mk_lxor (args_to_int args)) - | Int31add -> of_int (mk_add (args_to_int args)) - | Int31sub -> of_int (mk_sub (args_to_int args)) - | Int31mul -> of_int (mk_mul (args_to_int args)) - | _ -> app_prim (Coq_primitive(op,None)) args - end *) - | PAml ml -> ml - and naive_prim_aux paux = + let args = Array.map opt_prim_aux args in + app_prim (Coq_primitive(op,None)) args + | PAml ml -> ml + + and naive_prim_aux paux = match paux with | PAprim(prefix, kn, op, args) -> - app_prim (Coq_primitive(op, Some (prefix, kn))) (Array.map naive_prim_aux args) - | PAml ml -> ml in + app_prim (Coq_primitive(op, Some (prefix,kn))) (Array.map naive_prim_aux args) + | PAml ml -> ml + in - let compile_cond cond paux = + let compile_cond cond paux = match cond with - | [] -> opt_prim_aux paux + | [] -> opt_prim_aux paux | [c1] -> - MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) + MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) | c1::cond -> - let cond = - List.fold_left - (fun ml c -> app_prim MLland [| ml; to_int c|]) - (app_prim MLland [|to_int c1; MLint 0 |]) cond in - let cond = app_prim MLmagic [|cond|] in - MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in + let cond = + List.fold_left + (fun ml c -> app_prim MLland [| ml; cast_to_int c|]) + (app_prim MLland [| cast_to_int c1; MLint 0 |]) cond in + let cond = app_prim MLmagic [|cond|] in + MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in + let add_decl decl body = List.fold_left (fun body (x,d) -> MLlet(x,d,body)) body decl in - add_decl decl (compile_cond cond paux) + + (* The optimizations done for checking if integer values are closed are valid + only on 64-bit architectures. So on 32-bit architectures, we fall back to less optimized checks. *) + if max_int = 1073741823 (* 32-bits *) then + add_decl decl (naive_prim_aux paux) + else + add_decl decl (compile_cond cond paux) let ml_of_instance instance u = let ml_of_level l = @@ -1089,6 +1055,11 @@ let ml_of_instance instance u = | Llam(ids,body) -> let lnames,env = push_rels env ids in MLlam(lnames, ml_of_lam env l body) + | Lrec(id,body) -> + let ids,body = decompose_Llam body in + let lname, env = push_rel env id in + let lnames, env = push_rels env ids in + MLletrec([|lname, lnames, ml_of_lam env l body|], MLlocal lname) | Llet(id,def,body) -> let def = ml_of_lam env l def in let lname, env = push_rel env id in @@ -1101,8 +1072,8 @@ let ml_of_instance instance u = mkMLapp (MLglobal(Gconstant (prefix, c))) args | Lproj (prefix, ind, i) -> MLglobal(Gproj (prefix, ind, i)) | Lprim _ -> - let decl,cond,paux = extract_prim (ml_of_lam env l) t in - compile_prim decl cond paux + let decl,cond,paux = extract_prim (ml_of_lam env l) t in + compile_prim decl cond paux | Lcase (annot,p,a,bs) -> (* let predicate_uid fv_pred = compilation of p let rec case_uid fv a_uid = @@ -1311,18 +1282,7 @@ let ml_of_instance instance u = | Lconstruct (prefix, (cn,u)) -> let uargs = ml_of_instance env.env_univ u in mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs - | Luint v -> - (match v with - | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) - | UintDigits (prefix,cn,ds) -> - let c = MLglobal (Gconstruct (prefix, cn)) in - let ds = Array.map (ml_of_lam env l) ds in - let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in - MLapp(i31, ds) - | UintDecomp (prefix,cn,t) -> - let c = MLglobal (Gconstruct (prefix, cn)) in - let t = ml_of_lam env l t in - MLapp (MLprimitive Decomp_uint, [|c;t|])) + | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i | Lsort s -> @@ -1646,7 +1606,7 @@ let pp_mllam fmt l = Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" (string_of_construct prefix c) pp_cargs args | MLint i -> pp_int fmt i - | MLuint i -> Format.fprintf fmt "(Uint31.of_int %a)" pp_int (Uint31.to_int i) + | MLuint i -> Format.fprintf fmt "(%s)" (Uint63.compile i) | MLsetref (s, body) -> Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body | MLsequence(l1,l2) -> @@ -1766,8 +1726,6 @@ let pp_mllam fmt l = | Mk_int -> Format.fprintf fmt "mk_int" | Mk_bool -> Format.fprintf fmt "mk_bool" | Val_to_int -> Format.fprintf fmt "val_to_int" - | Mk_I31_accu -> Format.fprintf fmt "mk_I31_accu" - | Decomp_uint -> Format.fprintf fmt "decomp_uint" | Mk_meta -> Format.fprintf fmt "mk_meta_accu" | Mk_evar -> Format.fprintf fmt "mk_evar_accu" | MLand -> Format.fprintf fmt "(&&)" @@ -1787,9 +1745,9 @@ let pp_mllam fmt l = | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty" | Coq_primitive (op,None) -> Format.fprintf fmt "no_check_%s" (CPrimitives.to_string op) - | Coq_primitive (op, Some (prefix,kn)) -> + | Coq_primitive (op, Some (prefix,(c,_))) -> Format.fprintf fmt "%s %a" (CPrimitives.to_string op) - pp_mllam (MLglobal (Gconstant (prefix, kn))) + pp_mllam (MLglobal (Gconstant (prefix,c))) in Format.fprintf fmt "@[%a@]" pp_mllam l @@ -1893,17 +1851,13 @@ and compile_named env sigma univ auxdefs id = Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = - let no_univs = - match cb.const_universes with - | Monomorphic_const _ -> true - | Polymorphic_const ctx -> Int.equal (Univ.AUContext.size ctx) 0 - in + let no_univs = 0 = Univ.AUContext.size (Declareops.constant_polymorphic_context cb) in begin match cb.const_body with | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); - let is_lazy = is_lazy env prefix t in + let is_lazy = is_lazy t in let code = if is_lazy then mk_lazy code else code in let name = if interactive then LinkedInteractive prefix diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index f5d7ab3c9d..baa290367f 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -34,6 +34,8 @@ let rec conv_val env pb lvl v1 v2 cu = conv_accu env pb lvl k1 k2 cu | Vconst i1, Vconst i2 -> if Int.equal i1 i2 then cu else raise NotConvertible + | Vint64 i1, Vint64 i2 -> + if Int64.equal i1 i2 then cu else raise NotConvertible | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in @@ -47,7 +49,7 @@ let rec conv_val env pb lvl v1 v2 cu = aux lvl max b1 b2 (i+1) cu in aux lvl (n1-1) b1 b2 0 cu - | Vaccu _, _ | Vconst _, _ | Vblock _, _ -> raise NotConvertible + | Vaccu _, _ | Vconst _, _ | Vint64 _, _ | Vblock _, _ -> raise NotConvertible and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli deleted file mode 100644 index 2d8e2ba2f0..0000000000 --- a/kernel/nativeinstr.mli +++ /dev/null @@ -1,59 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -open Names -open Constr -open Nativevalues - -(** This file defines the lambda code for the native compiler. It has been -extracted from Nativelambda.ml because of the retroknowledge architecture. *) - -type prefix = string - -type uint = - | UintVal of Uint31.t - | UintDigits of prefix * constructor * lambda array - | UintDecomp of prefix * constructor * lambda - -and lambda = - | Lrel of Name.t * int - | Lvar of Id.t - | Lmeta of metavariable * lambda (* type *) - | Levar of Evar.t * lambda array (* arguments *) - | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda - | Lapp of lambda * lambda array - | Lconst of prefix * pconstant - | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) - | Lprim of prefix * Constant.t * CPrimitives.t * lambda array - | Lcase of annot_sw * lambda * lambda * lam_branches - (* annotations, term being matched, accu, branches *) - | Lif of lambda * lambda * lambda - | Lfix of (int array * (string * inductive) array * int) * fix_decl - | Lcofix of int * fix_decl (* must be in eta-expanded form *) - | Lmakeblock of prefix * pconstructor * int * lambda array - (* prefix, constructor name, constructor tag, arguments *) - (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor - (* A partially applied constructor *) - | Luint of uint - | Lval of Nativevalues.t - | Lsort of Sorts.t - | Lind of prefix * pinductive - | Llazy - | Lforce - -(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation -to be correct. Otherwise, memoization of previous evaluations will be applied -again to extra arguments (see #7333). *) - -and lam_branches = (constructor * Name.t array * lambda) array - -and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 70cb8691c6..0869f94042 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -14,12 +14,46 @@ open Constr open Declarations open Environ open Nativevalues -open Nativeinstr module RelDecl = Context.Rel.Declaration - -exception NotClosed +(** This file defines the lambda code generation phase of the native compiler *) +type prefix = string + +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Lmeta of metavariable * lambda (* type *) + | Levar of Evar.t * lambda array (* arguments *) + | Lprod of lambda * lambda + | Llam of Name.t array * lambda + | Lrec of Name.t * lambda + | Llet of Name.t * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of prefix * pconstant + | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) + | Lprim of prefix * pconstant * CPrimitives.t * lambda array + (* No check if None *) + | Lcase of annot_sw * lambda * lambda * lam_branches + (* annotations, term being matched, accu, branches *) + | Lif of lambda * lambda * lambda + | Lfix of (int array * (string * inductive) array * int) * fix_decl + | Lcofix of int * fix_decl + | Lmakeblock of prefix * pconstructor * int * lambda array + (* prefix, constructor Name.t, constructor tag, arguments *) + (* A fully applied constructor *) + | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) + (* A partially applied constructor *) + | Luint of Uint63.t + | Lval of Nativevalues.t + | Lsort of Sorts.t + | Lind of prefix * pinductive + | Llazy + | Lforce + +and lam_branches = (constructor * Name.t array * lambda) array + +and fix_decl = Name.t array * lambda array * lambda array type evars = { evars_val : existential -> constr option; @@ -84,9 +118,9 @@ let get_const_prefix env c = (* A generic map function *) -let rec map_lam_with_binders g f n lam = +let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ | Lconstruct _ | Llazy | Lforce | Lmeta _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in @@ -95,6 +129,9 @@ let rec map_lam_with_binders g f n lam = | Llam(ids,body) -> let body' = f (g (Array.length ids) n) body in if body == body' then lam else mkLlam ids body' + | Lrec(id,body) -> + let body' = f (g 1 n) body in + if body == body' then lam else Lrec(id,body') | Llet(id,def,body) -> let def' = f n def in let body' = f (g 1 n) body in @@ -135,23 +172,10 @@ let rec map_lam_with_binders g f n lam = | Lmakeblock(prefix,cn,tag,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(prefix,cn,tag,args') - | Luint u -> - let u' = map_uint g f n u in - if u == u' then lam else Luint u' | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') -and map_uint _g f n u = - match u with - | UintVal _ -> u - | UintDigits(prefix,c,args) -> - let args' = Array.Smart.map (f n) args in - if args == args' then u else UintDigits(prefix,c,args') - | UintDecomp(prefix,c,a) -> - let a' = f n a in - if a == a' then u else UintDecomp(prefix,c,a') - (*s Lift and substitution *) let rec lam_exlift el lam = @@ -186,7 +210,7 @@ let lam_subst_args subst args = (* [simplify subst lam] simplify the expression [lam_subst subst lam] *) (* that is : *) (* - Reduce [let] is the definition can be substituted i.e: *) -(* - a variable (rel or identifier) *) +(* - a variable (rel or Id.t) *) (* - a constant *) (* - a structured constant *) (* - a function *) @@ -298,7 +322,7 @@ let is_value lc = match lc with | Lval _ -> true | Lmakeblock(_,_,_,args) when Array.is_empty args -> true - | Luint (UintVal _) -> true + | Luint _ -> true | _ -> false let get_value lc = @@ -306,7 +330,7 @@ let get_value lc = | Lval v -> v | Lmakeblock(_,_,tag,args) when Array.is_empty args -> Nativevalues.mk_int tag - | Luint (UintVal i) -> Nativevalues.mk_uint i + | Luint i -> Nativevalues.mk_uint i | _ -> raise Not_found let make_args start _end = @@ -333,6 +357,20 @@ let rec get_alias env (kn, u as p) = | Cemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p +let prim env kn p args = + let prefix = get_const_prefix env (fst kn) in + Lprim(prefix, kn, p, args) + +let expand_prim env kn op arity = + let ids = Array.make arity Anonymous in + let args = make_args arity 1 in + Llam(ids, prim env kn op args) + +let lambda_of_prim env kn op args = + let arity = CPrimitives.arity op in + if Array.length args >= arity then prim env kn op args + else mkLapp (expand_prim env kn op arity) args + (*i Global environment *) let get_names decl = @@ -368,22 +406,9 @@ module Cache = r end -let is_lazy env prefix t = - match kind t with - | App (f,_args) -> - begin match kind f with - | Construct (c,_) -> - let gr = GlobRef.IndRef (fst c) in - (try - let _ = - Retroknowledge.get_native_before_match_info env.retroknowledge - gr prefix c Llazy; - in - false - with Not_found -> true) - | _ -> true - end - | LetIn _ | Case _ | Proj _ -> true +let is_lazy t = + match Constr.kind t with + | App _ | LetIn _ | Case _ | Proj _ -> true | _ -> false let evar_value sigma ev = sigma.evars_val ev @@ -482,13 +507,6 @@ let rec lambda_of_constr cache env sigma c = in (* translation of the argument *) let la = lambda_of_constr cache env sigma a in - let gr = GlobRef.IndRef ind in - let la = - try - Retroknowledge.get_native_before_match_info (env).retroknowledge - gr prefix (ind,1) la - with Not_found -> la - in (* translation of the type *) let lt = lambda_of_constr cache env sigma t in (* translation of branches *) @@ -519,7 +537,7 @@ let rec lambda_of_constr cache env sigma c = let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in let lbodies = lambda_of_args cache env sigma 0 rec_bodies in Lfix((pos, inds, i), (names, ltypes, lbodies)) - + | CoFix(init,(names,type_bodies,rec_bodies)) -> let rec_bodies = Array.map2 (Reduction.eta_expand env) rec_bodies type_bodies in let ltypes = lambda_of_args cache env sigma 0 type_bodies in @@ -527,27 +545,22 @@ let rec lambda_of_constr cache env sigma c = let lbodies = lambda_of_args cache env sigma 0 rec_bodies in Lcofix(init, (names, ltypes, lbodies)) + | Int i -> Luint i + and lambda_of_app cache env sigma f args = match kind f with | Const (_kn,_u as c) -> let kn,u = get_alias env c in let cb = lookup_constant kn env in - (try - let prefix = get_const_prefix env kn in - (* We delay the compilation of arguments to avoid an exponential behavior *) - let f = Retroknowledge.get_native_compiling_info - (env).retroknowledge (GlobRef.ConstRef kn) prefix in - let args = lambda_of_args cache env sigma 0 args in - f args - with Not_found -> begin match cb.const_body with + | Primitive op -> lambda_of_prim env c op (lambda_of_args cache env sigma 0 args) | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then lambda_of_app cache env sigma (Mod_subst.force_constr csubst) args else let prefix = get_const_prefix env kn in let t = - if is_lazy env prefix (Mod_subst.force_constr csubst) then + if is_lazy (Mod_subst.force_constr csubst) then mkLapp Lforce [|Lconst (prefix, (kn,u))|] else Lconst (prefix, (kn,u)) in @@ -555,34 +568,18 @@ and lambda_of_app cache env sigma f args = | OpaqueDef _ | Undef _ -> let prefix = get_const_prefix env kn in mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) - end) + end | Construct (c,u) -> let tag, nparams, arity = Cache.get_construct_info cache env c in let expected = nparams + arity in let nargs = Array.length args in let prefix = get_mind_prefix env (fst (fst c)) in - let gr = GlobRef.ConstructRef c in if Int.equal nargs expected then - try - try - Retroknowledge.get_native_constant_static_info - (env).retroknowledge - gr args - with NotClosed -> - assert (Int.equal nparams 0); (* should be fine for int31 *) - let args = lambda_of_args cache env sigma nparams args in - Retroknowledge.get_native_constant_dynamic_info - (env).retroknowledge gr prefix c args - with Not_found -> let args = lambda_of_args cache env sigma nparams args in makeblock env c u tag args else let args = lambda_of_args cache env sigma 0 args in - (try - Retroknowledge.get_native_constant_dynamic_info - (env).retroknowledge gr prefix c args - with Not_found -> - mkLapp (Lconstruct (prefix, (c,u))) args) + mkLapp (Lconstruct (prefix, (c,u))) args | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in @@ -615,45 +612,3 @@ let lambda_of_constr env sigma c = let mk_lazy c = mkLapp Llazy [|c|] - -(** Retroknowledge, to be removed once we move to primitive machine integers *) -let compile_static_int31 fc args = - if not fc then raise Not_found else - Luint (UintVal - (Uint31.of_int (Array.fold_left - (fun temp_i -> fun t -> match kind t with - | Construct ((_,d),_) -> 2*temp_i+d-1 - | _ -> raise NotClosed) - 0 args))) - -let compile_dynamic_int31 fc prefix c args = - if not fc then raise Not_found else - Luint (UintDigits (prefix,c,args)) - -(* We are relying here on the order of digits constructors *) -let digits_from_uint digits_ind prefix i = - let d0 = Lconstruct (prefix, ((digits_ind, 1), Univ.Instance.empty)) in - let d1 = Lconstruct (prefix, ((digits_ind, 2), Univ.Instance.empty)) in - let digits = Array.make 31 d0 in - for k = 0 to 30 do - if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then - digits.(30-k) <- d1 - done; - digits - -let before_match_int31 digits_ind fc prefix c t = - if not fc then - raise Not_found - else - match t with - | Luint (UintVal i) -> - let digits = digits_from_uint digits_ind prefix i in - mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) digits - | Luint (UintDigits (prefix,c,args)) -> - mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) args - | _ -> Luint (UintDecomp (prefix,c,t)) - -let compile_prim prim kn fc prefix args = - if not fc then raise Not_found - else - Lprim(prefix, kn, prim, args) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index 7b20258929..eb06522a33 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -10,9 +10,45 @@ open Names open Constr open Environ -open Nativeinstr +open Nativevalues (** This file defines the lambda code generation phase of the native compiler *) +type prefix = string + +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Lmeta of metavariable * lambda (* type *) + | Levar of Evar.t * lambda array (* arguments *) + | Lprod of lambda * lambda + | Llam of Name.t array * lambda + | Lrec of Name.t * lambda + | Llet of Name.t * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of prefix * pconstant + | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) + | Lprim of prefix * pconstant * CPrimitives.t * lambda array + | Lcase of annot_sw * lambda * lambda * lam_branches + (* annotations, term being matched, accu, branches *) + | Lif of lambda * lambda * lambda + | Lfix of (int array * (string * inductive) array * int) * fix_decl + | Lcofix of int * fix_decl + | Lmakeblock of prefix * pconstructor * int * lambda array + (* prefix, constructor Name.t, constructor tag, arguments *) + (* A fully applied constructor *) + | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) + (* A partially applied constructor *) + | Luint of Uint63.t + | Lval of Nativevalues.t + | Lsort of Sorts.t + | Lind of prefix * pinductive + | Llazy + | Lforce + +and lam_branches = (constructor * Name.t array * lambda) array + +and fix_decl = Name.t array * lambda array * lambda array + type evars = { evars_val : existential -> constr option; evars_metas : metavariable -> types } @@ -22,7 +58,7 @@ val empty_evars : evars val decompose_Llam : lambda -> Name.t array * lambda val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda -val is_lazy : env -> prefix -> constr -> bool +val is_lazy : constr -> bool val mk_lazy : lambda -> lambda val get_mind_prefix : env -> MutInd.t -> string @@ -30,14 +66,3 @@ val get_mind_prefix : env -> MutInd.t -> string val get_alias : env -> pconstant -> pconstant val lambda_of_constr : env -> evars -> Constr.constr -> lambda - -val compile_static_int31 : bool -> Constr.constr array -> lambda - -val compile_dynamic_int31 : bool -> prefix -> constructor -> lambda array -> - lambda - -val before_match_int31 : inductive -> bool -> prefix -> constructor -> lambda -> - lambda - -val compile_prim : CPrimitives.t -> Constant.t -> bool -> prefix -> lambda array -> - lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 93e74af845..a6b48cd7e3 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -196,11 +196,17 @@ let dummy_value : unit -> t = fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed.") let cast_accu v = (Obj.magic v:accumulator) +[@@ocaml.inline always] let mk_int (x : int) = (Obj.magic x : t) +[@@ocaml.inline always] + (* Coq's booleans are reversed... *) let mk_bool (b : bool) = (Obj.magic (not b) : t) -let mk_uint (x : Uint31.t) = (Obj.magic x : t) +[@@ocaml.inline always] + +let mk_uint (x : Uint63.t) = (Obj.magic x : t) +[@@ocaml.inline always] type block @@ -216,8 +222,9 @@ type kind_of_value = | Vaccu of accumulator | Vfun of (t -> t) | Vconst of int + | Vint64 of int64 | Vblock of block - + let kind_of_value (v:t) = let o = Obj.repr v in if Obj.is_int o then Vconst (Obj.magic v) @@ -225,8 +232,8 @@ let kind_of_value (v:t) = let tag = Obj.tag o in if Int.equal tag accumulate_tag then Vaccu (Obj.magic v) - else - if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) + else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) + else if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) else (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); or ??? what is 1002*) @@ -236,92 +243,105 @@ let kind_of_value (v:t) = let is_int (x:t) = let o = Obj.repr x in - Obj.is_int o + Obj.is_int o || Int.equal (Obj.tag o) Obj.custom_tag let val_to_int (x:t) = (Obj.magic x : int) +[@@ocaml.inline always] -let to_uint (x:t) = (Obj.magic x : Uint31.t) -let of_uint (x: Uint31.t) = (Obj.magic x : t) +let to_uint (x:t) = (Obj.magic x : Uint63.t) +[@@ocaml.inline always] let no_check_head0 x = - of_uint (Uint31.head0 (to_uint x)) + mk_uint (Uint63.head0 (to_uint x)) +[@@ocaml.inline always] let head0 accu x = if is_int x then no_check_head0 x else accu x let no_check_tail0 x = - of_uint (Uint31.tail0 (to_uint x)) + mk_uint (Uint63.tail0 (to_uint x)) +[@@ocaml.inline always] let tail0 accu x = if is_int x then no_check_tail0 x else accu x let no_check_add x y = - of_uint (Uint31.add (to_uint x) (to_uint y)) + mk_uint (Uint63.add (to_uint x) (to_uint y)) +[@@ocaml.inline always] let add accu x y = if is_int x && is_int y then no_check_add x y else accu x y let no_check_sub x y = - of_uint (Uint31.sub (to_uint x) (to_uint y)) + mk_uint (Uint63.sub (to_uint x) (to_uint y)) +[@@ocaml.inline always] let sub accu x y = if is_int x && is_int y then no_check_sub x y else accu x y let no_check_mul x y = - of_uint (Uint31.mul (to_uint x) (to_uint y)) + mk_uint (Uint63.mul (to_uint x) (to_uint y)) +[@@ocaml.inline always] let mul accu x y = if is_int x && is_int y then no_check_mul x y else accu x y let no_check_div x y = - of_uint (Uint31.div (to_uint x) (to_uint y)) + mk_uint (Uint63.div (to_uint x) (to_uint y)) +[@@ocaml.inline always] let div accu x y = if is_int x && is_int y then no_check_div x y else accu x y let no_check_rem x y = - of_uint (Uint31.rem (to_uint x) (to_uint y)) + mk_uint (Uint63.rem (to_uint x) (to_uint y)) +[@@ocaml.inline always] let rem accu x y = if is_int x && is_int y then no_check_rem x y else accu x y let no_check_l_sr x y = - of_uint (Uint31.l_sr (to_uint x) (to_uint y)) + mk_uint (Uint63.l_sr (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_sr accu x y = if is_int x && is_int y then no_check_l_sr x y else accu x y let no_check_l_sl x y = - of_uint (Uint31.l_sl (to_uint x) (to_uint y)) + mk_uint (Uint63.l_sl (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_sl accu x y = if is_int x && is_int y then no_check_l_sl x y else accu x y let no_check_l_and x y = - of_uint (Uint31.l_and (to_uint x) (to_uint y)) + mk_uint (Uint63.l_and (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_and accu x y = if is_int x && is_int y then no_check_l_and x y else accu x y let no_check_l_xor x y = - of_uint (Uint31.l_xor (to_uint x) (to_uint y)) + mk_uint (Uint63.l_xor (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_xor accu x y = if is_int x && is_int y then no_check_l_xor x y else accu x y let no_check_l_or x y = - of_uint (Uint31.l_or (to_uint x) (to_uint y)) + mk_uint (Uint63.l_or (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_or accu x y = if is_int x && is_int y then no_check_l_or x y @@ -337,61 +357,57 @@ type coq_pair = | Paccu of t | PPair of t * t -type coq_zn2z = - | Zaccu of t - | ZW0 - | ZWW of t * t - let mkCarry b i = - if b then (Obj.magic (C1(of_uint i)):t) - else (Obj.magic (C0(of_uint i)):t) + if b then (Obj.magic (C1(mk_uint i)):t) + else (Obj.magic (C0(mk_uint i)):t) let no_check_addc x y = - let s = Uint31.add (to_uint x) (to_uint y) in - mkCarry (Uint31.lt s (to_uint x)) s + let s = Uint63.add (to_uint x) (to_uint y) in + mkCarry (Uint63.lt s (to_uint x)) s +[@@ocaml.inline always] let addc accu x y = if is_int x && is_int y then no_check_addc x y else accu x y let no_check_subc x y = - let s = Uint31.sub (to_uint x) (to_uint y) in - mkCarry (Uint31.lt (to_uint x) (to_uint y)) s + let s = Uint63.sub (to_uint x) (to_uint y) in + mkCarry (Uint63.lt (to_uint x) (to_uint y)) s +[@@ocaml.inline always] let subc accu x y = if is_int x && is_int y then no_check_subc x y else accu x y -let no_check_addcarryc x y = +let no_check_addCarryC x y = let s = - Uint31.add (Uint31.add (to_uint x) (to_uint y)) - (Uint31.of_int 1) in - mkCarry (Uint31.le s (to_uint x)) s + Uint63.add (Uint63.add (to_uint x) (to_uint y)) + (Uint63.of_int 1) in + mkCarry (Uint63.le s (to_uint x)) s +[@@ocaml.inline always] -let addcarryc accu x y = - if is_int x && is_int y then no_check_addcarryc x y +let addCarryC accu x y = + if is_int x && is_int y then no_check_addCarryC x y else accu x y -let no_check_subcarryc x y = +let no_check_subCarryC x y = let s = - Uint31.sub (Uint31.sub (to_uint x) (to_uint y)) - (Uint31.of_int 1) in - mkCarry (Uint31.le (to_uint x) (to_uint y)) s + Uint63.sub (Uint63.sub (to_uint x) (to_uint y)) + (Uint63.of_int 1) in + mkCarry (Uint63.le (to_uint x) (to_uint y)) s +[@@ocaml.inline always] -let subcarryc accu x y = - if is_int x && is_int y then no_check_subcarryc x y +let subCarryC accu x y = + if is_int x && is_int y then no_check_subCarryC x y else accu x y let of_pair (x, y) = - (Obj.magic (PPair(of_uint x, of_uint y)):t) - -let zn2z_of_pair (x,y) = - if Uint31.equal x (Uint31.of_uint 0) && - Uint31.equal y (Uint31.of_uint 0) then Obj.magic ZW0 - else (Obj.magic (ZWW(of_uint x, of_uint y)) : t) + (Obj.magic (PPair(mk_uint x, mk_uint y)):t) +[@@ocaml.inline always] let no_check_mulc x y = - zn2z_of_pair(Uint31.mulc (to_uint x) (to_uint y)) + of_pair (Uint63.mulc (to_uint x) (to_uint y)) +[@@ocaml.inline always] let mulc accu x y = if is_int x && is_int y then no_check_mulc x y @@ -399,7 +415,8 @@ let mulc accu x y = let no_check_diveucl x y = let i1, i2 = to_uint x, to_uint y in - of_pair(Uint31.div i1 i2, Uint31.rem i1 i2) + of_pair(Uint63.div i1 i2, Uint63.rem i1 i2) +[@@ocaml.inline always] let diveucl accu x y = if is_int x && is_int y then no_check_diveucl x y @@ -407,21 +424,20 @@ let diveucl accu x y = let no_check_div21 x y z = let i1, i2, i3 = to_uint x, to_uint y, to_uint z in - of_pair (Uint31.div21 i1 i2 i3) + of_pair (Uint63.div21 i1 i2 i3) +[@@ocaml.inline always] let div21 accu x y z = if is_int x && is_int y && is_int z then no_check_div21 x y z else accu x y z -let no_check_addmuldiv x y z = +let no_check_addMulDiv x y z = let p, i, j = to_uint x, to_uint y, to_uint z in - let p' = Uint31.to_int p in - of_uint (Uint31.l_or - (Uint31.l_sl i p) - (Uint31.l_sr j (Uint31.of_int (31 - p')))) + mk_uint (Uint63.addmuldiv p i j) +[@@ocaml.inline always] -let addmuldiv accu x y z = - if is_int x && is_int y && is_int z then no_check_addmuldiv x y z +let addMulDiv accu x y z = + if is_int x && is_int y && is_int z then no_check_addMulDiv x y z else accu x y z [@@@ocaml.warning "-34"] @@ -436,29 +452,32 @@ type coq_cmp = | CmpLt | CmpGt -let no_check_eq x y = - mk_bool (Uint31.equal (to_uint x) (to_uint y)) +let no_check_eq x y = + mk_bool (Uint63.equal (to_uint x) (to_uint y)) +[@@ocaml.inline always] let eq accu x y = if is_int x && is_int y then no_check_eq x y else accu x y let no_check_lt x y = - mk_bool (Uint31.lt (to_uint x) (to_uint y)) + mk_bool (Uint63.lt (to_uint x) (to_uint y)) +[@@ocaml.inline always] let lt accu x y = if is_int x && is_int y then no_check_lt x y else accu x y let no_check_le x y = - mk_bool (Uint31.le (to_uint x) (to_uint y)) + mk_bool (Uint63.le (to_uint x) (to_uint y)) +[@@ocaml.inline always] let le accu x y = if is_int x && is_int y then no_check_le x y else accu x y let no_check_compare x y = - match Uint31.compare (to_uint x) (to_uint y) with + match Uint63.compare (to_uint x) (to_uint y) with | x when x < 0 -> (Obj.magic CmpLt:t) | 0 -> (Obj.magic CmpEq:t) | _ -> (Obj.magic CmpGt:t) @@ -467,6 +486,11 @@ let compare accu x y = if is_int x && is_int y then no_check_compare x y else accu x y +let print x = + Printf.fprintf stderr "%s" (Uint63.to_string (to_uint x)); + flush stderr; + x + let hobcnv = Array.init 256 (fun i -> Printf.sprintf "%02x" i) let bohcnv = Array.init 256 (fun i -> i - (if 0x30 <= i then 0x30 else 0) - @@ -491,63 +515,3 @@ let str_decode s = Buffer.add_char mshl_expr (bin_of_hex (Bytes.to_string buf)) done; Marshal.from_bytes (Buffer.to_bytes mshl_expr) 0 - -(** Retroknowledge, to be removed when we switch to primitive integers *) - -(* This will be unsafe with 63-bits integers *) -let digit_to_uint d = (Obj.magic d : Uint31.t) - -let mk_I31_accu c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 - x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 = - if is_int x0 && is_int x1 && is_int x2 && is_int x3 && is_int x4 && is_int x5 - && is_int x6 && is_int x7 && is_int x8 && is_int x9 && is_int x10 - && is_int x11 && is_int x12 && is_int x13 && is_int x14 && is_int x15 - && is_int x16 && is_int x17 && is_int x18 && is_int x19 && is_int x20 - && is_int x21 && is_int x22 && is_int x23 && is_int x24 && is_int x25 - && is_int x26 && is_int x27 && is_int x28 && is_int x29 && is_int x30 - then - let r = digit_to_uint x0 in - let r = Uint31.add_digit r (digit_to_uint x1) in - let r = Uint31.add_digit r (digit_to_uint x2) in - let r = Uint31.add_digit r (digit_to_uint x3) in - let r = Uint31.add_digit r (digit_to_uint x4) in - let r = Uint31.add_digit r (digit_to_uint x5) in - let r = Uint31.add_digit r (digit_to_uint x6) in - let r = Uint31.add_digit r (digit_to_uint x7) in - let r = Uint31.add_digit r (digit_to_uint x8) in - let r = Uint31.add_digit r (digit_to_uint x9) in - let r = Uint31.add_digit r (digit_to_uint x10) in - let r = Uint31.add_digit r (digit_to_uint x11) in - let r = Uint31.add_digit r (digit_to_uint x12) in - let r = Uint31.add_digit r (digit_to_uint x13) in - let r = Uint31.add_digit r (digit_to_uint x14) in - let r = Uint31.add_digit r (digit_to_uint x15) in - let r = Uint31.add_digit r (digit_to_uint x16) in - let r = Uint31.add_digit r (digit_to_uint x17) in - let r = Uint31.add_digit r (digit_to_uint x18) in - let r = Uint31.add_digit r (digit_to_uint x19) in - let r = Uint31.add_digit r (digit_to_uint x20) in - let r = Uint31.add_digit r (digit_to_uint x21) in - let r = Uint31.add_digit r (digit_to_uint x22) in - let r = Uint31.add_digit r (digit_to_uint x23) in - let r = Uint31.add_digit r (digit_to_uint x24) in - let r = Uint31.add_digit r (digit_to_uint x25) in - let r = Uint31.add_digit r (digit_to_uint x26) in - let r = Uint31.add_digit r (digit_to_uint x27) in - let r = Uint31.add_digit r (digit_to_uint x28) in - let r = Uint31.add_digit r (digit_to_uint x29) in - let r = Uint31.add_digit r (digit_to_uint x30) in - mk_uint r - else - c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 - x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 - -let decomp_uint c v = - if is_int v then - let r = ref c in - let v = val_to_int v in - for i = 30 downto 0 do - r := (!r) (mk_int ((v lsr i) land 1)); - done; - !r - else v diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 10689941e8..58cb6e2c30 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -78,8 +78,13 @@ val mk_const : tag -> t val mk_block : tag -> t array -> t val mk_bool : bool -> t +[@@ocaml.inline always] + val mk_int : int -> t -val mk_uint : Uint31.t -> t +[@@ocaml.inline always] + +val mk_uint : Uint63.t -> t +[@@ocaml.inline always] val napply : t -> t array -> t (* Functions over accumulators *) @@ -90,6 +95,8 @@ val args_of_accu : accumulator -> t array val accu_nargs : accumulator -> int val cast_accu : t -> accumulator +[@@ocaml.inline always] + (* Functions over block: i.e constructors *) type block @@ -106,6 +113,7 @@ type kind_of_value = | Vaccu of accumulator | Vfun of (t -> t) | Vconst of int + | Vint64 of int64 | Vblock of block val kind_of_value : t -> kind_of_value @@ -136,51 +144,90 @@ val l_or : t -> t -> t -> t val addc : t -> t -> t -> t val subc : t -> t -> t -> t -val addcarryc : t -> t -> t -> t -val subcarryc : t -> t -> t -> t +val addCarryC : t -> t -> t -> t +val subCarryC : t -> t -> t -> t val mulc : t -> t -> t -> t val diveucl : t -> t -> t -> t val div21 : t -> t -> t -> t -> t -val addmuldiv : t -> t -> t -> t -> t +val addMulDiv : t -> t -> t -> t -> t val eq : t -> t -> t -> t val lt : t -> t -> t -> t val le : t -> t -> t -> t val compare : t -> t -> t -> t +val print : t -> t + (* Function without check *) val no_check_head0 : t -> t +[@@ocaml.inline always] + val no_check_tail0 : t -> t +[@@ocaml.inline always] val no_check_add : t -> t -> t +[@@ocaml.inline always] + val no_check_sub : t -> t -> t +[@@ocaml.inline always] + val no_check_mul : t -> t -> t +[@@ocaml.inline always] + val no_check_div : t -> t -> t +[@@ocaml.inline always] + val no_check_rem : t -> t -> t +[@@ocaml.inline always] val no_check_l_sr : t -> t -> t +[@@ocaml.inline always] + val no_check_l_sl : t -> t -> t +[@@ocaml.inline always] + val no_check_l_and : t -> t -> t +[@@ocaml.inline always] + val no_check_l_xor : t -> t -> t +[@@ocaml.inline always] + val no_check_l_or : t -> t -> t +[@@ocaml.inline always] val no_check_addc : t -> t -> t +[@@ocaml.inline always] + val no_check_subc : t -> t -> t -val no_check_addcarryc : t -> t -> t -val no_check_subcarryc : t -> t -> t +[@@ocaml.inline always] + +val no_check_addCarryC : t -> t -> t +[@@ocaml.inline always] + +val no_check_subCarryC : t -> t -> t +[@@ocaml.inline always] val no_check_mulc : t -> t -> t +[@@ocaml.inline always] + val no_check_diveucl : t -> t -> t +[@@ocaml.inline always] val no_check_div21 : t -> t -> t -> t -val no_check_addmuldiv : t -> t -> t -> t +[@@ocaml.inline always] + +val no_check_addMulDiv : t -> t -> t -> t +[@@ocaml.inline always] val no_check_eq : t -> t -> t +[@@ocaml.inline always] + val no_check_lt : t -> t -> t +[@@ocaml.inline always] + val no_check_le : t -> t -> t -val no_check_compare : t -> t -> t +[@@ocaml.inline always] -val mk_I31_accu : t -val decomp_uint : t -> t -> t +val no_check_compare : t -> t -> t diff --git a/kernel/primred.ml b/kernel/primred.ml new file mode 100644 index 0000000000..d95d7de7aa --- /dev/null +++ b/kernel/primred.ml @@ -0,0 +1,208 @@ +(* Reduction of native operators *) +open Names +open CPrimitives +open Retroknowledge +open Environ +open CErrors + +let add_retroknowledge env action = + match action with + | Register_type(PT_int63,c) -> + let retro = env.retroknowledge in + let retro = + match retro.retro_int63 with + | None -> { retro with retro_int63 = Some c } + | Some c' -> assert (Constant.equal c c'); retro in + set_retroknowledge env retro + | Register_ind(pit,ind) -> + let retro = env.retroknowledge in + let retro = + match pit with + | PIT_bool -> + let r = + match retro.retro_bool with + | None -> ((ind,1), (ind,2)) + | Some (((ind',_),_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_bool = Some r } + | PIT_carry -> + let r = + match retro.retro_carry with + | None -> ((ind,1), (ind,2)) + | Some (((ind',_),_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_carry = Some r } + | PIT_pair -> + let r = + match retro.retro_pair with + | None -> (ind,1) + | Some ((ind',_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_pair = Some r } + | PIT_cmp -> + let r = + match retro.retro_cmp with + | None -> ((ind,1), (ind,2), (ind,3)) + | Some (((ind',_),_,_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_cmp = Some r } + in + set_retroknowledge env retro + | Register_inline(c) -> + let (cb,r) = lookup_constant_key c env in + let cb = {cb with Declarations.const_inline_code = true} in + add_constant_key c cb !(fst r) env + +let get_int_type env = + match env.retroknowledge.retro_int63 with + | Some c -> c + | None -> anomaly Pp.(str"Reduction of primitive: int63 not registered") + +let get_bool_constructors env = + match env.retroknowledge.retro_bool with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: bool not registered") + +let get_carry_constructors env = + match env.retroknowledge.retro_carry with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: carry not registered") + +let get_pair_constructor env = + match env.retroknowledge.retro_pair with + | Some c -> c + | None -> anomaly Pp.(str"Reduction of primitive: pair not registered") + +let get_cmp_constructors env = + match env.retroknowledge.retro_cmp with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: cmp not registered") + +exception NativeDestKO + +module type RedNativeEntries = + sig + type elem + type args + type evd (* will be unit in kernel, evar_map outside *) + + val get : args -> int -> elem + val get_int : evd -> elem -> Uint63.t + val mkInt : env -> Uint63.t -> elem + val mkBool : env -> bool -> elem + val mkCarry : env -> bool -> elem -> elem (* true if carry *) + val mkIntPair : env -> elem -> elem -> elem + val mkLt : env -> elem + val mkEq : env -> elem + val mkGt : env -> elem + + end + +module type RedNative = + sig + type elem + type args + type evd + val red_prim : env -> evd -> CPrimitives.t -> args -> elem option + end + +module RedNative (E:RedNativeEntries) : + RedNative with type elem = E.elem + with type args = E.args + with type evd = E.evd = +struct + type elem = E.elem + type args = E.args + type evd = E.evd + + let get_int evd args i = E.get_int evd (E.get args i) + + let get_int1 evd args = get_int evd args 0 + + let get_int2 evd args = get_int evd args 0, get_int evd args 1 + + let get_int3 evd args = + get_int evd args 0, get_int evd args 1, get_int evd args 2 + + let red_prim_aux env evd op args = + let open CPrimitives in + match op with + | Int63head0 -> + let i = get_int1 evd args in E.mkInt env (Uint63.head0 i) + | Int63tail0 -> + let i = get_int1 evd args in E.mkInt env (Uint63.tail0 i) + | Int63add -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.add i1 i2) + | Int63sub -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.sub i1 i2) + | Int63mul -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.mul i1 i2) + | Int63div -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.div i1 i2) + | Int63mod -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.rem i1 i2) + | Int63lsr -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sr i1 i2) + | Int63lsl -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sl i1 i2) + | Int63land -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_and i1 i2) + | Int63lor -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_or i1 i2) + | Int63lxor -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_xor i1 i2) + | Int63addc -> + let i1, i2 = get_int2 evd args in + let s = Uint63.add i1 i2 in + E.mkCarry env (Uint63.lt s i1) (E.mkInt env s) + | Int63subc -> + let i1, i2 = get_int2 evd args in + let s = Uint63.sub i1 i2 in + E.mkCarry env (Uint63.lt i1 i2) (E.mkInt env s) + | Int63addCarryC -> + let i1, i2 = get_int2 evd args in + let s = Uint63.add (Uint63.add i1 i2) (Uint63.of_int 1) in + E.mkCarry env (Uint63.le s i1) (E.mkInt env s) + | Int63subCarryC -> + let i1, i2 = get_int2 evd args in + let s = Uint63.sub (Uint63.sub i1 i2) (Uint63.of_int 1) in + E.mkCarry env (Uint63.le i1 i2) (E.mkInt env s) + | Int63mulc -> + let i1, i2 = get_int2 evd args in + let (h, l) = Uint63.mulc i1 i2 in + E.mkIntPair env (E.mkInt env h) (E.mkInt env l) + | Int63diveucl -> + let i1, i2 = get_int2 evd args in + let q,r = Uint63.div i1 i2, Uint63.rem i1 i2 in + E.mkIntPair env (E.mkInt env q) (E.mkInt env r) + | Int63div21 -> + let i1, i2, i3 = get_int3 evd args in + let q,r = Uint63.div21 i1 i2 i3 in + E.mkIntPair env (E.mkInt env q) (E.mkInt env r) + | Int63addMulDiv -> + let p, i, j = get_int3 evd args in + E.mkInt env + (Uint63.l_or + (Uint63.l_sl i p) + (Uint63.l_sr j (Uint63.sub (Uint63.of_int Uint63.uint_size) p))) + | Int63eq -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.equal i1 i2) + | Int63lt -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.lt i1 i2) + | Int63le -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.le i1 i2) + | Int63compare -> + let i1, i2 = get_int2 evd args in + begin match Uint63.compare i1 i2 with + | x when x < 0 -> E.mkLt env + | 0 -> E.mkEq env + | _ -> E.mkGt env + end + + let red_prim env evd p args = + try + let r = + red_prim_aux env evd p args + in Some r + with NativeDestKO -> None + +end diff --git a/kernel/primred.mli b/kernel/primred.mli new file mode 100644 index 0000000000..f5998982d7 --- /dev/null +++ b/kernel/primred.mli @@ -0,0 +1,44 @@ +open Names +open Environ + +(** {5 Reduction of primitives} *) +val add_retroknowledge : env -> Retroknowledge.action -> env + +val get_int_type : env -> Constant.t +val get_bool_constructors : env -> constructor * constructor +val get_carry_constructors : env -> constructor * constructor +val get_pair_constructor : env -> constructor +val get_cmp_constructors : env -> constructor * constructor * constructor + +exception NativeDestKO (* Should be raised by get_* functions on failure *) + +module type RedNativeEntries = + sig + type elem + type args + type evd (* will be unit in kernel, evar_map outside *) + + val get : args -> int -> elem + val get_int : evd -> elem -> Uint63.t + val mkInt : env -> Uint63.t -> elem + val mkBool : env -> bool -> elem + val mkCarry : env -> bool -> elem -> elem (* true if carry *) + val mkIntPair : env -> elem -> elem -> elem + val mkLt : env -> elem + val mkEq : env -> elem + val mkGt : env -> elem + end + +module type RedNative = + sig + type elem + type args + type evd + val red_prim : env -> evd -> CPrimitives.t -> args -> elem option + end + +module RedNative : + functor (E:RedNativeEntries) -> + RedNative with type elem = E.elem + with type args = E.args + with type evd = E.evd diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 97cd4c00d7..b583d33e29 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -21,6 +21,7 @@ open CErrors open Util open Names open Constr +open Declarations open Vars open Environ open CClosure @@ -59,16 +60,23 @@ let compare_stack_shape stk1 stk2 = Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 + | Zprimitive(op1,_,rargs1, _kargs1)::s1, Zprimitive(op2,_,rargs2, _kargs2)::s2 -> + bal=0 && op1=op2 && List.length rargs1=List.length rargs2 && + compare_rec 0 s1 s2 | [], _ :: _ - | (Zproj _ | ZcaseT _ | Zfix _) :: _, _ -> false + | (Zproj _ | ZcaseT _ | Zfix _ | Zprimitive _) :: _, _ -> false in compare_rec 0 stk1 stk2 +type lft_fconstr = lift * fconstr + type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * constr * constr array * fconstr subs + | Zlprimitive of + CPrimitives.t * pconstant * lft_fconstr list * lft_fconstr next_native_args and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function @@ -102,7 +110,10 @@ let pure_stack lfts stk = let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,p,br,e)::pstk)) + (l,Zlcase(ci,l,p,br,e)::pstk) + | (Zprimitive(op,c,rargs,kargs),(l,pstk)) -> + (l,Zlprimitive(op,c,List.map (fun t -> (l,t)) rargs, + List.map (fun (k,t) -> (k,(l,t))) kargs)::pstk)) in snd (pure_rec lfts stk) @@ -127,10 +138,10 @@ let nf_betaiota env t = let whd_betaiotazeta env x = match kind x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _) -> x + Prod _|Lambda _|Fix _|CoFix _|Int _) -> x | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | Const _ -> x + | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | Int _ -> x | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos betaiotazeta env) (create_tab ()) (inject x) @@ -141,10 +152,10 @@ let whd_betaiotazeta env x = let whd_all env t = match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _) -> t + Prod _|Lambda _|Fix _|CoFix _|Int _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | Int _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Const _ |Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos all env) (create_tab ()) (inject t) @@ -155,10 +166,10 @@ let whd_all env t = let whd_allnolet env t = match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t + Prod _|Lambda _|Fix _|CoFix _|LetIn _|Int _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ | Int _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | App _ | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos allnolet env) (create_tab ()) (inject t) @@ -233,18 +244,14 @@ let inductive_cumulativity_arguments (mind,ind) = mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs let convert_inductives_gen cmp_instances cmp_cumul cv_pb (mind,ind) nargs u1 u2 s = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); - s - | Declarations.Polymorphic_ind _ -> - cmp_instances u1 u2 s - | Declarations.Cumulative_ind cumi -> + match mind.Declarations.mind_variance with + | None -> cmp_instances u1 u2 s + | Some variances -> let num_param_arity = inductive_cumulativity_arguments (mind,ind) in if not (Int.equal num_param_arity nargs) then cmp_instances u1 u2 s else - cmp_cumul cv_pb (Univ.ACumulativityInfo.variance cumi) u1 u2 s + cmp_cumul cv_pb variances u1 u2 s let convert_inductives cv_pb ind nargs u1 u2 (s, check) = convert_inductives_gen (check.compare_instances ~flex:false) check.compare_cumul_instances @@ -255,13 +262,9 @@ let constructor_cumulativity_arguments (mind, ind, ctor) = mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(ctor - 1) let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u2 s = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); - s - | Declarations.Polymorphic_ind _ -> - cmp_instances u1 u2 s - | Declarations.Cumulative_ind _cumi -> + match mind.Declarations.mind_variance with + | None -> cmp_instances u1 u2 s + | Some _ -> let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in if not (Int.equal num_cnstr_args nargs) then cmp_instances u1 u2 s @@ -296,6 +299,15 @@ let rec skip_pattern n c = | Lambda (_, _, c) -> skip_pattern (pred n) c | _ -> raise IrregularPatternShape +let unfold_ref_with_args infos tab fl v = + match unfold_reference infos tab fl with + | Def def -> Some (def, v) + | Primitive op when check_native_args op v -> + let c = match fl with ConstKey c -> c | _ -> assert false in + let rargs, a, nargs, v = get_native_args1 op c v in + Some (whd_stack infos tab a (Zupdate a::(Zprimitive(op,c,rargs,nargs)::v))) + | Undef _ | OpaqueDef _ | Primitive _ -> None + type conv_tab = { cnv_inf : clos_infos; lft_tab : clos_tab; @@ -355,28 +367,26 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try - let cuniv = conv_table_key infos.cnv_inf fl1 fl2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + let cuniv = conv_table_key infos.cnv_inf fl1 fl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with NotConvertible | Univ.UniverseInconsistency _ -> - (* else the oracle tells which constant is to be expanded *) + (* else the oracle tells which constant is to be expanded *) let oracle = CClosure.oracle_of_infos infos.cnv_inf in let (app1,app2) = + let aux appr1 lft1 fl1 tab1 v1 appr2 lft2 fl2 tab2 v2 = + match unfold_ref_with_args infos.cnv_inf tab1 fl1 v1 with + | Some t1 -> ((lft1, t1), appr2) + | None -> match unfold_ref_with_args infos.cnv_inf tab2 fl2 v2 with + | Some t2 -> (appr1, (lft2, t2)) + | None -> raise NotConvertible + in if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then - match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> ((lft1, (def1, v1)), appr2) - | None -> - (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> (appr1, (lft2, (def2, v2))) - | None -> raise NotConvertible) + aux appr1 lft1 fl1 infos.lft_tab v1 appr2 lft2 fl2 infos.rgt_tab v2 else - match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> (appr1, (lft2, (def2, v2))) - | None -> - (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> ((lft1, (def1, v1)), appr2) - | None -> raise NotConvertible) - in - eqappr cv_pb l2r infos app1 app2 cuniv) + let (app2,app1) = aux appr2 lft2 fl2 infos.rgt_tab v2 appr1 lft1 fl1 infos.lft_tab v1 in + (app1,app2) + in + eqappr cv_pb l2r infos app1 app2 cuniv) | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, @@ -400,31 +410,37 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = raise NotConvertible) | (FProj (p1,c1), t2) -> - (match unfold_projection infos.cnv_inf p1 with - | Some s1 -> + begin match unfold_projection infos.cnv_inf p1 with + | Some s1 -> eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv - | None -> - (match t2 with - | FFlex fl2 -> - (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv - | None -> raise NotConvertible) - | _ -> raise NotConvertible)) - + | None -> + begin match t2 with + | FFlex fl2 -> + begin match unfold_ref_with_args infos.cnv_inf infos.rgt_tab fl2 v2 with + | Some t2 -> + eqappr cv_pb l2r infos appr1 (lft2, t2) cuniv + | None -> raise NotConvertible + end + | _ -> raise NotConvertible + end + end + | (t1, FProj (p2,c2)) -> - (match unfold_projection infos.cnv_inf p2 with - | Some s2 -> + begin match unfold_projection infos.cnv_inf p2 with + | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv - | None -> - (match t1 with - | FFlex fl1 -> - (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> - eqappr cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv - | None -> raise NotConvertible) - | _ -> raise NotConvertible)) - + | None -> + begin match t1 with + | FFlex fl1 -> + begin match unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 with + | Some t1 -> + eqappr cv_pb l2r infos (lft1, t1) appr2 cuniv + | None -> raise NotConvertible + end + | _ -> raise NotConvertible + end + end + (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but @@ -469,8 +485,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> - (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> + begin match unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 with + | Some (def1,v1) -> (** By virtue of the previous case analyses, we know [c2] is rigid. Conversion check to rigid terms eventually implies full weak-head reduction, so instead of repeatedly performing small-step @@ -478,32 +494,34 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in let r1 = whd_stack (infos_with_reds infos.cnv_inf all) infos.lft_tab def1 v1 in eqappr cv_pb l2r infos (lft1, r1) appr2 cuniv - | None -> - match c2 with + | None -> + (match c2 with | FConstruct ((ind2,_j2),_u2) -> - (try - let v2, v1 = - eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - with Not_found -> raise NotConvertible) - | _ -> raise NotConvertible) - + (try + let v2, v1 = + eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + end + | (c1, FFlex fl2) -> - (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> + begin match unfold_ref_with_args infos.cnv_inf infos.rgt_tab fl2 v2 with + | Some (def2, v2) -> (** Symmetrical case of above. *) let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in let r2 = whd_stack (infos_with_reds infos.cnv_inf all) infos.rgt_tab def2 v2 in eqappr cv_pb l2r infos appr1 (lft2, r2) cuniv - | None -> - match c1 with - | FConstruct ((ind1,_j1),_u1) -> - (try let v1, v2 = - eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - with Not_found -> raise NotConvertible) - | _ -> raise NotConvertible) - + | None -> + match c1 with + | FConstruct ((ind1,_j1),_u1) -> + (try let v1, v2 = + eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible + end + (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1), FInd (ind2,u2)) -> if eq_ind ind1 ind2 then @@ -584,13 +602,17 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible + | FInt i1, FInt i2 -> + if Uint63.equal i1 i2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ - | FProd _ | FEvar _), _ -> raise NotConvertible + | FProd _ | FEvar _ | FInt _), _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = let f (l1, t1) (l2, t2) cuniv = ccnv CONV l2r infos l1 l2 t1 t2 cuniv in @@ -613,7 +635,12 @@ and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = raise NotConvertible; let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 - | _ -> assert false) + | (Zlprimitive(op1,_,rargs1,kargs1),Zlprimitive(op2,_,rargs2,kargs2)) -> + if not (CPrimitives.equal op1 op2) then raise NotConvertible else + let cu2 = List.fold_right2 f rargs1 rargs2 cu1 in + let fk (_,a1) (_,a2) cu = f a1 a2 cu in + List.fold_right2 fk kargs1 kargs2 cu2 + | ((Zlapp _ | Zlproj _ | Zlfix _| Zlcase _| Zlprimitive _), _) -> assert false) | _ -> cuniv in if compare_stack_shape stk1 stk2 then cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index e51c25c06b..18fafdb6d3 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -12,249 +12,30 @@ (* Addition of native Head (nb of heading 0) and Tail (nb of trailing 0) by Benjamin Grégoire, Jun 2007 *) -(* This file defines the knowledge that the kernel is able to optimize - for evaluation in the bytecode virtual machine *) +(* This file defines the knowledge that the kernel is able to optimize. *) open Names -open Constr - -(* The retroknowledge defines a bijective correspondance between some - [entry]-s (which are, in fact, merely names) and [field]-s which - are roles assigned to these entries. *) - -type int31_field = - | Int31Bits - | Int31Type - | Int31Constructor - | Int31Twice - | Int31TwicePlusOne - | Int31Phi - | Int31PhiInv - | Int31Plus - | Int31PlusC - | Int31PlusCarryC - | Int31Minus - | Int31MinusC - | Int31MinusCarryC - | Int31Times - | Int31TimesC - | Int31Div21 - | Int31Div - | Int31Diveucl - | Int31AddMulDiv - | Int31Compare - | Int31Head0 - | Int31Tail0 - | Int31Lor - | Int31Land - | Int31Lxor - -type field = - | KInt31 of int31_field - -let int31_field_of_string = - function - | "bits" -> Int31Bits - | "type" -> Int31Type - | "twice" -> Int31Twice - | "twice_plus_one" -> Int31TwicePlusOne - | "phi" -> Int31Phi - | "phi_inv" -> Int31PhiInv - | "plus" -> Int31Plus - | "plusc" -> Int31PlusC - | "pluscarryc" -> Int31PlusCarryC - | "minus" -> Int31Minus - | "minusc" -> Int31MinusC - | "minuscarryc" -> Int31MinusCarryC - | "times" -> Int31Times - | "timesc" -> Int31TimesC - | "div21" -> Int31Div21 - | "div" -> Int31Div - | "diveucl" -> Int31Diveucl - | "addmuldiv" -> Int31AddMulDiv - | "compare" -> Int31Compare - | "head0" -> Int31Head0 - | "tail0" -> Int31Tail0 - | "lor" -> Int31Lor - | "land" -> Int31Land - | "lxor" -> Int31Lxor - | s -> CErrors.user_err Pp.(str "Registering unknown int31 operator " ++ str s) - -let int31_path = DirPath.make [ Id.of_string "int31" ] - -(* record representing all the flags of the internal state of the kernel *) -type flags = {fastcomputation : bool} - - - - - -(* The [proactive] knowledge contains the mapping [field->entry]. *) - -module Proactive = - Map.Make (struct type t = field let compare = Pervasives.compare end) - -type proactive = GlobRef.t Proactive.t - -(* The [reactive] knowledge contains the mapping - [entry->field]. Fields are later to be interpreted as a - [reactive_info]. *) - -module Reactive = GlobRef.Map - -type reactive_info = {(*information required by the compiler of the VM *) - vm_compiling : - (*fastcomputation flag -> continuation -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - vm_constant_static : - (*fastcomputation flag -> constructor -> args -> result*) - (bool -> constr array -> Cinstr.lambda) - option; - vm_constant_dynamic : - (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - (* fastcomputation flag -> cont -> result *) - vm_before_match : (bool -> Cinstr.lambda -> Cinstr.lambda) option; - (* tag (= compiled int for instance) -> result *) - vm_decompile_const : (int -> constr) option; - - native_compiling : - (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> - Nativeinstr.lambda) option; - - native_constant_static : - (bool -> constr array -> Nativeinstr.lambda) option; - - native_constant_dynamic : - (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda array -> Nativeinstr.lambda) option; - - native_before_match : (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda -> Nativeinstr.lambda) option +type retroknowledge = { + retro_int63 : Constant.t option; + retro_bool : (constructor * constructor) option; (* true, false *) + retro_carry : (constructor * constructor) option; (* C0, C1 *) + retro_pair : constructor option; + retro_cmp : (constructor * constructor * constructor) option; + (* Eq, Lt, Gt *) + retro_refl : constructor option; } +let empty = { + retro_int63 = None; + retro_bool = None; + retro_carry = None; + retro_pair = None; + retro_cmp = None; + retro_refl = None; +} - -and reactive = field Reactive.t - -and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive} - -(* This type represent an atomic action of the retroknowledge. It - is stored in the compiled libraries *) -(* As per now, there is only the possibility of registering things - the possibility of unregistering or changing the flag is under study *) type action = - | RKRegister of field * GlobRef.t - - -(*initialisation*) -let initial_flags = - {fastcomputation = true;} - -let initial_proactive = - (Proactive.empty:proactive) - -let initial_reactive = - (Reactive.empty:reactive) - -let initial_retroknowledge = - {flags = initial_flags; - proactive = initial_proactive; - reactive = initial_reactive } - -let empty_reactive_info = - { vm_compiling = None ; - vm_constant_static = None; - vm_constant_dynamic = None; - vm_before_match = None; - vm_decompile_const = None; - native_compiling = None; - native_constant_static = None; - native_constant_dynamic = None; - native_before_match = None; - } - - - -(* adds a binding [entry<->field]. *) -let add_field knowledge field entry = - {knowledge with - proactive = Proactive.add field entry knowledge.proactive; - reactive = Reactive.add entry field knowledge.reactive} - -(* acces functions for proactive retroknowledge *) -let mem knowledge field = - Proactive.mem field knowledge.proactive - -let find knowledge field = - Proactive.find field knowledge.proactive - - -let (dispatch,dispatch_hook) = Hook.make () - -let dispatch_reactive entry retroknowledge = - Hook.get dispatch retroknowledge entry (Reactive.find entry retroknowledge.reactive) - -(*access functions for reactive retroknowledge*) - -(* used for compiling of functions (add, mult, etc..) *) -let get_vm_compiling_info knowledge key = - match (dispatch_reactive key knowledge).vm_compiling - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of fully applied constructors *) -let get_vm_constant_static_info knowledge key = - match (dispatch_reactive key knowledge).vm_constant_static - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of partially applied constructors *) -let get_vm_constant_dynamic_info knowledge key = - match (dispatch_reactive key knowledge).vm_constant_dynamic - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -let get_vm_before_match_info knowledge key = - match (dispatch_reactive key knowledge).vm_before_match - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -let get_vm_decompile_constant_info knowledge key = - match (dispatch_reactive key knowledge).vm_decompile_const - with - | None -> raise Not_found - | Some f -> f - -let get_native_compiling_info knowledge key = - match (dispatch_reactive key knowledge).native_compiling - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of fully applied constructors *) -let get_native_constant_static_info knowledge key = - match (dispatch_reactive key knowledge).native_constant_static - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of partially applied constructors *) -let get_native_constant_dynamic_info knowledge key = - match (dispatch_reactive key knowledge).native_constant_dynamic - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -let get_native_before_match_info knowledge key = - match (dispatch_reactive key knowledge).native_before_match - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation + | Register_ind of CPrimitives.prim_ind * inductive + | Register_type of CPrimitives.prim_type * Constant.t + | Register_inline of Constant.t diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 0a2ef5300e..1554fe88da 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -9,157 +9,20 @@ (************************************************************************) open Names -open Constr - -type retroknowledge - -(** the following types correspond to the different "things" - the kernel can learn about.*) -type int31_field = - | Int31Bits - | Int31Type - | Int31Constructor - | Int31Twice - | Int31TwicePlusOne - | Int31Phi - | Int31PhiInv - | Int31Plus - | Int31PlusC - | Int31PlusCarryC - | Int31Minus - | Int31MinusC - | Int31MinusCarryC - | Int31Times - | Int31TimesC - | Int31Div21 - | Int31Div - | Int31Diveucl - | Int31AddMulDiv - | Int31Compare - | Int31Head0 - | Int31Tail0 - | Int31Lor - | Int31Land - | Int31Lxor - -type field = - | KInt31 of int31_field - -val int31_field_of_string : string -> int31_field - -val int31_path : DirPath.t - -(** This type represent an atomic action of the retroknowledge. It - is stored in the compiled libraries - As per now, there is only the possibility of registering things - the possibility of unregistering or changing the flag is under study *) -type action = - | RKRegister of field * GlobRef.t - - -(** initial value for retroknowledge *) -val initial_retroknowledge : retroknowledge - - -(** Given an identifier id (usually Const _) - and the continuation cont of the bytecode compilation - returns the compilation of id in cont if it has a specific treatment - or raises Not_found if id should be compiled as usual *) -val get_vm_compiling_info : retroknowledge -> GlobRef.t -> - Cinstr.lambda array -> Cinstr.lambda -(*Given an identifier id (usually Construct _) - and its argument array, returns a function that tries an ad-hoc optimisated - compilation (in the case of the 31-bit integers it means compiling them - directly into an integer) - raises Not_found if id should be compiled as usual, and expectingly - CBytecodes.NotClosed if the term is not a closed constructor pattern - (a constant for the compiler) *) -val get_vm_constant_static_info : retroknowledge -> GlobRef.t -> - constr array -> Cinstr.lambda - -(*Given an identifier id (usually Construct _ ) - its argument array and a continuation, returns the compiled version - of id+args+cont when id has a specific treatment (in the case of - 31-bit integers, that would be the dynamic compilation into integers) - or raises Not_found if id should be compiled as usual *) -val get_vm_constant_dynamic_info : retroknowledge -> GlobRef.t -> - Cinstr.lambda array -> Cinstr.lambda - -(** Given a type identifier, this function is used before compiling a match - over this type. In the case of 31-bit integers for instance, it is used - to add the instruction sequence which would perform a dynamic decompilation - in case the argument of the match is not in coq representation *) -val get_vm_before_match_info : retroknowledge -> GlobRef.t -> Cinstr.lambda - -> Cinstr.lambda - -(** Given a type identifier, this function is used by pretyping/vnorm.ml to - recover the elements of that type from their compiled form if it's non - standard (it is used (and can be used) only when the compiled form - is not a block *) -val get_vm_decompile_constant_info : retroknowledge -> GlobRef.t -> int -> constr - - -val get_native_compiling_info : retroknowledge -> GlobRef.t -> Nativeinstr.prefix -> - Nativeinstr.lambda array -> Nativeinstr.lambda - -val get_native_constant_static_info : retroknowledge -> GlobRef.t -> - constr array -> Nativeinstr.lambda - -val get_native_constant_dynamic_info : retroknowledge -> GlobRef.t -> - Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda array -> - Nativeinstr.lambda - -val get_native_before_match_info : retroknowledge -> GlobRef.t -> - Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda -> Nativeinstr.lambda - - -(** the following functions are solely used in Environ and Safe_typing to implement - the functions register and unregister (and mem) of Environ *) -val add_field : retroknowledge -> field -> GlobRef.t -> retroknowledge -val mem : retroknowledge -> field -> bool -(* val remove : retroknowledge -> field -> retroknowledge *) -val find : retroknowledge -> field -> GlobRef.t - - -(** Dispatching type for the above [get_*] functions. *) -type reactive_info = {(*information required by the compiler of the VM *) - vm_compiling : - (*fastcomputation flag -> continuation -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - vm_constant_static : - (*fastcomputation flag -> constructor -> args -> result*) - (bool -> constr array -> Cinstr.lambda) - option; - vm_constant_dynamic : - (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - (* fastcomputation flag -> cont -> result *) - vm_before_match : (bool -> Cinstr.lambda -> Cinstr.lambda) option; - (* tag (= compiled int for instance) -> result *) - vm_decompile_const : (int -> constr) option; - - native_compiling : - (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> - Nativeinstr.lambda) option; - - native_constant_static : - (bool -> constr array -> Nativeinstr.lambda) option; - - native_constant_dynamic : - (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda array -> Nativeinstr.lambda) option; - - native_before_match : (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda -> Nativeinstr.lambda) option +type retroknowledge = { + retro_int63 : Constant.t option; + retro_bool : (constructor * constructor) option; (* true, false *) + retro_carry : (constructor * constructor) option; (* C0, C1 *) + retro_pair : constructor option; + retro_cmp : (constructor * constructor * constructor) option; + (* Eq, Lt, Gt *) + retro_refl : constructor option; } -val empty_reactive_info : reactive_info +val empty : retroknowledge -(** Hook to be set after the compiler are installed to dispatch fields - into the above [get_*] functions. *) -val dispatch_hook : (retroknowledge -> GlobRef.t -> field -> reactive_info) Hook.t +type action = + | Register_ind of CPrimitives.prim_ind * inductive + | Register_type of CPrimitives.prim_type * Constant.t + | Register_inline of Constant.t diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index df9e253135..dc15d9d25e 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -59,10 +59,10 @@ etc. *) -open CErrors open Util open Names open Declarations +open Constr open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -227,6 +227,7 @@ let check_engagement env expected_impredicative_set = let get_opaque_body env cbo = match cbo.const_body with | Undef _ -> assert false + | Primitive _ -> assert false | Def _ -> `Nothing | OpaqueDef opaque -> `Opaque @@ -311,8 +312,8 @@ let universes_of_private eff = | `Opaque (_, ctx) -> ctx :: acc in match eff.seff_body.const_universes with - | Monomorphic_const ctx -> ctx :: acc - | Polymorphic_const _ -> acc + | Monomorphic ctx -> ctx :: acc + | Polymorphic _ -> acc in List.fold_left fold [] (side_effects_of_private_constants eff) @@ -464,10 +465,10 @@ let labels_of_mib mib = let globalize_constant_universes env cb = match cb.const_universes with - | Monomorphic_const cstrs -> + | Monomorphic cstrs -> Now (false, cstrs) :: (match cb.const_body with - | (Undef _ | Def _) -> [] + | (Undef _ | Def _ | Primitive _) -> [] | OpaqueDef lc -> match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with | None -> [] @@ -475,15 +476,14 @@ let globalize_constant_universes env cb = match Future.peek_val fc with | None -> [Later fc] | Some c -> [Now (false, c)]) - | Polymorphic_const _ -> + | Polymorphic _ -> [Now (true, Univ.ContextSet.empty)] let globalize_mind_universes mb = match mb.mind_universes with - | Monomorphic_ind ctx -> + | Monomorphic ctx -> [Now (false, ctx)] - | Polymorphic_ind _ -> [Now (true, Univ.ContextSet.empty)] - | Cumulative_ind _ -> [Now (true, Univ.ContextSet.empty)] + | Polymorphic _ -> [Now (true, Univ.ContextSet.empty)] let constraints_of_sfb env sfb = match sfb with @@ -492,6 +492,11 @@ let constraints_of_sfb env sfb = | SFBmodtype mtb -> [Now (false, mtb.mod_constraints)] | SFBmodule mb -> [Now (false, mb.mod_constraints)] +let add_retroknowledge pttc senv = + { senv with + env = Primred.add_retroknowledge senv.env pttc; + local_retroknowledge = pttc::senv.local_retroknowledge } + (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -606,13 +611,13 @@ let inline_side_effects env body side_eff = | _ -> assert false in match cb.const_universes with - | Monomorphic_const univs -> + | Monomorphic univs -> (** Abstract over the term at the top of the proof *) let ty = cb.const_type in let subst = Cmap_env.add c (Inr var) subst in let ctx = Univ.ContextSet.union ctx univs in (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) - | Polymorphic_const _ -> + | Polymorphic _ -> (** Inline the term to emulate universe polymorphism *) let subst = Cmap_env.add c (Inl b) subst in (subst, var, ctx, args) @@ -694,10 +699,10 @@ let constant_entry_of_side_effect cb u = let open Entries in let univs = match cb.const_universes with - | Monomorphic_const uctx -> - Monomorphic_const_entry uctx - | Polymorphic_const auctx -> - Polymorphic_const_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) + | Monomorphic uctx -> + Monomorphic_entry uctx + | Polymorphic auctx -> + Polymorphic_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) in let pt = match cb.const_body, u with @@ -750,8 +755,8 @@ let export_side_effects mb env c = let { seff_constant = kn; seff_body = cb ; _ } = eff in let env = Environ.add_constant kn cb env in match cb.const_universes with - | Polymorphic_const _ -> env - | Monomorphic_const ctx -> + | Polymorphic _ -> env + | Monomorphic ctx -> let ctx = match eff.seff_env with | `Nothing -> ctx | `Opaque(_, ctx') -> Univ.ContextSet.union ctx' ctx @@ -809,6 +814,13 @@ let add_constant ~in_section l decl senv = let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in if in_section then cb else Declareops.hcons_const_body cb in add_constant_aux ~in_section senv (kn, cb) in + let senv = + match decl with + | ConstantEntry (_,(Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ })) -> + if in_section then CErrors.anomaly (Pp.str "Primitive type not allowed in sections"); + add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv + | _ -> senv + in kn, senv (** Insertion of inductive types *) @@ -1101,7 +1113,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 -> @@ -1123,7 +1135,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 @@ -1173,18 +1185,6 @@ let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) -let register field value senv = - (* todo : value closed *) - (* spiwack : updates the safe_env with the information that the register - action has to be performed (again) when the environment is imported *) - { senv with - env = Environ.register senv.env field value; - local_retroknowledge = - Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge - } - -(* This function serves only for inlining constants in native compiler for now, -but it is meant to become a replacement for environ.register *) let register_inline kn senv = let open Environ in if not (evaluable_constant kn senv.env) then @@ -1194,6 +1194,80 @@ let register_inline kn senv = let cb = {cb with const_inline_code = true} in let env = add_constant kn cb env in { senv with env} +let check_register_ind (mind,i) r env = + let mb = Environ.lookup_mind mind env in + let check_if b s = + if not b then + CErrors.user_err ~hdr:"check_register_ind" (Pp.str s) in + check_if (Int.equal (Array.length mb.mind_packets) 1) "A non mutual inductive is expected"; + let ob = mb.mind_packets.(i) in + let check_nconstr n = + check_if (Int.equal (Array.length ob.mind_consnames) n) + ("an inductive type with "^(string_of_int n)^" constructors is expected") + in + let check_name pos s = + check_if (Id.equal ob.mind_consnames.(pos) (Id.of_string s)) + ("the "^(string_of_int (pos + 1))^ + "th constructor does not have the expected name: " ^ s) in + let check_type pos t = + check_if (Constr.equal t ob.mind_user_lc.(pos)) + ("the "^(string_of_int (pos + 1))^ + "th constructor does not have the expected type") in + let check_type_cte pos = check_type pos (Constr.mkRel 1) in + match r with + | CPrimitives.PIT_bool -> + check_nconstr 2; + check_name 0 "true"; + check_type_cte 0; + check_name 1 "false"; + check_type_cte 1 + | CPrimitives.PIT_carry -> + check_nconstr 2; + let test_type pos = + let c = ob.mind_user_lc.(pos) in + let s = "the "^(string_of_int (pos + 1))^ + "th constructor does not have the expected type" in + check_if (Constr.isProd c) s; + let (_,d,cd) = Constr.destProd c in + check_if (Constr.is_Type d) s; + check_if + (Constr.equal + (mkProd (Anonymous,mkRel 1, mkApp (mkRel 3,[|mkRel 2|]))) + cd) + s in + check_name 0 "C0"; + test_type 0; + check_name 1 "C1"; + test_type 1; + | CPrimitives.PIT_pair -> + check_nconstr 1; + check_name 0 "pair"; + let c = ob.mind_user_lc.(0) in + let s = "the "^(string_of_int 1)^ + "th constructor does not have the expected type" in + begin match Term.decompose_prod c with + | ([_,b;_,a;_,_B;_,_A], codom) -> + check_if (is_Type _A) s; + check_if (is_Type _B) s; + check_if (Constr.equal a (mkRel 2)) s; + check_if (Constr.equal b (mkRel 2)) s; + check_if (Constr.equal codom (mkApp (mkRel 5,[|mkRel 4; mkRel 3|]))) s + | _ -> check_if false s + end + | CPrimitives.PIT_cmp -> + check_nconstr 3; + check_name 0 "Eq"; + check_type_cte 0; + check_name 1 "Lt"; + check_type_cte 1; + check_name 2 "Gt"; + check_type_cte 2 + +let register_inductive ind prim senv = + check_register_ind ind prim senv.env; + let action = Retroknowledge.Register_ind(prim,ind) in + add_retroknowledge action senv + let add_constraints c = add_constraints (Now (false, Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) @@ -1222,125 +1296,3 @@ Would this be correct with respect to undo's and stuff ? let set_strategy k l e = { e with env = (Environ.set_oracle e.env (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) } - -(** Register retroknowledge hooks *) - -open Retroknowledge - -(* the Environ.register function synchronizes the proactive and reactive - retroknowledge. *) -let dispatch = - - (* subfunction used for static decompilation of int31 (after a vm_compute, - see pretyping/vnorm.ml for more information) *) - let constr_of_int31 = - let nth_digit_plus_one i n = (* calculates the nth (starting with 0) - digit of i and adds 1 to it - (nth_digit_plus_one 1 3 = 2) *) - if Int.equal (i land (1 lsl n)) 0 then - 1 - else - 2 - in - fun ind -> fun digit_ind -> fun tag -> - let array_of_int i = - Array.init 31 (fun n -> Constr.mkConstruct - (digit_ind, nth_digit_plus_one i (30-n))) - in - (* We check that no bit above 31 is set to one. This assertion used to - fail in the VM, and led to conversion tests failing at Qed. *) - assert (Int.equal (tag lsr 31) 0); - Constr.mkApp(Constr.mkConstruct(ind, 1), array_of_int tag) - in - - (* subfunction which dispatches the compiling information of an - int31 operation which has a specific vm instruction (associates - it to the name of the coq definition in the reactive retroknowledge) *) - let int31_op n op prim kn = - { empty_reactive_info with - vm_compiling = Some (Clambda.compile_prim n op (kn, Univ.Instance.empty)); (*XXX: FIXME universes? *) - native_compiling = Some (Nativelambda.compile_prim prim kn); - } - in - -fun rk value field -> - (* subfunction which shortens the (very common) dispatch of operations *) - let int31_op_from_const n op prim = - match value with - | GlobRef.ConstRef kn -> int31_op n op prim kn - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") - in - let int31_binop_from_const op prim = int31_op_from_const 2 op prim in - let int31_unop_from_const op prim = int31_op_from_const 1 op prim in - match field with - | KInt31 Int31Type -> - let int31bit = - (* invariant : the type of bits is registered, otherwise the function - would raise Not_found. The invariant is enforced in safe_typing.ml *) - match field with - | KInt31 Int31Type -> Retroknowledge.find rk (KInt31 Int31Bits) - | _ -> anomaly ~label:"Environ.register" - (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") - in - let i31bit_type = - match int31bit with - | GlobRef.IndRef i31bit_type -> i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "Int31Bits should be an inductive type.") - in - let int31_decompilation = - match value with - | GlobRef.IndRef i31t -> - constr_of_int31 i31t i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "should be an inductive type.") - in - { empty_reactive_info with - vm_decompile_const = Some int31_decompilation; - vm_before_match = Some Clambda.int31_escape_before_match; - native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); - } - | KInt31 Int31Constructor -> - { empty_reactive_info with - vm_constant_static = Some Clambda.compile_structured_int31; - vm_constant_dynamic = Some Clambda.dynamic_int31_compilation; - native_constant_static = Some Nativelambda.compile_static_int31; - native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; - } - | KInt31 Int31Plus -> int31_binop_from_const Cbytecodes.Kaddint31 - CPrimitives.Int31add - | KInt31 Int31PlusC -> int31_binop_from_const Cbytecodes.Kaddcint31 - CPrimitives.Int31addc - | KInt31 Int31PlusCarryC -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 - CPrimitives.Int31addcarryc - | KInt31 Int31Minus -> int31_binop_from_const Cbytecodes.Ksubint31 - CPrimitives.Int31sub - | KInt31 Int31MinusC -> int31_binop_from_const Cbytecodes.Ksubcint31 - CPrimitives.Int31subc - | KInt31 Int31MinusCarryC -> int31_binop_from_const - Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc - | KInt31 Int31Times -> int31_binop_from_const Cbytecodes.Kmulint31 - CPrimitives.Int31mul - | KInt31 Int31TimesC -> int31_binop_from_const Cbytecodes.Kmulcint31 - CPrimitives.Int31mulc - | KInt31 Int31Div21 -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 - CPrimitives.Int31div21 - | KInt31 Int31Diveucl -> int31_binop_from_const Cbytecodes.Kdivint31 - CPrimitives.Int31diveucl - | KInt31 Int31AddMulDiv -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 - CPrimitives.Int31addmuldiv - | KInt31 Int31Compare -> int31_binop_from_const Cbytecodes.Kcompareint31 - CPrimitives.Int31compare - | KInt31 Int31Head0 -> int31_unop_from_const Cbytecodes.Khead0int31 - CPrimitives.Int31head0 - | KInt31 Int31Tail0 -> int31_unop_from_const Cbytecodes.Ktail0int31 - CPrimitives.Int31tail0 - | KInt31 Int31Lor -> int31_binop_from_const Cbytecodes.Klorint31 - CPrimitives.Int31lor - | KInt31 Int31Land -> int31_binop_from_const Cbytecodes.Klandint31 - CPrimitives.Int31land - | KInt31 Int31Lxor -> int31_binop_from_const Cbytecodes.Klxorint31 - CPrimitives.Int31lxor - | _ -> empty_reactive_info - -let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 57b01f15e3..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 @@ -217,12 +217,8 @@ val mind_of_delta_kn_senv : safe_environment -> KerName.t -> MutInd.t (** {6 Retroknowledge / Native compiler } *) -open Retroknowledge - -val register : - field -> GlobRef.t -> safe_transformer0 - val register_inline : Constant.t -> safe_transformer0 +val register_inductive : inductive -> CPrimitives.prim_ind -> safe_transformer0 val set_strategy : Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_transformer0 diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 347c30dd64..dea72e8b59 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -92,11 +92,25 @@ let check_conv_error error why cst poly f env a1 a2 = with NotConvertible -> error why | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) -let check_polymorphic_instance error env auctx1 auctx2 = - if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then - error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) - else - Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env +let check_universes error env u1 u2 = + match u1, u2 with + | Monomorphic _, Monomorphic _ -> env + | Polymorphic auctx1, Polymorphic auctx2 -> + if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) + else + Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env + | Monomorphic _, Polymorphic _ -> error (PolymorphicStatusExpected true) + | Polymorphic _, Monomorphic _ -> error (PolymorphicStatusExpected false) + +let check_variance error v1 v2 = + match v1, v2 with + | None, None -> () + | Some v1, Some v2 -> + if not (Array.for_all2 Variance.check_subtype v2 v1) then + error IncompatibleVariance + | None, Some _ -> error (CumulativeStatusExpected true) + | Some _, None -> error (CumulativeStatusExpected false) (* for now we do not allow reorderings *) @@ -110,29 +124,9 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let env, inst = - match mib1.mind_universes, mib2.mind_universes with - | Monomorphic_ind _, Monomorphic_ind _ -> env, Univ.Instance.empty - | Polymorphic_ind auctx, Polymorphic_ind auctx' -> - let env = check_polymorphic_instance error env auctx auctx' in - env, Univ.make_abstract_instance auctx' - | Cumulative_ind cumi, Cumulative_ind cumi' -> - (** Currently there is no way to control variance of inductive types, but - just in case we require that they are in a subtyping relation. *) - let () = - let v = ACumulativityInfo.variance cumi in - let v' = ACumulativityInfo.variance cumi' in - if not (Array.for_all2 Variance.check_subtype v' v) then - CErrors.anomaly Pp.(str "Variance of " ++ KerName.print kn1 ++ - str " is not compatible with the one of " ++ KerName.print kn2) - in - let auctx = Univ.ACumulativityInfo.univ_context cumi in - let auctx' = Univ.ACumulativityInfo.univ_context cumi' in - let env = check_polymorphic_instance error env auctx auctx' in - env, Univ.make_abstract_instance auctx' - | _ -> error - (CumulativeStatusExpected (Declareops.inductive_is_cumulative mib2)) - in + let env = check_universes error env mib1.mind_universes mib2.mind_universes in + let () = check_variance error mib1.mind_variance mib2.mind_variance in + let inst = make_abstract_instance (Declareops.inductive_polymorphic_context mib1) in let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name t1 t2 = check_conv (NotConvertibleInductiveField name) @@ -235,17 +229,8 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking universes *) - let poly, env = - match cb1.const_universes, cb2.const_universes with - | Monomorphic_const _, Monomorphic_const _ -> - false, env - | Polymorphic_const auctx1, Polymorphic_const auctx2 -> - true, check_polymorphic_instance error env auctx1 auctx2 - | Monomorphic_const _, Polymorphic_const _ -> - error (PolymorphicStatusExpected true) - | Polymorphic_const _, Monomorphic_const _ -> - error (PolymorphicStatusExpected false) - in + let env = check_universes error env cb1.const_universes cb2.const_universes in + let poly = Declareops.constant_is_polymorphic cb1 in (* Now check types *) let typ1 = cb1.const_type in let typ2 = cb2.const_type in @@ -257,10 +242,10 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with - | Undef _ | OpaqueDef _ -> cst + | Primitive _ | Undef _ | OpaqueDef _ -> cst | Def lc2 -> (match cb1.const_body with - | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField + | Primitive _ | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField | Def lc1 -> (* NB: cb1 might have been strengthened and appear as transparent. Anyway [check_conv] will handle that afterwards. *) diff --git a/kernel/term.ml b/kernel/term.ml index 795cdeb040..58b289eaa5 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -379,4 +379,4 @@ let kind_of_type t = match kind t with | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) - | (Lambda _ | Construct _) -> failwith "Not a type" + | (Lambda _ | Construct _ | Int _) -> failwith "Not a type" diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f9fdbdd68e..929f1c13a3 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -65,23 +65,15 @@ let feedback_completion_typecheck = Option.iter (fun state_id -> Feedback.feedback ~id:state_id Feedback.Complete) -let abstract_constant_universes = function - | Monomorphic_const_entry uctx -> - Univ.empty_level_subst, Monomorphic_const uctx - | Polymorphic_const_entry (nas, uctx) -> - let sbst, auctx = Univ.abstract_universes nas uctx in - let sbst = Univ.make_instance_subst sbst in - sbst, Polymorphic_const auctx - let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = match dcl with | ParameterEntry (ctx,(t,uctx),nl) -> let env = match uctx with - | Monomorphic_const_entry uctx -> push_context_set ~strict:true uctx env - | Polymorphic_const_entry (_, uctx) -> push_context ~strict:false uctx env + | Monomorphic_entry uctx -> push_context_set ~strict:true uctx env + | Polymorphic_entry (_, uctx) -> push_context ~strict:false uctx env in let j = infer env t in - let usubst, univs = abstract_constant_universes uctx in + let usubst, univs = Declareops.abstract_universes uctx in let c = Typeops.assumption_of_judgment env j in let t = Constr.hcons (Vars.subst_univs_level_constr usubst c) in { @@ -93,13 +85,48 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_context = ctx; } + (** Primitives cannot be universe polymorphic *) + | PrimitiveEntry ({ prim_entry_type = otyp; + prim_entry_univs = uctxt; + prim_entry_content = op_t; + }) -> + let env = push_context_set ~strict:true uctxt env in + let ty = match otyp with + | Some typ -> + let tyj = infer_type env typ in + check_primitive_type env op_t tyj.utj_val; + Constr.hcons tyj.utj_val + | None -> + match op_t with + | CPrimitives.OT_op op -> type_of_prim env op + | CPrimitives.OT_type _ -> mkSet + in + let cd = + match op_t with + | CPrimitives.OT_op op -> Declarations.Primitive op + | CPrimitives.OT_type _ -> Undef None in + { Cooking.cook_body = cd; + cook_type = ty; + cook_universes = Monomorphic uctxt; + cook_private_univs = None; + cook_inline = false; + cook_context = None + } + (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, so we delay the typing and hash consing of its body. Remark: when the universe quantification is given explicitly, we could delay even in the polymorphic case. *) + +(** Definition is opaque (Qed) and non polymorphic with known type, so we delay +the typing and hash consing of its body. + +TODO: if the universe quantification is given explicitly, we could delay even in +the polymorphic case + *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; - const_entry_universes = Monomorphic_const_entry univs; _ } as c) -> + const_entry_universes = Monomorphic_entry univs; _ } as c) -> let env = push_context_set ~strict:true univs env in let { const_entry_body = body; const_entry_feedback = feedback_id ; _ } = c in let tyj = infer_type env typ in @@ -130,7 +157,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = { Cooking.cook_body = def; cook_type = typ; - cook_universes = Monomorphic_const univs; + cook_universes = Monomorphic univs; cook_private_univs = None; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; @@ -148,11 +175,11 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = body, Univ.ContextSet.union ctx ctx' in let env, usubst, univs, private_univs = match c.const_entry_universes with - | Monomorphic_const_entry univs -> + | Monomorphic_entry univs -> let ctx = Univ.ContextSet.union univs ctx in let env = push_context_set ~strict:true ctx env in - env, Univ.empty_level_subst, Monomorphic_const ctx, None - | Polymorphic_const_entry (nas, uctx) -> + env, Univ.empty_level_subst, Monomorphic ctx, None + | Polymorphic_entry (nas, uctx) -> (** [ctx] must contain local universes, such that it has no impact on the rest of the graph (up to transitivity). *) let env = push_context ~strict:false uctx env in @@ -165,7 +192,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = if Univ.ContextSet.is_empty ctx then env, None else CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition.") in - env, sbst, Polymorphic_const auctx, local + env, sbst, Polymorphic auctx, local in let j = infer env body in let typ = match typ with @@ -238,7 +265,7 @@ let build_constant_declaration _kn env result = we must look at the body NOW, if any *) let ids_typ = global_vars_set env typ in let ids_def = match def with - | Undef _ -> Id.Set.empty + | Undef _ | Primitive _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = @@ -258,7 +285,7 @@ let build_constant_declaration _kn env result = (* We use the declared set and chain a check of correctness *) sort declared, match def with - | Undef _ as x -> x (* nothing to check *) + | Undef _ | Primitive _ as x -> x (* nothing to check *) | Def cs as x -> let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in @@ -307,7 +334,7 @@ let translate_local_def env _id centry = const_entry_secctx = centry.secdef_secctx; const_entry_feedback = centry.secdef_feedback; const_entry_type = centry.secdef_type; - const_entry_universes = Monomorphic_const_entry Univ.ContextSet.empty; + const_entry_universes = Monomorphic_entry Univ.ContextSet.empty; const_entry_opaque = false; const_entry_inline_code = false; } in @@ -316,6 +343,7 @@ let translate_local_def env _id centry = if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin match decl.cook_body with | Undef _ -> () + | Primitive _ -> () | Def _ -> () | OpaqueDef lc -> let ids_typ = global_vars_set env typ in @@ -324,8 +352,8 @@ let translate_local_def env _id centry = record_aux env ids_typ ids_def end; let () = match decl.cook_universes with - | Monomorphic_const ctx -> assert (Univ.ContextSet.is_empty ctx) - | Polymorphic_const _ -> assert false + | Monomorphic ctx -> assert (Univ.ContextSet.is_empty ctx) + | Polymorphic _ -> assert false in let c = match decl.cook_body with | Def c -> Mod_subst.force_constr c @@ -336,7 +364,7 @@ let translate_local_def env _id centry = the body by virtue of the typing of [Entries.section_def_entry]. *) let () = assert (Univ.ContextSet.is_empty cst) in p - | Undef _ -> assert false + | Undef _ | Primitive _ -> assert false in c, typ diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index fd050085d7..964d32c6b3 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -144,3 +144,43 @@ let error_unsatisfied_constraints env c = let error_undeclared_universe env l = raise (TypeError (env, UndeclaredUniverse l)) + +let map_pguard_error f = function +| NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody +| RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) +| RecursionOnIllegalTerm (n, (env, c), l1, l2) -> RecursionOnIllegalTerm (n, (env, f c), l1, l2) +| NotEnoughArgumentsForFixCall n -> NotEnoughArgumentsForFixCall n +| CodomainNotInductiveType c -> CodomainNotInductiveType (f c) +| NestedRecursiveOccurrences -> NestedRecursiveOccurrences +| UnguardedRecursiveCall c -> UnguardedRecursiveCall (f c) +| RecCallInTypeOfAbstraction c -> RecCallInTypeOfAbstraction (f c) +| RecCallInNonRecArgOfConstructor c -> RecCallInNonRecArgOfConstructor (f c) +| RecCallInTypeOfDef c -> RecCallInTypeOfDef (f c) +| RecCallInCaseFun c -> RecCallInCaseFun (f c) +| RecCallInCaseArg c -> RecCallInCaseArg (f c) +| RecCallInCasePred c -> RecCallInCasePred (f c) +| NotGuardedForm c -> NotGuardedForm (f c) +| ReturnPredicateNotCoInductive c -> ReturnPredicateNotCoInductive (f c) + +let map_ptype_error f = function +| UnboundRel n -> UnboundRel n +| UnboundVar id -> UnboundVar id +| NotAType j -> NotAType (on_judgment f j) +| BadAssumption j -> BadAssumption (on_judgment f j) +| ReferenceVariables (id, c) -> ReferenceVariables (id, f c) +| ElimArity (pi, dl, c, j, ar) -> ElimArity (pi, dl, f c, on_judgment f j, ar) +| CaseNotInductive j -> CaseNotInductive (on_judgment f j) +| WrongCaseInfo (pi, ci) -> WrongCaseInfo (pi, ci) +| NumberBranches (j, n) -> NumberBranches (on_judgment f j, n) +| IllFormedBranch (c, pc, t1, t2) -> IllFormedBranch (f c, pc, f t1, f t2) +| Generalization ((na, t), j) -> Generalization ((na, f t), on_judgment f j) +| ActualType (j, t) -> ActualType (on_judgment f j, f t) +| CantApplyBadType ((n, c1, c2), j, vj) -> + CantApplyBadType ((n, f c1, f c2), on_judgment f j, Array.map (on_judgment f) vj) +| CantApplyNonFunctional (j, jv) -> CantApplyNonFunctional (on_judgment f j, Array.map (on_judgment f) jv) +| IllFormedRecBody (ge, na, n, env, jv) -> + IllFormedRecBody (map_pguard_error f ge, na, n, env, Array.map (on_judgment f) jv) +| IllTypedRecBody (n, na, jv, t) -> + IllTypedRecBody (n, na, Array.map (on_judgment f) jv, Array.map f t) +| UnsatisfiedConstraints g -> UnsatisfiedConstraints g +| UndeclaredUniverse l -> UndeclaredUniverse l diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 3e954d6a8e..4b832930e1 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -130,3 +130,6 @@ val error_elim_explain : Sorts.family -> Sorts.family -> arity_error val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a val error_undeclared_universe : env -> Univ.Level.t -> 'a + +val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error +val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error diff --git a/kernel/typeops.ml b/kernel/typeops.ml index c9acd168e8..7eb8e803b3 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -12,7 +12,7 @@ open CErrors open Util open Names open Univ -open Sorts +open Term open Constr open Vars open Declarations @@ -187,6 +187,74 @@ let type_of_apply env func funt argsv argstv = in apply_rec 0 (inject funt) +(* Type of primitive constructs *) +let type_of_prim_type _env = function + | CPrimitives.PT_int63 -> Constr.mkSet + +let type_of_int env = + match env.retroknowledge.Retroknowledge.retro_int63 with + | Some c -> mkConst c + | None -> CErrors.user_err Pp.(str"The type int must be registered before this construction can be typechecked.") + +let type_of_prim env t = + let int_ty = type_of_int env in + let bool_ty () = + match env.retroknowledge.Retroknowledge.retro_bool with + | Some ((ind,_),_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type bool must be registered before this primitive.") + in + let compare_ty () = + match env.retroknowledge.Retroknowledge.retro_cmp with + | Some ((ind,_),_,_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type compare must be registered before this primitive.") + in + let pair_ty fst_ty snd_ty = + match env.retroknowledge.Retroknowledge.retro_pair with + | Some (ind,_) -> Constr.mkApp(Constr.mkInd ind, [|fst_ty;snd_ty|]) + | None -> CErrors.user_err Pp.(str"The type pair must be registered before this primitive.") + in + let carry_ty int_ty = + match env.retroknowledge.Retroknowledge.retro_carry with + | Some ((ind,_),_) -> Constr.mkApp(Constr.mkInd ind, [|int_ty|]) + | None -> CErrors.user_err Pp.(str"The type carry must be registered before this primitive.") + in + let rec nary_int63_op arity ty = + if Int.equal arity 0 then ty + else Constr.mkProd(Name (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) + in + let return_ty = + let open CPrimitives in + match t with + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addMulDiv -> int_ty + | Int63eq + | Int63lt + | Int63le -> bool_ty () + | Int63mulc + | Int63div21 + | Int63diveucl -> pair_ty int_ty int_ty + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC -> carry_ty int_ty + | Int63compare -> compare_ty () + in + nary_int63_op (CPrimitives.arity t) return_ty + +let judge_of_int env i = + make_judge (Constr.mkInt i) (type_of_int env) + (* Type of product *) let sort_of_product env domsort rangsort = @@ -468,6 +536,9 @@ let rec execute env cstr = let (fix_ty,recdef') = execute_recdef env recdef i in let cofix = (i,recdef') in check_cofix env cofix; fix_ty + + (* Primitive types *) + | Int _ -> type_of_int env (* Partial proofs: unsupported by the kernel *) | Meta _ -> @@ -590,3 +661,20 @@ let judge_of_case env ci pj cj lfj = let lf, lft = dest_judgev lfj in make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft) + +(* Building type of primitive operators and type *) + +open CPrimitives + +let check_primitive_type env op_t t = + match op_t with + | OT_type PT_int63 -> + (try + default_conv ~l2r:false CUMUL env mkSet t + with NotConvertible -> + CErrors.user_err Pp.(str"Was expecting the sort of this primitive type to be Set")) + | OT_op p -> + (try + default_conv ~l2r:false CUMUL env (type_of_prim env p) t + with NotConvertible -> + CErrors.user_err Pp.(str"Not the expected type for this primitive")) diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 4193324136..52c261c5e8 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -118,3 +118,13 @@ val constr_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t (** Check that hyps are included in env and fails with error otherwise *) val check_hyps_inclusion : env -> ?evars:((existential->constr option) * UGraph.t) -> ('a -> constr) -> 'a -> Constr.named_context -> unit + +val check_primitive_type : env -> CPrimitives.op_or_type -> types -> unit + +(** Types for primitives *) + +val type_of_int : env -> types +val judge_of_int : env -> Uint63.t -> unsafe_judgment + +val type_of_prim_type : env -> CPrimitives.prim_type -> types +val type_of_prim : env -> CPrimitives.t -> types diff --git a/kernel/uint31.ml b/kernel/uint31.ml deleted file mode 100644 index d9c723c243..0000000000 --- a/kernel/uint31.ml +++ /dev/null @@ -1,153 +0,0 @@ - (* Invariant: For arch64 all extra bytes are set to 0 *) -type t = int - - (* to be used only on 32 bits architectures *) -let maxuint31 = Int32.of_string "0x7FFFFFFF" -let uint_32 i = Int32.logand (Int32.of_int i) maxuint31 - -let select f32 f64 = if Sys.word_size = 64 then f64 else f32 - - (* conversion to an int *) -let to_int i = i - -let of_int_32 i = i -let of_int_64 i = i land 0x7FFFFFFF - -let of_int = select of_int_32 of_int_64 -let of_uint i = i - - (* conversion of an uint31 to a string *) -let to_string_32 i = Int32.to_string (uint_32 i) -let to_string_64 = string_of_int - -let to_string = select to_string_32 to_string_64 -let of_string s = - let i32 = Int32.of_string s in - if Int32.compare Int32.zero i32 <= 0 - && Int32.compare i32 maxuint31 <= 0 - then Int32.to_int i32 - else raise (Failure "int_of_string") - - - - (* logical shift *) -let l_sl x y = - of_int (if 0 <= y && y < 31 then x lsl y else 0) - -let l_sr x y = - if 0 <= y && y < 31 then x lsr y else 0 - -let l_and x y = x land y -let l_or x y = x lor y -let l_xor x y = x lxor y - - (* addition of int31 *) -let add x y = of_int (x + y) - - (* subtraction *) -let sub x y = of_int (x - y) - - (* multiplication *) -let mul x y = of_int (x * y) - - (* exact multiplication *) -let mulc_32 x y = - let x = Int64.of_int32 (uint_32 x) in - let y = Int64.of_int32 (uint_32 y) in - let m = Int64.mul x y in - let l = Int64.to_int m in - let h = Int64.to_int (Int64.shift_right_logical m 31) in - h,l - -let mulc_64 x y = - let m = x * y in - let l = of_int_64 m in - let h = of_int_64 (m lsr 31) in - h, l -let mulc = select mulc_32 mulc_64 - - (* division *) -let div_32 x y = - if y = 0 then 0 else - Int32.to_int (Int32.div (uint_32 x) (uint_32 y)) -let div_64 x y = if y = 0 then 0 else x / y -let div = select div_32 div_64 - - (* modulo *) -let rem_32 x y = - if y = 0 then 0 - else Int32.to_int (Int32.rem (uint_32 x) (uint_32 y)) -let rem_64 x y = if y = 0 then 0 else x mod y -let rem = select rem_32 rem_64 - - (* division of two numbers by one *) -let div21_32 xh xl y = - if y = 0 then (0,0) - else - let x = - Int64.logor - (Int64.shift_left (Int64.of_int32 (uint_32 xh)) 31) - (Int64.of_int32 (uint_32 xl)) in - let y = Int64.of_int32 (uint_32 y) in - let q = Int64.div x y in - let r = Int64.rem x y in - Int64.to_int q, Int64.to_int r -let div21_64 xh xl y = - if y = 0 then (0,0) - else - let x = (xh lsl 31) lor xl in - let q = x / y in - let r = x mod y in - q, r -let div21 = select div21_32 div21_64 - - (* comparison *) -let lt_32 x y = (x lxor 0x40000000) < (y lxor 0x40000000) - -(* Do not remove the type information it is really important for - efficiency *) -let lt_64 (x:int) (y:int) = x < y -let lt = select lt_32 lt_64 - -let le_32 x y = - (x lxor 0x40000000) <= (y lxor 0x40000000) - -(* Do not remove the type information it is really important for - efficiency *) -let le_64 (x:int) (y:int) = x <= y -let le = select le_32 le_64 - -let equal (x:int) (y:int) = x == y - -let cmp_32 x y = Int32.compare (uint_32 x) (uint_32 y) -(* Do not remove the type information it is really important for - efficiency *) -let cmp_64 (x:int) (y:int) = compare x y -let compare = select cmp_32 cmp_64 - - (* head tail *) - -let head0 x = - let r = ref 0 in - let x = ref x in - if !x land 0x7FFF0000 = 0 then r := !r + 15 - else x := !x lsr 15; - if !x land 0xFF00 = 0 then (x := !x lsl 8; r := !r + 8); - if !x land 0xF000 = 0 then (x := !x lsl 4; r := !r + 4); - if !x land 0xC000 = 0 then (x := !x lsl 2; r := !r + 2); - if !x land 0x8000 = 0 then (x := !x lsl 1; r := !r + 1); - if !x land 0x8000 = 0 then ( r := !r + 1); - !r;; - -let tail0 x = - let r = ref 0 in - let x = ref x in - if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16); - if !x land 0xFF = 0 then (x := !x lsr 8; r := !r + 8); - if !x land 0xF = 0 then (x := !x lsr 4; r := !r + 4); - if !x land 0x3 = 0 then (x := !x lsr 2; r := !r + 2); - if !x land 0x1 = 0 then ( r := !r + 1); - !r - -let add_digit x d = - (x lsl 1) lor d diff --git a/kernel/uint31.mli b/kernel/uint63.mli index d1f933cc4e..b5f40ca804 100644 --- a/kernel/uint31.mli +++ b/kernel/uint63.mli @@ -1,14 +1,28 @@ type t +val uint_size : int +val maxuint31 : t + (* conversion to int *) -val to_int : t -> int val of_int : int -> t +val to_int2 : t -> int * int (* msb, lsb *) +val of_int64 : Int64.t -> t +(* val of_uint : int -> t +*) + +val hash : t -> int - (* conversion to a string *) + (* convertion to a string *) val to_string : t -> string val of_string : string -> t +val compile : t -> string + +(* constants *) +val zero : t +val one : t + (* logical operations *) val l_sl : t -> t -> t val l_sr : t -> t -> t @@ -16,20 +30,21 @@ val l_and : t -> t -> t val l_xor : t -> t -> t val l_or : t -> t -> t - (* Arithmetic operations *) + (* Arithmetic operations *) val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t - + (* Specific arithmetic operations *) val mulc : t -> t -> t * t +val addmuldiv : t -> t -> t -> t val div21 : t -> t -> t -> t * t - + (* comparison *) val lt : t -> t -> bool -val equal : t -> t -> bool +val equal : t -> t -> bool val le : t -> t -> bool val compare : t -> t -> int @@ -37,5 +52,4 @@ val compare : t -> t -> int val head0 : t -> t val tail0 : t -> t -(** Used by retroknowledge *) -val add_digit : t -> t -> t +val is_uint63 : Obj.t -> bool diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64.ml new file mode 100644 index 0000000000..010b594de8 --- /dev/null +++ b/kernel/uint63_amd64.ml @@ -0,0 +1,215 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type t = int + +let _ = assert (Sys.word_size = 64) + +let uint_size = 63 + +let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF" +let maxuint31 = 0x7FFFFFFF + + (* conversion from an int *) +let to_uint64 i = Int64.logand (Int64.of_int i) maxuint63 + +let of_int i = i +[@@ocaml.inline always] + +let to_int2 i = (0,i) + +let of_int64 _i = assert false + +let hash i = i +[@@ocaml.inline always] + + (* conversion of an uint63 to a string *) +let to_string i = Int64.to_string (to_uint64 i) + +let of_string s = + let i64 = Int64.of_string s in + if Int64.compare Int64.zero i64 <= 0 + && Int64.compare i64 maxuint63 <= 0 + then Int64.to_int i64 + else raise (Failure "Int64.of_string") + +(* Compiles an unsigned int to OCaml code *) +let compile i = Printf.sprintf "Uint63.of_int (%i)" i + +let zero = 0 +let one = 1 + + (* logical shift *) +let l_sl x y = + if 0 <= y && y < 63 then x lsl y else 0 + +let l_sr x y = + if 0 <= y && y < 63 then x lsr y else 0 + +let l_and x y = x land y +[@@ocaml.inline always] + +let l_or x y = x lor y +[@@ocaml.inline always] + +let l_xor x y = x lxor y +[@@ocaml.inline always] + + (* addition of int63 *) +let add x y = x + y +[@@ocaml.inline always] + + (* subtraction *) +let sub x y = x - y +[@@ocaml.inline always] + + (* multiplication *) +let mul x y = x * y +[@@ocaml.inline always] + + (* division *) +let div (x : int) (y : int) = + if y = 0 then 0 else Int64.to_int (Int64.div (to_uint64 x) (to_uint64 y)) + + (* modulo *) +let rem (x : int) (y : int) = + if y = 0 then 0 else Int64.to_int (Int64.rem (to_uint64 x) (to_uint64 y)) + +let addmuldiv p x y = + l_or (l_sl x p) (l_sr y (uint_size - p)) + + (* comparison *) +let lt (x : int) (y : int) = + (x lxor 0x4000000000000000) < (y lxor 0x4000000000000000) +[@@ocaml.inline always] + +let le (x : int) (y : int) = + (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) +[@@ocaml.inline always] + +(* A few helper functions on 128 bits *) +let lt128 xh xl yh yl = + lt xh yh || (xh = yh && lt xl yl) + +let le128 xh xl yh yl = + lt xh yh || (xh = yh && le xl yl) + + (* division of two numbers by one *) +let div21 xh xl y = + let maskh = ref 0 in + let maskl = ref 1 in + let dh = ref 0 in + let dl = ref y in + let cmp = ref true in + while !dh >= 0 && !cmp do + cmp := lt128 !dh !dl xh xl; + (* We don't use addmuldiv below to avoid checks on 1 *) + dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); + dl := !dl lsl 1; + maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); + maskl := !maskl lsl 1 + done; (* mask = 2^N, d = 2^N * d, d >= x *) + let remh = ref xh in + let reml = ref xl in + let quotient = ref 0 in + while !maskh lor !maskl <> 0 do + if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) + quotient := !quotient lor !maskl; + remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; + reml := !reml - !dl; + end; + maskl := (!maskl lsr 1) lor (!maskh lsl (uint_size - 1)); + maskh := !maskh lsr 1; + dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); + dh := !dh lsr 1; + done; + !quotient, !reml + + (* exact multiplication *) +(* TODO: check that none of these additions could be a logical or *) + + +(* size = 32 + 31 + (hx << 31 + lx) * (hy << 31 + ly) = + hxhy << 62 + (hxly + lxhy) << 31 + lxly +*) + +(* precondition : (x lsr 62 = 0 || y lsr 62 = 0) *) +let mulc_aux x y = + let lx = x land maxuint31 in + let ly = y land maxuint31 in + let hx = x lsr 31 in + let hy = y lsr 31 in + (* hx and hy are 32 bits value but at most one is 32 *) + let hxy = hx * hy in (* 63 bits *) + let hxly = hx * ly in (* 63 bits *) + let lxhy = lx * hy in (* 63 bits *) + let lxy = lx * ly in (* 62 bits *) + let l = lxy lor (hxy lsl 62) (* 63 bits *) in + let h = hxy lsr 1 in (* 62 bits *) + let hl = hxly + lxhy in (* We can have a carry *) + let h = if lt hl hxly then h + (1 lsl 31) else h in + let hl'= hl lsl 31 in + let l = l + hl' in + let h = if lt l hl' then h + 1 else h in + let h = h + (hl lsr 32) in + (h,l) + +let mulc x y = + if (x lsr 62 = 0 || y lsr 62 = 0) then mulc_aux x y + else + let yl = y lxor (1 lsl 62) in + let (h,l) = mulc_aux x yl in + (* h << 63 + l = x * yl + x * y = x * (1 << 62 + yl) = + x << 62 + x*yl = x << 62 + h << 63 + l *) + let l' = l + (x lsl 62) in + let h = if lt l' l then h + 1 else h in + (h + (x lsr 1), l') + +let equal (x : int) (y : int) = x = y +[@@ocaml.inline always] + +let compare (x:int) (y:int) = + let x = x lxor 0x4000000000000000 in + let y = y lxor 0x4000000000000000 in + if x > y then 1 + else if y > x then -1 + else 0 + + (* head tail *) + +let head0 x = + let r = ref 0 in + let x = ref x in + if !x land 0x7FFFFFFF00000000 = 0 then r := !r + 31 + else x := !x lsr 31; + if !x land 0xFFFF0000 = 0 then (x := !x lsl 16; r := !r + 16); + if !x land 0xFF000000 = 0 then (x := !x lsl 8; r := !r + 8); + if !x land 0xF0000000 = 0 then (x := !x lsl 4; r := !r + 4); + if !x land 0xC0000000 = 0 then (x := !x lsl 2; r := !r + 2); + if !x land 0x80000000 = 0 then (x := !x lsl 1; r := !r + 1); + if !x land 0x80000000 = 0 then ( r := !r + 1); + !r;; + +let tail0 x = + let r = ref 0 in + let x = ref x in + if !x land 0xFFFFFFFF = 0 then (x := !x lsr 32; r := !r + 32); + if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16); + if !x land 0xFF = 0 then (x := !x lsr 8; r := !r + 8); + if !x land 0xF = 0 then (x := !x lsr 4; r := !r + 4); + if !x land 0x3 = 0 then (x := !x lsr 2; r := !r + 2); + if !x land 0x1 = 0 then ( r := !r + 1); + !r + +let is_uint63 t = + Obj.is_int t +[@@ocaml.inline always] diff --git a/kernel/uint63_x86.ml b/kernel/uint63_x86.ml new file mode 100644 index 0000000000..461184c432 --- /dev/null +++ b/kernel/uint63_x86.ml @@ -0,0 +1,209 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Invariant: the msb should be 0 *) +type t = Int64.t + +let _ = assert (Sys.word_size = 32) + +let uint_size = 63 + +let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF" +let maxuint31 = Int64.of_string "0x7FFFFFFF" + +let zero = Int64.zero +let one = Int64.one + + (* conversion from an int *) +let mask63 i = Int64.logand i maxuint63 +let of_int i = Int64.of_int i +let to_int2 i = (Int64.to_int (Int64.shift_right_logical i 31), Int64.to_int i) +let of_int64 i = i +let hash i = + let (h,l) = to_int2 i in + (*Hashset.combine h l*) + h * 65599 + l + + (* conversion of an uint63 to a string *) +let to_string i = Int64.to_string i + +let of_string s = + let i64 = Int64.of_string s in + if Int64.compare Int64.zero i64 <= 0 + && Int64.compare i64 maxuint63 <= 0 + then i64 + else raise (Failure "Int63.of_string") + +(* Compiles an unsigned int to OCaml code *) +let compile i = Printf.sprintf "Uint63.of_int64 (%LiL)" i + + (* comparison *) +let lt x y = + Int64.compare x y < 0 + +let le x y = + Int64.compare x y <= 0 + + (* logical shift *) +let l_sl x y = + if le 0L y && lt y 63L then mask63 (Int64.shift_left x (Int64.to_int y)) else 0L + +let l_sr x y = + if le 0L y && lt y 63L then Int64.shift_right x (Int64.to_int y) else 0L + +let l_and x y = Int64.logand x y +let l_or x y = Int64.logor x y +let l_xor x y = Int64.logxor x y + + (* addition of int63 *) +let add x y = mask63 (Int64.add x y) + +let addcarry x y = add (add x y) Int64.one + + (* subtraction *) +let sub x y = mask63 (Int64.sub x y) + +let subcarry x y = sub (sub x y) Int64.one + + (* multiplication *) +let mul x y = mask63 (Int64.mul x y) + + (* division *) +let div x y = + if y = 0L then 0L else Int64.div x y + + (* modulo *) +let rem x y = + if y = 0L then 0L else Int64.rem x y + +let addmuldiv p x y = + l_or (l_sl x p) (l_sr y Int64.(sub (of_int uint_size) p)) + +(* A few helper functions on 128 bits *) +let lt128 xh xl yh yl = + lt xh yh || (xh = yh && lt xl yl) + +let le128 xh xl yh yl = + lt xh yh || (xh = yh && le xl yl) + + (* division of two numbers by one *) +let div21 xh xl y = + let maskh = ref zero in + let maskl = ref one in + let dh = ref zero in + let dl = ref y in + let cmp = ref true in + while le zero !dh && !cmp do + cmp := lt128 !dh !dl xh xl; + (* We don't use addmuldiv below to avoid checks on 1 *) + dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); + dl := l_sl !dl one; + maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); + maskl := l_sl !maskl one + done; (* mask = 2^N, d = 2^N * d, d >= x *) + let remh = ref xh in + let reml = ref xl in + let quotient = ref zero in + while not (Int64.equal (l_or !maskh !maskl) zero) do + if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) + quotient := l_or !quotient !maskl; + remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; + reml := sub !reml !dl + end; + maskl := l_or (l_sr !maskl one) (l_sl !maskh (of_int (uint_size - 1))); + maskh := l_sr !maskh one; + dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); + dh := l_sr !dh one + done; + !quotient, !reml + + + (* exact multiplication *) +let mulc x y = + let lx = ref (Int64.logand x maxuint31) in + let ly = ref (Int64.logand y maxuint31) in + let hx = Int64.shift_right x 31 in + let hy = Int64.shift_right y 31 in + let hr = ref (Int64.mul hx hy) in + let lr = ref (Int64.logor (Int64.mul !lx !ly) (Int64.shift_left !hr 62)) in + hr := (Int64.shift_right_logical !hr 1); + lx := Int64.mul !lx hy; + ly := Int64.mul hx !ly; + hr := Int64.logor !hr (Int64.add (Int64.shift_right !lx 32) (Int64.shift_right !ly 32)); + lr := Int64.add !lr (Int64.shift_left !lx 31); + hr := Int64.add !hr (Int64.shift_right_logical !lr 63); + lr := Int64.add (Int64.shift_left !ly 31) (mask63 !lr); + hr := Int64.add !hr (Int64.shift_right_logical !lr 63); + if Int64.logand !lr Int64.min_int <> 0L + then Int64.(sub !hr one, mask63 !lr) + else (!hr, !lr) + +let equal x y = mask63 x = mask63 y + +let compare x y = Int64.compare x y + +(* Number of leading zeroes *) +let head0 x = + let r = ref 0 in + let x = ref x in + if Int64.logand !x 0x7FFFFFFF00000000L = 0L then r := !r + 31 + else x := Int64.shift_right !x 31; + if Int64.logand !x 0xFFFF0000L = 0L then (x := Int64.shift_left !x 16; r := !r + 16); + if Int64.logand !x 0xFF000000L = 0L then (x := Int64.shift_left !x 8; r := !r + 8); + if Int64.logand !x 0xF0000000L = 0L then (x := Int64.shift_left !x 4; r := !r + 4); + if Int64.logand !x 0xC0000000L = 0L then (x := Int64.shift_left !x 2; r := !r + 2); + if Int64.logand !x 0x80000000L = 0L then (x := Int64.shift_left !x 1; r := !r + 1); + if Int64.logand !x 0x80000000L = 0L then (r := !r + 1); + Int64.of_int !r + +(* Number of trailing zeroes *) +let tail0 x = + let r = ref 0 in + let x = ref x in + if Int64.logand !x 0xFFFFFFFFL = 0L then (x := Int64.shift_right !x 32; r := !r + 32); + if Int64.logand !x 0xFFFFL = 0L then (x := Int64.shift_right !x 16; r := !r + 16); + if Int64.logand !x 0xFFL = 0L then (x := Int64.shift_right !x 8; r := !r + 8); + if Int64.logand !x 0xFL = 0L then (x := Int64.shift_right !x 4; r := !r + 4); + if Int64.logand !x 0x3L = 0L then (x := Int64.shift_right !x 2; r := !r + 2); + if Int64.logand !x 0x1L = 0L then (r := !r + 1); + Int64.of_int !r + +(* May an object be safely cast into an Uint63.t ? *) +let is_uint63 t = + Obj.is_block t && Int.equal (Obj.tag t) Obj.custom_tag + && le (Obj.magic t) maxuint63 + +(* Register all exported functions so that they can be called from C code *) + +let () = + Callback.register "uint63 add" add; + Callback.register "uint63 addcarry" addcarry; + Callback.register "uint63 addmuldiv" addmuldiv; + Callback.register "uint63 div" div; + Callback.register "uint63 div21_ml" div21; + Callback.register "uint63 eq" equal; + Callback.register "uint63 eq0" (equal Int64.zero); + Callback.register "uint63 head0" head0; + Callback.register "uint63 land" l_and; + Callback.register "uint63 leq" le; + Callback.register "uint63 lor" l_or; + Callback.register "uint63 lsl" l_sl; + Callback.register "uint63 lsl1" (fun x -> l_sl x Int64.one); + Callback.register "uint63 lsr" l_sr; + Callback.register "uint63 lsr1" (fun x -> l_sr x Int64.one); + Callback.register "uint63 lt" lt; + Callback.register "uint63 lxor" l_xor; + Callback.register "uint63 mod" rem; + Callback.register "uint63 mul" mul; + Callback.register "uint63 mulc_ml" mulc; + Callback.register "uint63 one" one; + Callback.register "uint63 sub" sub; + Callback.register "uint63 subcarry" subcarry; + Callback.register "uint63 tail0" tail0 diff --git a/kernel/univ.ml b/kernel/univ.ml index 8940c0337e..09bf695915 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -989,68 +989,6 @@ let map_univ_abstracted f {univ_abstracted_value;univ_abstracted_binder} = let hcons_abstract_universe_context = AUContext.hcons -(** Universe info for cumulative inductive types: A context of - universe levels with universe constraints, representing local - universe variables and constraints, together with an array of - Variance.t. - - This data structure maintains the invariant that the variance - array has the same length as the universe instance. *) -module CumulativityInfo = -struct - type t = universe_context * Variance.t array - - let make x = - if (Instance.length (UContext.instance (fst x))) = - (Array.length (snd x)) then x - else anomaly (Pp.str "Invalid subtyping information encountered!") - - let empty = (UContext.empty, [||]) - let is_empty (univs, variance) = UContext.is_empty univs && Array.is_empty variance - - let pr prl (univs, variance) = - UContext.pr prl ~variance univs - - let hcons (univs, variance) = (* should variance be hconsed? *) - (UContext.hcons univs, variance) - - let univ_context (univs, _subtypcst) = univs - let variance (_univs, variance) = variance - - (** This function takes a universe context representing constraints - of an inductive and produces a CumulativityInfo.t with the - trivial subtyping relation. *) - let from_universe_context univs = - (univs, Array.init (UContext.size univs) (fun _ -> Variance.Invariant)) - - let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts - let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts - -end - -let hcons_cumulativity_info = CumulativityInfo.hcons - -module ACumulativityInfo = -struct - type t = AUContext.t * Variance.t array - - let repr (auctx,var) = AUContext.repr auctx, var - - let pr prl (univs, variance) = - AUContext.pr prl ~variance univs - - let hcons (univs, variance) = (* should variance be hconsed? *) - (AUContext.hcons univs, variance) - - let univ_context (univs, _subtypcst) = univs - let variance (_univs, variance) = variance - - let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts - let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts -end - -let hcons_abstract_cumulativity_info = ACumulativityInfo.hcons - (** A set of universes with universe constraints. We linearize the set to a list after typechecking. Beware, representation could change. @@ -1211,10 +1149,6 @@ let abstract_universes nas ctx = let ctx = (nas, cstrs) in instance, ctx -let abstract_cumulativity_info nas (univs, variance) = - let subst, univs = abstract_universes nas univs in - subst, (univs, variance) - let rec compact_univ s vars i u = match u with | [] -> (s, List.rev vars) @@ -1235,12 +1169,8 @@ let pr_constraints prl = Constraint.pr prl let pr_universe_context = UContext.pr -let pr_cumulativity_info = CumulativityInfo.pr - let pr_abstract_universe_context = AUContext.pr -let pr_abstract_cumulativity_info = ACumulativityInfo.pr - let pr_universe_context_set = ContextSet.pr let pr_universe_subst = diff --git a/kernel/univ.mli b/kernel/univ.mli index b83251e983..1fbebee350 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -368,45 +368,6 @@ type 'a univ_abstracted = { val map_univ_abstracted : ('a -> 'b) -> 'a univ_abstracted -> 'b univ_abstracted -(** Universe info for cumulative inductive types: A context of - universe levels with universe constraints, representing local - universe variables and constraints, together with an array of - Variance.t. - - This data structure maintains the invariant that the variance - array has the same length as the universe instance. *) -module CumulativityInfo : -sig - type t - - val make : UContext.t * Variance.t array -> t - - val empty : t - val is_empty : t -> bool - - val univ_context : t -> UContext.t - val variance : t -> Variance.t array - - (** This function takes a universe context representing constraints - of an inductive and produces a CumulativityInfo.t with the - trivial subtyping relation. *) - val from_universe_context : UContext.t -> t - - val leq_constraints : t -> Instance.t constraint_function - val eq_constraints : t -> Instance.t constraint_function -end - -module ACumulativityInfo : -sig - type t - - val repr : t -> CumulativityInfo.t - val univ_context : t -> AUContext.t - val variance : t -> Variance.t array - val leq_constraints : t -> Instance.t constraint_function - val eq_constraints : t -> Instance.t constraint_function -end - (** Universe contexts (as sets) *) (** A set of universes with universe Constraint.t. @@ -487,7 +448,6 @@ val make_instance_subst : Instance.t -> universe_level_subst val make_inverse_instance_subst : Instance.t -> universe_level_subst val abstract_universes : Names.Name.t array -> UContext.t -> Instance.t * AUContext.t -val abstract_cumulativity_info : Names.Name.t array -> CumulativityInfo.t -> Instance.t * ACumulativityInfo.t (** TODO: move universe abstraction out of the kernel *) val make_abstract_instance : AUContext.t -> Instance.t @@ -505,10 +465,8 @@ val pr_constraint_type : constraint_type -> Pp.t val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t val pr_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> UContext.t -> Pp.t -val pr_cumulativity_info : (Level.t -> Pp.t) -> CumulativityInfo.t -> Pp.t val pr_abstract_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> AUContext.t -> Pp.t -val pr_abstract_cumulativity_info : (Level.t -> Pp.t) -> ACumulativityInfo.t -> Pp.t val pr_universe_context_set : (Level.t -> Pp.t) -> ContextSet.t -> Pp.t val explain_universe_inconsistency : (Level.t -> Pp.t) -> univ_inconsistency -> Pp.t @@ -524,5 +482,3 @@ val hcons_universe_set : LSet.t -> LSet.t val hcons_universe_context : UContext.t -> UContext.t val hcons_abstract_universe_context : AUContext.t -> AUContext.t val hcons_universe_context_set : ContextSet.t -> ContextSet.t -val hcons_cumulativity_info : CumulativityInfo.t -> CumulativityInfo.t -val hcons_abstract_cumulativity_info : ACumulativityInfo.t -> ACumulativityInfo.t diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 246c90c09d..414c443c4e 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -71,13 +71,15 @@ and conv_whd env pb k whd1 whd2 cu = done; !rcu else raise NotConvertible + | Vint64 i1, Vint64 i2 -> + if Int64.equal i1 i2 then cu else raise NotConvertible | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> (* on the fly eta expansion *) conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu - | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ + | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ | Vint64 _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible @@ -86,17 +88,11 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = match a1, a2 with | Aind ((mi,_i) as ind1) , Aind ind2 -> if eq_ind ind1 ind2 && compare_stack stk1 stk2 then - if Environ.polymorphic_ind ind1 env then - let mib = Environ.lookup_mind mi env in - let ulen = - match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind ctx -> Univ.ContextSet.size ctx - | Declarations.Polymorphic_ind auctx -> Univ.AUContext.size auctx - | Declarations.Cumulative_ind cumi -> - Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) - in + let ulen = Univ.AUContext.size (Environ.mind_context env mi) in + if ulen = 0 then + conv_stack env k stk1 stk2 cu + else match stk1 , stk2 with - | [], [] -> assert (Int.equal ulen 0); cu | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> assert (ulen <= nargs args1); assert (ulen <= nargs args2); @@ -108,8 +104,6 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = conv_arguments env ~from:ulen k args1 args2 (conv_stack env k stk1' stk2' cu) | _, _ -> assert false (* Should not happen if problem is well typed *) - else - conv_stack env k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> if Vmvalues.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then diff --git a/kernel/vm.ml b/kernel/vm.ml index eaf64ba4af..83312a8530 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -7,7 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) - open Vmvalues external set_drawinstr : unit -> unit = "coq_set_drawinstr" @@ -170,7 +169,7 @@ let rec apply_stack a stk v = let apply_whd k whd = let v = val_of_rel k in match whd with - | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false + | Vprod _ | Vconstr_const _ | Vconstr_block _ | Vint64 _ -> assert false | Vfun f -> reduce_fun k f | Vfix(f, None) -> push_ra stop; diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 217ef4b8e5..9a3eadf747 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -57,6 +57,7 @@ type structured_constant = | Const_b0 of tag | Const_univ_level of Univ.Level.t | Const_val of structured_values + | Const_uint of Uint63.t type reloc_table = (tag * int) array @@ -73,7 +74,9 @@ let rec eq_structured_values v1 v2 = let t2 = Obj.tag o2 in if Int.equal t1 t2 && Int.equal (Obj.size o1) (Obj.size o2) - then begin + then if Int.equal t1 Obj.custom_tag + then Int64.equal (Obj.magic v1 : int64) (Obj.magic v2 : int64) + else begin assert (t1 <= Obj.last_non_constant_constructor_tag && t2 <= Obj.last_non_constant_constructor_tag); let i = ref 0 in @@ -100,7 +103,9 @@ let eq_structured_constant c1 c2 = match c1, c2 with | Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 | Const_univ_level _ , _ -> false | Const_val v1, Const_val v2 -> eq_structured_values v1 v2 -| Const_val _v1, _ -> false +| Const_val _, _ -> false +| Const_uint i1, Const_uint i2 -> Uint63.equal i1 i2 +| Const_uint _, _ -> false let hash_structured_constant c = let open Hashset.Combine in @@ -110,6 +115,7 @@ let hash_structured_constant c = | Const_b0 t -> combinesmall 3 (Int.hash t) | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l) | Const_val v -> combinesmall 5 (hash_structured_values v) + | Const_uint i -> combinesmall 6 (Uint63.hash i) let eq_annot_switch asw1 asw2 = let eq_ci ci1 ci2 = @@ -142,6 +148,7 @@ let pp_struct_const = function | Const_b0 i -> Pp.int i | Const_univ_level l -> Univ.Level.pr l | Const_val _ -> Pp.str "(value)" + | Const_uint i -> Pp.str (Uint63.to_string i) (* Abstract data *) type vprod @@ -276,6 +283,7 @@ type whd = | Vcofix of vcofix * to_update * arguments option | Vconstr_const of int | Vconstr_block of vblock + | Vint64 of int64 | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -306,8 +314,9 @@ let uni_lvl_val (v : values) : Univ.Level.t = | Vcofix _ -> str "Vcofix" | Vconstr_const _i -> str "Vconstr_const" | Vconstr_block _b -> str "Vconstr_block" + | Vint64 _ -> str "Vint64" | Vatom_stk (_a,_stk) -> str "Vatom_stk" - | _ -> assert false + | Vuniv_level _ -> assert false in CErrors.anomaly Pp.( strbrk "Parsing virtual machine value expected universe level, got " @@ -363,6 +372,8 @@ let rec whd_accu a stk = | [Zapp args] -> Vcofix(vcofix, res, Some args) | _ -> assert false end + | i when Int.equal i Obj.custom_tag -> + Vint64 (Obj.magic i) | tg -> CErrors.anomaly Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") @@ -391,6 +402,7 @@ let whd_val : values -> whd = | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) else Vconstr_block(Obj.obj o) @@ -413,6 +425,7 @@ let obj_of_str_const str = | Const_b0 tag -> Obj.repr tag | Const_univ_level l -> Obj.repr (Vuniv_level l) | Const_val v -> Obj.repr v + | Const_uint i -> Obj.repr i let val_of_block tag (args : structured_values array) = let nargs = Array.length args in @@ -430,6 +443,8 @@ let val_of_atom a = val_of_obj (obj_of_atom a) let val_of_int i = (Obj.magic i : values) +let val_of_uint i = (Obj.magic i : values) + let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in Obj.set_field r 0 (Obj.repr kn); @@ -659,6 +674,7 @@ and pr_whd w = | Vcofix _ -> str "Vcofix" | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" | Vconstr_block _b -> str "Vconstr_block" + | Vint64 i -> i |> Format.sprintf "Vint64(%LiL)" |> str | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" | Vuniv_level _ -> assert false) and pr_stack stk = diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index ae1d416ed5..6d984d5f49 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -44,6 +44,7 @@ type structured_constant = | Const_b0 of tag | Const_univ_level of Univ.Level.t | Const_val of structured_values + | Const_uint of Uint63.t val pp_struct_const : structured_constant -> Pp.t @@ -125,6 +126,7 @@ type whd = | Vcofix of vcofix * to_update * arguments option | Vconstr_const of int | Vconstr_block of vblock + | Vint64 of int64 | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -145,6 +147,7 @@ val val_of_proj : Projection.Repr.t -> values -> values val val_of_atom : atom -> values val val_of_int : int -> structured_values val val_of_block : tag -> structured_values array -> structured_values +val val_of_uint : Uint63.t -> structured_values external val_of_annot_switch : annot_switch -> values = "%identity" external val_of_proj_name : Projection.Repr.t -> values = "%identity" diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml new file mode 100644 index 0000000000..0fcaf4f10a --- /dev/null +++ b/kernel/write_uint63.ml @@ -0,0 +1,30 @@ +(** Equivalent of rm -f *) + +let safe_remove f = + try Unix.chmod f 0o644; Sys.remove f with _ -> () + +(** * Generate an implementation of 63-bit arithmetic *) + +let ml_file_copy input output = + safe_remove output; + let i = open_in input in + let o = open_out output in + let pr s = Printf.fprintf o s in + pr "(* DO NOT EDIT THIS FILE: automatically generated by ./write_uint63.ml *)\n"; + pr "(* see uint63_amd64.ml and uint63_x86.ml *)\n"; + try + while true do + output_string o (input_line i); output_char o '\n' + done + with End_of_file -> + close_in i; + close_out o; + Unix.chmod output 0o444 + +let write_uint63 () = + ml_file_copy + (if max_int = 1073741823 (* 32-bits *) then "uint63_x86.ml" + else (* 64 bits *) "uint63_amd64.ml") + "uint63.ml" + +let () = write_uint63 () diff --git a/lib/dAst.ml b/lib/dAst.ml index f34ab956a3..803b2a0cff 100644 --- a/lib/dAst.ml +++ b/lib/dAst.ml @@ -30,6 +30,8 @@ let make ?loc v = CAst.make ?loc (Value v) let delay ?loc v = CAst.make ?loc (Thunk (Lazy.from_fun v)) +let force x = CAst.make ?loc:x.CAst.loc (Value (get_thunk x.v)) + let map f n = CAst.map (fun x -> map_thunk f x) n let map_with_loc f n = diff --git a/lib/dAst.mli b/lib/dAst.mli index 28c78784e6..2f58cfc41f 100644 --- a/lib/dAst.mli +++ b/lib/dAst.mli @@ -21,6 +21,7 @@ val get_thunk : ('a, 'b) thunk -> 'a val make : ?loc:Loc.t -> 'a -> ('a, 'b) t val delay : ?loc:Loc.t -> (unit -> 'a) -> ('a, [ `thunk ]) t +val force : ('a, 'b) t -> ('a, 'b) t val map : ('a -> 'b) -> ('a, 'c) t -> ('b, 'c) t val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> ('b, 'c) t diff --git a/lib/envars.ml b/lib/envars.ml index b5036e7340..0f4670688b 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -114,7 +114,7 @@ let set_coqlib ~fail = match !coqlib with | Some _ -> () | None -> - let lib = if !Flags.boot then coqroot else guess_coqlib fail in + let lib = guess_coqlib fail in coqlib := Some lib let coqlib () = Option.default "" !coqlib diff --git a/lib/flags.ml b/lib/flags.ml index 55bfa3cbde..1195b8caf1 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 @@ -103,16 +101,6 @@ let verbosely f x = without_option quiet f x let if_silent f x = if !quiet then f x let if_verbose f x = if not !quiet then f x -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 +112,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..2b4446a1db 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,14 +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 - val warn : bool ref val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit @@ -116,9 +106,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/decl_kinds.ml b/library/decl_kinds.ml index 171d51800e..8d5c2fb687 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -70,6 +70,7 @@ type goal_kind = locality * polymorphic * goal_object_kind (** Kinds used in library *) type logical_kind = + | IsPrimitive | IsAssumption of assumption_object_kind | IsDefinition of definition_object_kind | IsProof of theorem_kind 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 84d2a37170..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) @@ -175,11 +176,8 @@ let with_global f = let (a, ctx) = f (env ()) (current_dirpath ()) in push_context_set false ctx; a -(* spiwack: register/unregister functions for retroknowledge *) -let register field value = - globalize0 (Safe_typing.register field value) - let register_inline c = globalize0 (Safe_typing.register_inline c) +let register_inductive c r = globalize0 (Safe_typing.register_inductive c r) let set_strategy k l = globalize0 (Safe_typing.set_strategy k l) diff --git a/library/global.mli b/library/global.mli index 40962e21af..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 -> @@ -142,10 +142,8 @@ val universes_of_global : GlobRef.t -> Univ.AUContext.t (** {6 Retroknowledge } *) -val register : - Retroknowledge.field -> GlobRef.t -> unit - val register_inline : Constant.t -> unit +val register_inductive : inductive -> CPrimitives.prim_ind -> unit (** {6 Oracle } *) diff --git a/library/keys.ml b/library/keys.ml index 58883ccc88..45b6fae2f0 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -25,13 +25,14 @@ type key = | KFix | KCoFix | KRel + | KInt module KeyOrdered = struct type t = key let hash gr = match gr with - | KGlob gr -> 8 + GlobRef.Ordered.hash gr + | KGlob gr -> 9 + GlobRef.Ordered.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 @@ -40,6 +41,7 @@ module KeyOrdered = struct | KFix -> 5 | KCoFix -> 6 | KRel -> 7 + | KInt -> 8 let compare gr1 gr2 = match gr1, gr2 with @@ -133,6 +135,7 @@ let constr_key kind c = | Evar _ -> raise Not_found | Sort _ -> KSort | LetIn _ -> KLet + | Int _ -> KInt in Some (aux c) with Not_found -> None @@ -148,6 +151,7 @@ let pr_key pr_global = function | KFix -> str"Fix" | KCoFix -> str"CoFix" | KRel -> str"Rel" + | KInt -> str"Int" let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) 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/man/coqtop.1 b/man/coqtop.1 index 084adfe453..addfb54672 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -85,22 +85,6 @@ load Coq library and import it (Require Import path.) .TP -.BI \-compile \ filename.v -compile Coq file -.I filename.v -(implies -.B \-batch -) - -.TP -.BI \-compile\-verbose \ filename.v -verbosely compile Coq file -.I filename.v -(implies -.B \-batch -) - -.TP .B \-where print Coq's standard library location and exit @@ -125,8 +109,6 @@ batch mode (exits just after arguments parsing) .B \-boot boot mode (implies .B \-q -and -.B \-batch ) .TP 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/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index b0f6301192..b59e3b608c 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -147,7 +147,7 @@ let check_fix env sg cb i = | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd) | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd) | _ -> raise Impossible) - | Undef _ | OpaqueDef _ -> raise Impossible + | Undef _ | OpaqueDef _ | Primitive _ -> raise Impossible let prec_declaration_equal sg (na1, ca1, ta1) (na2, ca2, ta2) = Array.equal Name.equal na1 na2 && diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 67c605ea1d..204f889f90 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -304,9 +304,9 @@ let rec extract_type env sg db j c args = | (Info, TypeScheme) -> let mlt = extract_type_app env sg db (r, type_sign env sg typ) args in (match (lookup_constant kn env).const_body with - | Undef _ | OpaqueDef _ -> mlt - | Def _ when is_custom (ConstRef kn) -> mlt - | Def lbody -> + | Undef _ | OpaqueDef _ | Primitive _ -> mlt + | Def _ when is_custom (ConstRef kn) -> mlt + | Def lbody -> let newc = applistc (get_body lbody) args in let mlt' = extract_type env sg db j newc [] in (* ML type abbreviations interact badly with Coq *) @@ -318,7 +318,7 @@ let rec extract_type env sg db j c args = | (Info, Default) -> (* Not an ML type, for example [(c:forall X, X->X) Type nat] *) (match (lookup_constant kn env).const_body with - | Undef _ | OpaqueDef _ -> Tunknown (* Brutal approx ... *) + | Undef _ | OpaqueDef _ | Primitive _ -> Tunknown (* Brutal approx ... *) | Def lbody -> (* We try to reduce. *) let newc = applistc (get_body lbody) args in @@ -346,7 +346,7 @@ let rec extract_type env sg db j c args = | (Info, TypeScheme) -> extract_type_app env sg db (r, type_sign env sg ty) args | (Info, Default) -> Tunknown)) - | Cast _ | LetIn _ | Construct _ -> assert false + | Cast _ | LetIn _ | Construct _ | Int _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], @@ -564,7 +564,7 @@ and mlt_env env r = match r with | ConstRef kn -> let cb = Environ.lookup_constant kn env in match cb.const_body with - | Undef _ | OpaqueDef _ -> None + | Undef _ | OpaqueDef _ | Primitive _ -> None | Def l_body -> match lookup_typedef kn cb with | Some _ as o -> o @@ -683,6 +683,7 @@ let rec extract_term env sg mle mlt c args = let vty = extract_type env sg [] 0 ty [] in let extract_var mlt = put_magic (mlt,vty) (MLglob (VarRef v)) in extract_app env sg mle mlt extract_var args + | Int i -> assert (args = []); MLuint i | Ind _ | Prod _ | Sort _ -> assert false (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) @@ -1031,6 +1032,55 @@ let extract_fixpoint env sg vkn (fi,ti,ci) = current_fixpoints := []; Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) +(** Because of automatic unboxing the easy way [mk_def c] on the + constant body of primitive projections doesn't work. We pretend + that they are implemented by matches until someone figures out how + to clean it up (test with #4710 when working on this). *) +let fake_match_projection env p = + let ind = Projection.Repr.inductive p in + let proj_arg = Projection.Repr.arg p in + let mib, mip = Inductive.lookup_mind_specif env ind in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in + let indu = mkIndU (ind,u) in + let ctx, paramslet = + let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((fst ind, mib.mind_ntypes - i - 1), u)) in + let rctx, _ = decompose_prod_assum (Vars.substl subst mip.mind_nf_lc.(0)) in + List.chop mip.mind_consnrealdecls.(0) rctx + in + let ci_pp_info = { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in + let ci = { + ci_ind = ind; + ci_npar = mib.mind_nparams; + ci_cstr_ndecls = mip.mind_consnrealdecls; + ci_cstr_nargs = mip.mind_consnrealargs; + ci_pp_info; + } + in + let x = match mib.mind_record with + | NotRecord | FakeRecord -> assert false + | PrimRecord info -> Name (pi1 info.(snd ind)) + in + let indty = mkApp (indu, Context.Rel.to_extended_vect mkRel 0 paramslet) in + let rec fold arg j subst = function + | [] -> assert false + | LocalAssum (na,ty) :: rem -> + let ty = Vars.substl subst (liftn 1 j ty) in + if arg != proj_arg then + let lab = match na with Name id -> Label.of_id id | Anonymous -> assert false in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in + fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem + else + let p = mkLambda (x, lift 1 indty, liftn 1 2 ty) in + let branch = lift 1 (it_mkLambda_or_LetIn (mkRel (List.length ctx - (j-1))) ctx) in + let body = mkCase (ci, p, mkRel 1, [|branch|]) in + it_mkLambda_or_LetIn (mkLambda (x,indty,body)) mib.mind_params_ctxt + | LocalDef (_,c,t) :: rem -> + let c = liftn 1 j c in + let c1 = Vars.substl subst c in + fold arg (j+1) (c1::subst) rem + in + fold 0 1 [] (List.rev ctx) + let extract_constant env kn cb = let sg = Evd.from_env env in let r = ConstRef kn in @@ -1063,15 +1113,12 @@ let extract_constant env kn cb = | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop) | (Info,TypeScheme) -> (match cb.const_body with - | Undef _ -> warn_info (); mk_typ_ax () + | Primitive _ | Undef _ -> warn_info (); mk_typ_ax () | Def c -> (match Recordops.find_primitive_projection kn with | None -> mk_typ (get_body c) | Some p -> - let p = Projection.make p false in - let ind = Projection.inductive p in - let bodies = Inductiveops.legacy_match_projection env ind in - let body = bodies.(Projection.arg p) in + let body = fake_match_projection env p in mk_typ (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; @@ -1079,15 +1126,12 @@ let extract_constant env kn cb = else mk_typ_ax ()) | (Info,Default) -> (match cb.const_body with - | Undef _ -> warn_info (); mk_ax () + | Primitive _ | Undef _ -> warn_info (); mk_ax () | Def c -> (match Recordops.find_primitive_projection kn with | None -> mk_def (get_body c) | Some p -> - let p = Projection.make p false in - let ind = Projection.inductive p in - let bodies = Inductiveops.legacy_match_projection env ind in - let body = bodies.(Projection.arg p) in + let body = fake_match_projection env p in mk_def (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; @@ -1107,7 +1151,7 @@ let extract_constant_spec env kn cb = | (Info, TypeScheme) -> let s,vl = type_sign_vl env sg typ in (match cb.const_body with - | Undef _ | OpaqueDef _ -> Stype (r, vl, None) + | Undef _ | OpaqueDef _ | Primitive _ -> Stype (r, vl, None) | Def body -> let db = db_from_sign s in let body = get_body body in diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 97fe9f24d5..a3cd92d556 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -214,6 +214,8 @@ let rec pp_expr par env args = | MLmagic a -> pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") + | MLuint _ -> + pp_par par (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") and pp_cons_pat par r ppl = pp_par par diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index e43c47d050..f88d29e9ed 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -155,6 +155,10 @@ let rec json_expr env = function ("value", json_expr env a) ] | MLaxiom -> json_dict [("what", json_str "expr:axiom")] + | MLuint i -> json_dict [ + ("what", json_str "expr:int"); + ("int", json_str (Uint63.to_string i)) + ] and json_one_pat env (ids,p,t) = let ids', env' = push_vars (List.rev_map id_of_mlid ids) env in json_dict [ diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml index ce920ad6a0..b7f80d543b 100644 --- a/plugins/extraction/miniml.ml +++ b/plugins/extraction/miniml.ml @@ -126,6 +126,7 @@ and ml_ast = | MLdummy of kill_reason | MLaxiom | MLmagic of ml_ast + | MLuint of Uint63.t and ml_pattern = | Pcons of GlobRef.t * ml_pattern list diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index ce920ad6a0..9df0f4964e 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -126,6 +126,7 @@ and ml_ast = | MLdummy of kill_reason | MLaxiom | MLmagic of ml_ast + | MLuint of Uint63.t and ml_pattern = | Pcons of GlobRef.t * ml_pattern list diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 9f5c1f1a17..2432887673 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -66,7 +66,8 @@ let rec eq_ml_type t1 t2 = match t1, t2 with | Tdummy k1, Tdummy k2 -> k1 == k2 | Tunknown, Tunknown -> true | Taxiom, Taxiom -> true -| _ -> false +| (Tarr _ | Tglob _ | Tvar _ | Tvar' _ | Tmeta _ | Tdummy _ | Tunknown | Taxiom), _ + -> false and eq_ml_meta m1 m2 = Int.equal m1.id m2.id && Option.equal eq_ml_type m1.contents m2.contents @@ -107,7 +108,7 @@ let rec type_occurs alpha t = | Tmeta {contents=Some u} -> type_occurs alpha u | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2 | Tglob (r,l) -> List.exists (type_occurs alpha) l - | _ -> false + | (Tdummy _ | Tvar _ | Tvar' _ | Taxiom | Tunknown) -> false (*s Most General Unificator *) @@ -310,7 +311,7 @@ let isMLdummy = function MLdummy _ -> true | _ -> false let sign_of_id = function | Dummy -> Kill Kprop - | _ -> Keep + | (Id _ | Tmp _) -> Keep (* Classification of signatures *) @@ -370,7 +371,10 @@ let eq_ml_ident i1 i2 = match i1, i2 with | Dummy, Dummy -> true | Id id1, Id id2 -> Id.equal id1 id2 | Tmp id1, Tmp id2 -> Id.equal id1 id2 -| _ -> false +| Dummy, (Id _ | Tmp _) +| Id _, (Dummy | Tmp _) +| Tmp _, (Dummy | Id _) + -> false let rec eq_ml_ast t1 t2 = match t1, t2 with | MLrel i1, MLrel i2 -> @@ -394,7 +398,8 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLdummy k1, MLdummy k2 -> k1 == k2 | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 -| _ -> false +| MLuint i1, MLuint i2 -> Uint63.equal i1 i2 +| _, _ -> false and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> @@ -426,7 +431,7 @@ let ast_iter_rel f = | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a - | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> () in iter 0 (*s Map over asts. *) @@ -445,7 +450,7 @@ let ast_map f = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ as a -> a (*s Map over asts, with binding depth as parameter. *) @@ -463,7 +468,7 @@ let ast_map_lift f n = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ as a -> a (*s Iter over asts. *) @@ -477,7 +482,7 @@ let ast_iter f = function | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a - | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> () (*S Operations concerning De Bruijn indices. *) @@ -513,7 +518,7 @@ let nb_occur_match = | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a - | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> 0 in nb 1 (* Replace unused variables by _ *) @@ -565,7 +570,7 @@ let dump_unused_vars a = let b' = ren env b in if b' == b then a else MLmagic b' - | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> a + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> a and ren_branch env ((ids,p,b) as tr) = let occs = List.map (fun _ -> ref false) ids in @@ -1398,7 +1403,7 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index b398bc07a0..654695c232 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -108,7 +108,7 @@ let ast_iter_references do_term do_cons do_type a = Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ - | MLdummy _ | MLaxiom | MLmagic _ -> () + | MLdummy _ | MLaxiom | MLmagic _ | MLuint _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 96d8760404..8940aedd6d 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -310,6 +310,10 @@ let rec pp_expr par env args = apply2 (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++ pp_pat env pv)))) + | MLuint i -> + assert (args=[]); + str "(" ++ str (Uint63.compile i) ++ str ")" + and pp_record_proj par env typ t pv args = (* Can a match be printed as a mere record projection ? *) diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 76a0c74068..6aa3a6220e 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -129,6 +129,8 @@ let rec pp_expr env args = | MLmagic a -> pp_expr env args a | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") + | MLuint _ -> + paren (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 3b95423067..8da30bd9c9 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -763,12 +763,13 @@ let build_proof end | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> do_finalize dyn_infos g | App(_,_) -> let f,args = decompose_app sigma dyn_infos.info in begin match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") | App _ -> assert false (* we have collected all the app in decompose_app *) | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 12b68e208c..25a7675113 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -364,7 +364,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) let evd',value = change_property_sort evd' s new_principle_type new_princ_name in let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.const_univ_entry ~poly:false evd' in + let univs = Evd.univ_entry ~poly:false evd' in let ce = Declare.definition_entry ~univs value in ignore( Declare.declare_constant diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 4b6caea70d..ba0a3bbb5c 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -321,12 +321,10 @@ let build_constructors_of_type ind' argl = construct in let argl = - if List.is_empty argl - then - Array.to_list - (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) - ) - else argl + if List.is_empty argl then + List.make cst_narg (mkGHole ()) + else + List.make npar (mkGHole ()) @ argl in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) @@ -478,7 +476,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid | GApp(_,_) -> @@ -588,6 +586,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> user_err Pp.(str "Not handled GRec") | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GInt _ -> user_err Pp.(str "Cannot apply an integer") end (* end of the application treatement *) | GLambda(n,_,t,b) -> @@ -1221,7 +1220,7 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) let rec compute_cst_params relnames params gt = DAst.with_val (function - | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ -> params | GApp(f,args) -> begin match DAst.get f with | GVar relname' when Id.Set.mem relname' relnames -> diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 5b45a8dbed..13ff19a46b 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -106,6 +106,7 @@ let change_vars = | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") | GSort _ as x -> x | GHole _ as x -> x + | GInt _ as x -> x | GCast(b,c) -> GCast(change_vars mapping b, Glob_ops.map_cast_type (change_vars mapping) c) @@ -285,6 +286,7 @@ let rec alpha_rt excluded rt = ) | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ + | GInt _ | GHole _ as rt -> rt | GCast (b,c) -> GCast(alpha_rt excluded b, @@ -344,6 +346,7 @@ let is_free_in id = | GHole _ -> false | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t | GCast (b,CastCoerce) -> is_free_in b + | GInt _ -> false ) x and is_free_in_br {CAst.v=(ids,_,rt)} = (not (Id.List.mem id ids)) && is_free_in rt @@ -434,6 +437,7 @@ let replace_var_by_term x_id term = | GRec _ -> raise (UserError(None,str "Not handled GRec")) | GSort _ | GHole _ as rt -> rt + | GInt _ as rt -> rt | GCast(b,c) -> GCast(replace_var_by_pattern b, Glob_ops.map_cast_type replace_var_by_pattern c) @@ -516,7 +520,7 @@ let expand_as = | PatCstr(_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map = DAst.map (function - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ as rt -> rt | GVar id as rt -> begin try diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 3a04c753ea..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)) @@ -201,7 +201,7 @@ let is_rec names = let check_id id names = Id.Set.mem id names in let rec lookup names gt = match DAst.get gt with | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> false | GCast(b,_) -> lookup names b | GRec _ -> error "GRec not handled" | GIf(b,_,lhs,rhs) -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 38f27f760b..a8517e9ab1 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -306,6 +306,7 @@ let check_not_nested sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with | Rel _ -> () + | Int _ -> () | Var x -> if Id.List.mem x forbidden then user_err ~hdr:"Recdef.check_not_nested" @@ -487,7 +488,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in new_continuation_tac expr_info g @@ -1294,6 +1295,7 @@ let is_opaque_constant c = | Declarations.OpaqueDef _ -> Proof_global.Opaque | Declarations.Undef _ -> Proof_global.Opaque | Declarations.Def _ -> Proof_global.Transparent + | Declarations.Primitive _ -> Proof_global.Opaque let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) @@ -1516,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 @@ -1545,7 +1547,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = - let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evd) in + let univs = Evd.univ_entry ~poly:false evd in declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res in (* Refresh the global universes, now including those of _F *) 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/rewrite.ml b/plugins/ltac/rewrite.ml index 2055b25ff4..7da4464e59 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1889,7 +1889,7 @@ let declare_projection n instance_id r = in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let univs = Evd.const_univ_entry ~poly sigma in + let univs = Evd.univ_entry ~poly sigma in let typ = EConstr.to_constr sigma typ in let term = EConstr.to_constr sigma term in let cst = @@ -1975,7 +1975,7 @@ let add_morphism_infer atts m n = let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then - let uctx = UState.const_univ_entry ~poly:atts.polymorphic uctx in + let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry (None,(instance,uctx),None), diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 3e7479903a..30f716d764 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -117,9 +117,14 @@ let combine_appl appl1 appl2 = let of_tacvalue v = in_gen (topwit wit_tacvalue) v let to_tacvalue v = out_gen (topwit wit_tacvalue) v +let log_trace = ref false + +let is_traced () = + !log_trace || !Flags.profile_ltac + (** More naming applications *) let name_vfun appl vle = - if has_type vle (topwit wit_tacvalue) then + if is_traced () && has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) | _ -> vle @@ -137,9 +142,11 @@ type interp_sign = Geninterp.interp_sign = { lfun : value Id.Map.t; extra : TacStore.t } -let extract_trace ist = match TacStore.get ist.extra f_trace with -| None -> [] -| Some l -> l +let extract_trace ist = + if is_traced () then match TacStore.get ist.extra f_trace with + | None -> [] + | Some l -> l + else [] let print_top_val env v = Pptactic.pr_value Pptactic.ltop v @@ -161,8 +168,11 @@ let catch_error call_trace f x = let e = CErrors.push e in catching_error call_trace iraise e +let wrap_error tac k = + if is_traced () then Proofview.tclORELSE tac k else tac + let catch_error_tac call_trace tac = - Proofview.tclORELSE + wrap_error tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) @@ -203,9 +213,11 @@ let constr_of_id env id = (** Generic arguments : table of interpretation functions *) (* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) -let push_trace call ist = match TacStore.get ist.extra f_trace with -| None -> Proofview.tclUNIT [call] -| Some trace -> Proofview.tclUNIT (call :: trace) +let push_trace call ist = + if is_traced () then match TacStore.get ist.extra f_trace with + | None -> Proofview.tclUNIT [call] + | Some trace -> Proofview.tclUNIT (call :: trace) + else Proofview.tclUNIT [] let propagate_trace ist loc id v = if has_type v (topwit wit_tacvalue) then @@ -530,7 +542,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 +564,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 +580,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 = @@ -1247,7 +1275,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = let fold accu (id, v) = Id.Map.add id v accu in let newlfun = List.fold_left fold olfun extfun in if List.is_empty lvar then - begin Proofview.tclORELSE + begin wrap_error begin let ist = { lfun = newlfun; @@ -1407,7 +1435,7 @@ and interp_match_successes lz ist s = (* Interprets the Match expressions *) and interp_match ist lz constr lmr = let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE + begin wrap_error (interp_ltac_constr ist constr) begin function | (e, info) -> @@ -1493,7 +1521,7 @@ and interp_genarg_var_list ist x = (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : EConstr.t Ftactic.t = let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE + begin wrap_error (val_interp ist e) begin function (err, info) -> match err with | Not_found -> @@ -2033,7 +2061,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 @@ -2051,4 +2088,13 @@ let () = optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } +let () = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "Ltac Backtrace"; + optkey = ["Ltac"; "Backtrace"]; + optread = (fun () -> !log_trace); + optwrite = (fun b -> log_trace := b) } + let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index d4bafe773f..7adae148bd 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -846,7 +846,7 @@ struct match env with | [] -> ([v],n) | e::l -> - if EConstr.eq_constr sigma e v + if EConstr.eq_constr_nounivs sigma e v then (env,n) else let (env,n) = _add l ( n+1) v in diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 94a3d40441..695f000cb1 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -12,6 +12,120 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Local Open Scope Z_scope. +(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) + +(** These tactic use the complete specification of [Z.div] and + [Z.modulo] ([Z.quot] and [Z.rem], respectively) to remove these + functions from the goal without losing information. The + [Z.euclidean_division_equations_cleanup] tactic removes needless + hypotheses, which makes tactics like [nia] run faster. The tactic + [Z.to_euclidean_division_equations] combines the handling of both variants + of division/quotient and modulo/remainder. *) + +Module Z. + Lemma mod_0_r_ext x y : y = 0 -> x mod y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + Lemma div_0_r_ext x y : y = 0 -> x / y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + + Lemma rem_0_r_ext x y : y = 0 -> Z.rem x y = x. + Proof. intro; subst; destruct x; reflexivity. Qed. + Lemma quot_0_r_ext x y : y = 0 -> Z.quot x y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + + Lemma rem_bound_pos_pos x y : 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. + Proof. intros; apply Z.rem_bound_pos; assumption. Qed. + Lemma rem_bound_neg_pos x y : y < 0 -> 0 <= x -> 0 <= Z.rem x y < -y. + Proof. rewrite <- Z.rem_opp_r'; intros; apply Z.rem_bound_pos; rewrite ?Z.opp_pos_neg; assumption. Qed. + Lemma rem_bound_pos_neg x y : 0 < y -> x <= 0 -> -y < Z.rem x y <= 0. + Proof. rewrite <- (Z.opp_involutive x), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg; apply rem_bound_pos_pos. Qed. + Lemma rem_bound_neg_neg x y : y < 0 -> x <= 0 -> y < Z.rem x y <= 0. + Proof. rewrite <- (Z.opp_involutive x), <- (Z.opp_involutive y), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg, Z.opp_involutive; apply rem_bound_neg_pos. Qed. + + Ltac div_mod_to_equations_generalize x y := + pose proof (Z.div_mod x y); + pose proof (Z.mod_pos_bound x y); + pose proof (Z.mod_neg_bound x y); + pose proof (div_0_r_ext x y); + pose proof (mod_0_r_ext x y); + let q := fresh "q" in + let r := fresh "r" in + set (q := x / y) in *; + set (r := x mod y) in *; + clearbody q r. + Ltac quot_rem_to_equations_generalize x y := + pose proof (Z.quot_rem' x y); + pose proof (rem_bound_pos_pos x y); + pose proof (rem_bound_pos_neg x y); + pose proof (rem_bound_neg_pos x y); + pose proof (rem_bound_neg_neg x y); + pose proof (quot_0_r_ext x y); + pose proof (rem_0_r_ext x y); + let q := fresh "q" in + let r := fresh "r" in + set (q := Z.quot x y) in *; + set (r := Z.rem x y) in *; + clearbody q r. + + Ltac div_mod_to_equations_step := + match goal with + | [ |- context[?x / ?y] ] => div_mod_to_equations_generalize x y + | [ |- context[?x mod ?y] ] => div_mod_to_equations_generalize x y + | [ H : context[?x / ?y] |- _ ] => div_mod_to_equations_generalize x y + | [ H : context[?x mod ?y] |- _ ] => div_mod_to_equations_generalize x y + end. + Ltac quot_rem_to_equations_step := + match goal with + | [ |- context[Z.quot ?x ?y] ] => quot_rem_to_equations_generalize x y + | [ |- context[Z.rem ?x ?y] ] => quot_rem_to_equations_generalize x y + | [ H : context[Z.quot ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y + | [ H : context[Z.rem ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y + end. + Ltac div_mod_to_equations' := repeat div_mod_to_equations_step. + Ltac quot_rem_to_equations' := repeat quot_rem_to_equations_step. + Ltac euclidean_division_equations_cleanup := + repeat match goal with + | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl) + | [ H : ?x <> ?x -> _ |- _ ] => clear H + | [ H : ?x < ?x -> _ |- _ ] => clear H + | [ H : ?T -> _, H' : ?T |- _ ] => specialize (H H') + | [ H : ?T -> _, H' : ~?T |- _ ] => clear H + | [ H : ~?T -> _, H' : ?T |- _ ] => clear H + | [ H : ?A -> ?x = ?x -> _ |- _ ] => specialize (fun a => H a eq_refl) + | [ H : ?A -> ?x <> ?x -> _ |- _ ] => clear H + | [ H : ?A -> ?x < ?x -> _ |- _ ] => clear H + | [ H : ?A -> ?B -> _, H' : ?B |- _ ] => specialize (fun a => H a H') + | [ H : ?A -> ?B -> _, H' : ~?B |- _ ] => clear H + | [ H : ?A -> ~?B -> _, H' : ?B |- _ ] => clear H + | [ H : 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : ?A -> 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?A -> ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : ?A -> 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?A -> ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H + | [ H : ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H + | [ H : ?A -> 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H + | [ H : ?A -> ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H + | [ H : 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x (eq_sym pf))) + | [ H : ?A -> 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl 0 x (eq_sym pf))) + | [ H : ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x pf)) + | [ H : ?A -> ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl x 0 pf)) + | [ H : ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H + | [ H : ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H + | [ H : ?A -> ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H + | [ H : ?A -> ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H + | [ H : ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H + | [ H : ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H + | [ H : ?A -> ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H + | [ H : ?A -> ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H + end. + Ltac div_mod_to_equations := div_mod_to_equations'; euclidean_division_equations_cleanup. + Ltac quot_rem_to_equations := quot_rem_to_equations'; euclidean_division_equations_cleanup. + Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. +End Z. (** * zify: the Z-ification tactic *) @@ -411,6 +525,24 @@ Ltac zify_N_op := | |- context [ Z.of_N (N.mul ?a ?b) ] => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * + (* N.div -> Z.div and a positivity hypothesis *) + | H : context [ Z.of_N (N.div ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * + | |- context [ Z.of_N (N.div ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * + + (* N.modulo -> Z.rem / Z.modulo and a positivity hypothesis (N.modulo agrees with Z.modulo on everything except 0; so we pose both the non-zero proof for this agreement, but also replace things with [Z.rem]) *) + | H : context [ Z.of_N (N.modulo ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.modulo a b)); + pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + rewrite (N2Z.inj_rem a b) in * + | |- context [ Z.of_N (N.div ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.modulo a b)); + pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + rewrite (N2Z.inj_rem a b) in * + (* atoms of type N : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 65201d922f..3f69701bd3 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -153,7 +153,7 @@ let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context univs vars in - let univs = Monomorphic_const_entry univs in + let univs = Monomorphic_entry univs in mkConst(declare_constant (Id.of_string na) (DefinitionEntry (definition_entry ~opaque:true ~univs c), IsProof Lemma)) 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/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 191a4e9a20..d083d34b52 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -596,26 +596,6 @@ VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF Ssrview.AdaptorDb.declare k hints } END -(** Canonical Structure alias *) - -GRAMMAR EXTEND Gram - GLOBAL: gallina_ext; - - gallina_ext: - (* Canonical structure *) - [[ IDENT "Canonical"; qid = Constr.global -> - { Vernacexpr.VernacCanonical (CAst.make @@ AN qid) } - | IDENT "Canonical"; ntn = Prim.by_notation -> - { Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) } - | IDENT "Canonical"; qid = Constr.global; - d = G_vernac.def_body -> - { let s = coerce_reference_to_id qid in - Vernacexpr.VernacDefinition - ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), - ((CAst.make (Name s)),None), d) } - ]]; -END - (** Keyword compatibility fixes. *) (* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 4ddaeb49fd..d1c7a23e99 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) + { open Ltac_plugin diff --git a/plugins/ssrmatching/g_ssrmatching.mli b/plugins/ssrmatching/g_ssrmatching.mli index 588a1a3eac..65ea3f79c8 100644 --- a/plugins/ssrmatching/g_ssrmatching.mli +++ b/plugins/ssrmatching/g_ssrmatching.mli @@ -1,5 +1,14 @@ -(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) open Genarg open Ssrmatching diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index efd65ade15..552a4048b1 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -312,7 +312,8 @@ let iter_constr_LR f c = match kind c with | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ + | Int _) -> () (* The comparison used to determine which subterms matches is KEYED *) (* CONVERSION. This looks for convertible terms that either have the same *) diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml deleted file mode 100644 index e34a401c2c..0000000000 --- a/plugins/syntax/int31_syntax.ml +++ /dev/null @@ -1,114 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "int31_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -(* digit-based syntax for int31 *) - -open Bigint -open Names -open Globnames -open Glob_term - -(*** Constants for locating int31 constructors ***) - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -let make_mind mp id = Names.MutInd.make2 mp (Label.make id) -let make_mind_mpfile dir id = make_mind (ModPath.MPfile (make_dir dir)) id -let make_mind_mpdot dir modname id = - let mp = ModPath.MPdot (ModPath.MPfile (make_dir dir), Label.make modname) - in make_mind mp id - - -(* int31 stuff *) -let int31_module = ["Coq"; "Numbers"; "Cyclic"; "Int31"; "Int31"] -let int31_path = make_path int31_module "int31" -let int31_id = make_mind_mpfile int31_module -let int31_scope = "int31_scope" - -let int31_construct = ConstructRef ((int31_id "int31",0),1) - -let int31_0 = ConstructRef ((int31_id "digits",0),1) -let int31_1 = ConstructRef ((int31_id "digits",0),2) - -(*** Definition of the Non_closed exception, used in the pretty printing ***) -exception Non_closed - -(*** Parsing for int31 in digital notation ***) - -(* parses a *non-negative* integer (from bigint.ml) into an int31 - wraps modulo 2^31 *) -let int31_of_pos_bigint ?loc n = - let ref_construct = DAst.make ?loc (GRef (int31_construct, None)) in - let ref_0 = DAst.make ?loc (GRef (int31_0, None)) in - let ref_1 = DAst.make ?loc (GRef (int31_1, None)) in - let rec args counter n = - if counter <= 0 then - [] - else - let (q,r) = div2_with_rest n in - (if r then ref_1 else ref_0)::(args (counter-1) q) - in - DAst.make ?loc (GApp (ref_construct, List.rev (args 31 n))) - -let error_negative ?loc = - CErrors.user_err ?loc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") - -let interp_int31 ?loc n = - if is_pos_or_zero n then - int31_of_pos_bigint ?loc n - else - error_negative ?loc - -(* Pretty prints an int31 *) - -let bigint_of_int31 = - let rec args_parsing args cur = - match args with - | [] -> cur - | r::l when is_gr r int31_0 -> args_parsing l (mult_2 cur) - | r::l when is_gr r int31_1 -> args_parsing l (add_1 (mult_2 cur)) - | _ -> raise Non_closed - in - fun c -> match DAst.get c with - | GApp (r, args) when is_gr r int31_construct -> args_parsing args zero - | _ -> raise Non_closed - -let uninterp_int31 (AnyGlobConstr i) = - try - Some (bigint_of_int31 i) - with Non_closed -> - None - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -(* Actually declares the interpreter for int31 *) - -let _ = - register_bignumeral_interpretation int31_scope (interp_int31,uninterp_int31); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = int31_scope; - pt_interp_info = Uid int31_scope; - pt_required = (int31_path,int31_module); - pt_refs = [int31_construct]; - pt_in_match = true } diff --git a/plugins/syntax/int31_syntax_plugin.mlpack b/plugins/syntax/int31_syntax_plugin.mlpack deleted file mode 100644 index 54a5bc0cd1..0000000000 --- a/plugins/syntax/int31_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Int31_syntax diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml new file mode 100644 index 0000000000..992b7a986b --- /dev/null +++ b/plugins/syntax/int63_syntax.ml @@ -0,0 +1,55 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + + +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "int63_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + +(* digit-based syntax for int63 *) + +open Names +open Libnames + +(*** Constants for locating int63 constructors ***) + +let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.Int63.int" +let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.Int63.id_int" + +let make_dir l = DirPath.make (List.rev_map Id.of_string l) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +(* int63 stuff *) +let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "Int63"] +let int63_path = make_path int63_module "int" +let int63_scope = "int63_scope" + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + +(* Actually declares the interpreter for int63 *) + +let _ = + let open Notation in + at_declare_ml_module + (fun () -> + let id_int63 = Nametab.locate q_id_int63 in + let o = { to_kind = Int63, Direct; + to_ty = id_int63; + of_kind = Int63, Direct; + of_ty = id_int63; + ty_name = q_int63; + warning = Nop } in + enable_prim_token_interpretation + { pt_local = false; + pt_scope = int63_scope; + pt_interp_info = NumeralNotation o; + pt_required = (int63_path, int63_module); + pt_refs = []; + pt_in_match = false }) + () diff --git a/plugins/syntax/int63_syntax_plugin.mlpack b/plugins/syntax/int63_syntax_plugin.mlpack new file mode 100644 index 0000000000..d83d554fe6 --- /dev/null +++ b/plugins/syntax/int63_syntax_plugin.mlpack @@ -0,0 +1 @@ +Int63_syntax diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index ea564ae2ba..0c6d2ac0d1 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -69,6 +69,14 @@ let locate_int () = }, mkRefC q_int, mkRefC q_uint) else None +let locate_int63 () = + let int63n = "num.int63.type" in + if Coqlib.has_ref int63n + then + let q_int63 = qualid_of_ref int63n in + Some (mkRefC q_int63) + else None + let has_type f ty = let (sigma, env) = Pfedit.get_current_context () in let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in @@ -79,17 +87,18 @@ let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Decimal.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first).") + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ - str "Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first).") + str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") let vernac_numeral_notation local ty f g scope opts = let int_ty = locate_int () in let z_pos_ty = locate_z () in + let int63_ty = locate_int63 () in let tyc = Smartlocate.global_inductive_with_alias ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in @@ -111,6 +120,10 @@ let vernac_numeral_notation local ty f g scope opts = match z_pos_ty with | Some (z_pos_ty, cZ) when has_type f (arrow cZ cty) -> Z z_pos_ty, Direct | Some (z_pos_ty, cZ) when has_type f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type f (arrow cint63 cty) -> Int63, Direct + | Some cint63 when has_type f (arrow cint63 (opt cty)) -> Int63, Option | _ -> type_error_to f ty in (* Check the type of g *) @@ -124,6 +137,10 @@ let vernac_numeral_notation local ty f g scope opts = match z_pos_ty with | Some (z_pos_ty, cZ) when has_type g (arrow cty cZ) -> Z z_pos_ty, Direct | Some (z_pos_ty, cZ) when has_type g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type g (arrow cty cint63) -> Int63, Direct + | Some cint63 when has_type g (arrow cty (opt cint63)) -> Int63, Option | _ -> type_error_of g ty in let o = { to_kind; to_ty; of_kind; of_ty; diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index 1ab16c700d..aac46338ea 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -20,8 +20,8 @@ (libraries coq.vernac)) (library - (name int31_syntax_plugin) - (public_name coq.plugins.int31_syntax) - (synopsis "Coq syntax plugin: int31") - (modules int31_syntax) + (name int63_syntax_plugin) + (public_name coq.plugins.int63_syntax) + (synopsis "Coq syntax plugin: int63") + (modules int63_syntax) (libraries coq.vernac)) diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 0ace11839e..08df9a2460 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -43,7 +43,7 @@ let subst_rename_args (subst, (_, (r, names as orig))) = if r==r' then orig else (r', names) let discharge_rename_args = function - | _, (ReqGlobal (c, names), _ as req) -> + | _, (ReqGlobal (c, names), _ as req) when not (isVarRef c && Lib.is_in_section c) -> (try let vars = Lib.variable_section_segment_of_reference c in let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in 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/cbv.ml b/pretyping/cbv.ml index f8289f558c..e27fc536eb 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -38,6 +38,10 @@ open Esubst * the bindings S, and then applied to args. Here again, * weak reduction. * CONSTR(c,args) is the constructor [c] applied to [args]. + * PRIMITIVE(cop,args) represent a particial application of + * a primitive, or a fully applied primitive + * which does not reduce. + * cop is the constr representing op. * *) type cbv_value = @@ -48,6 +52,7 @@ type cbv_value = | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array + | PRIMITIVE of CPrimitives.t * constr * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -90,6 +95,9 @@ let rec shift_value n = function COFIXP (cofix,subs_shft (n,s), Array.map (shift_value n) args) | CONSTR (c,args) -> CONSTR (c, Array.map (shift_value n) args) + | PRIMITIVE(op,c,args) -> + PRIMITIVE(op,c,Array.map (shift_value n) args) + let shift_value n v = if Int.equal n 0 then v else shift_value n v @@ -109,10 +117,11 @@ let contract_cofixp env (i,(_,_,bds as bodies)) = let n = Array.length bds in subs_cons(Array.init n make_body, env), bds.(i) -let make_constr_ref n = function +let make_constr_ref n k t = + match k with | RelKey p -> mkRel (n+p) - | VarKey id -> mkVar id - | ConstKey cst -> mkConstU cst + | VarKey id -> t + | ConstKey cst -> t (* Adds an application list. Collapse APPs! *) let stack_app appl stack = @@ -136,7 +145,7 @@ let mkSTACK = function type cbv_infos = { env : Environ.env; - tab : cbv_value KeyTable.t; + tab : cbv_value Declarations.constant_def KeyTable.t; reds : RedFlags.reds; sigma : Evd.evar_map } @@ -159,7 +168,8 @@ let strip_appl head stack = | FIXP (fix,env,app) -> (FIXP(fix,env,[||]), stack_app app stack) | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[||]), stack_app app stack) | CONSTR (c,app) -> (CONSTR(c,[||]), stack_app app stack) - | _ -> (head, stack) + | PRIMITIVE(op,c,app) -> (PRIMITIVE(op,c,[||]), stack_app app stack) + | VAL _ | STACK _ | CBN _ | LAM _ -> (head, stack) (* Tests if fixpoint reduction is possible. *) @@ -189,6 +199,60 @@ let get_debug_cbv = Goptions.declare_bool_option_and_ref ~name:"cbv visited constants display" ~key:["Debug";"Cbv"] +(* Reduction of primitives *) + +open Primred + +module VNativeEntries = + struct + + type elem = cbv_value + type args = cbv_value array + type evd = unit + + let get = Array.get + + let get_int () e = + match e with + | VAL(_, ci) -> + (match kind ci with + | Int i -> i + | _ -> raise Primred.NativeDestKO) + | _ -> raise Primred.NativeDestKO + + let mkInt env i = VAL(0, mkInt i) + + let mkBool env b = + let (ct,cf) = get_bool_constructors env in + CONSTR(Univ.in_punivs (if b then ct else cf), [||]) + + let int_ty env = VAL(0, mkConst @@ get_int_type env) + + let mkCarry env b e = + let (c0,c1) = get_carry_constructors env in + CONSTR(Univ.in_punivs (if b then c1 else c0), [|int_ty env;e|]) + + let mkIntPair env e1 e2 = + let int_ty = int_ty env in + let c = get_pair_constructor env in + CONSTR(Univ.in_punivs c, [|int_ty;int_ty;e1;e2|]) + + let mkLt env = + let (_eq,lt,_gt) = get_cmp_constructors env in + CONSTR(Univ.in_punivs lt, [||]) + + let mkEq env = + let (eq,_lt,_gt) = get_cmp_constructors env in + CONSTR(Univ.in_punivs eq, [||]) + + let mkGt env = + let (_eq,_lt,gt) = get_cmp_constructors env in + CONSTR(Univ.in_punivs gt, [||]) + + end + +module VredNative = RedNative(VNativeEntries) + let debug_pr_key = function | ConstKey (sp,_) -> Names.Constant.print sp | VarKey id -> Names.Id.print id @@ -225,6 +289,8 @@ and reify_value = function (* reduction under binders *) mkApp (apply_env env cofix, Array.map reify_value args) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map reify_value args) + | PRIMITIVE(op,c,args) -> + mkApp(c, Array.map reify_value args) and apply_env env t = match kind t with @@ -277,14 +343,14 @@ let rec norm_head info env t stack = | Inl (0,v) -> strip_appl v stack | Inl (n,v) -> strip_appl (shift_value n v) stack | Inr (n,None) -> (VAL(0, mkRel n), stack) - | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (RelKey p)) + | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (RelKey p) t) - | Var id -> norm_head_ref 0 info env stack (VarKey id) + | Var id -> norm_head_ref 0 info env stack (VarKey id) t | Const sp -> Reductionops.reduction_effect_hook info.env info.sigma (fst sp) (lazy (reify_stack t stack)); - norm_head_ref 0 info env stack (ConstKey sp) + norm_head_ref 0 info env stack (ConstKey sp) t | LetIn (_, b, _, c) -> (* zeta means letin are contracted; delta without zeta means we *) @@ -315,22 +381,23 @@ let rec norm_head info env t stack = | Construct c -> (CONSTR(c, [||]), stack) (* neutral cases *) - | (Sort _ | Meta _ | Ind _) -> (VAL(0, t), stack) + | (Sort _ | Meta _ | Ind _ | Int _) -> (VAL(0, t), stack) | Prod _ -> (CBN(t,env), stack) -and norm_head_ref k info env stack normt = +and norm_head_ref k info env stack normt t = if red_set_ref info.reds normt then match cbv_value_cache info normt with - | Some body -> + | Declarations.Def body -> if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); strip_appl (shift_value k body) stack - | None -> + | Declarations.Primitive op -> (PRIMITIVE(op,t,[||]),stack) + | Declarations.OpaqueDef _ | Declarations.Undef _ -> if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); - (VAL(0,make_constr_ref k normt),stack) + (VAL(0,make_constr_ref k normt t),stack) else begin if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); - (VAL(0,make_constr_ref k normt),stack) + (VAL(0,make_constr_ref k normt t),stack) end (* cbv_stack_term performs weak reduction on constr t under the subs @@ -392,32 +459,58 @@ and cbv_stack_value info env = function | (COFIXP(cofix,env,[||]), APP(appl,TOP)) -> COFIXP(cofix,env,appl) | (CONSTR(c,[||]), APP(appl,TOP)) -> CONSTR(c,appl) + (* primitive apply to arguments *) + | (PRIMITIVE(op,c,[||]), APP(appl,stk)) -> + let nargs = CPrimitives.arity op in + let len = Array.length appl in + if nargs <= len then + let args = + if len = nargs then appl + else Array.sub appl 0 nargs in + let stk = + if nargs < len then + stack_app (Array.sub appl nargs (len - nargs)) stk + else stk in + match VredNative.red_prim info.env () op args with + | Some (CONSTR (c, args)) -> + (* args must be moved to the stack to allow future reductions *) + cbv_stack_value info env (CONSTR(c, [||]), stack_app args stk) + | Some v -> cbv_stack_value info env (v,stk) + | None -> mkSTACK(PRIMITIVE(op,c,args), stk) + else (* partical application *) + (assert (stk = TOP); + PRIMITIVE(op,c,appl)) + (* definitely a value *) | (head,stk) -> mkSTACK(head, stk) -and cbv_value_cache info ref = match KeyTable.find info.tab ref with -| v -> Some v -| exception Not_found -> - try - let body = match ref with - | RelKey n -> - let open Context.Rel.Declaration in - begin match Environ.lookup_rel n info.env with - | LocalDef (_, c, _) -> lift n c - | LocalAssum _ -> raise Not_found - end - | VarKey id -> - let open Context.Named.Declaration in - begin match Environ.lookup_named id info.env with - | LocalDef (_, c, _) -> c - | LocalAssum _ -> raise Not_found - end - | ConstKey cst -> Environ.constant_value_in info.env cst +and cbv_value_cache info ref = + try KeyTable.find info.tab ref with + Not_found -> + let v = + try + let body = match ref with + | RelKey n -> + let open Context.Rel.Declaration in + begin match Environ.lookup_rel n info.env with + | LocalDef (_, c, _) -> lift n c + | LocalAssum _ -> raise Not_found + end + | VarKey id -> + let open Context.Named.Declaration in + begin match Environ.lookup_named id info.env with + | LocalDef (_, c, _) -> c + | LocalAssum _ -> raise Not_found + end + | ConstKey cst -> Environ.constant_value_in info.env cst + in + let v = cbv_stack_term info TOP (subs_id 0) body in + Declarations.Def v + with + | Environ.NotEvaluableConst (Environ.IsPrimitive op) -> Declarations.Primitive op + | Not_found | Environ.NotEvaluableConst _ -> Declarations.Undef None in - let v = cbv_stack_term info TOP (subs_id 0) body in - let () = KeyTable.add info.tab ref v in - Some v - with Not_found | Environ.NotEvaluableConst _ -> None + KeyTable.add info.tab ref v; v (* When we are sure t will never produce a redex with its stack, we * normalize (even under binders) the applied terms and we build the @@ -471,6 +564,8 @@ and cbv_norm_value info = function (* reduction under binders *) Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) + | PRIMITIVE(op,c,args) -> + mkApp(c,Array.map (cbv_norm_value info) args) (* with profiling *) let cbv_norm infos constr = diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 83844c95a7..0a1e771921 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -36,6 +36,7 @@ type cbv_value = | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array + | PRIMITIVE of CPrimitives.t * Constr.t * cbv_value array and cbv_stack = | TOP diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 4d1d405bd7..2329b87acc 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 = @@ -434,7 +434,7 @@ let inh_tosort_force ?loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in let evd,j1 = apply_coercion env evd p j t in - let j2 = on_judgment_type (whd_evar evd) j1 in + let j2 = Environ.on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env evd j2) with Not_found | NoCoercion -> error_not_a_type ?loc env evd 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/constr_matching.ml b/pretyping/constr_matching.ml index 032e4bbf85..94257fedd7 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -410,9 +410,10 @@ let matches_core env sigma allow_bound_rels | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> Array.fold_left2 (sorec ctx env) subst args1 args2 + | PInt i1, Int i2 when Uint63.equal i1 i2 -> subst | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PIf _ | PCase _ - | PFix _ | PCoFix _| PEvar _), _ -> raise PatternMatchingFailure + | PFix _ | PCoFix _| PEvar _ | PInt _), _ -> raise PatternMatchingFailure in sorec [] env ((Id.Map.empty,Id.Set.empty), Id.Map.empty) pat c @@ -530,7 +531,7 @@ let sub_match ?(closed=true) env sigma pat c = aux env term mk_ctx next with Retyping.RetypeError _ -> next () end - | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> + | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ | Int _ -> next () in here next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 517834f014..99cd89cc2a 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module CVars = Vars - open Pp open CErrors open Util @@ -175,16 +173,6 @@ let () = declare_bool_option optread = print_primproj_params; optwrite = (:=) print_primproj_params_value } -let print_primproj_compatibility_value = ref false -let print_primproj_compatibility () = !print_primproj_compatibility_value - -let () = declare_bool_option - { optdepr = false; - optname = "backwards-compatible printing of primitive projections"; - optkey = ["Printing";"Primitive";"Projection";"Compatibility"]; - optread = print_primproj_compatibility; - optwrite = (:=) print_primproj_compatibility_value } - (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) @@ -702,30 +690,12 @@ and detype_r d flags avoid env sigma t = GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), [detype d flags avoid env sigma c]) else - if print_primproj_compatibility () && Projection.unfolded p then - (* Print the compatibility match version *) - let c' = - try - let ind = Projection.inductive p in - let bodies = Inductiveops.legacy_match_projection (snd env) ind in - let body = bodies.(Projection.arg p) in - let ty = Retyping.get_type_of (snd env) sigma c in - let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in - let body' = strip_lam_assum body in - let u = EInstance.kind sigma u in - let body' = CVars.subst_instance_constr u body' in - let body' = EConstr.of_constr body' in - substl (c :: List.rev args) body' - with Retyping.RetypeError _ | Not_found -> - anomaly (str"Cannot detype an unfolded primitive projection.") - in DAst.get (detype d flags avoid env sigma c') - else - if print_primproj_params () then - try - let c = Retyping.expand_projection (snd env) sigma p c [] in - DAst.get (detype d flags avoid env sigma c) - with Retyping.RetypeError _ -> noparams () - else noparams () + if print_primproj_params () then + try + let c = Retyping.expand_projection (snd env) sigma p c [] in + DAst.get (detype d flags avoid env sigma c) + with Retyping.RetypeError _ -> noparams () + else noparams () | Evar (evk,cl) -> let bound_to_itself_or_letin decl c = @@ -739,7 +709,7 @@ and detype_r d flags avoid env sigma t = let id,l = try let id = match Evd.evar_ident evk sigma with - | None -> Termops.pr_evar_suggested_name evk sigma + | None -> Termops.evar_suggested_name evk sigma | Some id -> id in let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in @@ -766,6 +736,7 @@ and detype_r d flags avoid env sigma t = p c bl | Fix (nvn,recdef) -> detype_fix (detype d flags) avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d flags) avoid env sigma n recdef + | Int i -> GInt i and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try @@ -959,6 +930,7 @@ let rec subst_glob_constr subst = DAst.map (function | GSort _ | GVar _ | GEvar _ + | GInt _ | GPatVar _ as raw -> raw | GApp (r,rl) as raw -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index ed28cc7725..bb163ddaee 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -107,7 +107,7 @@ let flex_kind_of_term ts env evd c sk = Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env evd c) | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c | Evar ev -> Flexible ev - | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid + | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false @@ -127,7 +127,7 @@ let occur_rigidly (evk,_ as ev) evd t = let rec aux t = match EConstr.kind evd t with | App (f, c) -> if aux f then Array.exists aux c else false - | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ -> true + | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ | Int _ -> true | Proj (p, c) -> not (aux c) | Evar (evk',_) -> if Evar.equal evk evk' then raise Occur else false | Cast (p, _, _) -> aux p @@ -468,17 +468,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let u = EInstance.kind evd u and u' = EInstance.kind evd u' in let mind = Environ.lookup_mind mi env in let open Declarations in - begin match mind.mind_universes with - | Monomorphic_ind _ -> assert false - | Polymorphic_ind _ -> check_strict evd u u' - | Cumulative_ind cumi -> + begin match mind.mind_variance with + | None -> check_strict evd u u' + | Some variances -> let nparamsaplied = Stack.args_size sk in let nparamsaplied' = Stack.args_size sk' in let needed = Reduction.inductive_cumulativity_arguments (mind,i) in if not (Int.equal nparamsaplied needed && Int.equal nparamsaplied' needed) then check_strict evd u u' else - compare_cumulative_instances evd (Univ.ACumulativityInfo.variance cumi) u u' + compare_cumulative_instances evd variances u u' end | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') @@ -488,10 +487,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let u = EInstance.kind evd u and u' = EInstance.kind evd u' in let mind = Environ.lookup_mind mi env in let open Declarations in - begin match mind.mind_universes with - | Monomorphic_ind _ -> assert false - | Polymorphic_ind _ -> check_strict evd u u' - | Cumulative_ind cumi -> + begin match mind.mind_variance with + | None -> check_strict evd u u' + | Some variances -> let nparamsaplied = Stack.args_size sk in let nparamsaplied' = Stack.args_size sk' in let needed = Reduction.constructor_cumulativity_arguments (mind,ind,ctor) in @@ -769,7 +767,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) let rec is_unnamed (hd, args) = match EConstr.kind i hd with - | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) -> + | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _) -> Stack.not_purely_applicative args | (CoFix _|Meta _|Rel _)-> true | Evar _ -> Stack.not_purely_applicative args @@ -887,8 +885,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Const _, Const _ | Ind _, Ind _ - | Construct _, Construct _ -> - rigids env evd sk1 term1 sk2 term2 + | Construct _, Construct _ + | Int _, Int _ -> + rigids env evd sk1 term1 sk2 term2 | Construct u, _ -> eta_constructor ts env evd sk1 u sk2 term2 @@ -923,9 +922,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) end - | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _), _ -> - UnifFailure (evd,NotSameHead) - | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _) -> + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _), _ -> UnifFailure (evd,NotSameHead) | (App _ | Cast _ | Case _ | Proj _), _ -> assert false 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/glob_ops.ml b/pretyping/glob_ops.ml index e14766f370..68626597fc 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -152,8 +152,10 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with Namegen.intro_pattern_naming_eq nam1 nam2 | GCast (c1, t1), GCast (c2, t2) -> f c1 c2 && cast_type_eq f t1 t2 + | GInt i1, GInt i2 -> Uint63.equal i1 i2 | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | - GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ ), _ -> false + GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ | + GInt _), _ -> false let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c @@ -214,7 +216,7 @@ let map_glob_constr_left_to_right f = DAst.map (function let comp1 = f c in let comp2 = map_cast_type f k in GCast (comp1,comp2) - | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x + | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) as x -> x ) let map_glob_constr = map_glob_constr_left_to_right @@ -246,9 +248,8 @@ let fold_glob_constr f acc = DAst.with_val (function let acc = match k with | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in f acc c - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) -> acc ) - let fold_return_type_with_binders f g v acc (na,tyopt) = Option.fold_left (f (Name.fold_right g na v)) acc tyopt @@ -289,7 +290,7 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function let acc = match k with | CastConv t | CastVM t | CastNative t -> f v acc t | CastCoerce -> acc in f v acc c - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc)) + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) -> acc)) let iter_glob_constr f = fold_glob_constr (fun () -> f) () @@ -484,7 +485,11 @@ let is_gvar id c = match DAst.get c with | GVar id' -> Id.equal id id' | _ -> false -let rec cases_pattern_of_glob_constr na = DAst.map (function +let rec cases_pattern_of_glob_constr na c = + (* Forcing evaluation to ensure that the possible raising of + Not_found is not delayed *) + let c = DAst.force c in + DAst.map (function | GVar id -> begin match na with | Name _ -> @@ -497,6 +502,8 @@ let rec cases_pattern_of_glob_constr na = DAst.map (function | GApp (c, l) -> begin match DAst.get c with | GRef (ConstructRef cstr,_) -> + let nparams = Inductiveops.inductive_nparams (fst cstr) in + let _,l = List.chop nparams l in PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found end @@ -504,7 +511,7 @@ let rec cases_pattern_of_glob_constr na = DAst.map (function (* A canonical encoding of aliases *) DAst.get (cases_pattern_of_glob_constr na' b) | _ -> raise Not_found - ) + ) c open Declarations open Term diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 91a2ef9c1e..c189a3bcb2 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -89,6 +89,7 @@ val map_pattern : (glob_constr -> glob_constr) -> (** Conversion from glob_constr to cases pattern, if possible + Evaluation is forced. Take the current alias as parameter, @raise Not_found if translation is impossible *) val cases_pattern_of_glob_constr : Name.t -> 'a glob_constr_g -> 'a cases_pattern_g diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index c405fcfc72..8670c1d964 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -82,6 +82,7 @@ type 'a glob_constr_r = | GSort of glob_sort | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type + | GInt of Uint63.t and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g diff --git a/pretyping/heads.ml b/pretyping/heads.ml index ccbb2934bc..cdeec875a2 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -91,6 +91,7 @@ let kind_of_head env t = | Proj (p,c) -> RigidHead RigidOther | Case (_,_,c,_) -> aux k [] c true + | Int _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in try aux k [] (List.nth l n) true diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index ff552c7caf..4c02dc0f09 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -453,12 +453,7 @@ let build_branch_type env sigma dep p cs = let compute_projections env (kn, i as ind) = let open Term in let mib = Environ.lookup_mind kn env in - let u = match mib.mind_universes with - | Monomorphic_ind _ -> Instance.empty - | Polymorphic_ind auctx -> make_abstract_instance auctx - | Cumulative_ind acumi -> - make_abstract_instance (ACumulativityInfo.univ_context acumi) - in + let u = make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let x = match mib.mind_record with | NotRecord | FakeRecord -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") @@ -480,25 +475,6 @@ let compute_projections env (kn, i as ind) = (* [Ind inst] is typed in context [params-wo-let] *) ty in - let ci = - let print_info = - { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in - { ci_ind = ind; - ci_npar = nparamargs; - ci_cstr_ndecls = pkt.mind_consnrealdecls; - ci_cstr_nargs = pkt.mind_consnrealargs; - ci_pp_info = print_info } - in - let len = List.length ctx in - let compat_body ccl i = - (* [ccl] is defined in context [params;x:indty] *) - (* [ccl'] is defined in context [params;x:indty;x:indty] *) - let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 indty, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in - let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in - it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params - in let projections decl (proj_arg, j, pbs, subst) = match decl with | LocalDef (na,c,t) -> @@ -528,10 +504,9 @@ let compute_projections env (kn, i as ind) = let ty = substl subst t in let term = mkProj (Projection.make kn true, mkRel 1) in let fterm = mkProj (Projection.make kn false, mkRel 1) in - let compat = compat_body ty (j - 1) in let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in - let body = (etab, etat, compat) in + let body = (etab, etat) in (proj_arg + 1, j + 1, body :: pbs, fterm :: subst) | Anonymous -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") @@ -541,13 +516,6 @@ let compute_projections env (kn, i as ind) = in Array.rev_of_list pbs -let legacy_match_projection env ind = - Array.map pi3 (compute_projections env ind) - -let compute_projections ind mib = - let ans = compute_projections ind mib in - Array.map (fun (prj, ty, _) -> (prj, ty)) ans - (**************************************************) let extract_mrectype sigma t = diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index b2e205115f..5a4257e175 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -194,14 +194,6 @@ val compute_projections : Environ.env -> inductive -> (constr * types) array (** Given a primitive record type, for every field computes the eta-expanded projection and its type. *) -val legacy_match_projection : Environ.env -> inductive -> constr array -(** Given a record type, computes the legacy match-based projection of the - projections. - - BEWARE: such terms are ill-typed, and should thus only be used in upper - layers. The kernel will probably badly fail if presented with one of - those. *) - (********************) val type_of_inductive_knowing_conclusion : diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index e46d03b743..bf8a38a353 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -41,33 +41,31 @@ let variance_pb cv_pb var = | CONV, Covariant -> Invariant | CUMUL, Covariant -> Covariant -let infer_cumulative_ind_instance cv_pb cumi variances u = +let infer_cumulative_ind_instance cv_pb mind_variance variances u = Array.fold_left2 (fun variances varu u -> match LMap.find u variances with | exception Not_found -> variances | varu' -> LMap.set u (Variance.sup varu' (variance_pb cv_pb varu)) variances) - variances (ACumulativityInfo.variance cumi) (Instance.to_array u) + variances mind_variance (Instance.to_array u) let infer_inductive_instance cv_pb env variances ind nargs u = let mind = Environ.lookup_mind (fst ind) env in - match mind.mind_universes with - | Monomorphic_ind _ -> assert (Instance.is_empty u); variances - | Polymorphic_ind _ -> infer_generic_instance_eq variances u - | Cumulative_ind cumi -> + match mind.mind_variance with + | None -> infer_generic_instance_eq variances u + | Some mind_variance -> if not (Int.equal (inductive_cumulativity_arguments (mind,snd ind)) nargs) then infer_generic_instance_eq variances u - else infer_cumulative_ind_instance cv_pb cumi variances u + else infer_cumulative_ind_instance cv_pb mind_variance variances u let infer_constructor_instance_eq env variances ((mi,ind),ctor) nargs u = let mind = Environ.lookup_mind mi env in - match mind.mind_universes with - | Monomorphic_ind _ -> assert (Instance.is_empty u); variances - | Polymorphic_ind _ -> infer_generic_instance_eq variances u - | Cumulative_ind cumi -> + match mind.mind_variance with + | None -> infer_generic_instance_eq variances u + | Some _ -> if not (Int.equal (constructor_cumulativity_arguments (mind,ind,ctor)) nargs) then infer_generic_instance_eq variances u - else infer_cumulative_ind_instance CONV cumi variances u + else variances (* constructors are convertible at common supertype *) let infer_sort cv_pb variances s = match cv_pb with @@ -100,6 +98,7 @@ let rec infer_fterm cv_pb infos variances hd stk = let variances = infer_stack infos variances stk in infer_vect infos variances (Array.map (mk_clos e) args) | FRel _ -> infer_stack infos variances stk + | FInt _ -> infer_stack infos variances stk | FFlex fl -> let variances = infer_table_key infos variances fl in infer_stack infos variances stk @@ -155,6 +154,10 @@ and infer_stack infos variances (stk:CClosure.stack) = infer_vect infos variances (Array.map (mk_clos e) br) | Zshift _ -> variances | Zupdate _ -> variances + | Zprimitive (_,_,rargs,kargs) -> + let variances = List.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances rargs in + let variances = List.fold_left (fun variances (_,c) -> infer_fterm CONV infos variances c []) variances kargs in + variances in infer_stack infos variances stk @@ -184,12 +187,14 @@ let infer_inductive env mie = let { mind_entry_params = params; mind_entry_inds = entries; } = mie in - let univs = - match mie.mind_entry_universes with - | Monomorphic_ind_entry _ - | Polymorphic_ind_entry _ as univs -> univs - | Cumulative_ind_entry (nas, cumi) -> - let uctx = CumulativityInfo.univ_context cumi in + let variances = + match mie.mind_entry_variance with + | None -> None + | Some _ -> + let uctx = match mie.mind_entry_universes with + | Monomorphic_entry _ -> assert false + | Polymorphic_entry (_,uctx) -> uctx + in let uarray = Instance.to_array @@ UContext.instance uctx in let env = Environ.push_context uctx env in let variances = @@ -207,6 +212,10 @@ let infer_inductive env mie = entries in let variances = Array.map (fun u -> LMap.find u variances) uarray in - Cumulative_ind_entry (nas, CumulativityInfo.make (uctx, variances)) + Some variances in - { mie with mind_entry_universes = univs } + { mie with mind_entry_variance = variances } + +let dummy_variance = let open Entries in function + | Monomorphic_entry _ -> assert false + | Polymorphic_entry (_,uctx) -> Array.make (UContext.size uctx) Variance.Irrelevant diff --git a/pretyping/inferCumulativity.mli b/pretyping/inferCumulativity.mli index a0c8d339ac..6e5bf30f6b 100644 --- a/pretyping/inferCumulativity.mli +++ b/pretyping/inferCumulativity.mli @@ -10,3 +10,5 @@ val infer_inductive : Environ.env -> Entries.mutual_inductive_entry -> Entries.mutual_inductive_entry + +val dummy_variance : Entries.universes_entry -> Univ.Variance.t array diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index dc2663c1ca..b7090e69da 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -120,13 +120,6 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params = Array.sub allargs 0 nparams in - try - if const then - let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(0)) params in - Retroknowledge.get_vm_decompile_constant_info env.retroknowledge (GlobRef.IndRef ind) tag, ctyp - else - raise Not_found - with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstructU((ind,i),u), params), ctyp) @@ -137,7 +130,9 @@ let construct_of_constr const env sigma tag typ = match EConstr.kind_upto sigma t with | Ind (ind,u) -> construct_of_constr_notnative const env tag ind u l - | _ -> assert false + | _ -> + assert (Constr.equal t (Typeops.type_of_int env)); + (mkInt (Uint63.of_int tag), t) let construct_of_constr_const env sigma tag typ = fst (construct_of_constr true env sigma tag typ) @@ -208,6 +203,7 @@ let rec nf_val env sigma v typ = let body = nf_val env sigma (f (mk_rel_accu lvl)) codom in mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env sigma n typ + | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vblock b -> let capp,ctyp = construct_of_constr_block env sigma (block_tag b) typ in let args = nf_bargs env sigma b ctyp in diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index be7ebe49cf..2ca7f21e8d 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -39,6 +39,7 @@ type constr_pattern = (int * bool list * constr_pattern) list (** index of constructor, nb of args *) | PFix of (int array * int) * (Name.t array * constr_pattern array * constr_pattern array) | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) + | PInt of Uint63.t (** Nota : in a [PCase], the array of branches might be shorter than expected, denoting the use of a final "_ => _" branch *) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 248d5d0a0e..6803ea7d9b 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -61,9 +61,11 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with Int.equal i1 i2 && rec_declaration_eq f1 f2 | PProj (p1, t1), PProj (p2, t2) -> Projection.equal p1 p2 && constr_pattern_eq t1 t2 +| PInt i1, PInt i2 -> + Uint63.equal i1 i2 | (PRef _ | PVar _ | PEvar _ | PRel _ | PApp _ | PSoApp _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PMeta _ - | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _), _ -> false + | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _ | PInt _), _ -> false (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = @@ -90,7 +92,8 @@ let rec occur_meta_pattern = function (occur_meta_pattern c) || (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) | PMeta _ | PSoApp _ -> true - | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false + | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ + | PInt _ -> false let rec occurn_pattern n = function | PRel p -> Int.equal n p @@ -111,7 +114,7 @@ let rec occurn_pattern n = function (List.exists (fun (_,_,p) -> occurn_pattern n p) br) | PMeta _ | PSoApp _ -> true | PEvar (_,args) -> Array.exists (occurn_pattern n) args - | PVar _ | PRef _ | PSort _ -> false + | PVar _ | PRef _ | PSort _ | PInt _ -> false | PFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl | PCoFix (_,(_,tl,bl)) -> @@ -134,7 +137,7 @@ let rec head_pattern_bound t = -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern - | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") + | PCoFix _ | PInt _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") let head_of_constr_reference sigma c = match EConstr.kind sigma c with | Const (sp,_) -> ConstRef sp @@ -209,7 +212,8 @@ let pattern_of_constr env sigma t = let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in PCoFix (ln,(lna,Array.map (pattern_of_constr env) tl, - Array.map (pattern_of_constr env') bl)) in + Array.map (pattern_of_constr env') bl)) + | Int i -> PInt i in pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -231,7 +235,7 @@ let map_pattern_with_binders g f l = function let l' = Array.fold_left (fun l na -> g na l) l lna in PCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) (* Non recursive *) - | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ as x) -> x + | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PInt _ as x) -> x let error_instantiate_pattern id l = let is = match l with @@ -287,7 +291,8 @@ let rec subst_pattern subst pat = pattern_of_constr env evd t.Univ.univ_abstracted_value) | PVar _ | PEvar _ - | PRel _ -> pat + | PRel _ + | PInt _ -> pat | PProj (p,c) -> let p' = Projection.map (subst_mind subst) p in let c' = subst_pattern subst c in @@ -488,6 +493,7 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function let names = Array.map (fun id -> Name id) ids in PCoFix (n, (names, tl, cl)) + | GInt i -> PInt i | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ -> err ?loc (Pp.str "Non supported pattern.")) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 01b0d96f98..dc6607557d 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -53,6 +53,7 @@ type pretype_error = | NonLinearUnification of Name.t * constr (* Pretyping *) | VarNotFound of Id.t + | EvarNotFound of Id.t | UnexpectedType of constr * constr | NotProduct of constr | TypingError of type_error @@ -167,6 +168,9 @@ let error_not_product ?loc env sigma c = let error_var_not_found ?loc env sigma s = raise_pretype_error ?loc (env, sigma, VarNotFound s) +let error_evar_not_found ?loc env sigma id = + raise_pretype_error ?loc (env, sigma, EvarNotFound id) + (*s Typeclass errors *) let unsatisfiable_constraints env evd ev comp = diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 51103ca194..a0d459fe6b 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -59,6 +59,7 @@ type pretype_error = | NonLinearUnification of Name.t * constr (** Pretyping *) | VarNotFound of Id.t + | EvarNotFound of Id.t | UnexpectedType of constr * constr | NotProduct of constr | TypingError of type_error @@ -155,6 +156,8 @@ val error_not_product : val error_var_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b +val error_evar_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b + (** {6 Typeclass errors } *) val unsatisfiable_constraints : env -> Evd.evar_map -> Evar.t option -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ace2868255..a92b245b91 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -103,6 +103,12 @@ let search_guard ?loc env possible_indexes fixdefs = user_err ?loc ~hdr:"search_guard" (Pp.str errmsg) with Found indexes -> indexes) +let esearch_guard ?loc env sigma indexes fix = + let fix = nf_fix sigma fix in + try search_guard ?loc env indexes fix + with TypeError (env,err) -> + raise (PretypeError (env,sigma,TypingError (map_ptype_error of_constr err))) + (* To force universe name declaration before use *) let is_strict_universe_declarations = @@ -190,7 +196,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 +233,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 +271,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 +302,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 +325,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 +359,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 +461,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 +483,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) -> @@ -486,10 +492,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma let id = interp_ltac_id env id in let evk = try Evd.evar_key id sigma - with Not_found -> - user_err ?loc (str "Unknown existential variable.") in + 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 @@ -514,7 +519,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) -> @@ -526,24 +531,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 @@ -563,7 +569,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 -> @@ -572,8 +578,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 @@ -597,11 +603,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma vn) in let fixdecls = (names,ftys,fdefs) in - let indexes = - search_guard - ?loc !!env possible_indexes (nf_fix sigma fixdecls) - in - make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let fixdecls = (names,ftys,fdefs) in let cofix = (i, fixdecls) in @@ -619,14 +622,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 -> @@ -657,12 +660,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 @@ -679,7 +682,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 @@ -704,29 +707,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 = @@ -742,23 +747,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 -> @@ -793,7 +799,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 @@ -811,10 +818,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 = @@ -822,7 +829,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; @@ -832,7 +839,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 @@ -849,7 +856,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 -> @@ -870,10 +877,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 @@ -895,8 +903,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 @@ -911,23 +919,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 @@ -938,7 +946,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 @@ -948,13 +956,21 @@ 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 } in inh_conv_coerce_to_tycon ?loc env sigma cj tycon -and pretype_instance k0 resolve_tc env sigma loc hyps evk update = + | GInt i -> + let resj = + try Typing.judge_of_int !!env i + with Invalid_argument _ -> + user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") + in + inh_conv_coerce_to_tycon ?loc env sigma resj tycon + +and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = 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 @@ -986,7 +1002,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 -> @@ -1011,7 +1027,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 @@ -1035,10 +1051,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 @@ -1052,17 +1068,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) @@ -1071,13 +1091,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/recordops.ml b/pretyping/recordops.ml index f58cce41cc..6d9e3230a4 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -197,32 +197,19 @@ let keep_true_projections projs kinds = let filter (p, (_, b)) = if b then Some p else None in List.map_filter filter (List.combine projs kinds) -let cs_pattern_of_constr env t = +let rec cs_pattern_of_constr env t = match kind t with - App (f,vargs) -> - begin - try Const_cs (global_of_constr f) , None, Array.to_list vargs - with - | Not_found when isProj f -> - let p, c = destProj f in - let { Environ.uj_type = ty } = Typeops.infer env c in - let _, params = Inductive.find_rectype env ty in - Const_cs (ConstRef (Projection.constant p)), None, - params @ [c] @ Array.to_list vargs - | e when CErrors.noncritical e -> raise Not_found - end - | Rel n -> Default_cs, Some n, [] - | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] - | Proj (p, c) -> - let { Environ.uj_type = ty } = Typeops.infer env c in - let _, params = Inductive.find_rectype env ty in - Const_cs (ConstRef (Projection.constant p)), None, params @ [c] - | Sort s -> Sort_cs (Sorts.family s), None, [] - | _ -> - begin - try Const_cs (global_of_constr t) , None, [] - with e when CErrors.noncritical e -> raise Not_found - end + | App (f,vargs) -> + let patt, n, args = cs_pattern_of_constr env f in + patt, n, args @ Array.to_list vargs + | Rel n -> Default_cs, Some n, [] + | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] + | Proj (p, c) -> + let { Environ.uj_type = ty } = Typeops.infer env c in + let _, params = Inductive.find_rectype env ty in + Const_cs (ConstRef (Projection.constant p)), None, params @ [c] + | Sort s -> Sort_cs (Sorts.family s), None, [] + | _ -> Const_cs (global_of_constr t) , None, [] let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 9c9877fd23..98ca329117 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -279,7 +279,9 @@ sig | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t + | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t + and 'a t = 'a member list exception IncompatibleFold2 @@ -308,6 +310,8 @@ sig val nth : 'a t -> int -> 'a val best_state : evar_map -> constr * constr t -> Cst_stack.t -> constr * constr t val zip : ?refold:bool -> evar_map -> constr * constr t -> constr + val check_native_args : CPrimitives.t -> 'a t -> bool + val get_next_primitive_args : CPrimitives.args_red -> 'a t -> CPrimitives.args_red * ('a t * 'a * 'a t) option end = struct open EConstr @@ -336,7 +340,9 @@ struct | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t + | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t + and 'a t = 'a member list (* Debugging printer *) @@ -354,6 +360,9 @@ struct | Fix (f,args,cst) -> str "ZFix(" ++ Constr.debug_print_fix pr_c f ++ pr_comma () ++ pr pr_c args ++ str ")" + | Primitive (p,c,args,kargs,cst_l) -> + str "ZPrimitive(" ++ str (CPrimitives.to_string p) + ++ pr_comma () ++ pr pr_c args ++ str ")" | Cst (mem,curr,remains,params,cst_l) -> str "ZCst(" ++ pr_cst_member pr_c mem ++ pr_comma () ++ int curr ++ pr_comma () ++ @@ -420,7 +429,7 @@ struct equal_cst_member c1 c2 && equal_rec (List.rev params1) (List.rev params2) && equal_rec s1' s2' - | ((App _|Case _|Proj _|Fix _|Cst _)::_|[]), _ -> false + | ((App _|Case _|Proj _|Fix _|Cst _|Primitive _)::_|[]), _ -> false in equal_rec (List.rev sk1) (List.rev sk2) let compare_shape stk1 stk2 = @@ -435,9 +444,11 @@ struct Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 + | (Primitive(_,_,a1,_,_)::s1, Primitive(_,_,a2,_,_)::s2) -> + Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (Cst (_,_,_,p1,_)::s1, Cst (_,_,_,p2,_)::s2) -> - Int.equal bal 0 && compare_rec 0 p1 p2 && compare_rec 0 s1 s2 - | (_,_) -> false in + Int.equal bal 0 && compare_rec 0 p1 p2 && compare_rec 0 s1 s2 + | ((Case _|Proj _|Fix _|Cst _|Primitive _) :: _ | []) ,_ -> false in compare_rec 0 stk1 stk2 exception IncompatibleFold2 @@ -459,7 +470,7 @@ struct | Cst (cst1,_,_,params1,_) :: q1, Cst (cst2,_,_,params2,_) :: q2 -> let o' = aux o (List.rev params1) (List.rev params2) in aux o' q1 q2 - | (((App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) -> + | (((App _|Case _|Proj _|Fix _|Cst _|Primitive _) :: _|[]), _) -> raise IncompatibleFold2 in aux o (List.rev sk1) (List.rev sk2) @@ -473,7 +484,9 @@ struct Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) | Cst (cst,curr,remains,params,alt) -> Cst (cst,curr,remains,map f params,alt) - ) x + | Primitive (p,c,args,kargs,cst_l) -> + Primitive(p,c, map f args, kargs, cst_l) + ) x let append_app_list l s = let a = Array.of_list l in @@ -481,7 +494,7 @@ struct let rec args_size = function | App (i,_,j)::s -> j + 1 - i + args_size s - | (Case _|Fix _|Proj _|Cst _)::_ | [] -> 0 + | (Case _|Fix _|Proj _|Cst _|Primitive _)::_ | [] -> 0 let strip_app s = let rec aux out = function @@ -504,7 +517,8 @@ struct in aux n [] s let not_purely_applicative args = - List.exists (function (Fix _ | Case _ | Proj _ | Cst _) -> true | _ -> false) args + List.exists (function (Fix _ | Case _ | Proj _ | Cst _) -> true + | App _ | Primitive _ -> false) args let will_expose_iota args = List.exists (function (Fix (_,_,l) | Case (_,_,_,l) | @@ -588,9 +602,26 @@ struct | f, (Proj (p,cst_l)::s) when refold -> zip (best_state sigma (mkProj (p,f),s) cst_l) | f, (Proj (p,_)::s) -> zip (mkProj (p,f),s) + | f, (Primitive (p,c,args,kargs,cst_l)::s) -> + zip (mkConstU c, args @ append_app [|f|] s) in zip s + (* Check if there is enough arguments on [stk] w.r.t. arity of [op] *) + let check_native_args op stk = + let nargs = CPrimitives.arity op in + let rargs = args_size stk in + nargs <= rargs + + let get_next_primitive_args kargs stk = + let rec nargs = function + | [] -> 0 + | CPrimitives.Kwhnf :: _ -> 0 + | _ :: s -> 1 + nargs s + in + let n = nargs kargs in + (List.skipn (n+1) kargs, strip_n_app n stk) + end (** The type of (machine) states (= lambda-bar-calculus' cuts) *) @@ -815,6 +846,57 @@ let fix_recarg ((recindices,bodynum),_) stack = with Not_found -> None +open Primred + +module CNativeEntries = +struct + + type elem = EConstr.t + type args = EConstr.t array + type evd = evar_map + + let get = Array.get + + let get_int evd e = + match EConstr.kind evd e with + | Int i -> i + | _ -> raise Primred.NativeDestKO + + let mkInt env i = + mkInt i + + let mkBool env b = + let (ct,cf) = get_bool_constructors env in + mkConstruct (if b then ct else cf) + + let mkCarry env b e = + let int_ty = mkConst @@ get_int_type env in + let (c0,c1) = get_carry_constructors env in + mkApp (mkConstruct (if b then c1 else c0),[|int_ty;e|]) + + let mkIntPair env e1 e2 = + let int_ty = mkConst @@ get_int_type env in + let c = get_pair_constructor env in + mkApp(mkConstruct c, [|int_ty;int_ty;e1;e2|]) + + let mkLt env = + let (_eq, lt, _gt) = get_cmp_constructors env in + mkConstruct lt + + let mkEq env = + let (eq, _lt, _gt) = get_cmp_constructors env in + mkConstruct eq + + let mkGt env = + let (_eq, _lt, gt) = get_cmp_constructors env in + mkConstruct gt + +end + +module CredNative = RedNative(CNativeEntries) + + + (** Generic reduction function with environment Here is where unfolded constant are stored in order to be @@ -881,47 +963,55 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in - (match constant_opt_value_in env (c, u') with - | None -> fold () - | Some body -> + match constant_value_in env (c, u') with + | body -> + begin let body = EConstr.of_constr body in - if not tactic_mode - then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) - (body, stack) - else (* Looks for ReductionBehaviour *) - match ReductionBehaviour.get (Globnames.ConstRef c) with - | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < nargs)) - then fold () - else (* maybe unfolds *) - if List.mem `ReductionDontExposeCase flags then - let app_sk,sk = Stack.strip_app stack in - let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) - in - let rec is_case x = match EConstr.kind sigma x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if equal_stacks sigma (x, app_sk) (tm', sk') - || Stack.will_expose_iota sk' - || is_case tm' - then fold () - else whrec cst_l' (tm', sk' @ sk) - else match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) - whrec cst_l (body, stack) - |curr::remains -> match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') - ) else fold () + if not tactic_mode + then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) + (body, stack) + else (* Looks for ReductionBehaviour *) + match ReductionBehaviour.get (Globnames.ConstRef c) with + | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) + | Some (recargs, nargs, flags) -> + if (List.mem `ReductionNeverUnfold flags + || (nargs > 0 && Stack.args_size stack < nargs)) + then fold () + else (* maybe unfolds *) + if List.mem `ReductionDontExposeCase flags then + let app_sk,sk = Stack.strip_app stack in + let (tm',sk'),cst_l' = + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) + in + let rec is_case x = match EConstr.kind sigma x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if equal_stacks sigma (x, app_sk) (tm', sk') + || Stack.will_expose_iota sk' + || is_case tm' + then fold () + else whrec cst_l' (tm', sk' @ sk) + else match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) + whrec cst_l (body, stack) + |curr::remains -> match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') + end + | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> + let kargs = CPrimitives.kind p in + let (kargs,o) = Stack.get_next_primitive_args kargs stack in + (* Should not fail thanks to [check_native_args] *) + let (before,a,after) = Option.get o in + whrec Cst_stack.empty (a,Stack.Primitive(p,const,before,kargs,cst_l)::after) + | exception NotEvaluableConst _ -> fold () + else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let npars = Projection.npars p in if not tactic_mode then @@ -1049,6 +1139,30 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |_ -> fold () else fold () + | Int i -> + begin match Stack.strip_app stack with + | (_, Stack.Primitive(p,kn,rargs,kargs,cst_l')::s) -> + let more_to_reduce = List.exists (fun k -> CPrimitives.Kwhnf = k) kargs in + if more_to_reduce then + let (kargs,o) = Stack.get_next_primitive_args kargs s in + (* Should not fail because Primitive is put on the stack only if fully applied *) + let (before,a,after) = Option.get o in + whrec Cst_stack.empty (a,Stack.Primitive(p,kn,rargs @ Stack.append_app [|x|] before,kargs,cst_l')::after) + else + let n = List.length kargs in + let (args,s) = Stack.strip_app s in + let (args,extra_args) = + try List.chop n args + with List.IndexOutOfRange -> (args,[]) (* FIXME probably useless *) + in + let args = Array.of_list (Option.get (Stack.list_of_app_stack (rargs @ Stack.append_app [|x|] args))) in + begin match CredNative.red_prim env sigma p args with + | Some t -> whrec cst_l' (t,s) + | None -> ((mkApp (mkConstU kn, args), s), cst_l) + end + | _ -> fold () + end + | Rel _ | Var _ | LetIn _ | Proj _ -> fold () | Sort _ | Ind _ | Prod _ -> fold () in @@ -1127,7 +1241,8 @@ let local_whd_state_gen flags sigma = |_ -> s else s - | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ -> s + | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ + | Int _ -> s in whrec @@ -1577,7 +1692,7 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = if isConstruct sigma t_o then whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') else s,csts' - |_, ((Stack.App _|Stack.Cst _) :: _|[]) -> s,csts' + |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' in whrec csts s let find_conclusion env sigma = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index a1fd610676..fae0b23b83 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -77,6 +77,7 @@ module Stack : sig | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t + | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t | Cst of cst_member * int (* current foccussed arg *) * int list (* remaining args *) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 62ad296ecb..a76a203e37 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -143,6 +143,7 @@ let retype ?(polyprop=true) sigma = with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) + | Int _ -> EConstr.of_constr (Typeops.type_of_int env) and sort_of env t = match EConstr.kind sigma t with diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 2e7176a6b3..2308a541fb 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -48,8 +48,8 @@ let error_not_evaluable r = spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && - evaluable_constant cst env + is_transparent env (ConstKey cst) && + (evaluable_constant cst env || is_primitive env cst) let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env diff --git a/pretyping/typing.ml b/pretyping/typing.ml index b5729d7574..2e50e1ab3f 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -244,10 +244,10 @@ let judge_of_type u = uj_type = EConstr.mkType uu } let judge_of_relative env v = - Termops.on_judgment EConstr.of_constr (judge_of_relative env v) + Environ.on_judgment EConstr.of_constr (judge_of_relative env v) let judge_of_variable env id = - Termops.on_judgment EConstr.of_constr (judge_of_variable env id) + Environ.on_judgment EConstr.of_constr (judge_of_variable env id) let judge_of_projection env sigma p cj = let pty = lookup_projection p env in @@ -306,6 +306,9 @@ let type_of_constructor env sigma ((ind,_ as ctor),u) = let sigma = Evd.add_constraints sigma csts in sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstructRef ctor))) +let judge_of_int env v = + Environ.on_judgment EConstr.of_constr (judge_of_int env v) + (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env sigma cstr = @@ -408,6 +411,9 @@ let rec execute env sigma cstr = let sigma, tj = type_judgment env sigma tj in judge_of_cast env sigma cj k tj + | Int i -> + sigma, judge_of_int env i + and execute_recdef env sigma (names,lar,vdef) = let sigma, larj = execute_array env sigma lar in let sigma, lara = Array.fold_left_map (assumption_of_judgment env) sigma larj in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 79f2941554..1ea16bbf34 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -55,3 +55,4 @@ val judge_of_abstraction : Environ.env -> Name.t -> val judge_of_product : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment val judge_of_projection : env -> evar_map -> Projection.t -> unsafe_judgment -> unsafe_judgment +val judge_of_int : Environ.env -> Uint63.t -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f0cd5c5f6a..ac0b58b92b 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -550,7 +550,7 @@ let is_rigid_head sigma flags t = match EConstr.kind sigma t with | Const (cst,u) -> not (TransparentState.is_transparent_constant flags.modulo_delta cst) | Ind (i,u) -> true - | Construct _ -> true + | Construct _ | Int _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Lambda (_, _, _) | LetIn (_, _, _, _) | App (_, _) | Case (_, _, _, _) @@ -641,7 +641,7 @@ let rec is_neutral env sigma ts t = | Evar _ | Meta _ -> true | Case (_, p, c, cl) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c - | Lambda _ | LetIn _ | Construct _ | CoFix _ -> false + | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) | Fix _ -> false (* This is an approximation *) | App _ -> assert false @@ -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) @@ -1799,7 +1799,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = | Cast (_, _, _) (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ - | Construct _ -> user_err Pp.(str "Match_subterm"))) + | Construct _ | Int _ -> user_err Pp.(str "Match_subterm"))) in try matchrec cl with ex when precatchable_exception ex -> @@ -1868,7 +1868,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | Cast (_, _, _) -> fail "Match_subterm" (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ - | Construct _ -> fail "Match_subterm")) + | Construct _ | Int _ -> fail "Match_subterm")) in let res = matchrec cl [] in diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 113aac25da..083661a64b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -57,7 +57,7 @@ let find_rectype_a env c = let (t, l) = decompose_appvect (whd_all env c) in match kind t with | Ind ind -> (ind, l) - | _ -> assert false + | _ -> raise Not_found (* Instantiate inductives and parameters in constructor type *) @@ -75,25 +75,18 @@ let type_constructor mind mib u typ params = let construct_of_constr const env tag typ = - let ((mind,_ as ind), u) as indu, allargs = find_rectype_a env typ in - (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) - try - if const then - ((Retroknowledge.get_vm_decompile_constant_info env.retroknowledge (GlobRef.IndRef ind) tag), - typ) (*spiwack: this may need to be changed in case there are parameters in the - type which may cause a constant value to have an arity. - (type_constructor seems to be all about parameters actually) - but it shouldn't really matter since constant values don't use - their ctyp in the rest of the code.*) - else - raise Not_found (* No retroknowledge function (yet) for block decompilation *) - with Not_found -> + let (t, allargs) = decompose_appvect (whd_all env typ) in + match Constr.kind t with + | Ind ((mind,_ as ind), u as indu) -> let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstructUi(indu,i), params), ctyp) + (mkApp(mkConstructUi(indu,i), params), ctyp) + | _ -> + assert (Constr.equal t (Typeops.type_of_int env)); + (mkInt (Uint63.of_int tag), t) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) @@ -169,6 +162,7 @@ and nf_whd env sigma whd typ = let capp,ctyp = construct_of_constr_block env tag typ in let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) + | Vint64 i -> i |> Uint63.of_int64 |> mkInt | Vatom_stk(Aid idkey, stk) -> constr_type_of_idkey env sigma idkey stk | Vatom_stk(Aind ((mi,i) as ind), stk) -> @@ -344,9 +338,9 @@ and nf_fun env sigma f typ = let name,dom,codom = try decompose_prod env typ with DestKO -> - (* 27/2/13: Turned this into an anomaly *) CErrors.anomaly - (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") + Pp.(strbrk "Returned a functional value in type " ++ + Termops.Internal.print_constr_env env sigma (EConstr.of_constr typ)) in let body = nf_val (push_rel (LocalAssum (name,dom)) env) sigma vb codom in mkLambda(name,dom,body) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 408bd5f60b..797b6faa08 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -86,10 +86,7 @@ let print_ref reduce ref udecl = | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> let mind = Environ.lookup_mind ind env in - begin match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> None - | Declarations.Cumulative_ind cumi -> Some (Univ.ACumulativityInfo.variance cumi) - end + mind.Declarations.mind_variance in let inst = if Global.is_polymorphic ref @@ -98,7 +95,7 @@ let print_ref reduce ref udecl = in let priv = None in (* We deliberately don't print private univs in About. *) hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ - Printer.pr_abstract_universe_ctx sigma ?variance univs ~priv) + Printer.pr_abstract_universe_ctx sigma ?variance univs ?priv) (********************************) (** Printing implicit arguments *) @@ -193,7 +190,7 @@ let opacity env = | ConstRef cst -> let cb = Environ.lookup_constant cst env in (match cb.const_body with - | Undef _ -> None + | Undef _ | Primitive _ -> None | OpaqueDef _ -> Some FullyOpaque | Def _ -> Some (TransparentMaybeOpacified @@ -558,15 +555,15 @@ let print_constant with_values sep sp udecl = let open Univ in let otab = Global.opaque_tables () in match cb.const_body with - | Undef _ | Def _ -> cb.const_universes + | Undef _ | Def _ | Primitive _ -> cb.const_universes | OpaqueDef o -> let body_uctxs = Opaqueproof.force_constraints otab o in match cb.const_universes with - | Monomorphic_const ctx -> - Monomorphic_const (ContextSet.union body_uctxs ctx) - | Polymorphic_const ctx -> + | Monomorphic ctx -> + Monomorphic (ContextSet.union body_uctxs ctx) + | Polymorphic ctx -> assert(ContextSet.is_empty body_uctxs); - Polymorphic_const ctx + Polymorphic ctx in let ctx = UState.of_binders @@ -580,11 +577,11 @@ let print_constant with_values sep sp udecl = str"*** [ " ++ print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_constant_universes sigma univs ~priv:cb.const_private_poly_univs + Printer.pr_universes sigma univs ?priv:cb.const_private_poly_univs | Some (c, ctx) -> print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ - Printer.pr_constant_universes sigma univs ~priv:cb.const_private_poly_univs) + Printer.pr_universes sigma univs ?priv:cb.const_private_poly_univs) let gallina_print_constant_with_infos sp udecl = print_constant true " = " sp udecl ++ @@ -724,7 +721,10 @@ let print_full_pure_context env sigma = | Def c -> str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ - pr_lconstr_env env sigma (Mod_subst.force_constr c)) + pr_lconstr_env env sigma (Mod_subst.force_constr c) + | Primitive _ -> + str "Primitive " ++ + print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in diff --git a/printing/printer.ml b/printing/printer.ml index 3f7837fd6e..bc936975c2 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -209,7 +209,7 @@ let pr_universe_ctx sigma ?variance c = else mt() -let pr_abstract_universe_ctx sigma ?variance c ~priv = +let pr_abstract_universe_ctx sigma ?variance ?priv c = let open Univ in let priv = Option.default Univ.ContextSet.empty priv in let has_priv = not (ContextSet.is_empty priv) in @@ -221,23 +221,9 @@ let pr_abstract_universe_ctx sigma ?variance c ~priv = else mt() -let pr_constant_universes sigma ~priv = function - | Declarations.Monomorphic_const ctx -> pr_universe_ctx_set sigma ctx - | Declarations.Polymorphic_const ctx -> pr_abstract_universe_ctx sigma ctx ~priv - -let pr_cumulativity_info sigma cumi = - if !Detyping.print_universes - && not (Univ.UContext.is_empty (Univ.CumulativityInfo.univ_context cumi)) then - fnl()++pr_in_comment (v 0 (Univ.pr_cumulativity_info (Termops.pr_evd_level sigma) cumi)) - else - mt() - -let pr_abstract_cumulativity_info sigma cumi = - if !Detyping.print_universes - && not (Univ.AUContext.is_empty (Univ.ACumulativityInfo.univ_context cumi)) then - fnl()++pr_in_comment (v 0 (Univ.pr_abstract_cumulativity_info (Termops.pr_evd_level sigma) cumi)) - else - mt() +let pr_universes sigma ?variance ?priv = function + | Declarations.Monomorphic ctx -> pr_universe_ctx_set sigma ctx + | Declarations.Polymorphic ctx -> pr_abstract_universe_ctx sigma ?variance ?priv ctx (**********************************************************************) (* Global references *) diff --git a/printing/printer.mli b/printing/printer.mli index 9a06d555e4..4e27268c4d 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -86,11 +86,11 @@ val pr_universe_instance_constraints : evar_map -> Univ.Instance.t -> Univ.Const val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> - Univ.AUContext.t -> priv:Univ.ContextSet.t option -> Pp.t + ?priv:Univ.ContextSet.t -> Univ.AUContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t -val pr_constant_universes : evar_map -> priv:Univ.ContextSet.t option -> Declarations.constant_universes -> Pp.t -val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t -val pr_abstract_cumulativity_info : evar_map -> Univ.ACumulativityInfo.t -> Pp.t +val pr_universes : evar_map -> + ?variance:Univ.Variance.t array -> ?priv:Univ.ContextSet.t -> + Declarations.universes -> Pp.t (** Printing global references using names as short as possible *) diff --git a/printing/printmod.ml b/printing/printmod.ml index 898f231a8b..3438063f76 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -126,10 +126,7 @@ let print_mutual_inductive env mind mib udecl = hov 0 (def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") (print_one_inductive env sigma mib) inds ++ - match mib.mind_universes with - | Monomorphic_ind _ | Polymorphic_ind _ -> str "" - | Cumulative_ind cumi -> - Printer.pr_abstract_cumulativity_info sigma cumi) + Printer.pr_universes sigma ?variance:mib.mind_variance mib.mind_universes) let get_fields = let rec prodec_rec l subst c = @@ -178,10 +175,7 @@ let print_record env mind mib udecl = (fun (id,b,c) -> Id.print id ++ str (if b then " : " else " := ") ++ Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++ - match mib.mind_universes with - | Monomorphic_ind _ | Polymorphic_ind _ -> str "" - | Cumulative_ind cumi -> - Printer.pr_abstract_cumulativity_info sigma cumi + Printer.pr_universes sigma ?variance:mib.mind_variance mib.mind_universes ) let pr_mutual_inductive_body env mind mib udecl = @@ -302,7 +296,7 @@ let print_body is_impl extent env mp (l,body) = hov 2 (str ":= " ++ Printer.pr_lconstr_env env sigma (Mod_subst.force_constr l)) | _ -> mt ()) ++ str "." ++ - Printer.pr_abstract_universe_ctx sigma ctx ~priv:cb.const_private_poly_univs) + Printer.pr_abstract_universe_ctx sigma ctx ?priv:cb.const_private_poly_univs) | SFBmind mib -> match extent with | WithContents -> diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index c1ea067567..878e9f477b 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -546,7 +546,7 @@ let to_constr p = module GoalMap = Evar.Map -let goal_to_evar g sigma = Id.to_string (Termops.pr_evar_suggested_name g sigma) +let goal_to_evar g sigma = Id.to_string (Termops.evar_suggested_name g sigma) open Goal.Set 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/goal_select.ml b/proofs/goal_select.ml index cef3fd3f5e..955d797227 100644 --- a/proofs/goal_select.ml +++ b/proofs/goal_select.ml @@ -45,7 +45,7 @@ let parse_goal_selector = function | "!" -> SelectAlreadyFocused | "all" -> SelectAll | i -> - let err_msg = "The default selector must be \"all\" or a natural number." in + let err_msg = "The default selector must be \"all\", \"!\" or a natural number." in begin try let i = int_of_string i in if i < 0 then CErrors.user_err Pp.(str err_msg); 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..a47fa78f4d 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 @@ -273,7 +268,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let used_univs_body = Vars.universes_of_constr body in let used_univs_typ = Vars.universes_of_constr typ in if allow_deferred then - let initunivs = UState.const_univ_entry ~poly initial_euctx in + let initunivs = UState.univ_entry ~poly initial_euctx in let ctx = constrain_variables universes in (* For vi2vo compilation proofs are computed now but we need to complement the univ constraints of the typ with the ones of @@ -307,7 +302,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now else fun t p -> (* Already checked the univ_decl for the type universes when starting the proof. *) - let univctx = Entries.Monomorphic_const_entry (UState.context_set universes) in + let univctx = UState.univ_entry ~poly:false universes in let t = nf t in Future.from_val (univctx, t), Future.chain p (fun (pt,eff) -> @@ -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 2f8129bbfd..73b9ef7da0 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -118,18 +118,40 @@ module Make(T : Task) () = struct let spawn id = let name = Printf.sprintf "%s:%d" !T.name id in let proc, ic, oc = + (* Filter arguments for slaves. *) let rec set_slave_opt = function | [] -> !async_proofs_flags_for_workers @ ["-worker-id"; name; "-async-proofs-worker-priority"; - CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] - | ("-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-vio2vo" - |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" - |"-compile" |"-compile-verbose" - |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> + CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] + (* Options to discard: 0 arguments *) + | ("-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | x::tl -> x :: set_slave_opt tl in + (* 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-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" + | "-load-ml-object" | "-load-ml-source" | "-require" | "-w" | "-color" | "-init-file" + | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" + | "-diffs" | "-mangle-name" | "-dump-glob" | "-bytecode-compiler" | "-native-compiler" as x) :: a :: tl -> + x :: a :: set_slave_opt tl + (* We need to pass some options with two arguments *) + | ( "-R" | "-Q" as x) :: a1 :: a2 :: tl -> + x :: a1 :: a2 :: set_slave_opt tl + (* Finally we pass all options starting in '-'; check this is safe w.r.t the weird vio* option set *) + | x :: tl when x.[0] = '-' -> + x :: set_slave_opt tl + (* We assume this is a file, filter out *) + | _ :: tl -> + set_slave_opt tl + in let args = Array.of_list (set_slave_opt (List.tl (Array.to_list Sys.argv))) in let env = Array.append (T.extra_env ()) (Unix.environment ()) in diff --git a/stm/stm.ml b/stm/stm.ml index dfe5581ed5..b4f26570c6 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1671,7 +1671,7 @@ end = struct (* {{{ *) when is_tac expr && State.same_env o n -> (* A pure tactic *) Some (id, `ProofOnly (prev, State.proof_part_of_frozen n)) | Some _, Some s -> - msg_debug (Pp.str "STM: sending back a fat state"); + if !Flags.debug then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function @@ -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 292e3966a1..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 = @@ -130,6 +131,8 @@ let classify_vernac e = | VernacAssumption (_,_,l) -> let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> id.v) l) l) in VtSideff ids, VtLater + | VernacPrimitive (id,_,_) -> + VtSideff [id.CAst.v], VtLater | VernacDefinition (_,({v=id},_),DefineBody _) -> VtSideff (idents_of_name id), VtLater | VernacInductive (_, _,_,l) -> let ids = List.map (fun (((_,({v=id},_)),_,_,_,cl),_) -> id :: match cl with diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 3a687a6b41..7a61deba0c 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 @@ -147,8 +162,8 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = in let cst = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with - | Entries.Monomorphic_const_entry _ -> EInstance.empty - | Entries.Polymorphic_const_entry (_, ctx) -> + | Entries.Monomorphic_entry _ -> EInstance.empty + | Entries.Polymorphic_entry (_, ctx) -> (* We mimick what the kernel does, that is ensuring that no additional constraints appear in the body of polymorphic constants. Ideally this should be enforced statically. *) @@ -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/hints.ml b/tactics/hints.ml index 571ad9d160..c1f6365f5d 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1309,7 +1309,7 @@ let project_hint ~poly pri l2r r = let id = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in - let ctx = Evd.const_univ_entry ~poly sigma in + let ctx = Evd.univ_entry ~poly sigma in let c = EConstr.to_constr sigma c in let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index a67f5f6d6e..d1b77f3758 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -121,7 +121,7 @@ let define internal id c poly univs = let id = compute_name internal id in let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in - let univs = UState.const_univ_entry ~poly ctx in + let univs = UState.univ_entry ~poly ctx in let entry = { const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 356b43ec14..335f3c74ff 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -237,9 +237,7 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in - let univs = - Evd.const_univ_entry ~poly sigma - in + let univs = Evd.univ_entry ~poly sigma in let entry = definition_entry ~univs invProof in let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in () @@ -250,7 +248,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/tactics/term_dnet.ml b/tactics/term_dnet.ml index e273891500..e8a66f1889 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -44,6 +44,7 @@ struct | DCase of case_info * 't * 't * 't array | DFix of int array * int * 't array * 't array | DCoFix of int * 't array * 't array + | DInt of Uint63.t (* special constructors only inside the left-hand side of DCtx or DApp. Used to encode lists of foralls/letins/apps as contexts *) @@ -61,6 +62,7 @@ struct | DCase (_,t1,t2,ta) -> str "case" | DFix _ -> str "fix" | DCoFix _ -> str "cofix" + | DInt _ -> str "INT" | DCons ((t,dopt),tl) -> f t ++ (match dopt with Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl @@ -72,7 +74,7 @@ struct *) let map f = function - | (DRel | DSort | DNil | DRef _) as c -> c + | (DRel | DSort | DNil | DRef _ | DInt _) as c -> c | DCtx (ctx,c) -> DCtx (f ctx, f c) | DLambda (t,c) -> DLambda (f t, f c) | DApp (t,u) -> DApp (f t,f u) @@ -145,6 +147,10 @@ struct else c | DCoFix _, _ -> -1 | _, DCoFix _ -> 1 + | DInt i1, DInt i2 -> Uint63.compare i1 i2 + + | DInt _, _ -> -1 | _, DInt _ -> 1 + | DCons ((t1, ot1), u1), DCons ((t2, ot2), u2) -> let c = cmp t1 t2 in if Int.equal c 0 then @@ -157,7 +163,7 @@ struct | DNil, DNil -> 0 let fold f acc = function - | (DRel | DNil | DSort | DRef _) -> acc + | (DRel | DNil | DSort | DRef _ | DInt _) -> acc | DCtx (ctx,c) -> f (f acc ctx) c | DLambda (t,c) -> f (f acc t) c | DApp (t,u) -> f (f acc t) u @@ -169,7 +175,7 @@ struct | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function - | (DRel | DSort | DNil | DRef _) -> invalid_arg "choose" + | (DRel | DSort | DNil | DRef _ | DInt _) -> invalid_arg "choose" | DCtx (ctx,c) -> f ctx | DLambda (t,c) -> f t | DApp (t,u) -> f u @@ -185,7 +191,8 @@ struct if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) then invalid_arg "fold2:compare" else match c1,c2 with - | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc + | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _ + | DInt _, DInt _) -> acc | (DCtx (c1,t1), DCtx (c2,t2) | DApp (c1,t1), DApp (c2,t2) | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 @@ -198,14 +205,15 @@ struct | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ - | DFix _ | DCoFix _ | DCons _), _ -> assert false + | DFix _ | DCoFix _ | DCons _ | DInt _), _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0) then invalid_arg "map2_t:compare" else match c1,c2 with - | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc -> + | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _ + | DInt _, DInt _) as cc -> let (c,_) = cc in c | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) @@ -219,10 +227,10 @@ struct | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ - | DFix _ | DCoFix _ | DCons _), _ -> assert false + | DFix _ | DCoFix _ | DCons _ | DInt _), _ -> assert false let terminal = function - | (DRel | DSort | DNil | DRef _) -> true + | (DRel | DSort | DNil | DRef _ | DInt _) -> true | DLambda _ | DApp _ | DCase _ | DFix _ | DCoFix _ | DCtx _ | DCons _ -> false @@ -315,6 +323,7 @@ struct (pat_of_constr f) (Array.map pat_of_constr ca) | Proj (p,c) -> Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) + | Int i -> Term (DInt i) and ctx_of_constr ctx c = match Constr.kind c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c diff --git a/test-suite/Makefile b/test-suite/Makefile index 37091a49e5..03bfc5ffac 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -38,14 +38,15 @@ LIB := .. BIN := $(shell cd ..; pwd)/bin/ COQFLAGS?= -coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite $(COQFLAGS) +coqc_boot := $(BIN)coqc -coqlib $(LIB) -boot -q -test-mode -R prerequisite TestSuite $(COQFLAGS) coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite coqdoc := $(BIN)coqdoc +coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -test-mode -R prerequisite TestSuite coqtopbyte := $(BIN)coqtop.byte -coqtopload := $(coqtop) -async-proofs-cache force -load-vernac-source -coqtopcompile := $(coqtop) -async-proofs-cache force -compile +coqc_interactive := $(coqc) -async-proofs-cache force +coqc_boot_interactive := $(coqc_boot) -async-proofs-cache force coqdep := $(BIN)coqdep -coqlib $(LIB) VERBOSE?= @@ -60,12 +61,8 @@ SINGLE_QUOTE=" #" # double up on the quotes, in a comment, to appease the emacs syntax highlighter # wrap the arguments in parens, but only if they exist get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) -# get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop -has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) -get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqtopcompile),$(coqtopload)) get_set_impredicativity= $(filter "-impredicative-set",$(call get_coq_prog_args,$(1))) - bogomips:= ifneq (,$(wildcard /proc/cpuinfo)) sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc @@ -98,7 +95,7 @@ INTERACTIVE := interactive UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ - coqdoc ssr + coqdoc ssr arithmetic # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) @@ -179,6 +176,7 @@ summary: $(call summary_dir, "Coqdoc tests", coqdoc); \ $(call summary_dir, "tools/ tests", tools); \ $(call summary_dir, "Unit tests", unit-tests); \ + $(call summary_dir, "Machine arithmetic tests", arithmetic); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -209,7 +207,7 @@ $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ @@ -231,7 +229,7 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -262,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) @@ -269,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 ####################################################################### @@ -297,7 +303,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -307,16 +313,16 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v echo " $<...correctly prepared" ; \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE)$(coqchk) -norec TestSuite.$(shell basename $< .v) > $(shell dirname $<)/$(shell basename $< .v).chk.log 2>&1 ssr: $(wildcard ssr/*.v:%.v=%.v.log) -$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG) +$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -326,7 +332,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v $(FAIL); \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ @@ -342,7 +348,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ @@ -353,7 +359,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v $(FAIL); \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE){ \ $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ @@ -367,7 +373,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -377,7 +383,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(FAIL); \ fi; \ } > "$@" - @echo "CHK $(shell basename $< .v)" + @echo "CHECK $<" $(HIDE){ \ $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ @@ -392,7 +398,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ output=$*.out.real; \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ + $(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ @@ -431,7 +437,7 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out echo $(call log_intro,$<); \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ tmpexpected=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ + $(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ @@ -486,7 +492,7 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ + res=`$(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ @@ -517,7 +523,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ @@ -531,7 +537,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG # Additional dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v - $(HIDE)$(coqtop) -R modules Mods -compile $< + $(HIDE)$(coqc) -R modules Mods $< ####################################################################### # Miscellaneous tests @@ -550,7 +556,7 @@ $(patsubst %.sh,%.log,$(wildcard misc/*.sh)): %.log: %.sh $(PREREQUISITELOG) echo $(call log_intro,$<); \ export BIN="$(BIN)"; \ export coqc="$(coqc)"; \ - export coqtop="$(coqtop)"; \ + export coqtop="$(coqc_boot)"; \ export coqdep="$(coqdep)"; \ export coqtopbyte="$(coqtopbyte)"; \ "$<" 2>&1; R=$$?; times; \ @@ -591,7 +597,7 @@ vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) @echo "TEST $<" $(HIDE){ \ $(coqc) -quick -R vio vio $* 2>&1 && \ - $(coqtop) -R vio vio -vio2vo $*.vio 2>&1 && \ + $(coqc) -R vio vio -vio2vo $*.vio 2>&1 && \ $(coqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ diff --git a/test-suite/arithmetic/add.v b/test-suite/arithmetic/add.v new file mode 100644 index 0000000000..fb7eb1d53c --- /dev/null +++ b/test-suite/arithmetic/add.v @@ -0,0 +1,18 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 2 + 3 = 5). +Check (eq_refl 5 <: 2 + 3 = 5). +Check (eq_refl 5 <<: 2 + 3 = 5). + +Definition compute1 := Eval compute in 2 + 3. +Check (eq_refl compute1 : 5 = 5). + +Check (eq_refl : 9223372036854775807 + 1 = 0). +Check (eq_refl 0 <: 9223372036854775807 + 1 = 0). +Check (eq_refl 0 <<: 9223372036854775807 + 1 = 0). +Definition compute2 := Eval compute in 9223372036854775807 + 1. +Check (eq_refl compute2 : 0 = 0). diff --git a/test-suite/arithmetic/addc.v b/test-suite/arithmetic/addc.v new file mode 100644 index 0000000000..432aec0291 --- /dev/null +++ b/test-suite/arithmetic/addc.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 2 +c 3 = C0 5). +Check (eq_refl (C0 5) <: 2 +c 3 = C0 5). +Check (eq_refl (C0 5) <<: 2 +c 3 = C0 5). +Definition compute1 := Eval compute in 2 +c 3. +Check (eq_refl compute1 : C0 5 = C0 5). + +Check (eq_refl : 9223372036854775807 +c 2 = C1 1). +Check (eq_refl (C1 1) <: 9223372036854775807 +c 2 = C1 1). +Check (eq_refl (C1 1) <<: 9223372036854775807 +c 2 = C1 1). +Definition compute2 := Eval compute in 9223372036854775807 +c 2. +Check (eq_refl compute2 : C1 1 = C1 1). diff --git a/test-suite/arithmetic/addcarryc.v b/test-suite/arithmetic/addcarryc.v new file mode 100644 index 0000000000..a4430769ca --- /dev/null +++ b/test-suite/arithmetic/addcarryc.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : addcarryc 2 3 = C0 6). +Check (eq_refl (C0 6) <: addcarryc 2 3 = C0 6). +Check (eq_refl (C0 6) <<: addcarryc 2 3 = C0 6). +Definition compute1 := Eval compute in addcarryc 2 3. +Check (eq_refl compute1 : C0 6 = C0 6). + +Check (eq_refl : addcarryc 9223372036854775807 2 = C1 2). +Check (eq_refl (C1 2) <: addcarryc 9223372036854775807 2 = C1 2). +Check (eq_refl (C1 2) <<: addcarryc 9223372036854775807 2 = C1 2). +Definition compute2 := Eval compute in addcarryc 9223372036854775807 2. +Check (eq_refl compute2 : C1 2 = C1 2). diff --git a/test-suite/arithmetic/addmuldiv.v b/test-suite/arithmetic/addmuldiv.v new file mode 100644 index 0000000000..72b0164b49 --- /dev/null +++ b/test-suite/arithmetic/addmuldiv.v @@ -0,0 +1,12 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : addmuldiv 32 3 5629499534213120 = 12887523328). +Check (eq_refl 12887523328 <: addmuldiv 32 3 5629499534213120 = 12887523328). +Check (eq_refl 12887523328 <<: addmuldiv 32 3 5629499534213120 = 12887523328). + +Definition compute2 := Eval compute in addmuldiv 32 3 5629499534213120. +Check (eq_refl compute2 : 12887523328 = 12887523328). diff --git a/test-suite/arithmetic/compare.v b/test-suite/arithmetic/compare.v new file mode 100644 index 0000000000..a8d1ea1226 --- /dev/null +++ b/test-suite/arithmetic/compare.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 1 ?= 1 = Eq). +Check (eq_refl Eq <: 1 ?= 1 = Eq). +Check (eq_refl Eq <<: 1 ?= 1 = Eq). +Definition compute1 := Eval compute in 1 ?= 1. +Check (eq_refl compute1 : Eq = Eq). + +Check (eq_refl : 1 ?= 2 = Lt). +Check (eq_refl Lt <: 1 ?= 2 = Lt). +Check (eq_refl Lt <<: 1 ?= 2 = Lt). +Definition compute2 := Eval compute in 1 ?= 2. +Check (eq_refl compute2 : Lt = Lt). + +Check (eq_refl : 9223372036854775807 ?= 0 = Gt). +Check (eq_refl Gt <: 9223372036854775807 ?= 0 = Gt). +Check (eq_refl Gt <<: 9223372036854775807 ?= 0 = Gt). +Definition compute3 := Eval compute in 9223372036854775807 ?= 0. +Check (eq_refl compute3 : Gt = Gt). diff --git a/test-suite/arithmetic/div.v b/test-suite/arithmetic/div.v new file mode 100644 index 0000000000..0ee0b91580 --- /dev/null +++ b/test-suite/arithmetic/div.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 6 / 3 = 2). +Check (eq_refl 2 <: 6 / 3 = 2). +Check (eq_refl 2 <<: 6 / 3 = 2). +Definition compute1 := Eval compute in 6 / 3. +Check (eq_refl compute1 : 2 = 2). + +Check (eq_refl : 3 / 2 = 1). +Check (eq_refl 1 <: 3 / 2 = 1). +Check (eq_refl 1 <<: 3 / 2 = 1). +Definition compute2 := Eval compute in 3 / 2. +Check (eq_refl compute2 : 1 = 1). diff --git a/test-suite/arithmetic/diveucl.v b/test-suite/arithmetic/diveucl.v new file mode 100644 index 0000000000..8f88a0f356 --- /dev/null +++ b/test-suite/arithmetic/diveucl.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : diveucl 6 3 = (2,0)). +Check (eq_refl (2,0) <: diveucl 6 3 = (2,0)). +Check (eq_refl (2,0) <<: diveucl 6 3 = (2,0)). +Definition compute1 := Eval compute in diveucl 6 3. +Check (eq_refl compute1 : (2,0) = (2,0)). + +Check (eq_refl : diveucl 5 3 = (1,2)). +Check (eq_refl (1,2) <: diveucl 5 3 = (1,2)). +Check (eq_refl (1,2) <<: diveucl 5 3 = (1,2)). +Definition compute2 := Eval compute in diveucl 5 3. +Check (eq_refl compute2 : (1,2) = (1,2)). diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/arithmetic/diveucl_21.v new file mode 100644 index 0000000000..7e12a08906 --- /dev/null +++ b/test-suite/arithmetic/diveucl_21.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : diveucl_21 1 1 2 = (4611686018427387904,1)). +Check (eq_refl (4611686018427387904,1) <: diveucl_21 1 1 2 = (4611686018427387904,1)). +Check (eq_refl (4611686018427387904,1) <<: diveucl_21 1 1 2 = (4611686018427387904,1)). +Definition compute1 := Eval compute in diveucl_21 1 1 2. +Check (eq_refl compute1 : (4611686018427387904,1) = (4611686018427387904,1)). + +Check (eq_refl : diveucl_21 3 1 2 = (4611686018427387904, 1)). +Check (eq_refl (4611686018427387904, 1) <: diveucl_21 3 1 2 = (4611686018427387904, 1)). +Check (eq_refl (4611686018427387904, 1) <<: diveucl_21 3 1 2 = (4611686018427387904, 1)). +Definition compute2 := Eval compute in diveucl_21 3 1 2. +Check (eq_refl compute2 : (4611686018427387904, 1) = (4611686018427387904, 1)). diff --git a/test-suite/arithmetic/eqb.v b/test-suite/arithmetic/eqb.v new file mode 100644 index 0000000000..dcc0b71f6d --- /dev/null +++ b/test-suite/arithmetic/eqb.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 1 == 1 = true). +Check (eq_refl true <: 1 == 1 = true). +Check (eq_refl true <<: 1 == 1 = true). +Definition compute1 := Eval compute in 1 == 1. +Check (eq_refl compute1 : true = true). + +Check (eq_refl : 9223372036854775807 == 0 = false). +Check (eq_refl false <: 9223372036854775807 == 0 = false). +Check (eq_refl false <<: 9223372036854775807 == 0 = false). +Definition compute2 := Eval compute in 9223372036854775807 == 0. +Check (eq_refl compute2 : false = false). diff --git a/test-suite/arithmetic/head0.v b/test-suite/arithmetic/head0.v new file mode 100644 index 0000000000..f4234d2605 --- /dev/null +++ b/test-suite/arithmetic/head0.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : head0 3 = 61). +Check (eq_refl 61 <: head0 3 = 61). +Check (eq_refl 61 <<: head0 3 = 61). +Definition compute1 := Eval compute in head0 3. +Check (eq_refl compute1 : 61 = 61). + +Check (eq_refl : head0 4611686018427387904 = 0). +Check (eq_refl 0 <: head0 4611686018427387904 = 0). +Check (eq_refl 0 <<: head0 4611686018427387904 = 0). +Definition compute2 := Eval compute in head0 4611686018427387904. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : head0 0 = 63). +Check (eq_refl 63 <: head0 0 = 63). +Check (eq_refl 63 <<: head0 0 = 63). +Definition compute3 := Eval compute in head0 0. +Check (eq_refl compute3 : 63 = 63). diff --git a/test-suite/arithmetic/isint.v b/test-suite/arithmetic/isint.v new file mode 100644 index 0000000000..c215caa878 --- /dev/null +++ b/test-suite/arithmetic/isint.v @@ -0,0 +1,50 @@ +(* This file tests the check that arithmetic operations use to know if their +arguments are ground. The various test cases correspond to possible +optimizations of these tests made by the compiler. *) +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Section test. + +Variable m n : int. + +Check (eq_refl : (fun x => x + 3) m = m + 3). +Check (eq_refl (m + 3) <: (fun x => x + 3) m = m + 3). +Check (eq_refl (m + 3) <<: (fun x => x + 3) m = m + 3). +Definition compute1 := Eval compute in (fun x => x + 3) m. +Check (eq_refl compute1 : m + 3 = m + 3). + +Check (eq_refl : (fun x => 3 + x) m = 3 + m). +Check (eq_refl (3 + m) <: (fun x => 3 + x) m = 3 + m). +Check (eq_refl (3 + m) <<: (fun x => 3 + x) m = 3 + m). +Definition compute2 := Eval compute in (fun x => 3 + x) m. +Check (eq_refl compute2 : 3 + m = 3 + m). + +Check (eq_refl : (fun x y => x + y) m n = m + n). +Check (eq_refl (m + n) <: (fun x y => x + y) m n = m + n). +Check (eq_refl (m + n) <<: (fun x y => x + y) m n = m + n). +Definition compute3 := Eval compute in (fun x y => x + y) m n. +Check (eq_refl compute3 : m + n = m + n). + +Check (eq_refl : (fun x y => x + y) 2 3 = 5). +Check (eq_refl 5 <: (fun x y => x + y) 2 3 = 5). +Check (eq_refl 5 <<: (fun x y => x + y) 2 3 = 5). +Definition compute4 := Eval compute in (fun x y => x + y) 2 3. +Check (eq_refl compute4 : 5 = 5). + +Check (eq_refl : (fun x => x + x) m = m + m). +Check (eq_refl (m + m) <: (fun x => x + x) m = m + m). +Check (eq_refl (m + m) <<: (fun x => x + x) m = m + m). +Definition compute5 := Eval compute in (fun x => x + x) m. +Check (eq_refl compute5 : m + m = m + m). + +Check (eq_refl : (fun x => x + x) 2 = 4). +Check (eq_refl 4 <: (fun x => x + x) 2 = 4). +Check (eq_refl 4 <<: (fun x => x + x) 2 = 4). +Definition compute6 := Eval compute in (fun x => x + x) 2. +Check (eq_refl compute6 : 4 = 4). + +End test. diff --git a/test-suite/arithmetic/land.v b/test-suite/arithmetic/land.v new file mode 100644 index 0000000000..0ea6fd90b6 --- /dev/null +++ b/test-suite/arithmetic/land.v @@ -0,0 +1,29 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 0 land 0 = 0). +Check (eq_refl 0 <: 0 land 0 = 0). +Check (eq_refl 0 <<: 0 land 0 = 0). +Definition compute1 := Eval compute in 0 land 0. +Check (eq_refl compute1 : 0 = 0). + +Check (eq_refl : 9223372036854775807 land 0 = 0). +Check (eq_refl 0 <: 9223372036854775807 land 0 = 0). +Check (eq_refl 0 <<: 9223372036854775807 land 0 = 0). +Definition compute2 := Eval compute in 9223372036854775807 land 0. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 0 land 9223372036854775807 = 0). +Check (eq_refl 0 <: 0 land 9223372036854775807 = 0). +Check (eq_refl 0 <<: 0 land 9223372036854775807 = 0). +Definition compute3 := Eval compute in 0 land 9223372036854775807. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : 9223372036854775807 land 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 9223372036854775807 land 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 9223372036854775807 land 9223372036854775807 = 9223372036854775807). +Definition compute4 := Eval compute in 9223372036854775807 land 9223372036854775807. +Check (eq_refl compute4 : 9223372036854775807 = 9223372036854775807). diff --git a/test-suite/arithmetic/leb.v b/test-suite/arithmetic/leb.v new file mode 100644 index 0000000000..5354919978 --- /dev/null +++ b/test-suite/arithmetic/leb.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 1 <= 1 = true). +Check (eq_refl true <: 1 <= 1 = true). +Check (eq_refl true <<: 1 <= 1 = true). +Definition compute1 := Eval compute in 1 <= 1. +Check (eq_refl compute1 : true = true). + +Check (eq_refl : 1 <= 2 = true). +Check (eq_refl true <: 1 <= 2 = true). +Check (eq_refl true <<: 1 <= 2 = true). +Definition compute2 := Eval compute in 1 <= 2. +Check (eq_refl compute2 : true = true). + +Check (eq_refl : 9223372036854775807 <= 0 = false). +Check (eq_refl false <: 9223372036854775807 <= 0 = false). +Check (eq_refl false <<: 9223372036854775807 <= 0 = false). +Definition compute3 := Eval compute in 9223372036854775807 <= 0. +Check (eq_refl compute3 : false = false). diff --git a/test-suite/arithmetic/lor.v b/test-suite/arithmetic/lor.v new file mode 100644 index 0000000000..9c3b85c054 --- /dev/null +++ b/test-suite/arithmetic/lor.v @@ -0,0 +1,29 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 0 lor 0 = 0). +Check (eq_refl 0 <: 0 lor 0 = 0). +Check (eq_refl 0 <<: 0 lor 0 = 0). +Definition compute1 := Eval compute in 0 lor 0. +Check (eq_refl compute1 : 0 = 0). + +Check (eq_refl : 9223372036854775807 lor 0 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 9223372036854775807 lor 0 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 9223372036854775807 lor 0 = 9223372036854775807). +Definition compute2 := Eval compute in 9223372036854775807 lor 0. +Check (eq_refl compute2 : 9223372036854775807 = 9223372036854775807). + +Check (eq_refl : 0 lor 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 0 lor 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 0 lor 9223372036854775807 = 9223372036854775807). +Definition compute3 := Eval compute in 0 lor 9223372036854775807. +Check (eq_refl compute3 : 9223372036854775807 = 9223372036854775807). + +Check (eq_refl : 9223372036854775807 lor 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 9223372036854775807 lor 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 9223372036854775807 lor 9223372036854775807 = 9223372036854775807). +Definition compute4 := Eval compute in 9223372036854775807 lor 9223372036854775807. +Check (eq_refl compute4 : 9223372036854775807 = 9223372036854775807). diff --git a/test-suite/arithmetic/lsl.v b/test-suite/arithmetic/lsl.v new file mode 100644 index 0000000000..70f3b90140 --- /dev/null +++ b/test-suite/arithmetic/lsl.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 3 << 61 = 6917529027641081856). +Check (eq_refl 6917529027641081856 <: 3 << 61 = 6917529027641081856). +Check (eq_refl 6917529027641081856 <<: 3 << 61 = 6917529027641081856). +Definition compute1 := Eval compute in 3 << 61. +Check (eq_refl compute1 : 6917529027641081856 = 6917529027641081856). + +Check (eq_refl : 2 << 62 = 0). +Check (eq_refl 0 <: 2 << 62 = 0). +Check (eq_refl 0 <<: 2 << 62 = 0). +Definition compute2 := Eval compute in 2 << 62. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 9223372036854775807 << 64 = 0). +Check (eq_refl 0 <: 9223372036854775807 << 64 = 0). +Check (eq_refl 0 <<: 9223372036854775807 << 64 = 0). +Definition compute3 := Eval compute in 9223372036854775807 << 64. +Check (eq_refl compute3 : 0 = 0). diff --git a/test-suite/arithmetic/lsr.v b/test-suite/arithmetic/lsr.v new file mode 100644 index 0000000000..c36c24e237 --- /dev/null +++ b/test-suite/arithmetic/lsr.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 6917529027641081856 >> 61 = 3). +Check (eq_refl 3 <: 6917529027641081856 >> 61 = 3). +Check (eq_refl 3 <<: 6917529027641081856 >> 61 = 3). +Definition compute1 := Eval compute in 6917529027641081856 >> 61. +Check (eq_refl compute1 : 3 = 3). + +Check (eq_refl : 2305843009213693952 >> 62 = 0). +Check (eq_refl 0 <: 2305843009213693952 >> 62 = 0). +Check (eq_refl 0 <<: 2305843009213693952 >> 62 = 0). +Definition compute2 := Eval compute in 2305843009213693952 >> 62. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 9223372036854775807 >> 64 = 0). +Check (eq_refl 0 <: 9223372036854775807 >> 64 = 0). +Check (eq_refl 0 <<: 9223372036854775807 >> 64 = 0). +Definition compute3 := Eval compute in 9223372036854775807 >> 64. +Check (eq_refl compute3 : 0 = 0). diff --git a/test-suite/arithmetic/ltb.v b/test-suite/arithmetic/ltb.v new file mode 100644 index 0000000000..7ae5ac6493 --- /dev/null +++ b/test-suite/arithmetic/ltb.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 1 < 1 = false). +Check (eq_refl false <: 1 < 1 = false). +Check (eq_refl false <<: 1 < 1 = false). +Definition compute1 := Eval compute in 1 < 1. +Check (eq_refl compute1 : false = false). + +Check (eq_refl : 1 < 2 = true). +Check (eq_refl true <: 1 < 2 = true). +Check (eq_refl true <<: 1 < 2 = true). +Definition compute2 := Eval compute in 1 < 2. +Check (eq_refl compute2 : true = true). + +Check (eq_refl : 9223372036854775807 < 0 = false). +Check (eq_refl false <: 9223372036854775807 < 0 = false). +Check (eq_refl false <<: 9223372036854775807 < 0 = false). +Definition compute3 := Eval compute in 9223372036854775807 < 0. +Check (eq_refl compute3 : false = false). diff --git a/test-suite/arithmetic/lxor.v b/test-suite/arithmetic/lxor.v new file mode 100644 index 0000000000..b453fc7697 --- /dev/null +++ b/test-suite/arithmetic/lxor.v @@ -0,0 +1,29 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 0 lxor 0 = 0). +Check (eq_refl 0 <: 0 lxor 0 = 0). +Check (eq_refl 0 <<: 0 lxor 0 = 0). +Definition compute1 := Eval compute in 0 lxor 0. +Check (eq_refl compute1 : 0 = 0). + +Check (eq_refl : 9223372036854775807 lxor 0 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 9223372036854775807 lxor 0 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 9223372036854775807 lxor 0 = 9223372036854775807). +Definition compute2 := Eval compute in 9223372036854775807 lxor 0. +Check (eq_refl compute2 : 9223372036854775807 = 9223372036854775807). + +Check (eq_refl : 0 lxor 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 0 lxor 9223372036854775807 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 0 lxor 9223372036854775807 = 9223372036854775807). +Definition compute3 := Eval compute in 0 lxor 9223372036854775807. +Check (eq_refl compute3 : 9223372036854775807 = 9223372036854775807). + +Check (eq_refl : 9223372036854775807 lxor 9223372036854775807 = 0). +Check (eq_refl 0 <: 9223372036854775807 lxor 9223372036854775807 = 0). +Check (eq_refl 0 <<: 9223372036854775807 lxor 9223372036854775807 = 0). +Definition compute4 := Eval compute in 9223372036854775807 lxor 9223372036854775807. +Check (eq_refl compute4 : 0 = 0). diff --git a/test-suite/arithmetic/mod.v b/test-suite/arithmetic/mod.v new file mode 100644 index 0000000000..5307eed493 --- /dev/null +++ b/test-suite/arithmetic/mod.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 6 \% 3 = 0). +Check (eq_refl 0 <: 6 \% 3 = 0). +Check (eq_refl 0 <<: 6 \% 3 = 0). +Definition compute1 := Eval compute in 6 \% 3. +Check (eq_refl compute1 : 0 = 0). + +Check (eq_refl : 5 \% 3 = 2). +Check (eq_refl 2 <: 5 \% 3 = 2). +Check (eq_refl 2 <<: 5 \% 3 = 2). +Definition compute2 := Eval compute in 5 \% 3. +Check (eq_refl compute2 : 2 = 2). diff --git a/test-suite/arithmetic/mul.v b/test-suite/arithmetic/mul.v new file mode 100644 index 0000000000..9480e8cd46 --- /dev/null +++ b/test-suite/arithmetic/mul.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 2 * 3 = 6). +Check (eq_refl 6 <: 2 * 3 = 6). +Check (eq_refl 6 <<: 2 * 3 = 6). +Definition compute1 := Eval compute in 2 * 3. +Check (eq_refl compute1 : 6 = 6). + +Check (eq_refl : 9223372036854775807 * 2 = 9223372036854775806). +Check (eq_refl 9223372036854775806 <: 9223372036854775807 * 2 = 9223372036854775806). +Check (eq_refl 9223372036854775806 <<: 9223372036854775807 * 2 = 9223372036854775806). +Definition compute2 := Eval compute in 9223372036854775807 * 2. +Check (eq_refl compute2 : 9223372036854775806 = 9223372036854775806). diff --git a/test-suite/arithmetic/mulc.v b/test-suite/arithmetic/mulc.v new file mode 100644 index 0000000000..e10855bafa --- /dev/null +++ b/test-suite/arithmetic/mulc.v @@ -0,0 +1,22 @@ +Require Import Cyclic63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 2 *c 3 = WW 0 6). +Check (eq_refl (WW 0 6) <: 2 *c 3 = WW 0 6). +Check (eq_refl (WW 0 6) <<: 2 *c 3 = WW 0 6). +Definition compute1 := Eval compute in 2 *c 3. +Check (eq_refl compute1 : WW 0 6 = WW 0 6). + +Check (eq_refl : 9223372036854775807 *c 2 = WW 1 9223372036854775806). +Check (eq_refl (WW 1 9223372036854775806) <: 9223372036854775807 *c 2 = WW 1 9223372036854775806). +Check (eq_refl (WW 1 9223372036854775806) <<: 9223372036854775807 *c 2 = WW 1 9223372036854775806). + +Definition compute2 := Eval compute in 9223372036854775807 *c 2. +Check (eq_refl compute2 : WW 1 9223372036854775806 = WW 1 9223372036854775806). + +Check (eq_refl : 0 *c 0 = W0). +Check (eq_refl (@W0 int) <: 0 *c 0 = W0). +Check (eq_refl (@W0 int) <<: 0 *c 0 = W0). diff --git a/test-suite/arithmetic/primitive.v b/test-suite/arithmetic/primitive.v new file mode 100644 index 0000000000..f62f6109e1 --- /dev/null +++ b/test-suite/arithmetic/primitive.v @@ -0,0 +1,12 @@ +Section S. + Variable A : Type. + Fail Primitive int : let x := A in Set := #int63_type. + Fail Primitive add := #int63_add. +End S. + +(* [Primitive] should be forbidden in sections, otherwise its type after cooking +will be incorrect: + +Check int. + +*) diff --git a/test-suite/arithmetic/reduction.v b/test-suite/arithmetic/reduction.v new file mode 100644 index 0000000000..00e067ac5a --- /dev/null +++ b/test-suite/arithmetic/reduction.v @@ -0,0 +1,28 @@ +Require Import Int63. + +Open Scope int63_scope. + +Definition div_eucl_plus_one i1 i2 := + let (q,r) := diveucl i1 i2 in + (q+1, r+1)%int63. + +Definition rcbn := Eval cbn in div_eucl_plus_one 3 2. +Check (eq_refl : rcbn = (2, 2)). + +Definition rcbv := Eval cbv in div_eucl_plus_one 3 2. +Check (eq_refl : rcbv = (2, 2)). + +Definition rvmc := Eval vm_compute in div_eucl_plus_one 3 2. +Check (eq_refl : rvmc = (2, 2)). + +Definition f n m := + match (n ?= 42)%int63 with + | Lt => (n + m)%int63 + | _ => (2*m)%int63 + end. + +Goal forall n, (n ?= 42)%int63 = Gt -> f n 256 = 512%int63. + intros. unfold f. + cbn. Undo. cbv. (* Test reductions under match clauses *) + rewrite H. reflexivity. +Qed. diff --git a/test-suite/arithmetic/sub.v b/test-suite/arithmetic/sub.v new file mode 100644 index 0000000000..1606fd2aa1 --- /dev/null +++ b/test-suite/arithmetic/sub.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 3 - 2 = 1). +Check (eq_refl 1 <: 3 - 2 = 1). +Check (eq_refl 1 <<: 3 - 2 = 1). +Definition compute1 := Eval compute in 3 - 2. +Check (eq_refl compute1 : 1 = 1). + +Check (eq_refl : 0 - 1 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <: 0 - 1 = 9223372036854775807). +Check (eq_refl 9223372036854775807 <<: 0 - 1 = 9223372036854775807). +Definition compute2 := Eval compute in 0 - 1. +Check (eq_refl compute2 : 9223372036854775807 = 9223372036854775807). diff --git a/test-suite/arithmetic/subc.v b/test-suite/arithmetic/subc.v new file mode 100644 index 0000000000..fc4067e48b --- /dev/null +++ b/test-suite/arithmetic/subc.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : 3 -c 2 = C0 1). +Check (eq_refl (C0 1) <: 3 -c 2 = C0 1). +Check (eq_refl (C0 1) <<: 3 -c 2 = C0 1). +Definition compute1 := Eval compute in 3 -c 2. +Check (eq_refl compute1 : C0 1 = C0 1). + +Check (eq_refl : 0 -c 1 = C1 9223372036854775807). +Check (eq_refl (C1 9223372036854775807) <: 0 -c 1 = C1 9223372036854775807). +Check (eq_refl (C1 9223372036854775807) <<: 0 -c 1 = C1 9223372036854775807). +Definition compute2 := Eval compute in 0 -c 1. +Check (eq_refl compute2 : C1 9223372036854775807 = C1 9223372036854775807). diff --git a/test-suite/arithmetic/subcarryc.v b/test-suite/arithmetic/subcarryc.v new file mode 100644 index 0000000000..e81b6536b2 --- /dev/null +++ b/test-suite/arithmetic/subcarryc.v @@ -0,0 +1,17 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : subcarryc 3 1 = C0 1). +Check (eq_refl (C0 1) <: subcarryc 3 1 = C0 1). +Check (eq_refl (C0 1) <<: subcarryc 3 1 = C0 1). +Definition compute1 := Eval compute in subcarryc 3 1. +Check (eq_refl compute1 : C0 1 = C0 1). + +Check (eq_refl : subcarryc 0 1 = C1 9223372036854775806). +Check (eq_refl (C1 9223372036854775806) <: subcarryc 0 1 = C1 9223372036854775806). +Check (eq_refl (C1 9223372036854775806) <<: subcarryc 0 1 = C1 9223372036854775806). +Definition compute2 := Eval compute in subcarryc 0 1. +Check (eq_refl compute2 : C1 9223372036854775806 = C1 9223372036854775806). diff --git a/test-suite/arithmetic/tail0.v b/test-suite/arithmetic/tail0.v new file mode 100644 index 0000000000..c9d426087a --- /dev/null +++ b/test-suite/arithmetic/tail0.v @@ -0,0 +1,23 @@ +Require Import Int63. + +Set Implicit Arguments. + +Open Scope int63_scope. + +Check (eq_refl : tail0 2305843009213693952 = 61). +Check (eq_refl 61 <: tail0 2305843009213693952 = 61). +Check (eq_refl 61 <<: tail0 2305843009213693952 = 61). +Definition compute1 := Eval compute in tail0 2305843009213693952. +Check (eq_refl compute1 : 61 = 61). + +Check (eq_refl : tail0 1 = 0). +Check (eq_refl 0 <: tail0 1 = 0). +Check (eq_refl 0 <<: tail0 1 = 0). +Definition compute2 := Eval compute in tail0 1. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : tail0 0 = 63). +Check (eq_refl 63 <: tail0 0 = 63). +Check (eq_refl 63 <<: tail0 0 = 63). +Definition compute3 := Eval compute in tail0 0. +Check (eq_refl compute3 : 63 = 63). diff --git a/test-suite/arithmetic/unsigned.v b/test-suite/arithmetic/unsigned.v new file mode 100644 index 0000000000..82920bd201 --- /dev/null +++ b/test-suite/arithmetic/unsigned.v @@ -0,0 +1,18 @@ +(* This file checks that operations over int63 are unsigned. *) +Require Import Int63. + +Open Scope int63_scope. + +(* (0-1) must be the maximum integer value and not negative 1 *) + +Check (eq_refl : 1/(0-1) = 0). +Check (eq_refl 0 <: 1/(0-1) = 0). +Check (eq_refl 0 <<: 1/(0-1) = 0). +Definition compute1 := Eval compute in 1/(0-1). +Check (eq_refl compute1 : 0 = 0). + +Check (eq_refl : 3 \% (0-1) = 3). +Check (eq_refl 3 <: 3 \% (0-1) = 3). +Check (eq_refl 3 <<: 3 \% (0-1) = 3). +Definition compute2 := Eval compute in 3 \% (0-1). +Check (eq_refl compute2 : 3 = 3). 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_3441.v b/test-suite/bugs/closed/bug_3441.v deleted file mode 100644 index 52acb996f8..0000000000 --- a/test-suite/bugs/closed/bug_3441.v +++ /dev/null @@ -1,24 +0,0 @@ -Axiom f : nat -> nat -> nat. -Fixpoint do_n (n : nat) (k : nat) := - match n with - | 0 => k - | S n' => do_n n' (f k k) - end. - -Notation big := (_ = _). -Axiom k : nat. -Goal True. -Timeout 1 let H := fresh "H" in - let x := constr:(let n := 17 in do_n n = do_n n) in - let y := (eval lazy in x) in - pose proof y as H. (* Finished transaction in 1.102 secs (1.084u,0.016s) (successful) *) -Timeout 1 let H := fresh "H" in - let x := constr:(let n := 17 in do_n n = do_n n) in - let y := (eval lazy in x) in - pose y as H; clearbody H. (* Finished transaction in 0.412 secs (0.412u,0.s) (successful) *) - -Timeout 1 Time let H := fresh "H" in - let x := constr:(let n := 17 in do_n n = do_n n) in - let y := (eval lazy in x) in - assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *) -Abort. diff --git a/test-suite/bugs/closed/bug_4366.v b/test-suite/bugs/closed/bug_4366.v deleted file mode 100644 index 403c2d2026..0000000000 --- a/test-suite/bugs/closed/bug_4366.v +++ /dev/null @@ -1,15 +0,0 @@ -Fixpoint stupid (n : nat) : unit := -match n with -| 0 => tt -| S n => - let () := stupid n in - let () := stupid n in - tt -end. - -Goal True. -Proof. -pose (v := stupid 24). -Timeout 4 vm_compute in v. -exact I. -Qed. diff --git a/test-suite/bugs/closed/bug_4811.v b/test-suite/bugs/closed/bug_4811.v deleted file mode 100644 index b90257cb3f..0000000000 --- a/test-suite/bugs/closed/bug_4811.v +++ /dev/null @@ -1,1686 +0,0 @@ -(* Test about a slowness of f_equal in 8.5pl1 *) - -(* Submitted by Jason Gross *) - -(* -*- mode: coq; coq-prog-args: ("-R" "src" "Crypto" "-R" "Bedrock" "Bedrock" "-R" "coqprime-8.5/Coqprime" "Coqprime" "-top" "GF255192") -*- *) -(* File reduced by coq-bug-finder from original input, then from 162 lines to 23 lines, then from 245 lines to 95 lines, then from 198 lines to 101 lines, then from 654 lines to 452 lines, then from 591 lines to 505 lines, then from 1770 lines to 580 lines, then from 2238 lines to 1715 lines, then from 1776 lines to 1738 lines, then from 1750 lines to 1679 lines, then from 1693 lines to 1679 lines *) -(* coqc version 8.5pl1 (April 2016) compiled on Apr 18 2016 14:48:5 with OCaml 4.02.3 - coqtop version 8.5pl1 (April 2016) *) -Require Coq.ZArith.ZArith. - -Import Coq.ZArith.ZArith. - -Axiom F : Z -> Set. -Definition Let_In {A P} (x : A) (f : forall y : A, P y) - := let y := x in f y. -Local Open Scope Z_scope. -Definition modulus : Z := 2^255 - 19. -Axiom decode : list Z -> F modulus. -Goal forall x9 x8 x7 x6 x5 x4 x3 x2 x1 x0 y9 y8 y7 y6 y5 y4 y3 y2 y1 y0 : Z, - let Zmul := Z.mul in - let Zadd := Z.add in - let Zsub := Z.sub in - let Zpow_pos := Z.pow_pos in - @eq (F (Zsub (Zpow_pos (Zpos (xO xH)) (xI (xI (xI (xI (xI (xI (xI xH)))))))) (Zpos (xI (xI (xO (xO xH))))))) - (@decode - (@Let_In Z (fun _ : Z => list Z) - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) (Zmul (Zmul x7 y3) (Zpos (xO xH)))) - (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6)) - (Zmul (Zmul x3 y7) (Zpos (xO xH)))) (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (fun z : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5)) (Zmul x5 y6)) - (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9))))) - (fun z0 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z0 (Zpos (xI (xO (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (fun z1 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z1 (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7)) (Zmul x5 y8)) - (Zmul x4 y9))))) - (fun z2 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z2 (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2)) - (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (fun z3 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z3 (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) (Zmul x1 y4)) - (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9))))) - (fun z4 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z4 (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2)) - (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH)))) - (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) - (fun z5 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z5 (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3)) - (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9))))) - (fun z6 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z6 (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) (Zmul x6 y2)) - (Zmul (Zmul x5 y3) (Zpos (xO xH)))) (Zmul x4 y4)) - (Zmul (Zmul x3 y5) (Zpos (xO xH)))) (Zmul x2 y6)) - (Zmul (Zmul x1 y7) (Zpos (xO xH)))) (Zmul x0 y8)) - (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH))))) - (fun z7 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Z.shiftr z7 (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) (Zmul x6 y3)) - (Zmul x5 y4)) (Zmul x4 y5)) (Zmul x3 y6)) (Zmul x2 y7)) - (Zmul x1 y8)) (Zmul x0 y9))) - (fun z8 : Z => - @Let_In Z (fun _ : Z => list Z) - (Zadd (Zmul (Zpos (xI (xI (xO (xO xH))))) (Z.shiftr z8 (Zpos (xI (xO (xO (xI xH))))))) - (Z.land z - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))) - (fun z9 : Z => - @cons Z - (Z.land z9 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Zadd (Z.shiftr z9 (Zpos (xO (xI (xO (xI xH)))))) - (Z.land z0 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land z1 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land z2 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@cons Z - (Z.land z3 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land z4 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@cons Z - (Z.land z5 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land z6 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@cons Z - (Z.land z7 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land z8 - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@nil Z))))))))))))))))))))))) - (@decode - (@cons Z - (Z.land - (Zadd - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y1) - (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul - (Zmul x7 y3) - (Zpos (xO xH)))) - (Zmul x6 y4)) - (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) - (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) - (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul x9 y2) (Zmul x8 y3)) - (Zmul x7 y4)) - (Zmul x6 y5)) - (Zmul x5 y6)) - (Zmul x4 y7)) (Zmul x3 y8)) - (Zmul x2 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) - (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) - (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) - (Zmul x6 y6)) - (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) - (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) - (Zmul x6 y7)) (Zmul x5 y8)) - (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) - (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH)))) - (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) - (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) - (Zmul x1 y4)) (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2)) - (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4)) - (Zmul (Zmul x1 y5) (Zpos (xO xH)))) (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3)) - (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) (Zmul x6 y2)) - (Zmul (Zmul x5 y3) (Zpos (xO xH)))) (Zmul x4 y4)) - (Zmul (Zmul x3 y5) (Zpos (xO xH)))) (Zmul x2 y6)) (Zmul (Zmul x1 y7) (Zpos (xO xH)))) - (Zmul x0 y8)) (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) (Zmul x6 y3)) (Zmul x5 y4)) - (Zmul x4 y5)) (Zmul x3 y6)) (Zmul x2 y7)) (Zmul x1 y8)) (Zmul x0 y9))) - (Zpos (xI (xO (xO (xI xH))))))) - (Z.land - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) (Zmul x2 y8)) - (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Zadd - (Z.shiftr - (Zadd - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y1) - (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul - (Zmul x7 y3) - (Zpos (xO xH)))) - (Zmul x6 y4)) - (Zmul - (Zmul x5 y5) - (Zpos (xO xH)))) - (Zmul x4 y6)) - (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) - (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul x9 y2) - (Zmul x8 y3)) - (Zmul x7 y4)) - (Zmul x6 y5)) - (Zmul x5 y6)) - (Zmul x4 y7)) - (Zmul x3 y8)) - (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zmul x2 y0) - (Zmul (Zmul x1 y1) (Zpos (xO xH)))) - (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul (Zmul x9 y3) (Zpos (xO xH))) - (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) - (Zmul x6 y6)) - (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) - (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) - (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) - (Zmul x7 y6)) (Zmul x6 y7)) - (Zmul x5 y8)) (Zmul x4 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) - (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH)))) - (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) - (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) - (Zmul x2 y3)) (Zmul x1 y4)) (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) - (Zmul x6 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) - (Zmul x4 y2)) (Zmul (Zmul x3 y3) (Zpos (xO xH)))) - (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH)))) - (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3)) - (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) (Zmul x6 y2)) - (Zmul (Zmul x5 y3) (Zpos (xO xH)))) (Zmul x4 y4)) - (Zmul (Zmul x3 y5) (Zpos (xO xH)))) (Zmul x2 y6)) - (Zmul (Zmul x1 y7) (Zpos (xO xH)))) (Zmul x0 y8)) - (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) (Zmul x6 y3)) - (Zmul x5 y4)) (Zmul x4 y5)) (Zmul x3 y6)) (Zmul x2 y7)) - (Zmul x1 y8)) (Zmul x0 y9))) (Zpos (xI (xO (xO (xI xH))))))) - (Z.land - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4)) - (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Z.land - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4)) - (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5)) (Zmul x5 y6)) - (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) (Zmul x6 y4)) - (Zmul (Zmul x5 y5) (Zpos (xO xH)))) (Zmul x4 y6)) - (Zmul (Zmul x3 y7) (Zpos (xO xH)))) (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5)) - (Zmul x5 y6)) (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) - (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) (Zmul x6 y5)) - (Zmul x5 y6)) (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6)) - (Zmul (Zmul x5 y7) (Zpos (xO xH)))) (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7)) (Zmul x5 y8)) - (Zmul x4 y9))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) - (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) - (Zmul x6 y5)) (Zmul x5 y6)) (Zmul x4 y7)) - (Zmul x3 y8)) (Zmul x2 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) (Zmul x6 y6)) - (Zmul (Zmul x5 y7) (Zpos (xO xH)))) (Zmul x4 y8)) - (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7)) - (Zmul x5 y8)) (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2)) - (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y1) (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) - (Zmul x6 y4)) (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) (Zmul x7 y4)) - (Zmul x6 y5)) (Zmul x5 y6)) - (Zmul x4 y7)) (Zmul x3 y8)) (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) - (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) (Zmul x6 y7)) - (Zmul x5 y8)) (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2)) - (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8)) - (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) (Zmul x1 y4)) - (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul (Zmul x9 y1) (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul (Zmul x7 y3) (Zpos (xO xH)))) - (Zmul x6 y4)) - (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) - (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x9 y2) (Zmul x8 y3)) - (Zmul x7 y4)) (Zmul x6 y5)) - (Zmul x5 y6)) (Zmul x4 y7)) - (Zmul x3 y8)) (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) - (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) - (Zmul x8 y4)) (Zmul (Zmul x7 y5) (Zpos (xO xH)))) - (Zmul x6 y6)) (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) - (Zmul x6 y7)) (Zmul x5 y8)) (Zmul x4 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) (Zmul x2 y2)) - (Zmul (Zmul x1 y3) (Zpos (xO xH)))) (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) (Zmul x6 y8)) - (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) - (Zmul x1 y4)) (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2)) - (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4)) - (Zmul (Zmul x1 y5) (Zpos (xO xH)))) (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y1) - (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul - (Zmul x7 y3) - (Zpos (xO xH)))) - (Zmul x6 y4)) - (Zmul (Zmul x5 y5) (Zpos (xO xH)))) - (Zmul x4 y6)) - (Zmul (Zmul x3 y7) (Zpos (xO xH)))) - (Zmul x2 y8)) - (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul x9 y2) (Zmul x8 y3)) - (Zmul x7 y4)) - (Zmul x6 y5)) - (Zmul x5 y6)) - (Zmul x4 y7)) (Zmul x3 y8)) - (Zmul x2 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zmul x2 y0) (Zmul (Zmul x1 y1) (Zpos (xO xH)))) - (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y3) (Zpos (xO xH))) - (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) - (Zmul x6 y6)) - (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) - (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) (Zmul x7 y6)) - (Zmul x6 y7)) (Zmul x5 y8)) - (Zmul x4 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) - (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH)))) - (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) - (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) (Zmul x2 y3)) - (Zmul x1 y4)) (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) (Zmul x6 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) (Zmul x4 y2)) - (Zmul (Zmul x3 y3) (Zpos (xO xH)))) (Zmul x2 y4)) - (Zmul (Zmul x1 y5) (Zpos (xO xH)))) (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) (Zmul x4 y3)) - (Zmul x3 y4)) (Zmul x2 y5)) (Zmul x1 y6)) (Zmul x0 y7)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y1) - (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul - (Zmul x7 y3) - (Zpos (xO xH)))) - (Zmul x6 y4)) - (Zmul - (Zmul x5 y5) - (Zpos (xO xH)))) - (Zmul x4 y6)) - (Zmul - (Zmul x3 y7) - (Zpos (xO xH)))) - (Zmul x2 y8)) - (Zmul (Zmul x1 y9) (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul x9 y2) - (Zmul x8 y3)) - (Zmul x7 y4)) - (Zmul x6 y5)) - (Zmul x5 y6)) - (Zmul x4 y7)) - (Zmul x3 y8)) - (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zmul x2 y0) - (Zmul (Zmul x1 y1) (Zpos (xO xH)))) - (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y3) - (Zpos (xO xH))) - (Zmul x8 y4)) - (Zmul (Zmul x7 y5) (Zpos (xO xH)))) - (Zmul x6 y6)) - (Zmul (Zmul x5 y7) (Zpos (xO xH)))) - (Zmul x4 y8)) - (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) (Zmul x1 y2)) - (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x9 y4) (Zmul x8 y5)) - (Zmul x7 y6)) (Zmul x6 y7)) - (Zmul x5 y8)) (Zmul x4 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul x4 y0) (Zmul (Zmul x3 y1) (Zpos (xO xH)))) - (Zmul x2 y2)) (Zmul (Zmul x1 y3) (Zpos (xO xH)))) - (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) - (Zmul x8 y6)) (Zmul (Zmul x7 y7) (Zpos (xO xH)))) - (Zmul x6 y8)) (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) - (Zmul x2 y3)) (Zmul x1 y4)) (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) - (Zmul x6 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x6 y0) (Zmul (Zmul x5 y1) (Zpos (xO xH)))) - (Zmul x4 y2)) (Zmul (Zmul x3 y3) (Zpos (xO xH)))) - (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH)))) - (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) - (Zmul x4 y3)) (Zmul x3 y4)) (Zmul x2 y5)) - (Zmul x1 y6)) (Zmul x0 y7)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) - (Zmul x6 y2)) (Zmul (Zmul x5 y3) (Zpos (xO xH)))) - (Zmul x4 y4)) (Zmul (Zmul x3 y5) (Zpos (xO xH)))) - (Zmul x2 y6)) (Zmul (Zmul x1 y7) (Zpos (xO xH)))) (Zmul x0 y8)) - (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH))))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI xH))))))))))))))))))))))))))) - (@cons Z - (Z.land - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd - (Z.shiftr - (Zadd (Zmul x0 y0) - (Zmul - (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y1) - (Zpos (xO xH))) - (Zmul x8 y2)) - (Zmul - (Zmul x7 y3) - (Zpos (xO xH)))) - (Zmul x6 y4)) - (Zmul - (Zmul x5 y5) - (Zpos (xO xH)))) - (Zmul x4 y6)) - (Zmul - (Zmul x3 y7) - (Zpos (xO xH)))) - (Zmul x2 y8)) - (Zmul - (Zmul x1 y9) - (Zpos (xO xH)))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd (Zadd (Zmul x1 y0) (Zmul x0 y1)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul x9 y2) - (Zmul x8 y3)) - (Zmul x7 y4)) - (Zmul x6 y5)) - (Zmul x5 y6)) - (Zmul x4 y7)) - (Zmul x3 y8)) - (Zmul x2 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zmul x2 y0) - (Zmul (Zmul x1 y1) (Zpos (xO xH)))) - (Zmul x0 y2)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zmul - (Zmul x9 y3) - (Zpos (xO xH))) - (Zmul x8 y4)) - (Zmul - (Zmul x7 y5) - (Zpos (xO xH)))) - (Zmul x6 y6)) - (Zmul - (Zmul x5 y7) - (Zpos (xO xH)))) - (Zmul x4 y8)) - (Zmul (Zmul x3 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd (Zadd (Zmul x3 y0) (Zmul x2 y1)) - (Zmul x1 y2)) (Zmul x0 y3)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul x9 y4) (Zmul x8 y5)) - (Zmul x7 y6)) - (Zmul x6 y7)) - (Zmul x5 y8)) - (Zmul x4 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul x4 y0) - (Zmul (Zmul x3 y1) (Zpos (xO xH)))) - (Zmul x2 y2)) - (Zmul (Zmul x1 y3) (Zpos (xO xH)))) - (Zmul x0 y4)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd - (Zadd - (Zadd - (Zadd (Zmul (Zmul x9 y5) (Zpos (xO xH))) - (Zmul x8 y6)) - (Zmul (Zmul x7 y7) (Zpos (xO xH)))) - (Zmul x6 y8)) - (Zmul (Zmul x5 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x5 y0) (Zmul x4 y1)) (Zmul x3 y2)) - (Zmul x2 y3)) (Zmul x1 y4)) - (Zmul x0 y5)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zadd (Zmul x9 y6) (Zmul x8 y7)) (Zmul x7 y8)) - (Zmul x6 y9))))) (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zmul x6 y0) - (Zmul (Zmul x5 y1) (Zpos (xO xH)))) - (Zmul x4 y2)) (Zmul (Zmul x3 y3) (Zpos (xO xH)))) - (Zmul x2 y4)) (Zmul (Zmul x1 y5) (Zpos (xO xH)))) - (Zmul x0 y6)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) - (Zadd (Zadd (Zmul (Zmul x9 y7) (Zpos (xO xH))) (Zmul x8 y8)) - (Zmul (Zmul x7 y9) (Zpos (xO xH))))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x7 y0) (Zmul x6 y1)) (Zmul x5 y2)) - (Zmul x4 y3)) (Zmul x3 y4)) (Zmul x2 y5)) - (Zmul x1 y6)) (Zmul x0 y7)) - (Zmul (Zpos (xI (xI (xO (xO xH))))) (Zadd (Zmul x9 y8) (Zmul x8 y9))))) - (Zpos (xI (xO (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zmul x8 y0) (Zmul (Zmul x7 y1) (Zpos (xO xH)))) - (Zmul x6 y2)) (Zmul (Zmul x5 y3) (Zpos (xO xH)))) - (Zmul x4 y4)) (Zmul (Zmul x3 y5) (Zpos (xO xH)))) - (Zmul x2 y6)) (Zmul (Zmul x1 y7) (Zpos (xO xH)))) - (Zmul x0 y8)) - (Zmul (Zmul (Zmul (Zpos (xI (xI (xO (xO xH))))) x9) y9) (Zpos (xO xH))))) - (Zpos (xO (xI (xO (xI xH)))))) - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd - (Zadd (Zadd (Zadd (Zmul x9 y0) (Zmul x8 y1)) (Zmul x7 y2)) - (Zmul x6 y3)) (Zmul x5 y4)) (Zmul x4 y5)) - (Zmul x3 y6)) (Zmul x2 y7)) (Zmul x1 y8)) (Zmul x0 y9))) - (Zpos - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI - (xI (xI (xI (xI (xI (xI (xI xH)))))))))))))))))))))))))) - (@nil Z)))))))))))). - cbv beta zeta. - intros. - (timeout 1 (apply f_equal; reflexivity)) || fail 0 "too early". - Undo. - Time Timeout 1 f_equal. (* Finished transaction in 0. secs (0.3u,0.s) in 8.4 *) -Abort. diff --git a/test-suite/bugs/closed/bug_4836.v b/test-suite/bugs/closed/bug_4836.v index 5838dcd8a7..9aefb10172 100644 --- a/test-suite/bugs/closed/bug_4836.v +++ b/test-suite/bugs/closed/bug_4836.v @@ -1 +1 @@ -(* -*- coq-prog-args: ("-compile" "bugs/closed/PLACEHOLDER.v") -*- *) +(* -*- coq-prog-args: ("bugs/closed/PLACEHOLDER.v") -*- *) diff --git a/test-suite/bugs/closed/bug_5197.v b/test-suite/bugs/closed/bug_5197.v index b67e93d677..0c236e12ad 100644 --- a/test-suite/bugs/closed/bug_5197.v +++ b/test-suite/bugs/closed/bug_5197.v @@ -1,6 +1,6 @@ Set Universe Polymorphism. Set Primitive Projections. -Unset Printing Primitive Projection Compatibility. + Axiom Ω : Type. Record Pack (A : Ω -> Type) (Aᴿ : Ω -> (forall ω : Ω, A ω) -> Type) := mkPack { 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_7811.v b/test-suite/bugs/closed/bug_7811.v index fee330f22d..155f3285b7 100644 --- a/test-suite/bugs/closed/bug_7811.v +++ b/test-suite/bugs/closed/bug_7811.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-top" "atomic" "-Q" "." "iris" "-R" "." "stdpp") -*- *) +(* -*- mode: coq; coq-prog-args: ("-top" "atomic" "-Q" "." "iris" "-R" "." "stdpp") -*- *) (* File reduced by coq-bug-finder from original input, then from 140 lines to 26 lines, then from 141 lines to 27 lines, then from 142 lines to 27 lines, then from 272 lines to 61 lines, then from 291 lines to 94 lines, then from 678 lines to 142 lines, then from 418 lines to 161 lines, then from 538 lines to 189 lines, then from 840 lines to 493 lines, then from 751 lines to 567 lines, then from 913 lines to 649 lines, then from 875 lines to 666 lines, then from 784 lines to 568 lines, then from 655 lines to 173 lines, then from 317 lines to 94 lines, then from 172 lines to 86 lines, then from 102 lines to 86 lines, then from 130 lines to 86 lines, then from 332 lines to 112 lines, then from 279 lines to 111 lines, then from 3996 lines to 5697 lines, then from 153 lines to 117 lines, then from 146 lines to 108 lines, then from 124 lines to 108 lines *) (* coqc version 8.8.0 (May 2018) compiled on May 2 2018 16:49:46 with OCaml 4.02.3 coqtop version 8.8.0 (May 2018) *) diff --git a/test-suite/bugs/closed/bug_8076.v b/test-suite/bugs/closed/bug_8076.v new file mode 100644 index 0000000000..7bee43620f --- /dev/null +++ b/test-suite/bugs/closed/bug_8076.v @@ -0,0 +1,3 @@ + +Notation leak a := ltac:(let x := constr:(Type) in exact a) (only parsing). +Record foo@{} (P:leak Prop) := { f : leak Prop }. diff --git a/test-suite/bugs/closed/bug_9268.v b/test-suite/bugs/closed/bug_9268.v new file mode 100644 index 0000000000..02dd46f6d2 --- /dev/null +++ b/test-suite/bugs/closed/bug_9268.v @@ -0,0 +1,46 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.micromega.Lia. + +Local Open Scope Z_scope. + +Definition Register := Z%type. + +Definition Opcode := Z%type. + +Inductive InstructionI : Type + := Lb : Register -> Register -> Z -> InstructionI + | InvalidI : InstructionI. + +Inductive Instruction : Type + := IInstruction : InstructionI -> Instruction. + +Definition funct3_LB : Z := 0. + +Definition opcode_LOAD : Opcode := 3. + +Set Universe Polymorphism. + +Definition MachineInt := Z. + +Definition funct3_JALR := 0. + +Axiom InstructionMapper: Type -> Type. + +Definition apply_InstructionMapper(mapper: InstructionMapper Z)(inst: Instruction): Z := + match inst with + | IInstruction InvalidI => 2 + | IInstruction (Lb rd rs1 oimm12) => 3 + end. + +Axiom Encoder: InstructionMapper MachineInt. + +Definition encode: Instruction -> MachineInt := apply_InstructionMapper Encoder. + +Lemma foo: forall (ins: InstructionI), + 0 <= encode (IInstruction ins) -> + 0 <= encode (IInstruction ins) . +Proof. + Set Printing Universes. + intros. + lia. +Qed. diff --git a/test-suite/bugs/closed/bug_9367.v b/test-suite/bugs/closed/bug_9367.v new file mode 100644 index 0000000000..885f6bc391 --- /dev/null +++ b/test-suite/bugs/closed/bug_9367.v @@ -0,0 +1,12 @@ +Section foo. +Variable f : forall n : nat, nat. +Arguments f {_}. +Check f (n := 3). +Global Arguments f {bar} : rename. +End foo. + +Section foo. +Variable f : forall n : nat, nat. +Arguments f {_}. +Fail Check f (bar := 3). +End foo. diff --git a/test-suite/bugs/closed/bug_9432.v b/test-suite/bugs/closed/bug_9432.v new file mode 100644 index 0000000000..c85f8129ce --- /dev/null +++ b/test-suite/bugs/closed/bug_9432.v @@ -0,0 +1,12 @@ + +Record foo := { f : Type }. + +Fail Canonical Structure xx@{} := {| f := Type |}. + +Canonical Structure xx@{i} := {| f := Type@{i} |}. + +Fail Coercion cc@{} := fun x : Type => Build_foo x. + +Polymorphic Coercion cc@{i} := fun x : Type@{i} => Build_foo x. + +Coercion cc1@{i} := (cc@{i}). diff --git a/test-suite/bugs/closed/bug_9451.v b/test-suite/bugs/closed/bug_9451.v new file mode 100644 index 0000000000..03bb0433f1 --- /dev/null +++ b/test-suite/bugs/closed/bug_9451.v @@ -0,0 +1,8 @@ +Goal False. +cut True. +assert False. +evar (x : True). +let v := open_constr:(_) in idtac. all: exfalso; clear. +Optimize Proof. +(* Error: Anomaly "grounding a non evar-free term" *) +Abort All. diff --git a/test-suite/bugs/closed/bug_9453.v b/test-suite/bugs/closed/bug_9453.v new file mode 100644 index 0000000000..18745533b2 --- /dev/null +++ b/test-suite/bugs/closed/bug_9453.v @@ -0,0 +1,7 @@ +(* check compatibility with 8.8 and earlier for lack of warnings on the nat 5000 *) +Set Warnings Append "+large-nat,+abstract-large-number". +Fail Check 5001. +Check 5000. +(* Error: +To avoid stack overflow, large numbers in nat are interpreted as applications of +Nat.of_uint. *) 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/bugs/closed/bug_9508.v b/test-suite/bugs/closed/bug_9508.v new file mode 100644 index 0000000000..2c38e24add --- /dev/null +++ b/test-suite/bugs/closed/bug_9508.v @@ -0,0 +1,29 @@ +Set Implicit Arguments. +Unset Strict Implicit. + +Module OK. +Record A := mkA { + T : Type; + P : T -> bool; +}. + +About P. (* Argument a is implicit *) +Check P (true: T (mkA negb)). +End OK. + +Module KO. +Set Primitive Projections. +Record A := mkA { + T : Type; + P : T -> bool; +}. + +About P. (* No implicit arguments *) +Check P (true: T (mkA negb)). +(* +The command has indeed failed with message: +The term "true : T {| T := bool; P := negb |}" has type "T {| T := bool; P := negb |}" +while it is expected to have type "A". +*) + +End KO. diff --git a/test-suite/bugs/closed/bug_9527.v b/test-suite/bugs/closed/bug_9527.v new file mode 100644 index 0000000000..e08d194c6c --- /dev/null +++ b/test-suite/bugs/closed/bug_9527.v @@ -0,0 +1 @@ +Fail Check fix f (x : nat) := (let x := (f x) in f 0). diff --git a/test-suite/complexity/constructor.v b/test-suite/complexity/constructor.v index c5e1953829..31217ca75e 100644 --- a/test-suite/complexity/constructor.v +++ b/test-suite/complexity/constructor.v @@ -214,3 +214,4 @@ Fixpoint expand (n : nat) : Prop := Example Expand : expand 2500. Time constructor. (* ~0.45 secs *) +Qed. diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v index 86698fa872..c2c566930b 100644 --- a/test-suite/complexity/f_equal.v +++ b/test-suite/complexity/f_equal.v @@ -12,3 +12,4 @@ end. Goal stupid 23 = stupid 23. Timeout 5 Time f_equal. +Abort. diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index a76fa19d3c..298a07c1c4 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -111,3 +111,4 @@ Lemma test: forall n1 w1 n2 w2, mk_world n1 w1 = mk_world n2 w2 -> Proof. intros. Timeout 10 Time injection H. +Abort. diff --git a/test-suite/complexity/ring.v b/test-suite/complexity/ring.v index 51f7c4dabc..2d585ce5c5 100644 --- a/test-suite/complexity/ring.v +++ b/test-suite/complexity/ring.v @@ -5,3 +5,4 @@ Require Import ZArith. Open Scope Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. +Abort. diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v index 04fa59075b..1c119b8e42 100644 --- a/test-suite/complexity/ring2.v +++ b/test-suite/complexity/ring2.v @@ -50,3 +50,4 @@ Infix "+" := Zadd : Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. +Abort. diff --git a/test-suite/complexity/setoid_rewrite.v b/test-suite/complexity/setoid_rewrite.v index 2e3b006ef0..10b270ccad 100644 --- a/test-suite/complexity/setoid_rewrite.v +++ b/test-suite/complexity/setoid_rewrite.v @@ -8,3 +8,4 @@ Variable f : nat -> Prop. Goal forall U:Prop, f 100 <-> U. intros U. Timeout 5 Time setoid_replace U with False. +Abort. diff --git a/test-suite/complexity/unification.v b/test-suite/complexity/unification.v index d2ea527516..0c9915c84e 100644 --- a/test-suite/complexity/unification.v +++ b/test-suite/complexity/unification.v @@ -49,3 +49,4 @@ Goal )))) . Timeout 2 Time try refine (refl_equal _). +Abort. diff --git a/test-suite/coqchk/inductive_functor_squash.v b/test-suite/coqchk/inductive_functor_squash.v new file mode 100644 index 0000000000..9d33fafc4c --- /dev/null +++ b/test-suite/coqchk/inductive_functor_squash.v @@ -0,0 +1,15 @@ + + +Module Type T. + Parameter f : nat -> Type. +End T. + +Module F(A:T). + Inductive ind : Prop := + C : A.f 0 -> ind. +End F. + +Module A. Definition f (x:nat) := True. End A. + +Module M := F A. +(* M.ind could eliminate into Set/Type even though F.ind can't *) diff --git a/test-suite/failure/int31.v b/test-suite/failure/int63.v index ed4c9f9c78..0bb87c6548 100644 --- a/test-suite/failure/int31.v +++ b/test-suite/failure/int63.v @@ -1,17 +1,16 @@ -Require Import Int31 Cyclic31. +Require Import Int63 Cyclic63. -Open Scope int31_scope. +Open Scope int63_scope. (* This used to go through because of an unbalanced stack bug in the bytecode interpreter *) Lemma bad : False. assert (1 = 2). -change 1 with (add31 (addmuldiv31 65 (add31 1 1) 2) 1). +change 1 with (Int63.add (Int63.addmuldiv 129 (Int63.add 1 1) 2) 1). Fail vm_compute; reflexivity. (* discriminate. Qed. *) Abort. - diff --git a/test-suite/misc/4722.sh b/test-suite/misc/4722.sh index 86bc50b5cd..70071b9d60 100755 --- a/test-suite/misc/4722.sh +++ b/test-suite/misc/4722.sh @@ -4,12 +4,12 @@ set -e # create test files mkdir -p misc/4722 ln -sf toto misc/4722/tata -touch misc/4722.v +touch misc/bug_4722.v # run test -$coqtop "-R" "misc/4722" "Foo" -top Top -load-vernac-source misc/4722.v +$coqc "-R" "misc/4722" "Foo" -top Top misc/bug_4722.v # clean up test files rm misc/4722/tata rmdir misc/4722 -rm misc/4722.v +rm misc/bug_4722.v diff --git a/test-suite/misc/7704.sh b/test-suite/misc/7704.sh index 0ca2c97d24..5fc171649e 100755 --- a/test-suite/misc/7704.sh +++ b/test-suite/misc/7704.sh @@ -4,4 +4,4 @@ set -e export PATH=$BIN:$PATH -${coqtop#"$BIN"} -compile misc/aux7704.v +${coqc#"$BIN"} misc/aux7704.v diff --git a/test-suite/misc/aux7704.v b/test-suite/misc/aux7704.v index 6fdcf67684..1c95211a71 100644 --- a/test-suite/misc/aux7704.v +++ b/test-suite/misc/aux7704.v @@ -1,4 +1,3 @@ - Goal True /\ True. Proof. split. diff --git a/test-suite/misc/deps-checksum.sh b/test-suite/misc/deps-checksum.sh index a15a8fbee9..8523358303 100755 --- a/test-suite/misc/deps-checksum.sh +++ b/test-suite/misc/deps-checksum.sh @@ -3,4 +3,4 @@ rm -f misc/deps/A/*.vo misc/deps/B/*.vo $coqc -R misc/deps/A A misc/deps/A/A.v $coqc -R misc/deps/B A misc/deps/B/A.v $coqc -R misc/deps/B A misc/deps/B/B.v -$coqtop -R misc/deps/B A -R misc/deps/A A -load-vernac-source misc/deps/checksum.v +$coqc -R misc/deps/B A -R misc/deps/A A misc/deps/checksum.v diff --git a/test-suite/misc/deps-order.sh b/test-suite/misc/deps-order.sh index 6bb2ba2da0..551515b0d6 100755 --- a/test-suite/misc/deps-order.sh +++ b/test-suite/misc/deps-order.sh @@ -10,12 +10,12 @@ R=$? times $coqc -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1 $coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1 -$coqtop -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1 +$coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 S=$? if [ $R = 0 ] && [ $S = 0 ]; then - printf "coqdep and coqtop agree\n" + printf "coqdep and coqc agree\n" exit 0 else - printf "coqdep and coqtop disagree\n" + printf "coqdep and coqc disagree\n" exit 1 fi diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh index acb45b2292..af69370ce4 100755 --- a/test-suite/misc/deps-utf8.sh +++ b/test-suite/misc/deps-utf8.sh @@ -8,7 +8,7 @@ rm -f misc/deps/théorèmes/*.v tmpoutput=$(mktemp /tmp/coqcheck.XXXXXX) $coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v R=$? -$coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v +$coqc -R misc/deps AlphaBêta misc/deps/αβ/εζ.v S=$? if [ $R = 0 ] && [ $S = 0 ]; then exit 0 diff --git a/test-suite/misc/exitstatus.sh b/test-suite/misc/exitstatus.sh index a327f4248b..afc415b2da 100755 --- a/test-suite/misc/exitstatus.sh +++ b/test-suite/misc/exitstatus.sh @@ -1,8 +1,5 @@ #!/bin/sh -$coqtop -load-vernac-source misc/exitstatus/illtyped.v -N=$? $coqc misc/exitstatus/illtyped.v P=$? -printf "On ill-typed input, coqtop returned %s.\n" "$N" printf "On ill-typed input, coqc returned %s.\n" "$P" -if [ $N = 1 ] && [ $P = 1 ]; then exit 0; else exit 1; fi +if [ $P = 1 ]; then exit 0; else exit 1; fi 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/misc/poly-capture-global-univs/src/evilImpl.ml b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml index 047f4cd080..f5043db099 100644 --- a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml @@ -9,13 +9,13 @@ let evil t f = let u = Level.var 0 in let tu = mkType (Universe.make u) in let te = Declare.definition_entry - ~univs:(Monomorphic_const_entry (ContextSet.singleton u)) tu + ~univs:(Monomorphic_entry (ContextSet.singleton u)) tu in let tc = Declare.declare_constant t (DefinitionEntry te, k) in let tc = mkConst tc in let fe = Declare.definition_entry - ~univs:(Polymorphic_const_entry ([|Anonymous|], UContext.make (Instance.of_array [|u|],Constraint.empty))) + ~univs:(Polymorphic_entry ([|Anonymous|], UContext.make (Instance.of_array [|u|],Constraint.empty))) ~types:(Term.mkArrow tc tu) (mkLambda (Name.Name (Id.of_string "x"), tc, mkRel 1)) in diff --git a/test-suite/misc/universes/dune b/test-suite/misc/universes/dune index 58bba300d2..0772f95604 100644 --- a/test-suite/misc/universes/dune +++ b/test-suite/misc/universes/dune @@ -5,4 +5,4 @@ (source_tree ../../../plugins)) (action (with-outputs-to all_stdlib.v - (run ./build_all_stdlib.sh)))) + (bash "./build_all_stdlib.sh")))) diff --git a/test-suite/output/Errors.v b/test-suite/output/Errors.v index edc35f17b4..b52537dec0 100644 --- a/test-suite/output/Errors.v +++ b/test-suite/output/Errors.v @@ -1,6 +1,8 @@ (* coq-prog-args: ("-top" "Errors") *) (* Test error messages *) +Set Ltac Backtrace. + (* Test non-regression of bug fixed in r13486 (bad printer for module names) *) Module Type S. diff --git a/test-suite/output/FunExt.out b/test-suite/output/FunExt.out index 8d2a125c1d..2a823396d5 100644 --- a/test-suite/output/FunExt.out +++ b/test-suite/output/FunExt.out @@ -1,19 +1,12 @@ The command has indeed failed with message: -Ltac call to "extensionality in (var)" failed. Tactic failure: Not an extensional equality. The command has indeed failed with message: -Ltac call to "extensionality in (var)" failed. Tactic failure: Not an extensional equality. The command has indeed failed with message: -Ltac call to "extensionality in (var)" failed. Tactic failure: Not an extensional equality. The command has indeed failed with message: -Ltac call to "extensionality in (var)" failed. Tactic failure: Not an extensional equality. The command has indeed failed with message: -Ltac call to "extensionality in (var)" failed. Tactic failure: Already an intensional equality. The command has indeed failed with message: -In nested Ltac calls to "extensionality in (var)" and -"clearbody (ne_var_list)", last call failed. Hypothesis e depends on the body of H' diff --git a/test-suite/output/FunExt.v b/test-suite/output/FunExt.v index 7658ce718e..440fe46003 100644 --- a/test-suite/output/FunExt.v +++ b/test-suite/output/FunExt.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) Require Import FunctionalExtensionality. (* Basic example *) diff --git a/test-suite/output/Int31Syntax.out b/test-suite/output/Int31Syntax.out index 4e8796c14b..0d6504f5f8 100644 --- a/test-suite/output/Int31Syntax.out +++ b/test-suite/output/Int31Syntax.out @@ -12,3 +12,5 @@ I31 : int31 = 710436486 : int31 +The command has indeed failed with message: +Cannot interpret this number as a value of type int31 diff --git a/test-suite/output/Int31Syntax.v b/test-suite/output/Int31Syntax.v index 83be3b976b..48889a26ef 100644 --- a/test-suite/output/Int31Syntax.v +++ b/test-suite/output/Int31Syntax.v @@ -3,11 +3,12 @@ Require Import Int31 Cyclic31. Open Scope int31_scope. Check I31. (* Would be nice to have I31 : digits->digits->...->int31 For the moment, I31 : digits31 int31, which is better - than (fix nfun .....) size int31 *) + than (fix nfun .....) size int31 *) Check 2. Check 1000000000000000000. (* = 660865024, after modulo 2^31 *) Check (add31 2 2). Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. +Fail Check -1. Close Scope int31_scope. diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out new file mode 100644 index 0000000000..fdd5599565 --- /dev/null +++ b/test-suite/output/Int63Syntax.out @@ -0,0 +1,16 @@ +2 + : int +9223372036854775807 + : int +2 + 2 + : int +2 + 2 + : int + = 4 + : int + = 37151199385380486 + : int +The command has indeed failed with message: +int63 are only non-negative numbers. +The command has indeed failed with message: +overflow in int63 literal: 9223372036854775808 diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v new file mode 100644 index 0000000000..3dc364eddb --- /dev/null +++ b/test-suite/output/Int63Syntax.v @@ -0,0 +1,12 @@ +Require Import Int63 Cyclic63. + +Open Scope int63_scope. +Check 2. +Check 9223372036854775807. +Check (Int63.add 2 2). +Check (2+2). +Eval vm_compute in 2+2. +Eval vm_compute in 65675757 * 565675998. +Fail Check -1. +Fail Check 9223372036854775808. +Close Scope int63_scope. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 72d5a9253a..5bf4ec7bfb 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -50,4 +50,26 @@ myAnd1 True True r 2 3 : Prop Notation Cn := Foo.FooCn -Expands to: Notation Top.J.Mfoo.Foo.Bar.Cn +Expands to: Notation Notations4.J.Mfoo.Foo.Bar.Cn +let v := 0%test17 in v : myint63 + : myint63 +fun y : nat => # (x, z) |-> y & y + : forall y : nat, + (?T1 * ?T2 -> ?T1 * ?T2 * nat) * (?T * ?T0 -> ?T * ?T0 * nat) +where +?T : [y : nat pat : ?T * ?T0 p0 : ?T * ?T0 p := p0 : ?T * ?T0 + |- Type] (pat, p0, p cannot be used) +?T0 : [y : nat pat : ?T * ?T0 p0 : ?T * ?T0 p := p0 : ?T * ?T0 + |- Type] (pat, p0, p cannot be used) +?T1 : [y : nat pat : ?T1 * ?T2 p0 : ?T1 * ?T2 p := p0 : ?T1 * ?T2 + |- Type] (pat, p0, p cannot be used) +?T2 : [y : nat pat : ?T1 * ?T2 p0 : ?T1 * ?T2 p := p0 : ?T1 * ?T2 + |- Type] (pat, p0, p cannot be used) +fun y : nat => # (x, z) |-> (x + y) & (y + z) + : forall y : nat, + (nat * ?T -> nat * ?T * nat) * (?T0 * nat -> ?T0 * nat * nat) +where +?T : [y : nat pat : nat * ?T p0 : nat * ?T p := p0 : nat * ?T + |- Type] (pat, p0, p cannot be used) +?T0 : [y : nat pat : ?T0 * nat p0 : ?T0 * nat p := p0 : ?T0 * nat + |- Type] (pat, p0, p cannot be used) diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 90babf9c55..b33ad17ed4 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -197,3 +197,25 @@ End Mfoo. About Cn. End J. + +Require Import Coq.Numbers.Cyclic.Int63.Int63. +Module NumeralNotations. + Module Test17. + (** Test int63 *) + Declare Scope test17_scope. + Delimit Scope test17_scope with test17. + Local Set Primitive Projections. + Record myint63 := of_int { to_int : int }. + Numeral Notation myint63 of_int to_int : test17_scope. + Check let v := 0%test17 in v : myint63. + End Test17. +End NumeralNotations. + +Module K. + +Notation "# x |-> t & u" := ((fun x => (x,t)),(fun x => (x,u))) + (at level 0, x pattern, t, u at level 39). +Check fun y : nat => # (x,z) |-> y & y. +Check fun y : nat => # (x,z) |-> (x + y) & (y + z). + +End K. diff --git a/test-suite/output/RecognizePluginWarning.v b/test-suite/output/RecognizePluginWarning.v index cd667bbd00..a53b52396f 100644 --- a/test-suite/output/RecognizePluginWarning.v +++ b/test-suite/output/RecognizePluginWarning.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-w" "extraction-logical-axiom") -*- *) +(* -*- mode: coq; coq-prog-args: ("-w" "extraction-logical-axiom") -*- *) (* Test that mentioning a warning defined in plugins works. The failure mode here is that these result in a warning about unknown warnings, since the diff --git a/test-suite/output/Show.v b/test-suite/output/Show.v index 60faac8dd9..c875051bdc 100644 --- a/test-suite/output/Show.v +++ b/test-suite/output/Show.v @@ -5,7 +5,7 @@ Theorem nums : forall (n m : nat), n = m -> (S n) = (S m). Proof. intros. - induction n as [| n']. + induction n as [| n']. induction m as [| m']. Show. Admitted. diff --git a/test-suite/output/TypeclassDebug.out b/test-suite/output/TypeclassDebug.out index 8b38fe0ff4..7ea7a08cb3 100644 --- a/test-suite/output/TypeclassDebug.out +++ b/test-suite/output/TypeclassDebug.out @@ -14,5 +14,4 @@ Debug: 1.1-1.1-1.1-1.1-1: looking for foo without backtracking Debug: 1.1-1.1-1.1-1.1-1.1: simple apply H on foo, 1 subgoal(s) Debug: 1.1-1.1-1.1-1.1-1.1-1 : foo The command has indeed failed with message: -Ltac call to "typeclasses eauto (int_or_var_opt) with (ne_preident_list)" failed. Tactic failure: Proof search reached its limit. diff --git a/test-suite/output/UnclosedBlocks.v b/test-suite/output/UnclosedBlocks.v index 854bd6a6d5..b9ba579246 100644 --- a/test-suite/output/UnclosedBlocks.v +++ b/test-suite/output/UnclosedBlocks.v @@ -1,4 +1,3 @@ -(* -*- mode: coq; coq-prog-args: ("-compile" "UnclosedBlocks.v") *) Module Foo. Module Closed. End Closed. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index a960fe3441..222a808768 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,5 +1,7 @@ Inductive Empty@{u} : Type@{u} := +(* u |= *) Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } +(* u |= *) PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] @@ -11,6 +13,7 @@ fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p Argument scopes are [type_scope _] Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } +(* u |= *) For RWrap: Argument scope is [type_scope] For rwrap: Argument scopes are [type_scope _] @@ -79,7 +82,9 @@ Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) Inductive Empty@{E} : Type@{E} := +(* E |= *) Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } +(* E |= *) PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] @@ -109,7 +114,9 @@ bind_univs.poly@{u} = Type@{u} insec@{v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* v |= *) -Inductive insecind@{k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{k} +Inductive insecind@{k} : Type@{k+1} := + inseccstr : Type@{k} -> insecind@{k} +(* k |= *) For inseccstr: Argument scope is [type_scope] insec@{u v} = Type@{u} -> Type@{v} @@ -117,6 +124,7 @@ insec@{u v} = Type@{u} -> Type@{v} (* u v |= *) Inductive insecind@{u k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{u k} +(* u k |= *) For inseccstr: Argument scope is [type_scope] insec2@{u} = Prop diff --git a/test-suite/output/UsePluginWarning.v b/test-suite/output/UsePluginWarning.v index c6e0054641..618b8fd42f 100644 --- a/test-suite/output/UsePluginWarning.v +++ b/test-suite/output/UsePluginWarning.v @@ -1,5 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-w" "-extraction-logical-axiom") -*- *) - +(* -*- mode: coq; coq-prog-args: ("-w" "-extraction-logical-axiom") -*- *) Require Extraction. Axiom foo : Prop. diff --git a/test-suite/output/bug5778.v b/test-suite/output/bug5778.v index 0dcd76aeff..441e87af84 100644 --- a/test-suite/output/bug5778.v +++ b/test-suite/output/bug5778.v @@ -1,3 +1,4 @@ +Set Ltac Backtrace. Ltac a _ := pose (I : I). Ltac b _ := a (). Ltac abs _ := abstract b (). diff --git a/test-suite/output/bug6404.v b/test-suite/output/bug6404.v index bbe6b1a00f..d9e5e20b66 100644 --- a/test-suite/output/bug6404.v +++ b/test-suite/output/bug6404.v @@ -1,3 +1,4 @@ +Set Ltac Backtrace. Ltac a _ := pose (I : I). Ltac b _ := a (). Ltac abs _ := transparent_abstract b (). diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 40e743c3f0..fcd5dd05f0 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -1,3 +1,5 @@ +Set Ltac Backtrace. + (* This used to refer to b instead of z sometimes between 8.4 and 8.5beta3 *) Goal True. Fail let T := constr:((fun a b : nat => a+b) 1 1) in diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v index 91331a1de5..e30c97aac6 100644 --- a/test-suite/output/ltac_missing_args.v +++ b/test-suite/output/ltac_missing_args.v @@ -1,3 +1,5 @@ +Set Ltac Backtrace. + Ltac foo x := idtac x. Ltac bar x := fun y _ => idtac x y. Ltac baz := foo. diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v index 5f1926f142..5f7e3ab9dd 100644 --- a/test-suite/output/simpl.v +++ b/test-suite/output/simpl.v @@ -11,3 +11,4 @@ Undo. simpl (0 + _). Show. Undo. +Abort. diff --git a/test-suite/output/sint63Notation.out b/test-suite/output/sint63Notation.out new file mode 100644 index 0000000000..9d325b38c7 --- /dev/null +++ b/test-suite/output/sint63Notation.out @@ -0,0 +1,24 @@ + = 0 + : uint + = 1 + : uint + = 9223372036854775807 + : uint +let v := 0 in v : uint + : uint +let v := 1 in v : uint + : uint +let v := 9223372036854775807 in v : uint + : uint + = 0 + : sint + = 1 + : sint + = -1 + : sint +let v := 0 in v : sint + : sint +let v := 1 in v : sint + : sint +let v := -1 in v : sint + : sint diff --git a/test-suite/output/sint63Notation.v b/test-suite/output/sint63Notation.v new file mode 100644 index 0000000000..331d74ed3d --- /dev/null +++ b/test-suite/output/sint63Notation.v @@ -0,0 +1,37 @@ +From Coq +Require Import Int63. +Import ZArith. + +Declare Scope uint_scope. +Declare Scope sint_scope. +Delimit Scope uint_scope with uint. +Delimit Scope sint_scope with sint. + +Record uint := wrapu { unwrapu : int }. +Record sint := wraps { unwraps : int }. + +Definition uof_Z (v : Z) := wrapu (of_Z v). +Definition uto_Z (v : uint) := to_Z (unwrapu v). + +Definition sof_Z (v : Z) := wraps (of_Z (v mod (2 ^ 31))). +Definition as_signed (bw : Z) (v : Z) := + (((2 ^ (bw - 1) + v) mod (2 ^ bw)) - 2 ^ (bw - 1))%Z. + +Definition sto_Z (v : sint) := as_signed 31 (to_Z (unwraps v)). +Numeral Notation uint uof_Z uto_Z : uint_scope. +Numeral Notation sint sof_Z sto_Z : sint_scope. +Open Scope uint_scope. +Compute uof_Z 0. +Compute uof_Z 1. +Compute uof_Z (-1). +Check let v := 0 in v : uint. +Check let v := 1 in v : uint. +Check let v := -1 in v : uint. +Close Scope uint_scope. +Open Scope sint_scope. +Compute sof_Z 0. +Compute sof_Z 1. +Compute sof_Z (-1). +Check let v := 0 in v : sint. +Check let v := 1 in v : sint. +Check let v := -1 in v : sint. diff --git a/test-suite/output/ssr_clear.out b/test-suite/output/ssr_clear.out index 1515954060..1a0f90493e 100644 --- a/test-suite/output/ssr_clear.out +++ b/test-suite/output/ssr_clear.out @@ -1,3 +1,2 @@ The command has indeed failed with message: -Ltac call to "move (ssrmovearg) (ssrclauses)" failed. No assumption is named NO_SUCH_NAME diff --git a/test-suite/output/ssr_explain_match.out b/test-suite/output/ssr_explain_match.out index 32cfb354bf..0f68ab0b02 100644 --- a/test-suite/output/ssr_explain_match.out +++ b/test-suite/output/ssr_explain_match.out @@ -51,5 +51,4 @@ instance: (addnC y x) matches: (x + y) instance: (addnC y x) matches: (x + y) END INSTANCES The command has indeed failed with message: -Ltac call to "ssrinstancesoftpat (cpattern)" failed. Not supported diff --git a/test-suite/output/unifconstraints.v b/test-suite/output/unifconstraints.v index 179dec3fb0..c987d66c5f 100644 --- a/test-suite/output/unifconstraints.v +++ b/test-suite/output/unifconstraints.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) (* Set Printing Existential Instances. *) Unset Solve Unification Constraints. Axiom veeryyyyyyyyyyyyloooooooooooooonggidentifier : nat. diff --git a/test-suite/report.sh b/test-suite/report.sh index 71aac029ea..5b74bee0c7 100755 --- a/test-suite/report.sh +++ b/test-suite/report.sh @@ -11,11 +11,8 @@ SAVEDIR="logs" rm -rf "$SAVEDIR" mkdir "$SAVEDIR" -# keep this synced with test-suite/Makefile -FAILMARK="==========> FAILURE <==========" - FAILED=$(mktemp /tmp/coq-check-XXXXXX) -find . '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" +find . '(' -name '*.log' -exec grep -q -F "Error!" '{}' ';' -print0 ')' > "$FAILED" rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" cp summary.log "$SAVEDIR"/ 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/test-suite/success/Compat88.v b/test-suite/success/Compat88.v index e2045900d5..1233a4b8f5 100644 --- a/test-suite/success/Compat88.v +++ b/test-suite/success/Compat88.v @@ -4,7 +4,7 @@ Require Coq.Strings.Ascii Coq.Strings.String. Require Coq.ZArith.BinIntDef Coq.PArith.BinPosDef Coq.NArith.BinNatDef. Require Coq.Reals.Rdefinitions. -Require Coq.Numbers.Cyclic.Int31.Cyclic31. +Require Coq.Numbers.Cyclic.Int63.Cyclic63. Require Import Coq.Compat.Coq88. (* XXX FIXME Should not need [Require], see https://github.com/coq/coq/issues/8311 *) @@ -15,4 +15,4 @@ Check BinNat.N.eqb 1 1. Check BinInt.Z.eqb 1 1. Check BinPos.Pos.eqb 1 1. Check Rdefinitions.Rplus 1 1. -Check Int31.iszero 1. +Check Int63.is_zero 1. diff --git a/test-suite/success/Nia.v b/test-suite/success/Nia.v new file mode 100644 index 0000000000..62ecece792 --- /dev/null +++ b/test-suite/success/Nia.v @@ -0,0 +1,918 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.micromega.Lia. +Open Scope Z_scope. + +(** Add [Z.to_euclidean_division_equations] to the end of [zify], just for this + file. *) +Ltac zify ::= repeat (zify_nat; zify_positive; zify_N); zify_op; Z.to_euclidean_division_equations. + +Lemma Z_zerop_or x : x = 0 \/ x <> 0. Proof. nia. Qed. +Lemma Z_eq_dec_or (x y : Z) : x = y \/ x <> y. Proof. nia. Qed. + +Ltac unique_pose_proof pf := + let T := type of pf in + lazymatch goal with + | [ H : T |- _ ] => fail + | _ => pose proof pf + end. + +Ltac saturate_mod_div := + repeat match goal with + | [ |- context[?x mod ?y] ] => unique_pose_proof (Z_zerop_or (x / y)) + | [ H : context[?x mod ?y] |- _ ] => unique_pose_proof (Z_zerop_or (x / y)) + | [ |- context[?x / ?y] ] => unique_pose_proof (Z_zerop_or y) + | [ H : context[?x / ?y] |- _ ] => unique_pose_proof (Z_zerop_or y) + | [ |- context[Z.rem ?x ?y] ] => unique_pose_proof (Z_zerop_or (Z.quot x y)) + | [ H : context[Z.rem ?x ?y] |- _ ] => unique_pose_proof (Z_zerop_or (Z.quot x y)) + | [ |- context[Z.quot ?x ?y] ] => unique_pose_proof (Z_zerop_or y) + | [ H : context[Z.quot ?x ?y] |- _ ] => unique_pose_proof (Z_zerop_or y) + end. + +Ltac t := intros; saturate_mod_div; try nia. + +Ltac destr_step := + match goal with + | [ H : and _ _ |- _ ] => destruct H + | [ H : or _ _ |- _ ] => destruct H + end. + +Example mod_0_l: forall x : Z, 0 mod x = 0. Proof. t. Qed. +Example mod_0_r: forall x : Z, x mod 0 = 0. Proof. intros; nia. Qed. +Example Z_mod_same_full: forall a : Z, a mod a = 0. Proof. t. Qed. +Example Zmod_0_l: forall a : Z, 0 mod a = 0. Proof. t. Qed. +Example Zmod_0_r: forall a : Z, a mod 0 = 0. Proof. intros; nia. Qed. +Example mod_mod_same: forall x y : Z, (x mod y) mod y = x mod y. Proof. t. Qed. +Example Zmod_mod: forall a n : Z, (a mod n) mod n = a mod n. Proof. t. Qed. +Example Zmod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. +Example Zmod_div: forall a b : Z, a mod b / b = 0. Proof. intros; nia. Qed. +Example Z_mod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. +Example Z_mod_same: forall a : Z, a > 0 -> a mod a = 0. Proof. t. Qed. +Example Z_mod_mult: forall a b : Z, (a * b) mod b = 0. +Proof. + intros a b. + assert (b = 0 \/ (a * b) / b = a) by nia. + nia. +Qed. +Example Z_mod_same': forall a : Z, a <> 0 -> a mod a = 0. Proof. t. Qed. +Example Z_mod_0_l: forall a : Z, a <> 0 -> 0 mod a = 0. Proof. t. Qed. +Example Zmod_opp_opp: forall a b : Z, - a mod - b = - (a mod b). +Proof. + intros a b. + pose proof (Z_eq_dec_or ((-a)/(-b)) (a/b)). + nia. +Qed. +Example Z_mod_le: forall a b : Z, 0 <= a -> 0 < b -> a mod b <= a. Proof. t. Qed. +Example Zmod_le: forall a b : Z, 0 < b -> 0 <= a -> a mod b <= a. Proof. t. Qed. +Example Zplus_mod_idemp_r: forall a b n : Z, (b + a mod n) mod n = (b + a) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((b + a mod n) / n = (b / n) + (b mod n + a mod n) / n) + by nia. + assert ((b + a) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) + by nia. + nia. +Qed. +Example Zplus_mod_idemp_l: forall a b n : Z, (a mod n + b) mod n = (a + b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a mod n + b) / n = (b / n) + (b mod n + a mod n) / n) by nia. + assert ((a + b) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) by nia. + nia. +Qed. +Example Zmult_mod_distr_r: forall a b c : Z, (a * c) mod (b * c) = a mod b * c. +Proof. + intros a b c. + destruct (Z_zerop c); try nia. + pose proof (Z_eq_dec_or ((a * c) / (b * c)) (a / b)). + nia. +Qed. +Example Z_mod_zero_opp_full: forall a b : Z, a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Zmult_mod_idemp_r: forall a b n : Z, (b * (a mod n)) mod n = (b * a) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((b * (a mod n)) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((b * a) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Zmult_mod_idemp_l: forall a b n : Z, (a mod n * b) mod n = (a * b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Zminus_mod_idemp_r: forall a b n : Z, (a - b mod n) mod n = (a - b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a - b mod n) / n = a / n + ((a mod n) - (b mod n)) / n) by nia. + assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Zminus_mod_idemp_l: forall a b n : Z, (a mod n - b) mod n = (a - b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a mod n - b) / n = - (b / n) + ((a mod n) - (b mod n)) / n) by nia. + assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Z_mod_plus_full: forall a b c : Z, (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c + b)). + nia. +Qed. +Example Zmult_mod_distr_l: forall a b c : Z, (c * a) mod (c * b) = c * (a mod b). +Proof. + intros a b c. + destruct (Z_zerop c); try nia. + pose proof (Z_eq_dec_or ((c * a) / (c * b)) (a / b)). + nia. +Qed. +Example Z_mod_zero_opp_r: forall a b : Z, a mod b = 0 -> a mod - b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(a/-b))). + nia. +Qed. +Example Zmod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. +Example Z_mod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. +Example Z_mod_mul: forall a b : Z, b <> 0 -> (a * b) mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or ((a*b)/b) a). + nia. +Qed. +Example Zminus_mod: forall a b n : Z, (a - b) mod n = (a mod n - b mod n) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a - b) / n = (a / n) - (b / n) + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Zplus_mod: forall a b n : Z, (a + b) mod n = (a mod n + b mod n) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a + b) / n = (a / n) + (b / n) + ((a mod n) + (b mod n)) / n) by nia. + nia. +Qed. +Example Zmult_mod: forall a b n : Z, (a * b) mod n = (a mod n * (b mod n)) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a * b) / n = n * (a / n) * (b / n) + (a mod n) * (b / n) + (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Z_mod_mod: forall a n : Z, n <> 0 -> (a mod n) mod n = a mod n. Proof. t. Qed. +Example Z_mod_div: forall a b : Z, b <> 0 -> a mod b / b = 0. Proof. intros; nia. Qed. +Example Z_div_exact_full_1: forall a b : Z, a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. +Example Z_mod_pos_bound: forall a b : Z, 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_sign_mul: forall a b : Z, b <> 0 -> 0 <= a mod b * b. Proof. intros; nia. Qed. +Example Z_mod_neg_bound: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. +Example Z_mod_neg: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. +Example div_mod_small: forall x y : Z, 0 <= x < y -> x mod y = x. Proof. t. Qed. +Example Zmod_small: forall a n : Z, 0 <= a < n -> a mod n = a. Proof. t. Qed. +Example Z_mod_small: forall a b : Z, 0 <= a < b -> a mod b = a. Proof. t. Qed. +Example Z_div_zero_opp_full: forall a b : Z, a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_zero_opp: forall a b : Z, b > 0 -> a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Z_div_zero_opp_r: forall a b : Z, a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_lt: forall a b : Z, b > 0 -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_opp_opp: forall a b : Z, b <> 0 -> - a mod - b = - (a mod b). +Proof. + intros a b. + pose proof (Z_eq_dec_or ((-a)/(-b)) ((a/b))). + nia. +Qed. +Example Z_mod_bound_pos: forall a b : Z, 0 <= a -> 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Z_mod_plus: forall a b c : Z, c > 0 -> (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). + nia. +Qed. +Example Z_mod_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a mod - b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(a/-b))). + nia. +Qed. +Example Zmod_eq: forall a b : Z, b > 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. +Example Z_div_exact_2: forall a b : Z, b > 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. +Example Z_div_mod_eq: forall a b : Z, b > 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. +Example Z_div_exact_1: forall a b : Z, b > 0 -> a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. +Example Z_mod_add: forall a b c : Z, c <> 0 -> (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). + nia. +Qed. +Example Z_mod_nz_opp_r: forall a b : Z, a mod b <> 0 -> a mod - b = a mod b - b. +Proof. + intros a b. + assert (a mod b <> 0 -> a / -b = -(a/b)-1) by t. + nia. +Qed. +Example Z_mul_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n * b) mod n = (a * b) mod n. +Proof. + intros a b n ?. + assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Z_mod_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a mod b = b - a mod b. +Proof. + intros a b. + assert (a mod b <> 0 -> -a/b = -1-a/b) by nia. + nia. +Qed. +Example Z_add_mod_idemp_r: forall a b n : Z, n <> 0 -> (a + b mod n) mod n = (a + b) mod n. +Proof. + intros a b n ?. + assert ((a + b mod n) / n = (a / n) + (a mod n + b mod n) / n) by nia. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_add_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n + b) mod n = (a + b) mod n. +Proof. + intros a b n ?. + assert ((a mod n + b) / n = (b / n) + (a mod n + b mod n) / n) by nia. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_mul_mod_idemp_r: forall a b n : Z, n <> 0 -> (a * (b mod n)) mod n = (a * b) mod n. +Proof. + intros a b n ?. + assert ((a * (b mod n)) / n = (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Zmod_eq_full: forall a b : Z, b <> 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. +Example div_eq: forall x y : Z, y <> 0 -> x mod y = 0 -> x / y * y = x. Proof. intros; nia. Qed. +Example Z_mod_eq: forall a b : Z, b <> 0 -> a mod b = a - b * (a / b). Proof. intros; nia. Qed. +Example Z_mod_sign_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> Z.sgn (a mod b) = Z.sgn b. Proof. intros; nia. Qed. +Example Z_div_exact_full_2: forall a b : Z, b <> 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. +Example Z_div_mod: forall a b : Z, b <> 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. +Example Z_add_mod: forall a b n : Z, n <> 0 -> (a + b) mod n = (a mod n + b mod n) mod n. +Proof. + intros a b n ?. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_mul_mod: forall a b n : Z, n <> 0 -> (a * b) mod n = (a mod n * (b mod n)) mod n. +Proof. + intros a b n ?. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Z_div_exact: forall a b : Z, b <> 0 -> a = b * (a / b) <-> a mod b = 0. Proof. intros; nia. Qed. +Example Z_div_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. +Example Z_div_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a mod - b = a mod b - b. +Proof. + intros a b. + assert (a mod b <> 0 -> a/(-b) = -1-a/b) by nia. + nia. +Qed. +Example Z_mul_mod_distr_r: forall a b c : Z, b <> 0 -> c <> 0 -> (a * c) mod (b * c) = a mod b * c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a*c)/(b*c)) (a/b)). + nia. +Qed. +Example Z_mul_mod_distr_l: forall a b c : Z, b <> 0 -> c <> 0 -> (c * a) mod (c * b) = c * (a mod b). +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((c*a)/(c*b)) (a/b)). + nia. +Qed. +Example Z_mod_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a mod b = b - a mod b. +Proof. + intros a b. + assert (a mod b <> 0 -> -a/b = -1-a/b) by nia. + nia. +Qed. +Example mod_eq: forall x x' y : Z, x / y = x' / y -> x mod y = x' mod y -> y <> 0 -> x = x'. Proof. intros; nia. Qed. +Example Z_div_nz_opp_r: forall a b : Z, a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_div_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Zmod_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_mod_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_mod_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_rem_mul_r: forall a b c : Z, b <> 0 -> 0 < c -> a mod (b * c) = a mod b + b * ((a / b) mod c). +Proof. + intros a b c ??. + assert (a / (b * c) = ((a / b) / c)) by nia. + nia. +Qed. +Example Z_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= a mod b < b \/ b < a mod b <= 0. Proof. intros; nia. Qed. +Example Z_div_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_div_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_mod_small_iff: forall a b : Z, b <> 0 -> a mod b = a <-> 0 <= a < b \/ b < a <= 0. Proof. t. Qed. +Example Z_mod_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a/b) by nia. + nia. +Qed. +Example Z_opp_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= - (a mod b) < - b \/ - b < - (a mod b) <= 0. Proof. intros; nia. Qed. + +Example Zdiv_0_r: forall a : Z, a / 0 = 0. Proof. intros; nia. Qed. +Example Zdiv_0_l: forall a : Z, 0 / a = 0. Proof. intros; nia. Qed. +Example Z_div_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. +Example Zdiv_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. +Example Zdiv_opp_opp: forall a b : Z, - a / - b = a / b. Proof. intros; nia. Qed. +Example Z_div_0_l: forall a : Z, a <> 0 -> 0 / a = 0. Proof. intros; nia. Qed. +Example Z_div_pos: forall a b : Z, b > 0 -> 0 <= a -> 0 <= a / b. Proof. intros; nia. Qed. +Example Z_div_ge0: forall a b : Z, b > 0 -> a >= 0 -> a / b >= 0. Proof. intros; nia. Qed. +Example Z_div_pos': forall a b : Z, 0 <= a -> 0 < b -> 0 <= a / b. Proof. intros; nia. Qed. +Example Z_mult_div_ge: forall a b : Z, b > 0 -> b * (a / b) <= a. Proof. intros; nia. Qed. +Example Z_mult_div_ge_neg: forall a b : Z, b < 0 -> b * (a / b) >= a. Proof. intros; nia. Qed. +Example Z_mul_div_le: forall a b : Z, 0 < b -> b * (a / b) <= a. Proof. intros; nia. Qed. +Example Z_mul_div_ge: forall a b : Z, b < 0 -> a <= b * (a / b). Proof. intros; nia. Qed. +Example Z_div_same: forall a : Z, a > 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Z_div_mult: forall a b : Z, b > 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_mul_succ_div_gt: forall a b : Z, 0 < b -> a < b * Z.succ (a / b). Proof. intros; nia. Qed. +Example Z_mul_succ_div_lt: forall a b : Z, b < 0 -> b * Z.succ (a / b) < a. Proof. intros; nia. Qed. +Example Zdiv_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. +Example Z_div_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. +Example Z_div_str_pos: forall a b : Z, 0 < b <= a -> 0 < a / b. Proof. intros; nia. Qed. +Example Z_div_ge: forall a b c : Z, c > 0 -> a >= b -> a / c >= b / c. Proof. intros; nia. Qed. +Example Z_div_mult_full: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_div_same': forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Zdiv_lt_upper_bound: forall a b q : Z, 0 < b -> a < q * b -> a / b < q. Proof. intros; nia. Qed. +Example Z_div_mul: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_div_lt: forall a b : Z, 0 < a -> 1 < b -> a / b < a. Proof. intros; nia. Qed. +Example Z_div_le_mono: forall a b c : Z, 0 < c -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. +Example Zdiv_sgn: forall a b : Z, 0 <= Z.sgn (a / b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. +Example Z_div_same_full: forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Z_div_lt_upper_bound: forall a b q : Z, 0 < b -> a < b * q -> a / b < q. Proof. intros; nia. Qed. +Example Z_div_le: forall a b c : Z, c > 0 -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. +Example Z_div_le_lower_bound: forall a b q : Z, 0 < b -> b * q <= a -> q <= a / b. Proof. intros; nia. Qed. +Example Zdiv_le_lower_bound: forall a b q : Z, 0 < b -> q * b <= a -> q <= a / b. Proof. intros; nia. Qed. +Example Zdiv_le_upper_bound: forall a b q : Z, 0 < b -> a <= q * b -> a / b <= q. Proof. intros; nia. Qed. +Example Z_div_le_upper_bound: forall a b q : Z, 0 < b -> a <= b * q -> a / b <= q. Proof. intros; nia. Qed. +Example Z_div_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. +Example Zdiv_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. +Example Z_div_opp_opp: forall a b : Z, b <> 0 -> - a / - b = a / b. Proof. intros; nia. Qed. +Example Zdiv_mult_cancel_r: forall a b c : Z, c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_exact: forall a b q : Z, b <> 0 -> a = b * q -> q = a / b. Proof. intros; nia. Qed. +Example Zdiv_mult_cancel_l: forall a b c : Z, c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. +Example Zdiv_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q < r -> p / r <= p / q. +Proof. + intros p q r ??. + assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. + assert (0 <= p / r) by nia. + assert (0 <= p / q) by nia. + nia. +Qed. +Example Z_div_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q <= r -> p / r <= p / q. +Proof. + intros p q r ??. + assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. + assert (0 <= p / r) by nia. + assert (0 <= p / q) by nia. + nia. +Qed. +Example Zdiv_Zdiv: forall a b c : Z, 0 <= b -> 0 <= c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. +Example Z_div_plus: forall a b c : Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_lt': forall a b : Z, b >= 2 -> a > 0 -> a / b < a. Proof. intros; nia. Qed. +Example Zdiv_mult_le: forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. +Example Z_div_add_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. +Example Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. +Example Z_div_add: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_plus_full: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_mul_le: forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. +Example Z_div_mul_cancel_r: forall a b c : Z, b <> 0 -> c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. +Example Z_div_div: forall a b c : Z, b <> 0 -> 0 < c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. +Example Z_div_mul_cancel_l: forall a b c : Z, b <> 0 -> c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Zdiv_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Z_div_small_iff: forall a b : Z, b <> 0 -> a / b = 0 <-> 0 <= a < b \/ b < a <= 0. Proof. intros; nia. Qed. +Example Z_div_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. + +(** Now we do the same, but with [Z.quot] and [Z.rem] instead. *) +Lemma N2Z_inj_quot : forall n m : N, Z.of_N (n / m) = Z.of_N n ÷ Z.of_N m. Proof. intros; nia. Qed. +Lemma N2Z_inj_rem : forall n m : N, Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. +Proof. intros; destruct (Z_zerop (a ÷ b)); nia. Qed. +Lemma OrdersEx_Z_as_DT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; destruct (Z_zerop (a ÷ b)); nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). +Proof. intros; assert (0 < b * c) by nia; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. +Proof. + intros. + destruct (Z_zerop p), (Z_zerop (p ÷ r)), (Z_zerop (p ÷ q)); subst; [ nia.. | ]. + assert (0 < q) by nia; assert (0 < r) by nia; assert (0 < p) by nia. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. +Proof. + intros. + destruct (Z_zerop p), (Z_zerop (p ÷ r)), (Z_zerop (p ÷ q)); [ subst; nia.. | ]. + assert (0 < p) by nia; assert (0 < r) by nia. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. +Proof. + intros. + destruct (Z_zerop a), (Z_zerop b), (Z_zerop (a ÷ c)), (Z_zerop (b ÷ c)); [ subst; nia.. | ]. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. +Proof. + intros. + assert (c * b <> 0) by nia. + destruct (Z_zerop a), (Z_zerop (c * a)); subst; [ nia | exfalso; nia.. | ]. +Abort. +Lemma OrdersEx_Z_as_DT_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. Abort. +Lemma OrdersEx_Z_as_DT_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; assert (b * c <> 0) by nia. Abort. +Lemma OrdersEx_Z_as_DT_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z2N_inj_quot : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (n ÷ m) = (Z.to_N n / Z.to_N m)%N. +Proof. intros; destruct (Z_zerop n), (Z_zerop m), (Z_zerop (n ÷ m)); [ subst; try nia.. | ]. Abort. +Lemma Z2N_inj_rem : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (Z.rem n m) = (Z.to_N n mod Z.to_N m)%N. Proof. intros. Abort. +Lemma Zabs2N_inj_quot : forall n m : Z, Z.abs_N (n ÷ m) = (Z.abs_N n / Z.abs_N m)%N. Proof. intros. Abort. +Lemma Zabs2N_inj_rem : forall n m : Z, Z.abs_N (Z.rem n m) = (Z.abs_N n mod Z.abs_N m)%N. Proof. intros. Abort. +(* Some of these don't work, and I haven't gone through and figured out which ones yet, so they're all commented out for now *) +(* +Lemma Z_add_rem : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (a + b) n = ZBinary.Z.rem (ZBinary.Z.rem a n + ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (ZBinary.Z.rem a n + b) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (a + ZBinary.Z.rem b n) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = ZBinary.Z.gcd a b -> ZBinary.Z.gcd (a ÷ g) (b ÷ g) = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_gcd_rem : forall a b : Z, b <> 0 -> ZBinary.Z.gcd (ZBinary.Z.rem a b) b = ZBinary.Z.gcd b a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mod_mul_r : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem a (b * c) = ZBinary.Z.rem a b + b * ZBinary.Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * ZBinary.Z.pred (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * ZBinary.Z.pred (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem (c * a) (c * b) = c * ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem (a * c) (b * c) = ZBinary.Z.rem a b * c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (a * b) n = ZBinary.Z.rem (ZBinary.Z.rem a n * ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (ZBinary.Z.rem a n * b) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (a * ZBinary.Z.rem b n) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * ZBinary.Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * ZBinary.Z.succ (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a + b) n = ZBinary.Z.rem (ZBinary.Z.rem a n + ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n + b) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a + ZBinary.Z.rem b n) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a ÷ b) <-> ZBinary.Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> ZBinary.Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> ZBinary.Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> ZBinary.Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> ZBinary.Z.rem (a + b * c) c = ZBinary.Z.rem a c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n) n = ZBinary.Z.rem a n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem a (b * c) = ZBinary.Z.rem a b + b * ZBinary.Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> ZBinary.Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> ZBinary.Z.rem a b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = a <-> a < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem (c * a) (c * b) = c * ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem (a * c) (b * c) = ZBinary.Z.rem a b * c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a * b) n = ZBinary.Z.rem (ZBinary.Z.rem a n * ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n * b) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a * ZBinary.Z.rem b n) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * ZBinary.Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +ZBinary_Z_Private_Div_Quot2Div_div_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) ZBinary.Z.quot +Lemma ZBinary_Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= ZBinary.Z.rem a b < b. Proof. intros; nia. Qed. +ZBinary_Z_Private_Div_Quot2Div_mod_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) ZBinary.Z.rem +Lemma ZBinary_Z_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs : forall a b : Z, b <> 0 -> ZBinary.Z.abs a ÷ ZBinary.Z.abs b = ZBinary.Z.abs (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs_l : forall a b : Z, b <> 0 -> ZBinary.Z.abs a ÷ b = ZBinary.Z.sgn a * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs_r : forall a b : Z, b <> 0 -> a ÷ ZBinary.Z.abs b = ZBinary.Z.sgn b * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_div : forall a b : Z, b <> 0 -> a ÷ b = ZBinary.Z.sgn a * ZBinary.Z.sgn b * (ZBinary.Z.abs a / ZBinary.Z.abs b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a ÷ b) <-> ZBinary.Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_rem' : forall a b : Z, a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_small_iff : forall a b : Z, b <> 0 -> a ÷ b = 0 <-> ZBinary.Z.abs a < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +ZBinary_Z_quot_wd Morphisms.Proper (Morphisms.respectful ZBinary.Z.eq (Morphisms.respectful ZBinary.Z.eq ZBinary.Z.eq)) ZBinary.Z.quot +Lemma ZBinary_Z_rem_0_l : forall a : Z, a <> 0 -> ZBinary.Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_1_l : forall a : Z, 1 < a -> ZBinary.Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_1_r : forall a : Z, ZBinary.Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs : forall a b : Z, b <> 0 -> ZBinary.Z.rem (ZBinary.Z.abs a) (ZBinary.Z.abs b) = ZBinary.Z.abs (ZBinary.Z.rem a b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs_l : forall a b : Z, b <> 0 -> ZBinary.Z.rem (ZBinary.Z.abs a) b = ZBinary.Z.abs (ZBinary.Z.rem a b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs_r : forall a b : Z, b <> 0 -> ZBinary.Z.rem a (ZBinary.Z.abs b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> ZBinary.Z.rem (a + b * c) c = ZBinary.Z.rem a c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_bound_abs : forall a b : Z, b <> 0 -> ZBinary.Z.abs (ZBinary.Z.rem a b) < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= ZBinary.Z.rem a b < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_eq : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = a - b * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = ZBinary.Z.sgn a * (ZBinary.Z.abs a mod ZBinary.Z.abs b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mul : forall a b : Z, b <> 0 -> ZBinary.Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> ZBinary.Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_l : forall a b : Z, b <> 0 -> ZBinary.Z.rem (- a) b = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_l' : forall a b : Z, ZBinary.Z.rem (- a) b = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_opp : forall a b : Z, b <> 0 -> ZBinary.Z.rem (- a) (- b) = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_r : forall a b : Z, b <> 0 -> ZBinary.Z.rem a (- b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_r' : forall a b : Z, ZBinary.Z.rem a (- b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_quot : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_rem : forall a n : Z, n <> 0 -> ZBinary.Z.rem (ZBinary.Z.rem a n) n = ZBinary.Z.rem a n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_same : forall a : Z, a <> 0 -> ZBinary.Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> ZBinary.Z.sgn (ZBinary.Z.rem a b) <> - ZBinary.Z.sgn a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= ZBinary.Z.rem a b * a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign_nz : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b <> 0 -> ZBinary.Z.sgn (ZBinary.Z.rem a b) = ZBinary.Z.sgn a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_small : forall a b : Z, 0 <= a < b -> ZBinary.Z.rem a b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_small_iff : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = a <-> ZBinary.Z.abs a < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +ZBinary_Z_rem_wd Morphisms.Proper (Morphisms.respectful ZBinary.Z.eq (Morphisms.respectful ZBinary.Z.eq ZBinary.Z.eq)) ZBinary.Z.rem +Lemma Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = Z.gcd a b -> Z.gcd (a ÷ g) (b ÷ g) = 1. Proof. intros; nia. Qed. +Lemma Z_gcd_rem : forall a b : Z, b <> 0 -> Z.gcd (Z.rem a b) b = Z.gcd b a. Proof. intros; nia. Qed. +Lemma Z_mod_mul_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * Z.pred (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * Z.pred (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Z_mul_rem : forall a b n : Z, n <> 0 -> Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * Z.succ (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a <-> a < b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Z_Private_Div_Quot2Div_div_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.quot +Lemma Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Z_Private_Div_Quot2Div_mod_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.rem +Lemma Z_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_quot_0_r_ext : forall x y : Z, y = 0 -> x ÷ y = 0. Proof. intros; nia. Qed. +Lemma Z_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma Zquot2_quot : forall n : Z, Z.quot2 n = n ÷ 2. Proof. intros; nia. Qed. +Lemma Z_quot_abs : forall a b : Z, b <> 0 -> Z.abs a ÷ Z.abs b = Z.abs (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_abs_l : forall a b : Z, b <> 0 -> Z.abs a ÷ b = Z.sgn a * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_abs_r : forall a b : Z, b <> 0 -> a ÷ Z.abs b = Z.sgn b * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Z_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_div : forall a b : Z, b <> 0 -> a ÷ b = Z.sgn a * Z.sgn b * (Z.abs a / Z.abs b). Proof. intros; nia. Qed. +Lemma Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Z_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Z_quot_rem' : forall a b : Z, a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma Z_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_quot_small_iff : forall a b : Z, b <> 0 -> a ÷ b = 0 <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Z_quot_wd Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.quot +Lemma Zquot_Zeven_rem : forall a : Z, Z.even a = (Z.rem a 2 =? 0). Proof. intros; nia. Qed. +Lemma Zquot_Z_mult_quot_ge : forall a b : Z, a <= 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Z_mult_quot_le : forall a b : Z, 0 <= a -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_distr_l : forall a b c : Z, Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_distr_r : forall a b c : Z, Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem : forall a b n : Z, Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_idemp_l : forall a b n : Z, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_idemp_r : forall a b n : Z, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n. Proof. intros; nia. Qed. +Lemma Zquot_Zodd_rem : forall a : Z, Z.odd a = negb (Z.rem a 2 =? 0). Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem : forall a b n : Z, 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem_idemp_l : forall a b n : Z, 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem_idemp_r : forall a b n : Z, 0 <= a * b -> Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_0_l : forall a : Z, 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_0_r : forall a : Z, a ÷ 0 = 0. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_exact_full : forall a b : Z, a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_le_lower_bound : forall a b q : Z, 0 < b -> q * b <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_le_upper_bound : forall a b q : Z, 0 < b -> a <= q * b -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_lt : forall a b : Z, 0 < a -> 2 <= b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < q * b -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mod_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a ÷ b /\ r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_monotone : forall a b c : Z, 0 <= c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_cancel_l : forall a b c : Z, c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_cancel_r : forall a b c : Z, c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_le : forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_l : forall a b : Z, - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_opp : forall a b : Z, - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_r : forall a b : Z, a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_plus : forall a b c : Z, 0 <= (a + b * c) * a -> c <> 0 -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_plus_l : forall a b c : Z, 0 <= (a * b + c) * c -> b <> 0 -> b <> 0 -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_pos : forall a b : Z, 0 <= a -> 0 <= b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquotrem_Zdiv_eucl_pos : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b /\ Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_sgn : forall a b : Z, 0 <= Z.sgn (a ÷ b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_Zdiv_pos : forall a b : Z, 0 <= a -> 0 <= b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_Zquot : forall a b c : Z, a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_0_l : forall a : Z, Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_0_r : forall a : Z, Z.rem a 0 = a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_divides : forall a b : Z, Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_even : forall a : Z, Z.rem a 2 = (if Z.even a then 0 else Z.sgn a). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_le : forall a b : Z, 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg : forall a b : Z, a <= 0 -> b <> 0 -> - Z.abs b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg_neg : forall a b : Z, a <= 0 -> b < 0 -> b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg_pos : forall a b : Z, a <= 0 -> 0 < b -> - b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= Z.rem a b < Z.abs b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos_neg : forall a b : Z, 0 <= a -> b < 0 -> 0 <= Z.rem a b < - b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_mult : forall a b : Z, Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_odd : forall a : Z, Z.rem a 2 = (if Z.odd a then Z.sgn a else 0). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_l : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_opp : forall a b : Z, Z.rem (- a) (- b) = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_r : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_plus : forall a b c : Z, 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_rem : forall a n : Z, Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_same : forall a : Z, Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_sgn2 : forall a b : Z, 0 <= Z.rem a b * a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_sgn : forall a b : Z, 0 <= Z.sgn (Z.rem a b) * Z.sgn a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_Zmod_pos : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_Zmod_zero : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_0_l : forall a : Z, a <> 0 -> Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Z_rem_0_r_ext : forall x y : Z, y = 0 -> Z.rem x y = x. Proof. intros; nia. Qed. +Lemma Z_rem_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma Z_rem_1_r : forall a : Z, Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma Z_rem_abs : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) (Z.abs b) = Z.abs (Z.rem a b). Proof. intros; nia. Qed. +Lemma Z_rem_abs_l : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) b = Z.abs (Z.rem a b). Proof. intros; nia. Qed. +Lemma Z_rem_abs_r : forall a b : Z, b <> 0 -> Z.rem a (Z.abs b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Z_rem_bound_abs : forall a b : Z, b <> 0 -> Z.abs (Z.rem a b) < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_rem_bound_neg_neg : forall x y : Z, y < 0 -> x <= 0 -> y < Z.rem x y <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_bound_neg_pos : forall x y : Z, y < 0 -> 0 <= x -> 0 <= Z.rem x y < - y. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos_neg : forall x y : Z, 0 < y -> x <= 0 -> - y < Z.rem x y <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos_pos : forall x y : Z, 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. Proof. intros; nia. Qed. +Lemma Z_rem_eq : forall a b : Z, b <> 0 -> Z.rem a b = a - b * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_mod : forall a b : Z, b <> 0 -> Z.rem a b = Z.sgn a * (Z.abs a mod Z.abs b). Proof. intros; nia. Qed. +Lemma Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Z_rem_mul : forall a b : Z, b <> 0 -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_opp_l : forall a b : Z, b <> 0 -> Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_l' : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_opp : forall a b : Z, b <> 0 -> Z.rem (- a) (- b) = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_r : forall a b : Z, b <> 0 -> Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_r' : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_quot : forall a b : Z, b <> 0 -> Z.rem a b ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_rem : forall a n : Z, n <> 0 -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Z_rem_same : forall a : Z, a <> 0 -> Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> Z.sgn (Z.rem a b) <> - Z.sgn a. Proof. intros; nia. Qed. +Lemma Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= Z.rem a b * a. Proof. intros; nia. Qed. +Lemma Z_rem_sign_nz : forall a b : Z, b <> 0 -> Z.rem a b <> 0 -> Z.sgn (Z.rem a b) = Z.sgn a. Proof. intros; nia. Qed. +Lemma Z_rem_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros; nia. Qed. +Lemma Z_rem_small_iff : forall a b : Z, b <> 0 -> Z.rem a b = a <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_wd : Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.rem. Proof. intros; nia. Qed. +*) diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 1b33863e3b..2533a39cc4 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -154,3 +154,14 @@ Module M16. Print Grammar foo. Print Grammar foo2. End M16. + +(* Example showing the need for strong evaluation of + cases_pattern_of_glob_constr (this used to raise Not_found at some + time) *) + +Module M17. + +Notation "# x ## t & u" := ((fun x => (x,t)),(fun x => (x,u))) (at level 0, x pattern). +Check fun y : nat => # (x,z) ## y & y. + +End M17. diff --git a/test-suite/success/NumeralNotations.v b/test-suite/success/NumeralNotations.v index 47ef381270..7b857c70c5 100644 --- a/test-suite/success/NumeralNotations.v +++ b/test-suite/success/NumeralNotations.v @@ -300,3 +300,14 @@ Module Test16. (** Ideally this should work, but it should definitely not anomaly *) Fail Check let v := 0%test16 in v : Foo. End Test16. + +Require Import Coq.Numbers.Cyclic.Int63.Int63. +Module Test17. + (** Test int63 *) + Declare Scope test17_scope. + Delimit Scope test17_scope with test17. + Local Set Primitive Projections. + Record myint63 := of_int { to_int : int }. + Numeral Notation myint63 of_int to_int : test17_scope. + Check let v := 0%test17 in v : myint63. +End Test17. diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index 106a79e8c9..59a1b8da43 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -67,8 +67,8 @@ Section Bool_eq_dec. Proof. intros x y; case (exists_beq_eq x y). intros b; case b; intro H. - left; apply beq_eq; assumption. - right; apply beq_false_not_eq; assumption. + - left; apply beq_eq; assumption. + - right; apply beq_false_not_eq; assumption. Defined. End Bool_eq_dec. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 6f99ea1da7..32ed7fe78d 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -45,6 +45,6 @@ Qed. Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. destruct b; intro H. -left; inversion H; auto with bool. -right; inversion H; auto with bool. +- left; inversion H; auto with bool. +- right; inversion H; auto with bool. Qed. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 97510578ae..f9ca1bed29 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -164,7 +164,11 @@ Section Relations. Lemma pointwise_pointwise {B} (R : crelation B) : relation_equivalence (pointwise_relation R) (@eq A ==> R). - Proof. intros. split. simpl_crelation. firstorder. Qed. + Proof. + intros. split. + - simpl_crelation. + - firstorder. + Qed. (** Subcrelations induce a morphism on the identity. *) @@ -265,8 +269,8 @@ Section GenericInstances. Next Obligation. Proof with auto. assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... + - transitivity y0... symmetry... + - transitivity (y x0)... Qed. Unset Strict Universe Declaration. @@ -339,10 +343,11 @@ Section GenericInstances. Next Obligation. Proof with auto. - split. intros ; transitivity x0... - intros. - transitivity y... - symmetry... + split. + - intros ; transitivity x0... + - intros. + transitivity y... + symmetry... Qed. (** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) @@ -364,9 +369,9 @@ Section GenericInstances. Next Obligation. Proof with auto. split ; intros. - transitivity x0... transitivity x... symmetry... + - transitivity x0... transitivity x... symmetry... - transitivity y... transitivity y0... symmetry... + - transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). @@ -397,8 +402,8 @@ Section GenericInstances. intros A B R R' HRR' S S' HSS' f g. unfold respectful , relation_equivalence in *; simpl in *. split ; intros H x y Hxy. - apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). - apply (snd (HSS' _ _)). apply H. now apply (fst (HRR' _ _)). + - apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). + - apply (snd (HSS' _ _)). apply H. now apply (fst (HRR' _ _)). Qed. (** [R] is Reflexive, hence we can build the needed proof. *) @@ -500,8 +505,8 @@ Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper Proof. intros A R R' HRR' x y <-. red in HRR'. split ; red ; intros. - now apply (fst (HRR' _ _)). - now apply (snd (HRR' _ _)). + - now apply (fst (HRR' _ _)). + - now apply (snd (HRR' _ _)). Qed. Ltac proper_reflexive := @@ -636,9 +641,9 @@ intros. apply proper_sym_arrow_iffT_2; auto with *. intros x x' Hx y y' Hy Hr. transitivity x. -generalize (partial_order_equivalence x x'); compute; intuition. -transitivity y; auto. -generalize (partial_order_equivalence y y'); compute; intuition. +- generalize (partial_order_equivalence x x'); compute; intuition. +- transitivity y; auto. + generalize (partial_order_equivalence y y'); compute; intuition. Qed. (** From a [PartialOrder] to the corresponding [StrictOrder]: @@ -649,13 +654,13 @@ Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : StrictOrder (relation_conjunction R (complement eqA)). Proof. split; compute. -intros x (_,Hx). apply Hx, Equivalence_Reflexive. -intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. -apply PreOrder_Transitive with y; assumption. -intro Hxz. -apply Hxy'. -apply partial_order_antisym; auto. -rewrite Hxz. auto. +- intros x (_,Hx). apply Hx, Equivalence_Reflexive. +- intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. + + apply PreOrder_Transitive with y; assumption. + + intro Hxz. + apply Hxy'. + apply partial_order_antisym; auto. + rewrite Hxz. auto. Qed. (** From a [StrictOrder] to the corresponding [PartialOrder]: @@ -667,12 +672,12 @@ Lemma StrictOrder_PreOrder PreOrder (relation_disjunction R eqA). Proof. split. -intros x. right. reflexivity. -intros x y z [Hxy|Hxy] [Hyz|Hyz]. -left. transitivity y; auto. -left. rewrite <- Hyz; auto. -left. rewrite Hxy; auto. -right. transitivity y; auto. +- intros x. right. reflexivity. +- intros x y z [Hxy|Hxy] [Hyz|Hyz]. + + left. transitivity y; auto. + + left. rewrite <- Hyz; auto. + + left. rewrite Hxy; auto. + + right. transitivity y; auto. Qed. Hint Extern 4 (PreOrder (relation_disjunction _ _)) => diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index bb873588b1..c014ecc7ab 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -315,9 +315,11 @@ Section Binary. Global Instance relation_equivalence_equivalence : Equivalence relation_equivalence. - Proof. split; red; unfold relation_equivalence, iffT. firstorder. - firstorder. - intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. + Proof. + split; red; unfold relation_equivalence, iffT. + - firstorder. + - firstorder. + - intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. Qed. Global Instance relation_implication_preorder : PreOrder (@subrelation A). @@ -342,8 +344,11 @@ Section Binary. Qed. Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). - Proof. unfold flip; constructor; unfold flip. intros. apply H. apply symmetry. apply X. - unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. Qed. + Proof. + unfold flip; constructor; unfold flip. + - intros. apply H. apply symmetry. apply X. + - unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. + Qed. End Binary. Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 001b7dfdfd..a4fa537128 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -260,8 +260,8 @@ Section GenericInstances. Next Obligation. Proof with auto. assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... + - transitivity y0... symmetry... + - transitivity (y x0)... Qed. (** The complement of a relation conserves its proper elements. *) @@ -344,10 +344,11 @@ Section GenericInstances. Next Obligation. Proof with auto. - split. intros ; transitivity x0... - intros. - transitivity y... - symmetry... + split. + - intros ; transitivity x0... + - intros. + transitivity y... + symmetry... Qed. (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *) @@ -369,9 +370,9 @@ Section GenericInstances. Next Obligation. Proof with auto. split ; intros. - transitivity x0... transitivity x... symmetry... + - transitivity x0... transitivity x... symmetry... - transitivity y... transitivity y0... symmetry... + - transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). @@ -403,15 +404,15 @@ Section GenericInstances. unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. split ; intros. - rewrite <- H0. - apply H1. - rewrite H. - assumption. - - rewrite H0. - apply H1. - rewrite <- H. - assumption. + - rewrite <- H0. + apply H1. + rewrite H. + assumption. + + - rewrite H0. + apply H1. + rewrite <- H. + assumption. Qed. (** [R] is Reflexive, hence we can build the needed proof. *) @@ -514,10 +515,10 @@ Proof. simpl_relation. reduce in H. split ; red ; intros. - setoid_rewrite <- H. - apply H0. - setoid_rewrite H. - apply H0. + - setoid_rewrite <- H. + apply H0. + - setoid_rewrite H. + apply H0. Qed. Ltac proper_reflexive := @@ -574,8 +575,8 @@ Proof. unfold relation_equivalence in *. unfold predicate_equivalence in *. simpl in *. unfold respectful. unfold flip in *. firstorder. - apply NB. apply H. apply NA. apply H0. - apply NB. apply H. apply NA. apply H0. + - apply NB. apply H. apply NA. apply H0. + - apply NB. apply H. apply NA. apply H0. Qed. Ltac normalizes := @@ -642,9 +643,9 @@ intros. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy Hr. transitivity x. -generalize (partial_order_equivalence x x'); compute; intuition. -transitivity y; auto. -generalize (partial_order_equivalence y y'); compute; intuition. +- generalize (partial_order_equivalence x x'); compute; intuition. +- transitivity y; auto. + generalize (partial_order_equivalence y y'); compute; intuition. Qed. (** From a [PartialOrder] to the corresponding [StrictOrder]: @@ -655,13 +656,13 @@ Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) : StrictOrder (relation_conjunction R (complement eqA)). Proof. split; compute. -intros x (_,Hx). apply Hx, Equivalence_Reflexive. -intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. -apply PreOrder_Transitive with y; assumption. -intro Hxz. -apply Hxy'. -apply partial_order_antisym; auto. -rewrite Hxz; auto. +- intros x (_,Hx). apply Hx, Equivalence_Reflexive. +- intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. + + apply PreOrder_Transitive with y; assumption. + + intro Hxz. + apply Hxy'. + apply partial_order_antisym; auto. + rewrite Hxz; auto. Qed. @@ -674,12 +675,12 @@ Lemma StrictOrder_PreOrder PreOrder (relation_disjunction R eqA). Proof. split. -intros x. right. reflexivity. -intros x y z [Hxy|Hxy] [Hyz|Hyz]. -left. transitivity y; auto. -left. rewrite <- Hyz; auto. -left. rewrite Hxy; auto. -right. transitivity y; auto. +- intros x. right. reflexivity. +- intros x y z [Hxy|Hxy] [Hyz|Hyz]. + + left. transitivity y; auto. + + left. rewrite <- Hyz; auto. + + left. rewrite Hxy; auto. + + right. transitivity y; auto. Qed. Hint Extern 4 (PreOrder (relation_disjunction _ _)) => diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 8881fda577..efb85aa341 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -85,10 +85,12 @@ Qed. Instance Acc_rel_morphism {A:Type} : Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A). Proof. - apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. - intros R R' EQ a a' Ha WF. subst a'. - induction WF as [x _ WF']. constructor. - intros y Ryx. now apply WF', EQ. + apply proper_sym_impl_iff_2. + - red; now symmetry. + - red; now symmetry. + - intros R R' EQ a a' Ha WF. subst a'. + induction WF as [x _ WF']. constructor. + intros y Ryx. now apply WF', EQ. Qed. (** Equivalent relations are simultaneously well-founded or not *) diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 6e2ff49536..440b317573 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -407,9 +407,10 @@ Program Instance predicate_equivalence_equivalence : Qed. Next Obligation. fold pointwise_lifting. - induction l. firstorder. - intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). - firstorder. + induction l. + - firstorder. + - intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). + firstorder. Qed. Program Instance predicate_implication_preorder : @@ -418,9 +419,10 @@ Program Instance predicate_implication_preorder : induction l ; firstorder. Qed. Next Obligation. - induction l. firstorder. - unfold predicate_implication in *. simpl in *. - intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. + induction l. + - firstorder. + - unfold predicate_implication in *. simpl in *. + intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. (** We define the various operations which define the algebra on binary relations, diff --git a/theories/Compat/Coq88.v b/theories/Compat/Coq88.v index 989072940a..e4a8df1e93 100644 --- a/theories/Compat/Coq88.v +++ b/theories/Compat/Coq88.v @@ -20,9 +20,11 @@ Require Coq.Strings.Ascii Coq.Strings.String. Export String.StringSyntax Ascii.AsciiSyntax. Require Coq.ZArith.BinIntDef Coq.PArith.BinPosDef Coq.NArith.BinNatDef. Require Coq.Reals.Rdefinitions. +Require Coq.Numbers.Cyclic.Int63.Int63. Require Coq.Numbers.Cyclic.Int31.Int31. Declare ML Module "r_syntax_plugin". -Declare ML Module "int31_syntax_plugin". +Declare ML Module "int63_syntax_plugin". Numeral Notation BinNums.Z BinIntDef.Z.of_int BinIntDef.Z.to_int : Z_scope. Numeral Notation BinNums.positive BinPosDef.Pos.of_int BinPosDef.Pos.to_int : positive_scope. Numeral Notation BinNums.N BinNatDef.N.of_int BinNatDef.N.to_int : N_scope. +Numeral Notation Int31.int31 Int31.phi_inv_nonneg Int31.phi : int31_scope. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 1db0a8e1b5..b607be4f94 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -383,6 +383,11 @@ Section Logic_lemmas. Register eq_trans as core.eq.trans. + Theorem eq_trans_r : x = y -> z = y -> x = z. + Proof. + destruct 2; trivial. + Defined. + Theorem f_equal : x = y -> f x = f y. Proof. destruct 1; trivial. @@ -695,8 +700,8 @@ Proof. - intros (x,(Hx,Huni)); split. + exists x; assumption. + intros x' x'' Hx' Hx''; transitivity x. - symmetry; auto. - auto. + * symmetry; auto. + * auto. Qed. Lemma forall_exists_unique_domain_coincide : diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 5e29f854e8..81268a87ad 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -38,7 +38,7 @@ Numeral Notation Decimal.int Decimal.int_of_int Decimal.int_of_int : dec_int_scope. (* Parsing / printing of [nat] numbers *) -Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5000). +Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5001). (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index cfba2bae69..e5d63c547d 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -765,8 +765,9 @@ Section Dependent_choice_lemmas. intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. - induction n; simpl; apply proj2_sig. + split. + - reflexivity. + - induction n; simpl; apply proj2_sig. Defined. End Dependent_choice_lemmas. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 8df533e743..af4632161e 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -202,13 +202,17 @@ Set Implicit Arguments. Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}), C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide. Proof. -intros; destruct decide. apply H0. contradiction. + intros; destruct decide. + - apply H0. + - contradiction. Qed. Lemma decide_right : forall (C:Prop) (decide:{C}+{~C}), ~C -> forall P:{C}+{~C}->Prop, (forall H:~C, P (right _ H)) -> P decide. Proof. -intros; destruct decide. contradiction. apply H0. + intros; destruct decide. + - contradiction. + - apply H0. Qed. Tactic Notation "decide" constr(lemma) "with" constr(H) := diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index d93816e9ff..419a0be49c 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -118,16 +118,16 @@ intros n; unfold dmemo_get, dmemo_list. rewrite (memo_get_correct memo_val mf n); simpl. case (is_eq n n); simpl; auto; intros e. assert (e = eq_refl n). - apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - left; auto. - right; intros HH; discriminate HH. - right; intros HH; discriminate HH. - case (Hx y). - intros HH; left; case HH; auto. - intros HH; right; intros HH1; case HH. - injection HH1; auto. -rewrite H; auto. +- apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + + left; auto. + + right; intros HH; discriminate HH. + + right; intros HH; discriminate HH. + + case (Hx y). + * intros HH; left; case HH; auto. + * intros HH; right; intros HH1; case HH. + injection HH1; auto. +- rewrite H; auto. Qed. (** Finally, a version with both dependency and iterator *) @@ -145,19 +145,19 @@ Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. Proof. intros n; unfold dmemo_get, dimemo_list. rewrite (imemo_get_correct memo_val mf mg); simpl. -case (is_eq n n); simpl; auto; intros e. -assert (e = eq_refl n). - apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - left; auto. - right; intros HH; discriminate HH. - right; intros HH; discriminate HH. - case (Hx y). - intros HH; left; case HH; auto. - intros HH; right; intros HH1; case HH. - injection HH1; auto. -rewrite H; auto. -intros n1; unfold mf; rewrite Hg_correct; auto. +- case (is_eq n n); simpl; auto; intros e. + assert (e = eq_refl n). + + apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + * left; auto. + * right; intros HH; discriminate HH. + * right; intros HH; discriminate HH. + * case (Hx y). + -- intros HH; left; case HH; auto. + -- intros HH; right; intros HH1; case HH. + injection HH1; auto. + + rewrite H; auto. +- intros n1; unfold mf; rewrite Hg_correct; auto. Qed. End DependentMemoFunction. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index a03799959e..4503b3b643 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -92,20 +92,20 @@ Qed. Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1. coinduction Eq_sym. -case H; intros; symmetry ; assumption. -case H; intros; assumption. ++ case H; intros; symmetry ; assumption. ++ case H; intros; assumption. Qed. Theorem trans_EqSt : forall s1 s2 s3:Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3. coinduction Eq_trans. -transitivity (hd s2). -case H; intros; assumption. -case H0; intros; assumption. -apply (Eq_trans (tl s1) (tl s2) (tl s3)). -case H; trivial with datatypes. -case H0; trivial with datatypes. +- transitivity (hd s2). + + case H; intros; assumption. + + case H0; intros; assumption. +- apply (Eq_trans (tl s1) (tl s2) (tl s3)). + + case H; trivial with datatypes. + + case H0; trivial with datatypes. Qed. (** The definition given is equivalent to require the elements at each @@ -114,20 +114,20 @@ Qed. Theorem eqst_ntheq : forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2. unfold Str_nth; simple induction n. -intros s1 s2 H; case H; trivial with datatypes. -intros m hypind. -simpl. -intros s1 s2 H. -apply hypind. -case H; trivial with datatypes. +- intros s1 s2 H; case H; trivial with datatypes. +- intros m hypind. + simpl. + intros s1 s2 H. + apply hypind. + case H; trivial with datatypes. Qed. Theorem ntheq_eqst : forall s1 s2:Stream, (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2. coinduction Equiv2. -apply (H 0). -intros n; apply (H (S n)). +- apply (H 0). +- intros n; apply (H (S n)). Qed. Section Stream_Properties. @@ -150,11 +150,11 @@ CoInductive ForAll (x: Stream) : Prop := Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x). Proof. induction m. - tauto. -intros x [_ H]. -simpl. -apply IHm. -assumption. +- tauto. +- intros x [_ H]. + simpl. + apply IHm. + assumption. Qed. Section Co_Induction_ForAll. @@ -179,10 +179,10 @@ CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)). Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s). Proof. induction n. -reflexivity. -simpl. -intros s. -apply IHn. +- reflexivity. +- simpl. + intros s. + apply IHn. Qed. Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s). @@ -228,11 +228,11 @@ Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). Proof. induction n. -reflexivity. -intros [x xs] [y ys]. -unfold Str_nth in *. -simpl in *. -apply IHn. +- reflexivity. +- intros [x xs] [y ys]. + unfold Str_nth in *. + simpl in *. + apply IHn. Qed. Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index ed4d69ab02..86894cd1f2 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -88,8 +88,8 @@ Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). Proof. intros A B. destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. - exists f0 g0; trivial. - exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; +- exists f0 g0; trivial. +- exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; destruct hf; auto. Qed. @@ -130,9 +130,9 @@ Proof. unfold R at 1. unfold g. rewrite AC. -trivial. -exists (fun x:pow U => x) (fun x:pow U => x). -trivial. +- trivial. +- exists (fun x:pow U => x) (fun x:pow U => x). + trivial. Qed. @@ -141,11 +141,11 @@ Proof. generalize not_has_fixpoint. unfold Not_b. apply AC_IF. -intros is_true is_false. -elim is_true; elim is_false; trivial. +- intros is_true is_false. + elim is_true; elim is_false; trivial. -intros not_true is_true. -elim not_true; trivial. +- intros not_true is_true. + elim not_true; trivial. Qed. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 8e59941f37..b930388d13 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -372,8 +372,7 @@ Proof. rewrite (UIP_refl y). intros z. assert (UIP:forall y' y'' : x = x, y' = y''). - { intros. apply eq_trans with (eq_refl x). apply UIP_refl. - symmetry. apply UIP_refl. } + { intros. apply eq_trans_r with (eq_refl x); apply UIP_refl. } transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z) (eq_sym (UIP (eq_refl x) (eq_refl x)))). - destruct z. destruct (UIP _ _). reflexivity. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 4e8b48af9f..3babc9437b 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -66,9 +66,9 @@ Section EqdepDec. intros. unfold nu. destruct (eq_dec y) as [Heq|Hneq]. - reflexivity. + - reflexivity. - case Hneq; trivial. + - case Hneq; trivial. Qed. @@ -118,15 +118,15 @@ Section EqdepDec. Proof. intros. cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y). - simpl. - destruct (eq_dec x) as [Heq|Hneq]. - elim Heq using K_dec_on; trivial. + - simpl. + destruct (eq_dec x) as [Heq|Hneq]. + + elim Heq using K_dec_on; trivial. - intros. - case Hneq; trivial. + + intros. + case Hneq; trivial. - case H. - reflexivity. + - case H. + reflexivity. Qed. End EqdepDec. @@ -163,8 +163,8 @@ Theorem K_dec_type : Proof. intros A eq_dec x P H p. elim p using K_dec; intros. - case (eq_dec x0 y); [left|right]; assumption. - trivial. + - case (eq_dec x0 y); [left|right]; assumption. + - trivial. Qed. Theorem K_dec_set : @@ -260,8 +260,8 @@ Module DecidableEqDep (M:DecidableType). Proof. intros. apply inj_right_pair with (A:=U). - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. - assumption. + - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. + - assumption. Qed. End DecidableEqDep. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 3914f44a2c..11897b6cb1 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -135,10 +135,10 @@ Proof. exists bool. exists (fun _ => True). exists true. exists false. exists I. exists I. split. -trivial. -intro H. -assert (true=false) by (destruct H; reflexivity). -discriminate. +- trivial. +- intro H. + assert (true=false) by (destruct H; reflexivity). + discriminate. Qed. (** However, when the dependencies are equal, [JMeq (P p) x (P q) y] diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index b6441bb76a..9547a642df 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -12,7 +12,7 @@ Set Implicit Arguments. -Require Import ZArith. +Require Import BinInt. Local Open Scope Z_scope. Definition base digits := Z.pow 2 (Zpos digits). @@ -23,7 +23,7 @@ Section Carry. Variable A : Type. #[universes(template)] - Inductive carry := + Variant carry := | C0 : A -> carry | C1 : A -> carry. @@ -46,7 +46,7 @@ Section Zn2Z. *) #[universes(template)] - Inductive zn2z := + Variant zn2z := | W0 : zn2z | WW : znz -> znz -> zn2z. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 4a1f24b95e..4b0bda3d44 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** This library has been deprecated since Coq version 8.10. *) + (** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *) (** @@ -1274,7 +1276,7 @@ Section Int31_Specs. Qed. Lemma spec_add_carry : - forall x y, [|x+y+1|] = ([|x|] + [|y|] + 1) mod wB. + forall x y, [|x+y+1|] = ([|x|] + [|y|] + 1) mod wB. Proof. unfold add31; intros. repeat rewrite phi_phi_inv. @@ -1776,7 +1778,7 @@ Section Int31_Specs. Qed. Lemma spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|head031 x|]) * [|x|] < wB. + wB/ 2 <= 2 ^ ([|head031 x|]) * [|x|] < wB. Proof. intros. rewrite head031_equiv. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index ce540775e3..b9185c9ca0 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -10,6 +10,8 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) +(** This library has been deprecated since Coq version 8.10. *) + Require Import NaryFunctions. Require Import Wf_nat. Require Export ZArith. @@ -44,18 +46,11 @@ Definition digits31 t := Eval compute in nfun digits size t. Inductive int31 : Type := I31 : digits31 int31. -(* spiwack: Registration of the type of integers, so that the matchs in - the functions below perform dynamic decompilation (otherwise some segfault - occur when they are applied to one non-closed term and one closed term). *) -Register digits as int31.bits. -Register int31 as int31.type. - Scheme int31_ind := Induction for int31 Sort Prop. Scheme int31_rec := Induction for int31 Sort Set. Scheme int31_rect := Induction for int31 Sort Type. Declare Scope int31_scope. -Declare ML Module "int31_syntax_plugin". Delimit Scope int31_scope with int31. Bind Scope int31_scope with int31. Local Open Scope int31_scope. @@ -208,6 +203,13 @@ Definition phi_inv : Z -> int31 := fun n => | Zneg p => incr (complement_negative p) end. +(** [phi_inv_nonneg] returns [None] if the [Z] is negative; this matches the old behavior of parsing int31 numerals *) +Definition phi_inv_nonneg : Z -> option int31 := fun n => + match n with + | Zneg _ => None + | _ => Some (phi_inv n) + end. + (** [phi_inv2] is similar to [phi_inv] but returns a double word [zn2z int31] *) @@ -351,22 +353,6 @@ Definition lor31 n m := phi_inv (Z.lor (phi n) (phi m)). Definition land31 n m := phi_inv (Z.land (phi n) (phi m)). Definition lxor31 n m := phi_inv (Z.lxor (phi n) (phi m)). -Register add31 as int31.plus. -Register add31c as int31.plusc. -Register add31carryc as int31.pluscarryc. -Register sub31 as int31.minus. -Register sub31c as int31.minusc. -Register sub31carryc as int31.minuscarryc. -Register mul31 as int31.times. -Register mul31c as int31.timesc. -Register div3121 as int31.div21. -Register div31 as int31.diveucl. -Register compare31 as int31.compare. -Register addmuldiv31 as int31.addmuldiv. -Register lor31 as int31.lor. -Register land31 as int31.land. -Register lxor31 as int31.lxor. - Definition lnot31 n := lxor31 Tn n. Definition ldiff31 n m := land31 n (lnot31 m). @@ -491,5 +477,4 @@ Definition tail031 (i:int31) := end) i On. -Register head031 as int31.head0. -Register tail031 as int31.tail0. +Numeral Notation int31 phi_inv_nonneg phi : int31_scope. diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v index b693529451..eb47141cab 100644 --- a/theories/Numbers/Cyclic/Int31/Ring31.v +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** This library has been deprecated since Coq version 8.10. *) + (** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped with a ring structure and a ring tactic *) @@ -101,4 +103,3 @@ Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. intros. ring. Qed. End TestRing. - diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v new file mode 100644 index 0000000000..3b431d5b47 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -0,0 +1,330 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Int63 numbers defines indeed a cyclic structure : Z/(2^31)Z *) + +(** +Author: Arnaud Spiwack (+ Pierre Letouzey) +*) +Require Import CyclicAxioms. +Require Export ZArith. +Require Export Int63. +Import Zpow_facts. +Import Utf8. +Import Lia. + +Local Open Scope int63_scope. +(** {2 Operators } **) + +Definition Pdigits := Eval compute in P_of_succ_nat (size - 1). + +Fixpoint positive_to_int_rec (n:nat) (p:positive) := + match n, p with + | O, _ => (Npos p, 0) + | S n, xH => (0%N, 1) + | S n, xO p => + let (N,i) := positive_to_int_rec n p in + (N, i << 1) + | S n, xI p => + let (N,i) := positive_to_int_rec n p in + (N, (i << 1) + 1) + end. + +Definition positive_to_int := positive_to_int_rec size. + +Definition mulc_WW x y := + let (h, l) := mulc x y in + if is_zero h then + if is_zero l then W0 + else WW h l + else WW h l. +Notation "n '*c' m" := (mulc_WW n m) (at level 40, no associativity) : int63_scope. + +Definition pos_mod p x := + if p <= digits then + let p := digits - p in + (x << p) >> p + else x. + +Notation pos_mod_int := pos_mod. + +Import ZnZ. + +Instance int_ops : ZnZ.Ops int := +{| + digits := Pdigits; (* number of digits *) + zdigits := Int63.digits; (* number of digits *) + to_Z := Int63.to_Z; (* conversion to Z *) + of_pos := positive_to_int; (* positive -> N*int63 : p => N,i + where p = N*2^31+phi i *) + head0 := Int63.head0; (* number of head 0 *) + tail0 := Int63.tail0; (* number of tail 0 *) + zero := 0; + one := 1; + minus_one := Int63.max_int; + compare := Int63.compare; + eq0 := Int63.is_zero; + opp_c := Int63.oppc; + opp := Int63.opp; + opp_carry := Int63.oppcarry; + succ_c := Int63.succc; + add_c := Int63.addc; + add_carry_c := Int63.addcarryc; + succ := Int63.succ; + add := Int63.add; + add_carry := Int63.addcarry; + pred_c := Int63.predc; + sub_c := Int63.subc; + sub_carry_c := Int63.subcarryc; + pred := Int63.pred; + sub := Int63.sub; + sub_carry := Int63.subcarry; + mul_c := mulc_WW; + mul := Int63.mul; + square_c := fun x => mulc_WW x x; + div21 := diveucl_21; + div_gt := diveucl; (* this is supposed to be the special case of + division a/b where a > b *) + div := diveucl; + modulo_gt := Int63.mod; + modulo := Int63.mod; + gcd_gt := Int63.gcd; + gcd := Int63.gcd; + add_mul_div := Int63.addmuldiv; + pos_mod := pos_mod_int; + is_even := Int63.is_even; + sqrt2 := Int63.sqrt2; + sqrt := Int63.sqrt; + ZnZ.lor := Int63.lor; + ZnZ.land := Int63.land; + ZnZ.lxor := Int63.lxor +|}. + +Local Open Scope Z_scope. + +Lemma is_zero_spec_aux : forall x : int, is_zero x = true -> [|x|] = 0%Z. +Proof. + intros x;rewrite is_zero_spec;intros H;rewrite H;trivial. +Qed. + +Lemma positive_to_int_spec : + forall p : positive, + Zpos p = + Z_of_N (fst (positive_to_int p)) * wB + to_Z (snd (positive_to_int p)). +Proof. + assert (H: (wB <= wB) -> forall p : positive, + Zpos p = Z_of_N (fst (positive_to_int p)) * wB + [|snd (positive_to_int p)|] /\ + [|snd (positive_to_int p)|] < wB). + 2: intros p; case (H (Z.le_refl wB) p); auto. + unfold positive_to_int, wB at 1 3 4. + elim size. + intros _ p; simpl; + rewrite to_Z_0, Pmult_1_r; split; auto with zarith; apply refl_equal. + intros n; rewrite inj_S; unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + intros IH Hle p. + assert (F1: 2 ^ Z_of_nat n <= wB); auto with zarith. + assert (0 <= 2 ^ Z_of_nat n); auto with zarith. + case p; simpl. + intros p1. + generalize (IH F1 p1); case positive_to_int_rec; simpl. + intros n1 i (H1,H2). + rewrite Zpos_xI, H1. + replace [|i << 1 + 1|] with ([|i|] * 2 + 1). + split; auto with zarith; ring. + rewrite add_spec, lsl_spec, Zplus_mod_idemp_l, to_Z_1, Z.pow_1_r, Zmod_small; auto. + case (to_Z_bounded i); split; auto with zarith. + intros p1. + generalize (IH F1 p1); case positive_to_int_rec; simpl. + intros n1 i (H1,H2). + rewrite Zpos_xO, H1. + replace [|i << 1|] with ([|i|] * 2). + split; auto with zarith; ring. + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto. + case (to_Z_bounded i); split; auto with zarith. + rewrite to_Z_1; assert (0 < 2^ Z_of_nat n); auto with zarith. +Qed. + +Lemma mulc_WW_spec : + forall x y,[|| x *c y ||] = [|x|] * [|y|]. +Proof. + intros x y;unfold mulc_WW. + generalize (mulc_spec x y);destruct (mulc x y);simpl;intros Heq;rewrite Heq. + case_eq (is_zero i);intros;trivial. + apply is_zero_spec in H;rewrite H, to_Z_0. + case_eq (is_zero i0);intros;trivial. + apply is_zero_spec in H0;rewrite H0, to_Z_0, Zmult_comm;trivial. +Qed. + +Lemma squarec_spec : + forall x, + [||x *c x||] = [|x|] * [|x|]. +Proof (fun x => mulc_WW_spec x x). + +Lemma diveucl_spec_aux : forall a b, 0 < [|b|] -> + let (q,r) := diveucl a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a b H;assert (W:= diveucl_spec a b). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod [|a|] [|b|] H0). + destruct (diveucl a b);destruct (Z.div_eucl [|a|] [|b|]). + inversion W;rewrite Zmult_comm;trivial. +Qed. + +Lemma diveucl_21_spec_aux : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := diveucl_21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). + assert (W1:= to_Z_bounded a1). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). + destruct (diveucl_21 a1 a2 b);destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). + inversion W;rewrite (Zmult_comm [|b|]);trivial. +Qed. + +Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + a mod 2 ^ p. + Proof. + intros n p a H. + rewrite Zmod_small. + - rewrite Zmod_eq by auto with zarith. + unfold Zminus at 1. + rewrite Zdiv.Z_div_plus_full_l by auto with zarith. + replace (2 ^ n) with (2 ^ (n - p) * 2 ^ p) by (rewrite <- Zpower_exp; [ f_equal | | ]; lia). + rewrite <- Zdiv_Zdiv, Z_div_mult by auto with zarith. + rewrite (Zmult_comm (2^(n-p))), Zmult_assoc. + rewrite Zopp_mult_distr_l. + rewrite Z_div_mult by auto with zarith. + symmetry; apply Zmod_eq; auto with zarith. + - remember (a * 2 ^ (n - p)) as b. + destruct (Z_mod_lt b (2^n)); auto with zarith. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.lt_le_trans with (2^n); auto with zarith. + generalize (pow2_pos (n - p)); nia. + Qed. + +Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. + Proof. + intros p x Hle;destruct (Z_le_gt_dec 0 p). + apply Zdiv_le_lower_bound;auto with zarith. + replace (2^p) with 0. + destruct x;compute;intro;discriminate. + destruct p;trivial;discriminate. + Qed. + +Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. + Proof. + intros p x y H;destruct (Z_le_gt_dec 0 p). + apply Zdiv_lt_upper_bound;auto with zarith. + apply Z.lt_le_trans with y;auto with zarith. + rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. + assert (0 < 2^p);auto with zarith. + replace (2^p) with 0. + destruct x;change (0<y);auto with zarith. + destruct p;trivial;discriminate. + Qed. + +Lemma P (A B C: Prop) : + A → (B → C) → (A → B) → C. +Proof. tauto. Qed. + +Lemma shift_unshift_mod_3: + forall n p a : Z, + 0 <= p <= n -> + (a * 2 ^ (n - p)) mod 2 ^ n / 2 ^ (n - p) = a mod 2 ^ p. +Proof. + intros;rewrite <- (shift_unshift_mod_2 n p a);[ | auto with zarith]. + symmetry;apply Zmod_small. + generalize (a * 2 ^ (n - p));intros w. + generalize (2 ^ (n - p)) (pow2_pos (n - p)); intros x; apply P. lia. intros hx. + generalize (2 ^ n) (pow2_pos n); intros y; apply P. lia. intros hy. + elim_div. intros q r. apply P. lia. + elim_div. intros z t. refine (P _ _ _ _ _). lia. + intros [ ? [ ht | ] ]; [ | lia ]; subst w. + intros [ ? [ hr | ] ]; [ | lia ]; subst t. + nia. +Qed. + +Lemma pos_mod_spec w p : φ(pos_mod p w) = φ(w) mod (2 ^ φ(p)). +Proof. + simpl. unfold pos_mod_int. + assert (W:=to_Z_bounded p);assert (W':=to_Z_bounded Int63.digits);assert (W'' := to_Z_bounded w). + case lebP; intros hle. + 2: { + symmetry; apply Zmod_small. + assert (2 ^ [|Int63.digits|] < 2 ^ [|p|]); [ apply Zpower_lt_monotone; auto with zarith | ]. + change wB with (2 ^ [|Int63.digits|]) in *; auto with zarith. } + rewrite <- (shift_unshift_mod_3 [|Int63.digits|] [|p|] [|w|]) by auto with zarith. + replace ([|Int63.digits|] - [|p|]) with [|Int63.digits - p|] by (rewrite sub_spec, Zmod_small; auto with zarith). + rewrite lsr_spec, lsl_spec; reflexivity. +Qed. + +(** {2 Specification and proof} **) +Global Instance int_specs : ZnZ.Specs int_ops := { + spec_to_Z := to_Z_bounded; + spec_of_pos := positive_to_int_spec; + spec_zdigits := refl_equal _; + spec_more_than_1_digit:= refl_equal _; + spec_0 := to_Z_0; + spec_1 := to_Z_1; + spec_m1 := refl_equal _; + spec_compare := compare_spec; + spec_eq0 := is_zero_spec_aux; + spec_opp_c := oppc_spec; + spec_opp := opp_spec; + spec_opp_carry := oppcarry_spec; + spec_succ_c := succc_spec; + spec_add_c := addc_spec; + spec_add_carry_c := addcarryc_spec; + spec_succ := succ_spec; + spec_add := add_spec; + spec_add_carry := addcarry_spec; + spec_pred_c := predc_spec; + spec_sub_c := subc_spec; + spec_sub_carry_c := subcarryc_spec; + spec_pred := pred_spec; + spec_sub := sub_spec; + spec_sub_carry := subcarry_spec; + spec_mul_c := mulc_WW_spec; + spec_mul := mul_spec; + spec_square_c := squarec_spec; + spec_div21 := diveucl_21_spec_aux; + spec_div_gt := fun a b _ => diveucl_spec_aux a b; + spec_div := diveucl_spec_aux; + spec_modulo_gt := fun a b _ _ => mod_spec a b; + spec_modulo := fun a b _ => mod_spec a b; + spec_gcd_gt := fun a b _ => gcd_spec a b; + spec_gcd := gcd_spec; + spec_head00 := head00_spec; + spec_head0 := head0_spec; + spec_tail00 := tail00_spec; + spec_tail0 := tail0_spec; + spec_add_mul_div := addmuldiv_spec; + spec_pos_mod := pos_mod_spec; + spec_is_even := is_even_spec; + spec_sqrt2 := sqrt2_spec; + spec_sqrt := sqrt_spec; + spec_land := land_spec'; + spec_lor := lor_spec'; + spec_lxor := lxor_spec' }. + + + +Module Int63Cyclic <: CyclicType. + Definition t := int. + Definition ops := int_ops. + Definition specs := int_specs. +End Int63Cyclic. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v new file mode 100644 index 0000000000..eac26add03 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -0,0 +1,1918 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +Require Import Utf8. +Require Export DoubleType. +Require Import Lia. +Require Import Zpow_facts. +Require Import Zgcd_alt. +Import Znumtheory. + +Register bool as kernel.ind_bool. +Register prod as kernel.ind_pair. +Register carry as kernel.ind_carry. +Register comparison as kernel.ind_cmp. + +Definition size := 63%nat. + +Primitive int := #int63_type. +Register int as num.int63.type. +Declare Scope int63_scope. +Definition id_int : int -> int := fun x => x. +Declare ML Module "int63_syntax_plugin". + +Delimit Scope int63_scope with int63. +Bind Scope int63_scope with int. + +(* Logical operations *) +Primitive lsl := #int63_lsl. +Infix "<<" := lsl (at level 30, no associativity) : int63_scope. + +Primitive lsr := #int63_lsr. +Infix ">>" := lsr (at level 30, no associativity) : int63_scope. + +Primitive land := #int63_land. +Infix "land" := land (at level 40, left associativity) : int63_scope. + +Primitive lor := #int63_lor. +Infix "lor" := lor (at level 40, left associativity) : int63_scope. + +Primitive lxor := #int63_lxor. +Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. + +(* Arithmetic modulo operations *) +Primitive add := #int63_add. +Notation "n + m" := (add n m) : int63_scope. + +Primitive sub := #int63_sub. +Notation "n - m" := (sub n m) : int63_scope. + +Primitive mul := #int63_mul. +Notation "n * m" := (mul n m) : int63_scope. + +Primitive mulc := #int63_mulc. + +Primitive div := #int63_div. +Notation "n / m" := (div n m) : int63_scope. + +Primitive mod := #int63_mod. +Notation "n '\%' m" := (mod n m) (at level 40, left associativity) : int63_scope. + +(* Comparisons *) +Primitive eqb := #int63_eq. +Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. + +Primitive ltb := #int63_lt. +Notation "m < n" := (ltb m n) : int63_scope. + +Primitive leb := #int63_le. +Notation "m <= n" := (leb m n) : int63_scope. +Notation "m ≤ n" := (leb m n) (at level 70, no associativity) : int63_scope. + +Local Open Scope int63_scope. + +(** The number of digits as a int *) +Definition digits := 63. + +(** The bigger int *) +Definition max_int := Eval vm_compute in 0 - 1. +Register Inline max_int. + +(** Access to the nth digits *) +Definition get_digit x p := (0 < (x land (1 << p))). + +Definition set_digit x p (b:bool) := + if if 0 <= p then p < digits else false then + if b then x lor (1 << p) + else x land (max_int lxor (1 << p)) + else x. + +(** Equality to 0 *) +Definition is_zero (i:int) := i == 0. +Register Inline is_zero. + +(** Parity *) +Definition is_even (i:int) := is_zero (i land 1). +Register Inline is_even. + +(** Bit *) + +Definition bit i n := negb (is_zero ((i >> n) << (digits - 1))). +(* Register bit as PrimInline. *) + +(** Extra modulo operations *) +Definition opp (i:int) := 0 - i. +Register Inline opp. +Notation "- x" := (opp x) : int63_scope. + +Definition oppcarry i := max_int - i. +Register Inline oppcarry. + +Definition succ i := i + 1. +Register Inline succ. + +Definition pred i := i - 1. +Register Inline pred. + +Definition addcarry i j := i + j + 1. +Register Inline addcarry. + +Definition subcarry i j := i - j - 1. +Register Inline subcarry. + +(** Exact arithmetic operations *) + +Definition addc_def x y := + let r := x + y in + if r < x then C1 r else C0 r. +(* the same but direct implementation for effeciancy *) +Primitive addc := #int63_addc. +Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. + +Definition addcarryc_def x y := + let r := addcarry x y in + if r <= x then C1 r else C0 r. +(* the same but direct implementation for effeciancy *) +Primitive addcarryc := #int63_addcarryc. + +Definition subc_def x y := + if y <= x then C0 (x - y) else C1 (x - y). +(* the same but direct implementation for effeciancy *) +Primitive subc := #int63_subc. +Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. + +Definition subcarryc_def x y := + if y < x then C0 (x - y - 1) else C1 (x - y - 1). +(* the same but direct implementation for effeciancy *) +Primitive subcarryc := #int63_subcarryc. + +Definition diveucl_def x y := (x/y, x\%y). +(* the same but direct implementation for effeciancy *) +Primitive diveucl := #int63_diveucl. + +Primitive diveucl_21 := #int63_div21. + +Definition addmuldiv_def p x y := + (x << p) lor (y >> (digits - p)). +Primitive addmuldiv := #int63_addmuldiv. + +Definition oppc (i:int) := 0 -c i. +Register Inline oppc. + +Definition succc i := i +c 1. +Register Inline succc. + +Definition predc i := i -c 1. +Register Inline predc. + +(** Comparison *) +Definition compare_def x y := + if x < y then Lt + else if (x == y) then Eq else Gt. + +Primitive compare := #int63_compare. +Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. + +Import Bool ZArith. +(** Translation to Z *) +Fixpoint to_Z_rec (n:nat) (i:int) := + match n with + | O => 0%Z + | S n => + (if is_even i then Z.double else Zdouble_plus_one) (to_Z_rec n (i >> 1)) + end. + +Definition to_Z := to_Z_rec size. + +Fixpoint of_pos_rec (n:nat) (p:positive) := + match n, p with + | O, _ => 0 + | S n, xH => 1 + | S n, xO p => (of_pos_rec n p) << 1 + | S n, xI p => (of_pos_rec n p) << 1 lor 1 + end. + +Definition of_pos := of_pos_rec size. + +Definition of_Z z := + match z with + | Zpos p => of_pos p + | Z0 => 0 + | Zneg p => - (of_pos p) + end. + +Notation "[| x |]" := (to_Z x) (at level 0, x at level 99) : int63_scope. + +Definition wB := (2 ^ (Z.of_nat size))%Z. + +Lemma to_Z_rec_bounded size : forall x, (0 <= to_Z_rec size x < 2 ^ Z.of_nat size)%Z. +Proof. + elim size. simpl; auto with zarith. + intros n ih x; rewrite inj_S; simpl; assert (W := ih (x >> 1)%int63). + rewrite Z.pow_succ_r; auto with zarith. + destruct (is_even x). + rewrite Zdouble_mult; auto with zarith. + rewrite Zdouble_plus_one_mult; auto with zarith. +Qed. + +Corollary to_Z_bounded : forall x, (0 <= [| x |] < wB)%Z. +Proof. apply to_Z_rec_bounded. Qed. + +(* =================================================== *) +Local Open Scope Z_scope. +(* General arithmetic results *) +Lemma Z_lt_div2 x y : x < 2 * y -> x / 2 < y. +Proof. apply Z.div_lt_upper_bound; reflexivity. Qed. + +Theorem Zmod_le_first a b : 0 <= a -> 0 < b -> 0 <= a mod b <= a. +Proof. + intros ha hb; case (Z_mod_lt a b); [ auto with zarith | ]; intros p q; apply (conj p). + case (Z.le_gt_cases b a). lia. + intros hlt; rewrite Zmod_small; lia. +Qed. + +Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. +Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (t < 2 ^ b). + apply Z.lt_le_trans with (1:= H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zplus_mod; auto with zarith. + rewrite -> Zmod_small with (a := t); auto with zarith. + apply Zmod_small; auto with zarith. + split; auto with zarith. + assert (0 <= 2 ^a * r); auto with zarith. + apply Z.add_nonneg_nonneg; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); + try ring. + apply Z.add_le_lt_mono; auto with zarith. + replace b with ((b - a) + a); try ring. + rewrite Zpower_exp; auto with zarith. + pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a)); + try rewrite <- Z.mul_sub_distr_r. + rewrite (Z.mul_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; + auto with zarith. + rewrite (Z.mul_comm (2 ^a)); apply Z.mul_le_mono_nonneg_r; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end. + apply Z.lt_gt; auto with zarith. + auto with zarith. +Qed. + +(* Results about pow2 *) +Lemma pow2_pos n : 0 <= n → 2 ^ n > 0. +Proof. intros h; apply Z.lt_gt, Zpower_gt_0; lia. Qed. + +Lemma pow2_nz n : 0 <= n → 2 ^ n ≠ 0. +Proof. intros h; generalize (pow2_pos _ h); lia. Qed. + +Hint Resolve pow2_pos pow2_nz : zarith. + +(* =================================================== *) + +(** Trivial lemmas without axiom *) + +Lemma wB_diff_0 : wB <> 0. +Proof. exact (fun x => let 'eq_refl := x in idProp). Qed. + +Lemma wB_pos : 0 < wB. +Proof. reflexivity. Qed. + +Lemma to_Z_0 : [|0|] = 0. +Proof. reflexivity. Qed. + +Lemma to_Z_1 : [|1|] = 1. +Proof. reflexivity. Qed. + +(* Notations *) +Local Open Scope Z_scope. + +Notation "[+| c |]" := + (interp_carry 1 wB to_Z c) (at level 0, c at level 99) : int63_scope. + +Notation "[-| c |]" := + (interp_carry (-1) wB to_Z c) (at level 0, c at level 99) : int63_scope. + +Notation "[|| x ||]" := + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99) : int63_scope. + +(* Bijection : int63 <-> Bvector size *) + +Axiom of_to_Z : forall x, of_Z [| x |] = x. + +Notation "'φ' x" := [| x |] (at level 0) : int63_scope. + +Lemma can_inj {rT aT} {f: aT -> rT} {g: rT -> aT} (K: forall a, g (f a) = a) {a a'} (e: f a = f a') : a = a'. +Proof. generalize (K a) (K a'). congruence. Qed. + +Lemma to_Z_inj x y : φ x = φ y → x = y. +Proof. exact (λ e, can_inj of_to_Z e). Qed. + +(** Specification of logical operations *) +Local Open Scope Z_scope. +Axiom lsl_spec : forall x p, [| x << p |] = [| x |] * 2 ^ [| p |] mod wB. + +Axiom lsr_spec : forall x p, [|x >> p|] = [|x|] / 2 ^ [|p|]. + +Axiom land_spec: forall x y i , bit (x land y) i = bit x i && bit y i. + +Axiom lor_spec: forall x y i, bit (x lor y) i = bit x i || bit y i. + +Axiom lxor_spec: forall x y i, bit (x lxor y) i = xorb (bit x i) (bit y i). + +(** Specification of basic opetations *) + +(* Arithmetic modulo operations *) + +(* Remarque : les axiomes seraient plus simple si on utilise of_Z a la place : + exemple : add_spec : forall x y, of_Z (x + y) = of_Z x + of_Z y. *) + +Axiom add_spec : forall x y, [|x + y|] = ([|x|] + [|y|]) mod wB. + +Axiom sub_spec : forall x y, [|x - y|] = ([|x|] - [|y|]) mod wB. + +Axiom mul_spec : forall x y, [| x * y |] = [|x|] * [|y|] mod wB. + +Axiom mulc_spec : forall x y, [|x|] * [|y|] = [|fst (mulc x y)|] * wB + [|snd (mulc x y)|]. + +Axiom div_spec : forall x y, [|x / y|] = [|x|] / [|y|]. + +Axiom mod_spec : forall x y, [|x \% y|] = [|x|] mod [|y|]. + +(* Comparisons *) +Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. + +Axiom eqb_refl : forall x, (x == x)%int63 = true. + +Axiom ltb_spec : forall x y, (x < y)%int63 = true <-> [|x|] < [|y|]. + +Axiom leb_spec : forall x y, (x <= y)%int63 = true <-> [|x|] <= [|y|]. + +(** Exotic operations *) + +(** I should add the definition (like for compare) *) +Primitive head0 := #int63_head0. +Primitive tail0 := #int63_tail0. + +(** Axioms on operations which are just short cut *) + +Axiom compare_def_spec : forall x y, compare x y = compare_def x y. + +Axiom head0_spec : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. + +Axiom tail0_spec : forall x, 0 < [|x|] -> + (exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]))%Z. + +Axiom addc_def_spec : forall x y, (x +c y)%int63 = addc_def x y. + +Axiom addcarryc_def_spec : forall x y, addcarryc x y = addcarryc_def x y. + +Axiom subc_def_spec : forall x y, (x -c y)%int63 = subc_def x y. + +Axiom subcarryc_def_spec : forall x y, subcarryc x y = subcarryc_def x y. + +Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. + +Axiom diveucl_21_spec : forall a1 a2 b, + let (q,r) := diveucl_21 a1 a2 b in + ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|]. + +Axiom addmuldiv_def_spec : forall p x y, + addmuldiv p x y = addmuldiv_def p x y. + +(** Square root functions using newton iteration **) +Local Open Scope int63_scope. + +Definition sqrt_step (rec: int -> int -> int) (i j: int) := + let quo := i / j in + if quo < j then rec i ((j + quo) >> 1) + else j. + +Definition iter_sqrt := + Eval lazy beta delta [sqrt_step] in + fix iter_sqrt (n: nat) (rec: int -> int -> int) + (i j: int) {struct n} : int := + sqrt_step + (fun i j => match n with + O => rec i j + | S n => (iter_sqrt n (iter_sqrt n rec)) i j + end) i j. + +Definition sqrt i := + match compare 1 i with + Gt => 0 + | Eq => 1 + | Lt => iter_sqrt size (fun i j => j) i (i >> 1) + end. + +Definition high_bit := 1 << (digits - 1). + +Definition sqrt2_step (rec: int -> int -> int -> int) + (ih il j: int) := + if ih < j then + let (quo,_) := diveucl_21 ih il j in + if quo < j then + match j +c quo with + | C0 m1 => rec ih il (m1 >> 1) + | C1 m1 => rec ih il ((m1 >> 1) + high_bit) + end + else j + else j. + +Definition iter2_sqrt := + Eval lazy beta delta [sqrt2_step] in + fix iter2_sqrt (n: nat) + (rec: int -> int -> int -> int) + (ih il j: int) {struct n} : int := + sqrt2_step + (fun ih il j => + match n with + | O => rec ih il j + | S n => (iter2_sqrt n (iter2_sqrt n rec)) ih il j + end) ih il j. + +Definition sqrt2 ih il := + let s := iter2_sqrt size (fun ih il j => j) ih il max_int in + let (ih1, il1) := mulc s s in + match il -c il1 with + | C0 il2 => + if ih1 < ih then (s, C1 il2) else (s, C0 il2) + | C1 il2 => + if ih1 < (ih - 1) then (s, C1 il2) else (s, C0 il2) + end. + +(** Gcd **) +Fixpoint gcd_rec (guard:nat) (i j:int) {struct guard} := + match guard with + | O => 1 + | S p => if j == 0 then i else gcd_rec p j (i \% j) + end. + +Definition gcd := gcd_rec (2*size). + +(** equality *) +Lemma eqb_complete : forall x y, x = y -> (x == y) = true. +Proof. + intros x y H; rewrite -> H, eqb_refl;trivial. +Qed. + +Lemma eqb_spec : forall x y, (x == y) = true <-> x = y. +Proof. + split;auto using eqb_correct, eqb_complete. +Qed. + +Lemma eqb_false_spec : forall x y, (x == y) = false <-> x <> y. +Proof. + intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. +Qed. + +Lemma eqb_false_complete : forall x y, x <> y -> (x == y) = false. +Proof. + intros x y;rewrite eqb_false_spec;trivial. +Qed. + +Lemma eqb_false_correct : forall x y, (x == y) = false -> x <> y. +Proof. + intros x y;rewrite eqb_false_spec;trivial. +Qed. + +Definition eqs (i j : int) : {i = j} + { i <> j } := + (if i == j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) + then fun (Heq : true = true -> i = j) _ => left _ (Heq (eq_refl true)) + else fun _ (Hdiff : false = false -> i <> j) => right _ (Hdiff (eq_refl false))) + (eqb_correct i j) + (eqb_false_correct i j). + +Lemma eq_dec : forall i j:int, i = j \/ i <> j. +Proof. + intros i j;destruct (eqs i j);auto. +Qed. + +(* Extra function on equality *) + +Definition cast i j := + (if i == j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) + then fun Heq : true = true -> i = j => + Some + (fun (P : int -> Type) (Hi : P i) => + match Heq (eq_refl true) in (_ = y) return (P y) with + | eq_refl => Hi + end) + else fun _ : false = true -> i = j => None) (eqb_correct i j). + +Lemma cast_refl : forall i, cast i i = Some (fun P H => H). +Proof. + unfold cast;intros. + generalize (eqb_correct i i). + rewrite eqb_refl;intros. + rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. +Qed. + +Lemma cast_diff : forall i j, i == j = false -> cast i j = None. +Proof. + intros;unfold cast;intros; generalize (eqb_correct i j). + rewrite H;trivial. +Qed. + +Definition eqo i j := + (if i == j as b return ((b = true -> i = j) -> option (i=j)) + then fun Heq : true = true -> i = j => + Some (Heq (eq_refl true)) + else fun _ : false = true -> i = j => None) (eqb_correct i j). + +Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). +Proof. + unfold eqo;intros. + generalize (eqb_correct i i). + rewrite eqb_refl;intros. + rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. +Qed. + +Lemma eqo_diff : forall i j, i == j = false -> eqo i j = None. +Proof. + unfold eqo;intros; generalize (eqb_correct i j). + rewrite H;trivial. +Qed. + +(** Comparison *) + +Lemma eqbP x y : reflect ([| x |] = [| y |]) (x == y). +Proof. apply iff_reflect; rewrite eqb_spec; split; [ apply to_Z_inj | apply f_equal ]. Qed. + +Lemma ltbP x y : reflect ([| x |] < [| y |])%Z (x < y). +Proof. apply iff_reflect; symmetry; apply ltb_spec. Qed. + +Lemma lebP x y : reflect ([| x |] <= [| y |])%Z (x ≤ y). +Proof. apply iff_reflect; symmetry; apply leb_spec. Qed. + +Lemma compare_spec x y : compare x y = ([|x|] ?= [|y|])%Z. +Proof. + rewrite compare_def_spec; unfold compare_def. + case ltbP; [ auto using Z.compare_lt_iff | intros hge ]. + case eqbP; [ now symmetry; apply Z.compare_eq_iff | intros hne ]. + symmetry; apply Z.compare_gt_iff; lia. +Qed. + +Lemma is_zero_spec x : is_zero x = true <-> x = 0%int63. +Proof. apply eqb_spec. Qed. + +Lemma diveucl_spec x y : + let (q,r) := diveucl x y in + ([| q |], [| r |]) = Z.div_eucl [| x |] [| y |]. +Proof. + rewrite diveucl_def_spec; unfold diveucl_def; rewrite div_spec, mod_spec; unfold Z.div, Zmod. + destruct (Z.div_eucl [| x |] [| y |]); trivial. +Qed. + +Local Open Scope Z_scope. +(** Addition *) +Lemma addc_spec x y : [+| x +c y |] = [| x |] + [| y |]. +Proof. + rewrite addc_def_spec; unfold addc_def, interp_carry. + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case ltbP; rewrite add_spec. + case (Z_lt_ge_dec ([| x |] + [| y |]) wB). + intros k; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] - wB)); lia. + case (Z_lt_ge_dec ([| x |] + [| y |]) wB). + intros k; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] - wB)); lia. +Qed. + +Lemma succ_spec x : [| succ x |] = ([| x |] + 1) mod wB. +Proof. apply add_spec. Qed. + +Lemma succc_spec x : [+| succc x |] = [| x |] + 1. +Proof. apply addc_spec. Qed. + +Lemma addcarry_spec x y : [| addcarry x y |] = ([| x |] + [| y |] + 1) mod wB. +Proof. unfold addcarry; rewrite -> !add_spec, Zplus_mod_idemp_l; trivial. Qed. + +Lemma addcarryc_spec x y : [+| addcarryc x y |] = [| x |] + [| y |] + 1. +Proof. + rewrite addcarryc_def_spec; unfold addcarryc_def, interp_carry. + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case lebP; rewrite addcarry_spec. + case (Z_lt_ge_dec ([| x |] + [| y |] + 1) wB). + intros hlt; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] + 1 - wB)); lia. + case (Z_lt_ge_dec ([| x |] + [| y |] + 1) wB). + intros hlt; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] + 1 - wB)); lia. +Qed. + +(** Subtraction *) +Lemma subc_spec x y : [-| x -c y |] = [| x |] - [| y |]. +Proof. + rewrite subc_def_spec; unfold subc_def; unfold interp_carry. + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case lebP. + intros hle; rewrite sub_spec, Z.mod_small; lia. + intros hgt; rewrite sub_spec, <- (Zmod_unique _ wB (-1) ([| x |] - [| y |] + wB)); lia. +Qed. + +Lemma pred_spec x : [| pred x |] = ([| x |] - 1) mod wB. +Proof. apply sub_spec. Qed. + +Lemma predc_spec x : [-| predc x |] = [| x |] - 1. +Proof. apply subc_spec. Qed. + +Lemma oppc_spec x : [-| oppc x |] = - [| x |]. +Proof. unfold oppc; rewrite -> subc_spec, to_Z_0; trivial. Qed. + +Lemma opp_spec x : [|- x |] = - [| x |] mod wB. +Proof. unfold opp; rewrite -> sub_spec, to_Z_0; trivial. Qed. + +Lemma oppcarry_spec x : [| oppcarry x |] = wB - [| x |] - 1. +Proof. + unfold oppcarry; rewrite sub_spec. + rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. + apply Zmod_small. + generalize (to_Z_bounded x); auto with zarith. +Qed. + +Lemma subcarry_spec x y : [| subcarry x y |] = ([| x |] - [| y |] - 1) mod wB. +Proof. unfold subcarry; rewrite !sub_spec, Zminus_mod_idemp_l; trivial. Qed. + +Lemma subcarryc_spec x y : [-| subcarryc x y |] = [| x |] - [| y |] - 1. +Proof. + rewrite subcarryc_def_spec; unfold subcarryc_def, interp_carry; fold (subcarry x y). + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case ltbP; rewrite subcarry_spec. + intros hlt; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ (-1) ([| x |] - [| y |] - 1 + wB)); lia. +Qed. + +(** GCD *) +Lemma to_Z_gcd : forall i j, [| gcd i j |] = Zgcdn (2 * size) [| j |] [| i |]. +Proof. + unfold gcd. + elim (2*size)%nat. reflexivity. + intros n ih i j; simpl. + pose proof (to_Z_bounded j) as hj; pose proof (to_Z_bounded i). + case eqbP; rewrite to_Z_0. + intros ->; rewrite Z.abs_eq; lia. + intros hne; rewrite ih; clear ih. + rewrite <- mod_spec. + revert hj hne; case [| j |]; intros; lia. +Qed. + +Lemma gcd_spec a b : Zis_gcd [| a |] [| b |] [| gcd a b |]. +Proof. + rewrite to_Z_gcd. + apply Zis_gcd_sym. + apply Zgcdn_is_gcd. + unfold Zgcd_bound. + generalize (to_Z_bounded b). + destruct [|b|]. + unfold size; auto with zarith. + intros (_,H). + cut (Psize p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. + intros (H,_); compute in H; elim H; auto. +Qed. + +(** Head0, Tail0 *) +Lemma head00_spec x : [| x |] = 0 -> [| head0 x |] = [| digits |]. +Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. + +Lemma tail00_spec x : [| x |] = 0 -> [|tail0 x|] = [|digits|]. +Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. + +Infix "≡" := (eqm wB) (at level 80) : int63_scope. + +Lemma eqm_mod x y : x mod wB ≡ y mod wB → x ≡ y. +Proof. + intros h. + eapply (eqm_trans). + apply eqm_sym; apply Zmod_eqm. + apply (eqm_trans _ _ _ _ h). + apply Zmod_eqm. +Qed. + +Lemma eqm_sub x y : x ≡ y → x - y ≡ 0. +Proof. intros h; unfold eqm; rewrite Zminus_mod, h, Z.sub_diag; reflexivity. Qed. + +Lemma eqmE x y : x ≡ y → ∃ k, x - y = k * wB. +Proof. + intros h. + exact (Zmod_divide (x - y) wB (λ e, let 'eq_refl := e in I) (eqm_sub _ _ h)). +Qed. + +Lemma eqm_subE x y : x ≡ y ↔ x - y ≡ 0. +Proof. + split. apply eqm_sub. + intros h; case (eqmE _ _ h); clear h; intros q h. + assert (y = x - q * wB) by lia. + clear h; subst y. + unfold eqm; rewrite Zminus_mod, Z_mod_mult, Z.sub_0_r, Zmod_mod; reflexivity. +Qed. + +Lemma int_eqm x y : x = y → φ x ≡ φ y. +Proof. unfold eqm; intros ->; reflexivity. Qed. + +Lemma eqmI x y : φ x ≡ φ y → x = y. +Proof. + unfold eqm. + repeat rewrite Zmod_small by apply to_Z_bounded. + apply to_Z_inj. +Qed. + +(* ADD *) +Lemma add_assoc x y z: (x + (y + z) = (x + y) + z)%int63. +Proof. + apply to_Z_inj; rewrite !add_spec. + rewrite -> Zplus_mod_idemp_l, Zplus_mod_idemp_r, Zplus_assoc; auto. +Qed. + +Lemma add_comm x y: (x + y = y + x)%int63. +Proof. + apply to_Z_inj; rewrite -> !add_spec, Zplus_comm; auto. +Qed. + +Lemma add_le_r m n: + if (n <= m + n)%int63 then ([|m|] + [|n|] < wB)%Z else (wB <= [|m|] + [|n|])%Z. +Proof. + case (to_Z_bounded m); intros H1m H2m. + case (to_Z_bounded n); intros H1n H2n. + case (Zle_or_lt wB ([|m|] + [|n|])); intros H. + assert (H1: ([| m + n |] = [|m|] + [|n|] - wB)%Z). + rewrite add_spec. + replace (([|m|] + [|n|]) mod wB)%Z with (((([|m|] + [|n|]) - wB) + wB) mod wB)%Z. + rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. + rewrite !Zmod_small; auto with zarith. + apply f_equal2 with (f := Zmod); auto with zarith. + case_eq (n <= m + n)%int63; auto. + rewrite leb_spec, H1; auto with zarith. + assert (H1: ([| m + n |] = [|m|] + [|n|])%Z). + rewrite add_spec, Zmod_small; auto with zarith. + replace (n <= m + n)%int63 with true; auto. + apply sym_equal; rewrite leb_spec, H1; auto with zarith. +Qed. + +Lemma add_cancel_l x y z : (x + y = x + z)%int63 -> y = z. +Proof. + intros h; apply int_eqm in h; rewrite !add_spec in h; apply eqm_mod, eqm_sub in h. + replace (_ + _ - _) with (φ(y) - φ(z)) in h by lia. + rewrite <- eqm_subE in h. + apply eqmI, h. +Qed. + +Lemma add_cancel_r x y z : (y + x = z + x)%int63 -> y = z. +Proof. + rewrite !(fun t => add_comm t x); intros Hl; apply (add_cancel_l x); auto. +Qed. + +Coercion b2i (b: bool) : int := if b then 1%int63 else 0%int63. + +(* LSR *) +Lemma lsr0 i : 0 >> i = 0%int63. +Proof. apply to_Z_inj; rewrite lsr_spec; reflexivity. Qed. + +Lemma lsr_0_r i: i >> 0 = i. +Proof. apply to_Z_inj; rewrite lsr_spec, Zdiv_1_r; exact eq_refl. Qed. + +Lemma lsr_1 n : 1 >> n = (n == 0). +Proof. + case eqbP. + intros h; rewrite (to_Z_inj _ _ h), lsr_0_r; reflexivity. + intros Hn. + assert (H1n : (1 >> n = 0)%int63); auto. + apply to_Z_inj; rewrite lsr_spec. + apply Zdiv_small; rewrite to_Z_1; split; auto with zarith. + change 1%Z with (2^0)%Z. + apply Zpower_lt_monotone; split; auto with zarith. + rewrite to_Z_0 in Hn. + generalize (to_Z_bounded n). + lia. +Qed. + +Lemma lsr_add i m n: ((i >> m) >> n = if n <= m + n then i >> (m + n) else 0)%int63. +Proof. + case (to_Z_bounded m); intros H1m H2m. + case (to_Z_bounded n); intros H1n H2n. + case (to_Z_bounded i); intros H1i H2i. + generalize (add_le_r m n); case (n <= m + n)%int63; intros H. + apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. + rewrite add_spec, Zmod_small; auto with zarith. + apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. + apply Zdiv_small. split; [ auto with zarith | ]. + eapply Z.lt_le_trans; [ | apply Zpower2_le_lin ]; auto with zarith. +Qed. + +Lemma lsr_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int63. +Proof. + apply to_Z_inj. + rewrite -> add_spec, !lsl_spec, add_spec. + rewrite -> Zmult_mod_idemp_l, <-Zplus_mod. + apply f_equal2 with (f := Zmod); auto with zarith. +Qed. + +(* LSL *) +Lemma lsl0 i: 0 << i = 0%int63. +Proof. + apply to_Z_inj. + generalize (lsl_spec 0 i). + rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. +Qed. + +Lemma lsl0_r i : i << 0 = i. +Proof. + apply to_Z_inj. + rewrite -> lsl_spec, to_Z_0, Z.mul_1_r. + apply Zmod_small; apply (to_Z_bounded i). +Qed. + +Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int63. +Proof. + apply to_Z_inj; rewrite -> !lsl_spec, !add_spec, Zmult_mod_idemp_l. + rewrite -> !lsl_spec, <-Zplus_mod. + apply f_equal2 with (f := Zmod); auto with zarith. +Qed. + +Lemma lsr_M_r x i (H: (digits <= i = true)%int63) : x >> i = 0%int63. +Proof. + apply to_Z_inj. + rewrite lsr_spec, to_Z_0. + case (to_Z_bounded x); intros H1x H2x. + case (to_Z_bounded digits); intros H1d H2d. + rewrite -> leb_spec in H. + apply Zdiv_small; split; [ auto | ]. + apply (Z.lt_le_trans _ _ _ H2x). + unfold wB; change (Z_of_nat size) with [|digits|]. + apply Zpower_le_monotone; auto with zarith. +Qed. + +(* BIT *) +Lemma bit_0_spec i: [|bit i 0|] = [|i|] mod 2. +Proof. + unfold bit, is_zero. rewrite lsr_0_r. + assert (Hbi: ([|i|] mod 2 < 2)%Z). + apply Z_mod_lt; auto with zarith. + case (to_Z_bounded i); intros H1i H2i. + case (Zmod_le_first [|i|] 2); auto with zarith; intros H3i H4i. + assert (H2b: (0 < 2 ^ [|digits - 1|])%Z). + apply Zpower_gt_0; auto with zarith. + case (to_Z_bounded (digits -1)); auto with zarith. + assert (H: [|i << (digits -1)|] = ([|i|] mod 2 * 2^ [|digits -1|])%Z). + rewrite lsl_spec. + rewrite -> (Z_div_mod_eq [|i|] 2) at 1; auto with zarith. + rewrite -> Zmult_plus_distr_l, <-Zplus_mod_idemp_l. + rewrite -> (Zmult_comm 2), <-Zmult_assoc. + replace (2 * 2 ^ [|digits - 1|])%Z with wB; auto. + rewrite Z_mod_mult, Zplus_0_l; apply Zmod_small. + split; auto with zarith. + replace wB with (2 * 2 ^ [|digits -1|])%Z; auto. + apply Zmult_lt_compat_r; auto with zarith. + case (Zle_lt_or_eq 0 ([|i|] mod 2)); auto with zarith; intros Hi. + 2: generalize H; rewrite <-Hi, Zmult_0_l. + 2: replace 0%Z with [|0|]; auto. + 2: now case eqbP. + generalize H; replace ([|i|] mod 2) with 1%Z; auto with zarith. + rewrite Zmult_1_l. + intros H1. + assert (H2: [|i << (digits - 1)|] <> [|0|]). + replace [|0|] with 0%Z; auto with zarith. + now case eqbP. +Qed. + +Lemma bit_split i : ( i = (i >> 1 ) << 1 + bit i 0)%int63. +Proof. + apply to_Z_inj. + rewrite -> add_spec, lsl_spec, lsr_spec, bit_0_spec, Zplus_mod_idemp_l. + replace (2 ^ [|1|]) with 2%Z; auto with zarith. + rewrite -> Zmult_comm, <-Z_div_mod_eq; auto with zarith. + rewrite Zmod_small; auto; case (to_Z_bounded i); auto. +Qed. + +Lemma bit_lsr x i j : + (bit (x >> i) j = if j <= i + j then bit x (i + j) else false)%int63. +Proof. + unfold bit; rewrite lsr_add; case (_ ≤ _); auto. +Qed. + +Lemma bit_b2i (b: bool) i : bit b i = (i == 0) && b. +Proof. + case b; unfold bit; simpl b2i. + rewrite lsr_1; case (i == 0); auto. + rewrite lsr0, lsl0, andb_false_r; auto. +Qed. + +Lemma bit_1 n : bit 1 n = (n == 0). +Proof. + unfold bit; rewrite lsr_1. + case (_ == _); simpl; auto. +Qed. + +Local Hint Resolve Z.lt_gt Z.div_pos : zarith. + +Lemma to_Z_split x : [|x|] = [|(x >> 1)|] * 2 + [|bit x 0|]. +Proof. + case (to_Z_bounded x); intros H1x H2x. + case (to_Z_bounded (bit x 0)); intros H1b H2b. + assert (F1: 0 <= [|x >> 1|] < wB/2). + rewrite -> lsr_spec, to_Z_1, Z.pow_1_r. split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite -> (bit_split x) at 1. + rewrite -> add_spec, Zmod_small, lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; + split; auto with zarith. + change wB with ((wB/2)*2); auto with zarith. + rewrite -> lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + change wB with ((wB/2)*2); auto with zarith. + rewrite -> lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + 2: change wB with ((wB/2)*2); auto with zarith. + change wB with (((wB/2 - 1) * 2 + 1) + 1). + assert ([|bit x 0|] <= 1); auto with zarith. + case bit; discriminate. +Qed. + +Lemma bit_M i n (H: (digits <= n = true)%int63): bit i n = false. +Proof. unfold bit; rewrite lsr_M_r; auto. Qed. + +Lemma bit_half i n (H: (n < digits = true)%int63) : bit (i>>1) n = bit i (n+1). +Proof. + unfold bit. + rewrite lsr_add. + case_eq (n <= (1 + n))%int63. + replace (1+n)%int63 with (n+1)%int63; [auto|idtac]. + apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. + intros H1; assert (H2: n = max_int). + 2: generalize H; rewrite H2; discriminate. + case (to_Z_bounded n); intros H1n H2n. + case (Zle_lt_or_eq [|n|] (wB - 1)); auto with zarith; + intros H2; apply to_Z_inj; auto. + generalize (add_le_r 1 n); rewrite H1. + change [|max_int|] with (wB - 1)%Z. + replace [|1|] with 1%Z; auto with zarith. +Qed. + +Lemma bit_ext i j : (forall n, bit i n = bit j n) -> i = j. +Proof. + case (to_Z_bounded j); case (to_Z_bounded i). + unfold wB; revert i j; elim size. + simpl; intros i j ???? _; apply to_Z_inj; lia. + intros n ih i j. + rewrite Nat2Z.inj_succ, Z.pow_succ_r by auto with zarith. + intros hi1 hi2 hj1 hj2 hext. + rewrite (bit_split i), (bit_split j), hext. + do 2 f_equal; apply ih; clear ih. + 1, 3: apply to_Z_bounded. + 1, 2: rewrite lsr_spec; auto using Z_lt_div2. + intros b. + case (Zle_or_lt [|digits|] [|b|]). + rewrite <- leb_spec; intros; rewrite !bit_M; auto. + rewrite <- ltb_spec; intros; rewrite !bit_half; auto. +Qed. + +Lemma bit_lsl x i j : bit (x << i) j = +(if (j < i) || (digits <= j) then false else bit x (j - i))%int63. +Proof. + assert (F1: 1 >= 0) by discriminate. + case_eq (digits <= j)%int63; intros H. + rewrite orb_true_r, bit_M; auto. + set (d := [|digits|]). + case (Zle_or_lt d [|j|]); intros H1. + case (leb_spec digits j); rewrite H; auto with zarith. + intros _ HH; generalize (HH H1); discriminate. + clear H. + generalize (ltb_spec j i); case ltb; intros H2; unfold bit; simpl. + assert (F2: ([|j|] < [|i|])%Z) by (case H2; auto); clear H2. + replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. + case (to_Z_bounded j); intros H1j H2j. + apply sym_equal; rewrite is_zero_spec; apply to_Z_inj. + rewrite lsl_spec, lsr_spec, lsl_spec. + replace wB with (2^d); auto. + pattern d at 1; replace d with ((d - ([|j|] + 1)) + ([|j|] + 1))%Z by ring. + rewrite Zpower_exp; auto with zarith. + replace [|i|] with (([|i|] - ([|j|] + 1)) + ([|j|] + 1))%Z by ring. + rewrite -> Zpower_exp, Zmult_assoc; auto with zarith. + rewrite Zmult_mod_distr_r. + rewrite -> Zplus_comm, Zpower_exp, !Zmult_assoc; auto with zarith. + rewrite -> Z_div_mult_full; auto with zarith. + rewrite <-Zmult_assoc, <-Zpower_exp; auto with zarith. + replace (1 + [|digits - 1|])%Z with d; auto with zarith. + rewrite Z_mod_mult; auto. + case H2; intros _ H3; case (Zle_or_lt [|i|] [|j|]); intros F2. + 2: generalize (H3 F2); discriminate. + clear H2 H3. + apply f_equal with (f := negb). + apply f_equal with (f := is_zero). + apply to_Z_inj. + rewrite -> !lsl_spec, !lsr_spec, !lsl_spec. + pattern wB at 2 3; replace wB with (2^(1+ [|digits - 1|])); auto. + rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. + rewrite !Zmult_mod_distr_r. + apply f_equal2 with (f := Zmult); auto. + replace wB with (2^ d); auto with zarith. + replace d with ((d - [|i|]) + [|i|])%Z by ring. + case (to_Z_bounded i); intros H1i H2i. + rewrite Zpower_exp; auto with zarith. + rewrite Zmult_mod_distr_r. + case (to_Z_bounded j); intros H1j H2j. + replace [|j - i|] with ([|j|] - [|i|])%Z. + 2: rewrite sub_spec, Zmod_small; auto with zarith. + set (d1 := (d - [|i|])%Z). + set (d2 := ([|j|] - [|i|])%Z). + pattern [|j|] at 1; + replace [|j|] with (d2 + [|i|])%Z. + 2: unfold d2; ring. + rewrite -> Zpower_exp; auto with zarith. + rewrite -> Zdiv_mult_cancel_r. + 2: generalize (Zpower2_lt_lin [| i |] H1i); auto with zarith. + rewrite -> (Z_div_mod_eq [|x|] (2^d1)) at 2; auto with zarith. + pattern d1 at 2; + replace d1 with (d2 + (1+ (d - [|j|] - 1)))%Z + by (unfold d1, d2; ring). + rewrite Zpower_exp; auto with zarith. + rewrite <-Zmult_assoc, Zmult_comm. + rewrite Zdiv.Z_div_plus_full_l; auto with zarith. + rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + rewrite <-Zplus_mod_idemp_l. + rewrite <-!Zmult_assoc, Zmult_comm, Z_mod_mult, Zplus_0_l; auto. +Qed. + +(* LOR *) +Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). +Proof. + apply bit_ext; intros n. + rewrite -> lor_spec, !bit_lsr, lor_spec. + case (_ <= _)%int63; auto. +Qed. + +Lemma lor_le x y : (y <= x lor y)%int63 = true. +Proof. + generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. + unfold wB; elim size. + replace (2^Z_of_nat 0) with 1%Z; auto with zarith. + intros x y Hx Hy; replace x with 0%int63. + replace y with 0%int63; auto. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + intros n IH x y; rewrite inj_S. + unfold Z.succ; rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. + intros Hx Hy. + rewrite leb_spec. + rewrite -> (to_Z_split y) at 1; rewrite (to_Z_split (x lor y)). + assert ([|y>>1|] <= [|(x lor y) >> 1|]). + rewrite -> lor_lsr, <-leb_spec; apply IH. + rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + assert ([|bit y 0|] <= [|bit (x lor y) 0|]); auto with zarith. + rewrite lor_spec; do 2 case bit; try discriminate. +Qed. + +Lemma bit_0 n : bit 0 n = false. +Proof. unfold bit; rewrite lsr0; auto. Qed. + +Lemma bit_add_or x y: + (forall n, bit x n = true -> bit y n = true -> False) <-> (x + y)%int63= x lor y. +Proof. + generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. + unfold wB; elim size. + replace (2^Z_of_nat 0) with 1%Z; auto with zarith. + intros x y Hx Hy; replace x with 0%int63. + replace y with 0%int63. + split; auto; intros _ n; rewrite !bit_0; discriminate. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + intros n IH x y; rewrite inj_S. + unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + intros Hx Hy. + split. + intros Hn. + assert (F1: ((x >> 1) + (y >> 1))%int63 = (x >> 1) lor (y >> 1)). + apply IH. + rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + intros m H1 H2. + case_eq (digits <= m)%int63; [idtac | rewrite <- not_true_iff_false]; + intros Heq. + rewrite bit_M in H1; auto; discriminate. + rewrite leb_spec in Heq. + apply (Hn (m + 1)%int63); + rewrite <-bit_half; auto; rewrite ltb_spec; auto with zarith. + rewrite (bit_split (x lor y)), lor_lsr, <- F1, lor_spec. + replace (b2i (bit x 0 || bit y 0)) with (bit x 0 + bit y 0)%int63. + 2: generalize (Hn 0%int63); do 2 case bit; auto; intros [ ]; auto. + rewrite lsl_add_distr. + rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. + rewrite <-!add_assoc; apply f_equal2 with (f := add); auto. + rewrite add_comm, <-!add_assoc; apply f_equal2 with (f := add); auto. + rewrite add_comm; auto. + intros Heq. + generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. + generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. + rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, + <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsr_add_distr. + rewrite (bit_split (x lor y)), lor_spec. + intros Heq. + assert (F: (bit x 0 + bit y 0)%int63 = (bit x 0 || bit y 0)). + assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). + assert (F2: 0 < wB) by (apply refl_equal). + assert (F3: [|bit x 0 + bit y 0|] mod 2 = [|bit x 0 || bit y 0|] mod 2). + apply trans_equal with (([|(x>>1 + y>>1) << 1|] + [|bit x 0 + bit y 0|]) mod 2). + rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. + rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. + rewrite (Zmod_div_mod 2 wB), <-add_spec, Heq; auto with zarith. + rewrite add_spec, <-Zmod_div_mod; auto with zarith. + rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. + rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. + generalize F3; do 2 case bit; try discriminate; auto. + case (IH (x >> 1) (y >> 1)). + rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + intros _ HH m; case (to_Z_bounded m); intros H1m H2m. + case_eq (digits <= m)%int63. + intros Hlm; rewrite bit_M; auto; discriminate. + rewrite <- not_true_iff_false, leb_spec; intros Hlm. + case (Zle_lt_or_eq 0 [|m|]); auto; intros Hm. + replace m with ((m -1) + 1)%int63. + rewrite <-(bit_half x), <-(bit_half y); auto with zarith. + apply HH. + rewrite <-lor_lsr. + assert (0 <= [|bit (x lor y) 0|] <= 1) by (case bit; split; discriminate). + rewrite F in Heq; generalize (add_cancel_r _ _ _ Heq). + intros Heq1; apply to_Z_inj. + generalize (f_equal to_Z Heq1); rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small. + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + case (to_Z_bounded (x lor y)); intros H1xy H2xy. + rewrite lsr_spec, to_Z_1, Z.pow_1_r; auto with zarith. + change wB with ((wB/2)*2); split; auto with zarith. + assert ([|x lor y|] / 2 < wB / 2); auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + split. + case (to_Z_bounded (x >> 1 + y >> 1)); auto with zarith. + rewrite add_spec. + apply Z.le_lt_trans with (([|x >> 1|] + [|y >> 1|]) * 2); auto with zarith. + case (Zmod_le_first ([|x >> 1|] + [|y >> 1|]) wB); auto with zarith. + case (to_Z_bounded (x >> 1)); case (to_Z_bounded (y >> 1)); auto with zarith. + generalize Hb; rewrite (to_Z_split x) at 1; rewrite (to_Z_split y) at 1. + case (to_Z_bounded (bit x 0)); case (to_Z_bounded (bit y 0)); auto with zarith. + rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. + rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. + apply to_Z_inj. + rewrite add_spec, sub_spec, Zplus_mod_idemp_l, to_Z_1, Zmod_small; auto with zarith. + pose proof (to_Z_inj 0 _ Hm); clear Hm; subst m. + intros hx hy; revert F; rewrite hx, hy; intros F. generalize (f_equal to_Z F). vm_compute. lia. +Qed. + +Lemma addmuldiv_spec x y p : + [| p |] <= [| digits |] -> + [| addmuldiv p x y |] = ([| x |] * (2 ^ [| p |]) + [| y |] / (2 ^ ([| digits |] - [| p |]))) mod wB. +Proof. + intros H. + assert (Fp := to_Z_bounded p); assert (Fd := to_Z_bounded digits). + rewrite addmuldiv_def_spec; unfold addmuldiv_def. + case (bit_add_or (x << p) (y >> (digits - p))); intros HH _. + rewrite <-HH, add_spec, lsl_spec, lsr_spec, Zplus_mod_idemp_l, sub_spec. + rewrite (fun x y => Zmod_small (x - y)); auto with zarith. + intros n; rewrite -> bit_lsl, bit_lsr. + generalize (add_le_r (digits - p) n). + case (_ ≤ _); try discriminate. + rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. + case_eq (n < p)%int63; try discriminate. + rewrite <- not_true_iff_false, ltb_spec; intros H2. + case (_ ≤ _); try discriminate. + intros _; rewrite bit_M; try discriminate. + rewrite -> leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. + rewrite -> sub_spec, Zmod_small; auto with zarith. +Qed. + +(* is_even *) +Lemma is_even_bit i : is_even i = negb (bit i 0). +Proof. + unfold is_even. + replace (i land 1) with (b2i (bit i 0)). + case bit; auto. + apply bit_ext; intros n. + rewrite bit_b2i, land_spec, bit_1. + generalize (eqb_spec n 0). + case (n == 0); auto. + intros(H,_); rewrite andb_true_r, H; auto. + rewrite andb_false_r; auto. +Qed. + +Lemma is_even_spec x : if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. +Proof. +rewrite is_even_bit. +generalize (bit_0_spec x); case bit; simpl; auto. +Qed. + +Lemma is_even_0 : is_even 0 = true. +Proof. apply refl_equal. Qed. + +Lemma is_even_lsl_1 i : is_even (i << 1) = true. +Proof. + rewrite is_even_bit, bit_lsl; auto. +Qed. + +(* Sqrt *) + + (* Direct transcription of an old proof + of a fortran program in boyer-moore *) + +Ltac elim_div := + unfold Z.div, Z.modulo; + match goal with + | H : context[ Z.div_eucl ?X ?Y ] |- _ => + generalize dependent H; generalize (Z_div_mod_full X Y) ; case (Z.div_eucl X Y) + | |- context[ Z.div_eucl ?X ?Y ] => + generalize (Z_div_mod_full X Y) ; case (Z.div_eucl X Y) + end; unfold Remainder. + +Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). +Proof. + case (Z_mod_lt a 2); auto with zarith. + intros H1; rewrite Zmod_eq_full; auto with zarith. +Qed. + +Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> + (j * k) + j <= ((j + k)/2 + 1) ^ 2. +Proof. + intros Hj; generalize Hj k; pattern j; apply natlike_ind; + auto; clear k j Hj. + intros _ k Hk; repeat rewrite Zplus_0_l. + apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. + intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. + rewrite -> Zmult_0_r, Zplus_0_r, Zplus_0_l. + generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); + unfold Z.succ. + rewrite Z.pow_2_r, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + intros k Hk _. + replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). + generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). + unfold Z.succ; repeat rewrite Z.pow_2_r; + repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. + auto with zarith. + rewrite -> Zplus_comm, <- Z_div_plus_full_l; auto with zarith. + apply f_equal2; auto with zarith. +Qed. + +Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. +Proof. + intros Hi Hj. + assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). + refine (Z.lt_le_trans _ _ _ _ (sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij)). + pattern i at 1; rewrite -> (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith. +Qed. + +Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. +Proof. + intros Hi Hj; elim_div; intros q r [ ? hr ]; [ lia | subst i ]. + elim_div; intros a b [ h [ hb | ] ]; lia. +Qed. + +Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. +Proof. + intros Hi Hj Hd; rewrite Z.pow_2_r. + apply Z.le_trans with (j * (i/j)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. +Qed. + +Lemma sqrt_step_correct rec i j: + 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> + 2 * [|j|] < wB -> + (forall j1 : int, + 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|sqrt_step rec i j|] ^ 2 <= [|i|] < ([|sqrt_step rec i j|] + 1) ^ 2. +Proof. + assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). + intros Hi Hj Hij H31 Hrec. + unfold sqrt_step. + case ltbP; rewrite div_spec. + - intros hlt. + assert ([| j + i / j|] = [|j|] + [|i|]/[|j|]) as hj. + rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. + apply Hrec; rewrite lsr_spec, hj, to_Z_1; change (2 ^ 1) with 2. + + split; [ | apply sqrt_test_false;auto with zarith]. + replace ([|j|] + [|i|]/[|j|]) with (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / 2) ; auto with zarith. + apply Z.div_pos; [ | lia ]. + case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1. + rewrite <- Hj1, Zdiv_1_r; lia. + + apply sqrt_main;auto with zarith. + - split;[apply sqrt_test_true | ];auto with zarith. +Qed. + +Lemma iter_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> + [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < wB -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < wB -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|iter_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter_sqrt n rec i j|] + 1) ^ 2. +Proof. + revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Zpower_0_r; auto with zarith. + intros n Hrec rec i j Hi Hj Hij H31 HHrec. + apply sqrt_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite -> inj_S, Z.pow_succ_r. + apply Z.le_trans with (2 ^Z_of_nat n + [|j2|]); auto with zarith. + apply Zle_0_nat. +Qed. + +Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. +Proof. + intros Hi. + assert (H1: 0 <= i - 2) by auto with zarith. + assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. + replace i with (1* 2 + (i - 2)); auto with zarith. + rewrite Z.pow_2_r, Z_div_plus_full_l; auto with zarith. + generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). + rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + generalize (quotient_by_2 i). + rewrite -> Z.pow_2_r in H2 |- *; + repeat (rewrite Zmult_plus_distr_l || + rewrite Zmult_plus_distr_r || + rewrite Zmult_1_l || rewrite Zmult_1_r). + auto with zarith. +Qed. + +Lemma sqrt_spec : forall x, + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. +Proof. + intros i; unfold sqrt. + rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; + intros Hi; auto with zarith. + repeat rewrite Z.pow_2_r; auto with zarith. + apply iter_sqrt_correct; auto with zarith; + rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. + replace [|i|] with (1 * 2 + ([|i|] - 2))%Z; try ring. + assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; auto with zarith). + rewrite Z_div_plus_full_l; auto with zarith. + apply sqrt_init; auto. + assert (W:= Z_mult_div_ge [|i|] 2);assert (W':= to_Z_bounded i);auto with zarith. + intros j2 H1 H2; contradict H2; apply Zlt_not_le. + fold wB;assert (W:=to_Z_bounded i). + apply Z.le_lt_trans with ([|i|]); auto with zarith. + assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith). + apply Z.le_trans with (2 * ([|i|]/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + case (to_Z_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. +Qed. + +(* sqrt2 *) +Lemma sqrt2_step_def rec ih il j: + sqrt2_step rec ih il j = + if (ih < j)%int63 then + let quo := fst (diveucl_21 ih il j) in + if (quo < j)%int63 then + let m := + match j +c quo with + | C0 m1 => m1 >> 1 + | C1 m1 => (m1 >> 1 + 1 << (digits -1))%int63 + end in + rec ih il m + else j + else j. +Proof. + unfold sqrt2_step; case diveucl_21; intros;simpl. + case (j +c i);trivial. +Qed. + +Lemma sqrt2_lower_bound ih il j: + [|| WW ih il||] < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. +Proof. + intros H1. + case (to_Z_bounded j); intros Hbj _. + case (to_Z_bounded il); intros Hbil _. + case (to_Z_bounded ih); intros Hbih Hbih1. + assert (([|ih|] < [|j|] + 1)%Z); auto with zarith. + apply Zlt_square_simpl; auto with zarith. + simpl zn2z_to_Z in H1. + repeat rewrite <-Z.pow_2_r. + refine (Z.le_lt_trans _ _ _ _ H1). + apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. +Qed. + +Lemma div2_phi ih il j: + [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|]. +Proof. + generalize (diveucl_21_spec ih il j). + case diveucl_21; intros q r Heq. + simpl zn2z_to_Z;unfold Z.div;rewrite <- Heq;trivial. +Qed. + +Lemma sqrt2_step_correct rec ih il j: + 2 ^ (Z_of_nat (size - 2)) <= [|ih|] -> + 0 < [|j|] -> [|| WW ih il||] < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] < [|j|] -> [|| WW ih il||] < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= [||WW ih il||] < ([|rec ih il j1|] + 1) ^ 2) -> + [|sqrt2_step rec ih il j|] ^ 2 <= [||WW ih il ||] + < ([|sqrt2_step rec ih il j|] + 1) ^ 2. +Proof. + assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt). + intros Hih Hj Hij Hrec; rewrite sqrt2_step_def. + assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt2_lower_bound with il; auto). + case (to_Z_bounded ih); intros Hih1 _. + case (to_Z_bounded il); intros Hil1 _. + case (to_Z_bounded j); intros _ Hj1. + assert (Hp3: (0 < [||WW ih il||])). + simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. + apply Zmult_lt_0_compat; auto with zarith. + refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. + cbv zeta. + case_eq (ih < j)%int63;intros Heq. + rewrite -> ltb_spec in Heq. + 2: rewrite <-not_true_iff_false, ltb_spec in Heq. + 2: split; auto. + 2: apply sqrt_test_true; auto with zarith. + 2: unfold zn2z_to_Z; replace [|ih|] with [|j|]; auto with zarith. + 2: assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). + 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. + case (Zle_or_lt (2^(Z_of_nat size -1)) [|j|]); intros Hjj. + case_eq (fst (diveucl_21 ih il j) < j)%int63;intros Heq0. + 2: rewrite <-not_true_iff_false, ltb_spec, div2_phi in Heq0. + 2: split; auto; apply sqrt_test_true; auto with zarith. + rewrite -> ltb_spec, div2_phi in Heq0. + match goal with |- context[rec _ _ ?X] => + set (u := X) + end. + assert (H: [|u|] = ([|j|] + ([||WW ih il||])/([|j|]))/2). + unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); + case addc;unfold interp_carry;rewrite div2_phi;simpl zn2z_to_Z. + intros i H;rewrite lsr_spec, H;trivial. + intros i H;rewrite <- H. + case (to_Z_bounded i); intros H1i H2i. + rewrite -> add_spec, Zmod_small, lsr_spec. + change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. + rewrite Z_div_plus_full_l; auto with zarith. + change wB with (2 * (wB/2))%Z; auto. + replace [|(1 << (digits - 1))|] with (wB/2); auto. + rewrite lsr_spec; auto. + replace (2^[|1|]) with 2%Z; auto. + split; auto with zarith. + assert ([|i|]/2 < wB/2); auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Hrec; rewrite H; clear u H. + assert (Hf1: 0 <= [||WW ih il||]/ [|j|]) by (apply Z_div_pos; auto with zarith). + case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. + 2: contradict Heq0; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. + split. + replace ([|j|] + [||WW ih il||]/ [|j|])%Z with + (1 * 2 + (([|j|] - 2) + [||WW ih il||] / [|j|])) by lia. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|j|] - 2 + [||WW ih il||] / [|j|]) / 2) ; auto with zarith. + apply sqrt_test_false; auto with zarith. + apply sqrt_main; auto with zarith. + contradict Hij; apply Zle_not_lt. + assert ((1 + [|j|]) <= 2 ^ (Z_of_nat size - 1)); auto with zarith. + apply Z.le_trans with ((2 ^ (Z_of_nat size - 1)) ^2); auto with zarith. + assert (0 <= 1 + [|j|]); auto with zarith. + apply Zmult_le_compat; auto with zarith. + change ((2 ^ (Z_of_nat size - 1))^2) with (2 ^ (Z_of_nat size - 2) * wB). + apply Z.le_trans with ([|ih|] * wB); auto with zarith. + unfold zn2z_to_Z, wB; auto with zarith. +Qed. + +Lemma iter2_sqrt_correct n rec ih il j: + 2^(Z_of_nat (size - 2)) <= [|ih|] -> 0 < [|j|] -> [||WW ih il||] < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + [||WW ih il||] < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= [||WW ih il||] < ([|rec ih il j1|] + 1) ^ 2) -> + [|iter2_sqrt n rec ih il j|] ^ 2 <= [||WW ih il||] + < ([|iter2_sqrt n rec ih il j|] + 1) ^ 2. +Proof. + revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Zpower_0_r; auto with zarith. + intros n Hrec rec ih il j Hi Hj Hij HHrec. + apply sqrt2_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite -> inj_S, Z.pow_succ_r. + apply Z.le_trans with (2 ^Z_of_nat n + [|j2|])%Z; auto with zarith. + apply Zle_0_nat. +Qed. + +Lemma sqrt2_spec : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros ih il Hih; unfold sqrt2. + change [||WW ih il||] with ([||WW ih il||]). + assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by + (intros s; ring). + assert (Hb: 0 <= wB) by (red; intros HH; discriminate). + assert (Hi2: [||WW ih il ||] < ([|max_int|] + 1) ^ 2). + apply Z.le_lt_trans with ((wB - 1) * wB + (wB - 1)); auto with zarith. + 2: apply refl_equal. + case (to_Z_bounded ih); case (to_Z_bounded il); intros H1 H2 H3 H4. + unfold zn2z_to_Z; auto with zarith. + case (iter2_sqrt_correct size (fun _ _ j => j) ih il max_int); auto with zarith. + apply refl_equal. + intros j1 _ HH; contradict HH. + apply Zlt_not_le. + case (to_Z_bounded j1); auto with zarith. + change (2 ^ Z_of_nat size) with ([|max_int|]+1)%Z; auto with zarith. + set (s := iter2_sqrt size (fun _ _ j : int=> j) ih il max_int). + intros Hs1 Hs2. + generalize (mulc_spec s s); case mulc. + simpl fst; simpl snd; intros ih1 il1 Hihl1. + generalize (subc_spec il il1). + case subc; intros il2 Hil2. + simpl interp_carry in Hil2. + case_eq (ih1 < ih)%int63; [idtac | rewrite <- not_true_iff_false]; + rewrite ltb_spec; intros Heq. + unfold interp_carry; rewrite Zmult_1_l. + rewrite -> Z.pow_2_r, Hihl1, Hil2. + case (Zle_lt_or_eq ([|ih1|] + 1) ([|ih|])); auto with zarith. + intros H2; contradict Hs2; apply Zle_not_lt. + replace (([|s|] + 1) ^ 2) with ([||WW ih1 il1||] + 2 * [|s|] + 1). + unfold zn2z_to_Z. + case (to_Z_bounded il); intros Hpil _. + assert (Hl1l: [|il1|] <= [|il|]). + case (to_Z_bounded il2); rewrite Hil2; auto with zarith. + assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB); auto with zarith. + case (to_Z_bounded s); intros _ Hps. + case (to_Z_bounded ih1); intros Hpih1 _; auto with zarith. + apply Z.le_trans with (([|ih1|] + 2) * wB); auto with zarith. + rewrite Zmult_plus_distr_l. + assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. + unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. + intros H2; split. + unfold zn2z_to_Z; rewrite <- H2; ring. + replace (wB + ([|il|] - [|il1|])) with ([||WW ih il||] - ([|s|] * [|s|])). + rewrite <-Hbin in Hs2; auto with zarith. + rewrite Hihl1; unfold zn2z_to_Z; rewrite <- H2; ring. + unfold interp_carry. + case (Zle_lt_or_eq [|ih|] [|ih1|]); auto with zarith; intros H. + contradict Hs1. + apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z. + case (to_Z_bounded il); intros _ H2. + apply Z.lt_le_trans with (([|ih|] + 1) * wB + 0). + rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. + case (to_Z_bounded il1); intros H3 _. + apply Zplus_le_compat; auto with zarith. + split. + rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; ring[Hil2 H]. + replace [|il2|] with ([||WW ih il||] - [||WW ih1 il1||]). + unfold zn2z_to_Z at 2; rewrite <-Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold zn2z_to_Z; rewrite H, Hil2; ring. + unfold interp_carry in Hil2 |- *. + assert (Hsih: [|ih - 1|] = [|ih|] - 1). + rewrite sub_spec, Zmod_small; auto; replace [|1|] with 1; auto. + case (to_Z_bounded ih); intros H1 H2. + split; auto with zarith. + apply Z.le_trans with (wB/4 - 1); auto with zarith. + case_eq (ih1 < ih - 1)%int63; [idtac | rewrite <- not_true_iff_false]; + rewrite ltb_spec, Hsih; intros Heq. + rewrite Z.pow_2_r, Hihl1. + case (Zle_lt_or_eq ([|ih1|] + 2) [|ih|]); auto with zarith. + intros H2; contradict Hs2; apply Zle_not_lt. + replace (([|s|] + 1) ^ 2) with ([||WW ih1 il1||] + 2 * [|s|] + 1). + unfold zn2z_to_Z. + assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB + ([|il|] - [|il1|])); + auto with zarith. + rewrite <-Hil2. + case (to_Z_bounded il2); intros Hpil2 _. + apply Z.le_trans with ([|ih|] * wB + - wB); auto with zarith. + case (to_Z_bounded s); intros _ Hps. + assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. + apply Z.le_trans with ([|ih1|] * wB + 2 * wB); auto with zarith. + assert (Hi: ([|ih1|] + 3) * wB <= [|ih|] * wB); auto with zarith. + rewrite Zmult_plus_distr_l in Hi; auto with zarith. + unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. + intros H2; unfold zn2z_to_Z; rewrite <-H2. + split. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2; ring. + replace (1 * wB + [|il2|]) with ([||WW ih il||] - [||WW ih1 il1||]). + unfold zn2z_to_Z at 2; rewrite <-Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold zn2z_to_Z; rewrite <-H2. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2; ring. + case (Zle_lt_or_eq ([|ih|] - 1) ([|ih1|])); auto with zarith; intros H1. + assert (He: [|ih|] = [|ih1|]). + apply Zle_antisym; auto with zarith. + case (Zle_or_lt [|ih1|] [|ih|]); auto; intros H2. + contradict Hs1; apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z. + case (to_Z_bounded il); intros _ Hpil1. + apply Z.lt_le_trans with (([|ih|] + 1) * wB). + rewrite Zmult_plus_distr_l, Zmult_1_l; auto with zarith. + case (to_Z_bounded il1); intros Hpil2 _. + apply Z.le_trans with (([|ih1|]) * wB); auto with zarith. + contradict Hs1; apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; rewrite He. + assert ([|il|] - [|il1|] < 0); auto with zarith. + rewrite <-Hil2. + case (to_Z_bounded il2); auto with zarith. + split. + rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; rewrite <-H1. + apply trans_equal with ([|ih|] * wB + [|il1|] + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2; ring. + replace [|il2|] with ([||WW ih il||] - [||WW ih1 il1||]). + unfold zn2z_to_Z at 2; rewrite <- Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold zn2z_to_Z. + rewrite <-H1. + ring_simplify. + apply trans_equal with (wB + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2; ring. +Qed. + +(* of_pos *) +Lemma of_pos_rec_spec (k: nat) : + (k <= size)%nat → + ∀ p, φ(of_pos_rec k p) = Zpos p mod 2 ^ Z.of_nat k. +Proof. + elim k; clear k. + intros _ p; simpl; rewrite to_Z_0, Zmod_1_r; reflexivity. + intros n ih hn. + assert (n <= size)%nat as hn' by lia. + specialize (ih hn'). + intros [ p | p | ]. + 3: { + rewrite Zmod_small. reflexivity. + split. lia. + apply Zpower_gt_1; lia. + } + - simpl. + destruct (bit_add_or (of_pos_rec n p << 1) 1) as (H1, _). + rewrite <- H1;clear H1. + 2: { + intros i; rewrite bit_lsl, bit_1. + case eqbP. + + intros h; apply to_Z_inj in h; subst. exact (λ e _, diff_false_true e). + + exact (λ _ _, diff_false_true). + } + rewrite add_spec, lsl_spec, ih, to_Z_1; clear ih. + rewrite Z.pow_pos_fold, Zpos_P_of_succ_nat. + change (Zpos p~1) with (2 ^ 1 * Zpos p + 1)%Z. + rewrite Zmod_distr by lia. + rewrite Zpower_Zsucc by auto with zarith. + rewrite Zplus_mod_idemp_l. + rewrite Zmod_small. + rewrite Zmult_mod_distr_l; lia. + set (a := Z.of_nat n). + set (b := Zpos p). + change (2 ^ 1) with 2. + pose proof (pow2_pos a (Nat2Z.is_nonneg _)). + elim_div; intros x y [ ? ha]. lia. + destruct ha as [ ha | ]. 2: lia. + split. lia. + apply Z.lt_le_trans with (2 ^ (a + 1)). + 2: apply Z.pow_le_mono_r; subst a; lia. + fold (Z.succ a); rewrite Z.pow_succ_r. lia. + subst a; lia. + - simpl. rewrite lsl_spec, ih, to_Z_1, Zmod_small. + rewrite Z.pow_pos_fold, Zpos_P_of_succ_nat, Zpower_Zsucc by lia. + change (Zpos p~0) with (2 ^ 1 * Zpos p)%Z. + rewrite Z.mul_mod_distr_l; auto with zarith. + set (a := Z.of_nat n). + set (b := Zpos p). + change (2 ^ 1) with 2. + pose proof (pow2_pos a (Nat2Z.is_nonneg _)). + elim_div; intros x y [ ? ha]. lia. + destruct ha as [ ha | ]. 2: lia. + split. lia. + apply Z.lt_le_trans with (2 ^ (a + 1)). + 2: apply Z.pow_le_mono_r; subst a; lia. + fold (Z.succ a); rewrite Z.pow_succ_r. lia. + subst a; lia. +Qed. + +Lemma is_int n : + 0 <= n < 2 ^ φ digits → + n = φ (of_Z n). +Proof. + destruct n. reflexivity. 2: lia. + intros [_ h]. simpl. + unfold of_pos. rewrite of_pos_rec_spec by lia. + symmetry; apply Z.mod_small. split. lia. exact h. +Qed. + +Lemma of_Z_spec n : [| of_Z n |] = n mod wB. +Proof. + destruct n. reflexivity. + { now simpl; unfold of_pos; rewrite of_pos_rec_spec by lia. } + simpl; unfold of_pos; rewrite opp_spec. + rewrite of_pos_rec_spec; [ |auto]; fold wB. + now rewrite <-(Z.sub_0_l), Zminus_mod_idemp_r. +Qed. + +(* General lemmas *) +Lemma negbE a b : a = negb b → negb a = b. +Proof. intros ->; apply negb_involutive. Qed. + +Lemma Z_oddE a : Z.odd a = (a mod 2 =? 1)%Z. +Proof. rewrite Zmod_odd; case Z.odd; reflexivity. Qed. + +Lemma Z_evenE a : Z.even a = (a mod 2 =? 0)%Z. +Proof. rewrite Zmod_even; case Z.even; reflexivity. Qed. + +(* is_zero *) +Lemma is_zeroE n : is_zero n = Z.eqb (φ n) 0. +Proof. + case Z.eqb_spec. + - intros h; apply (to_Z_inj n 0) in h; subst n; reflexivity. + - generalize (proj1 (is_zero_spec n)). + case is_zero; auto; intros ->; auto; destruct 1; reflexivity. +Qed. + +(* bit *) +Lemma bitE i j : bit i j = Z.testbit φ(i) φ(j). +Proof. + apply negbE; rewrite is_zeroE, lsl_spec, lsr_spec. + generalize (φ i) (to_Z_bounded i) (φ j) (to_Z_bounded j); clear i j; + intros i [hi hi'] j [hj hj']. + rewrite Z.testbit_eqb by auto; rewrite <- Z_oddE, Z.negb_odd, Z_evenE. + remember (i / 2 ^ j) as k. + change wB with (2 * 2 ^ φ (digits - 1)). + unfold Z.modulo at 2. + generalize (Z_div_mod_full k 2 (λ k, let 'eq_refl := k in I)); unfold Remainder. + destruct Z.div_eucl as [ p q ]; intros [hk [ hq | ]]. 2: lia. + rewrite hk. + remember φ (digits - 1) as m. + replace ((_ + _) * _) with (q * 2 ^ m + p * (2 * 2 ^ m)) by ring. + rewrite Z_mod_plus by (subst m; reflexivity). + assert (q = 0 ∨ q = 1) as D by lia. + destruct D; subst; reflexivity. +Qed. + +(* land, lor, lxor *) +Lemma lt_pow_lt_log d k n : + 0 < d <= n → + 0 <= k < 2 ^ d → + Z.log2 k < n. +Proof. + intros [hd hdn] [hk hkd]. + assert (k = 0 ∨ 0 < k) as D by lia. + clear hk; destruct D as [ hk | hk ]. + - subst k; simpl; lia. + - apply Z.log2_lt_pow2. lia. + eapply Z.lt_le_trans. eassumption. + apply Z.pow_le_mono_r; lia. +Qed. + +Lemma land_spec' x y : φ (x land y) = Z.land φ(x) φ(y). +Proof. + apply Z.bits_inj'; intros n hn. + destruct (to_Z_bounded (x land y)) as [ hxy hxy' ]. + destruct (to_Z_bounded x) as [ hx hx' ]. + destruct (to_Z_bounded y) as [ hy hy' ]. + case (Z_lt_le_dec n (φ digits)); intros hd. + 2: { + rewrite !Z.bits_above_log2; auto. + - apply Z.land_nonneg; auto. + - eapply Z.le_lt_trans. + apply Z.log2_land; assumption. + apply Z.min_lt_iff. + left. apply (lt_pow_lt_log φ digits). exact (conj eq_refl hd). + split; assumption. + - apply (lt_pow_lt_log φ digits). exact (conj eq_refl hd). + split; assumption. + } + rewrite (is_int n). + rewrite Z.land_spec, <- !bitE, land_spec; reflexivity. + apply (conj hn). + apply (Z.lt_trans _ _ _ hd). + apply Zpower2_lt_lin. lia. +Qed. + +Lemma lor_spec' x y : φ (x lor y) = Z.lor φ(x) φ(y). +Proof. + apply Z.bits_inj'; intros n hn. + destruct (to_Z_bounded (x lor y)) as [ hxy hxy' ]. + destruct (to_Z_bounded x) as [ hx hx' ]. + destruct (to_Z_bounded y) as [ hy hy' ]. + case (Z_lt_le_dec n (φ digits)); intros hd. + 2: { + rewrite !Z.bits_above_log2; auto. + - apply Z.lor_nonneg; auto. + - rewrite Z.log2_lor by assumption. + apply Z.max_lub_lt; apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + - apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + } + rewrite (is_int n). + rewrite Z.lor_spec, <- !bitE, lor_spec; reflexivity. + apply (conj hn). + apply (Z.lt_trans _ _ _ hd). + apply Zpower2_lt_lin. lia. +Qed. + +Lemma lxor_spec' x y : φ (x lxor y) = Z.lxor φ(x) φ(y). +Proof. + apply Z.bits_inj'; intros n hn. + destruct (to_Z_bounded (x lxor y)) as [ hxy hxy' ]. + destruct (to_Z_bounded x) as [ hx hx' ]. + destruct (to_Z_bounded y) as [ hy hy' ]. + case (Z_lt_le_dec n (φ digits)); intros hd. + 2: { + rewrite !Z.bits_above_log2; auto. + - apply Z.lxor_nonneg; split; auto. + - eapply Z.le_lt_trans. + apply Z.log2_lxor; assumption. + apply Z.max_lub_lt; apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + - apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + } + rewrite (is_int n). + rewrite Z.lxor_spec, <- !bitE, lxor_spec; reflexivity. + apply (conj hn). + apply (Z.lt_trans _ _ _ hd). + apply Zpower2_lt_lin. lia. +Qed. + +Lemma landC i j : i land j = j land i. +Proof. + apply bit_ext; intros n. + rewrite !land_spec, andb_comm; auto. +Qed. + +Lemma landA i j k : i land (j land k) = i land j land k. +Proof. + apply bit_ext; intros n. + rewrite !land_spec, andb_assoc; auto. +Qed. + +Lemma land0 i : 0 land i = 0%int63. +Proof. + apply bit_ext; intros n. + rewrite land_spec, bit_0; auto. +Qed. + +Lemma land0_r i : i land 0 = 0%int63. +Proof. rewrite landC; exact (land0 i). Qed. + +Lemma lorC i j : i lor j = j lor i. +Proof. + apply bit_ext; intros n. + rewrite !lor_spec, orb_comm; auto. +Qed. + +Lemma lorA i j k : i lor (j lor k) = i lor j lor k. +Proof. + apply bit_ext; intros n. + rewrite !lor_spec, orb_assoc; auto. +Qed. + +Lemma lor0 i : 0 lor i = i. +Proof. + apply bit_ext; intros n. + rewrite lor_spec, bit_0; auto. +Qed. + +Lemma lor0_r i : i lor 0 = i. +Proof. rewrite lorC; exact (lor0 i). Qed. + +Lemma lxorC i j : i lxor j = j lxor i. +Proof. + apply bit_ext; intros n. + rewrite !lxor_spec, xorb_comm; auto. +Qed. + +Lemma lxorA i j k : i lxor (j lxor k) = i lxor j lxor k. +Proof. + apply bit_ext; intros n. + rewrite !lxor_spec, xorb_assoc; auto. +Qed. + +Lemma lxor0 i : 0 lxor i = i. +Proof. + apply bit_ext; intros n. + rewrite lxor_spec, bit_0, xorb_false_l; auto. +Qed. + +Lemma lxor0_r i : i lxor 0 = i. +Proof. rewrite lxorC; exact (lxor0 i). Qed. diff --git a/theories/Numbers/Cyclic/Int63/Ring63.v b/theories/Numbers/Cyclic/Int63/Ring63.v new file mode 100644 index 0000000000..d230435378 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Ring63.v @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Int63 numbers defines Z/(2^63)Z, and can hence be equipped + with a ring structure and a ring tactic *) + +Require Import Cyclic63 CyclicAxioms. + +Local Open Scope int63_scope. + +(** Detection of constants *) + +Ltac isInt63cst t := + match eval lazy delta [add] in (t + 1)%int63 with + | add _ _ => constr:(false) + | _ => constr:(true) + end. + +Ltac Int63cst t := + match eval lazy delta [add] in (t + 1)%int63 with + | add _ _ => constr:(NotConstant) + | _ => constr:(t) + end. + +(** The generic ring structure inferred from the Cyclic structure *) + +Module Int63ring := CyclicRing Int63Cyclic. + +(** Unlike in the generic [CyclicRing], we can use Leibniz here. *) + +Lemma Int63_canonic : forall x y, to_Z x = to_Z y -> x = y. +Proof to_Z_inj. + +Lemma ring_theory_switch_eq : + forall A (R R':A->A->Prop) zero one add mul sub opp, + (forall x y : A, R x y -> R' x y) -> + ring_theory zero one add mul sub opp R -> + ring_theory zero one add mul sub opp R'. +Proof. +intros A R R' zero one add mul sub opp Impl Ring. +constructor; intros; apply Impl; apply Ring. +Qed. + +Lemma Int63Ring : ring_theory 0 1 add mul sub opp Logic.eq. +Proof. +exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Int63_canonic Int63ring.CyclicRing). +Qed. + +Lemma eq31_correct : forall x y, eqb x y = true -> x=y. +Proof. now apply eqb_spec. Qed. + +Add Ring Int63Ring : Int63Ring + (decidable eq31_correct, + constants [Int63cst]). + +Section TestRing. +Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. +intros. ring. +Qed. +End TestRing. diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index bc366c508d..9fcb029b3c 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -22,14 +22,16 @@ Ltac nzsimpl' := autorewrite with nz nz'. Theorem add_0_r : forall n, n + 0 == n. Proof. -nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_succ_r : forall n m, n + S m == S (n + m). Proof. -intros n m; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_succ_comm : forall n m, S n + m == n + S m. @@ -41,8 +43,9 @@ Hint Rewrite add_0_r add_succ_r : nz. Theorem add_comm : forall n m, n + m == m + n. Proof. -intros n m; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_1_l : forall n, 1 + n == S n. @@ -59,14 +62,16 @@ Hint Rewrite add_1_l add_1_r : nz. Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. Proof. -intros n m p; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite succ_inj_wd. + intros n m p; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m. Proof. -intros n m p; nzinduct p. now nzsimpl. -intro p. nzsimpl. now rewrite succ_inj_wd. +intros n m p; nzinduct p. +- now nzsimpl. +- intro p. nzsimpl. now rewrite succ_inj_wd. Qed. Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index 99812ee3fe..5f102e853b 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -17,8 +17,8 @@ Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ. Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m. Proof. -intros n m p; nzinduct p. now nzsimpl. -intro p. nzsimpl. now rewrite <- succ_lt_mono. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_lt_mono. Qed. Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. @@ -35,8 +35,8 @@ Qed. Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. Proof. -intros n m p; nzinduct p. now nzsimpl. -intro p. nzsimpl. now rewrite <- succ_le_mono. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_le_mono. Qed. Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. @@ -124,9 +124,9 @@ Qed. Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. Proof. intros n m p q H. -destruct (le_gt_cases n p) as [H1 | H1]. now left. -destruct (le_gt_cases m q) as [H2 | H2]. now right. -contradict H; rewrite nle_gt. now apply add_lt_mono. +destruct (le_gt_cases n p) as [H1 | H1]. - now left. +- destruct (le_gt_cases m q) as [H2 | H2]. + now right. + + contradict H; rewrite nle_gt. now apply add_lt_mono. Qed. Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. @@ -156,10 +156,10 @@ Qed. Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p. Proof. - intros n m H. apply le_ind with (4:=H). solve_proper. - exists 0; nzsimpl; split; order. - clear m H. intros m H (p & EQ & LE). exists (S p). - split. nzsimpl. now f_equiv. now apply le_le_succ_r. + intros n m H. apply le_ind with (4:=H). - solve_proper. + - exists 0; nzsimpl; split; order. + - clear m H. intros m H (p & EQ & LE). exists (S p). + split. + nzsimpl. now f_equiv. + now apply le_le_succ_r. Qed. (** For the moment, it doesn't seem possible to relate diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 595b2182ab..840a798d9b 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -49,8 +49,8 @@ bidirectional induction steps *) Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. Proof. intros; split. -apply succ_inj. -intros. now f_equiv. +- apply succ_inj. +- intros. now f_equiv. Qed. Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. @@ -72,9 +72,9 @@ Theorem central_induction : forall n, A n. Proof. intros z Base Step; revert Base; pattern z; apply bi_induction. -solve_proper. -intro; now apply bi_induction. -intro; pose proof (Step n); tauto. +- solve_proper. +- intro; now apply bi_induction. +- intro; pose proof (Step n); tauto. Qed. End CentralInduction. diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index 550aa226ac..b94cef7cee 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -54,22 +54,22 @@ Proof. intros b. assert (U : forall q1 q2 r1 r2, b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False). - intros q1 q2 r1 r2 EQ LT Hr1 Hr2. - contradict EQ. - apply lt_neq. - apply lt_le_trans with (b*q1+b). - rewrite <- add_lt_mono_l. tauto. - apply le_trans with (b*q2). - rewrite mul_comm, <- mul_succ_l, mul_comm. - apply mul_le_mono_nonneg_l; intuition; try order. - rewrite le_succ_l; auto. - rewrite <- (add_0_r (b*q2)) at 1. - rewrite <- add_le_mono_l. tauto. - -intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. -elim (U q1 q2 r1 r2); intuition. -split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. -elim (U q2 q1 r2 r1); intuition. +- intros q1 q2 r1 r2 EQ LT Hr1 Hr2. + contradict EQ. + apply lt_neq. + apply lt_le_trans with (b*q1+b). + + rewrite <- add_lt_mono_l. tauto. + + apply le_trans with (b*q2). + * rewrite mul_comm, <- mul_succ_l, mul_comm. + apply mul_le_mono_nonneg_l; intuition; try order. + rewrite le_succ_l; auto. + * rewrite <- (add_0_r (b*q2)) at 1. + rewrite <- add_le_mono_l. tauto. + +- intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. + + elim (U q1 q2 r1 r2); intuition. + + split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. + + elim (U q2 q1 r2 r1); intuition. Qed. Theorem div_unique: @@ -78,8 +78,8 @@ Theorem div_unique: Proof. intros a b q r Ha (Hb,Hr) EQ. destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -apply mod_bound_pos; order. -rewrite <- div_mod; order. +- apply mod_bound_pos; order. +- rewrite <- div_mod; order. Qed. Theorem mod_unique: @@ -88,8 +88,8 @@ Theorem mod_unique: Proof. intros a b q r Ha (Hb,Hr) EQ. destruct (div_mod_unique b q (a/b) r (a mod b)); auto. -apply mod_bound_pos; order. -rewrite <- div_mod; order. +- apply mod_bound_pos; order. +- rewrite <- div_mod; order. Qed. Theorem div_unique_exact a b q: @@ -167,16 +167,16 @@ Qed. Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a. Proof. intros; symmetry. apply div_unique_exact; trivial. -apply mul_nonneg_nonneg; order. -apply mul_comm. +- apply mul_nonneg_nonneg; order. +- apply mul_comm. Qed. Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0. Proof. intros; symmetry. apply mod_unique with a; try split; try order. -apply mul_nonneg_nonneg; order. -nzsimpl; apply mul_comm. +- apply mul_nonneg_nonneg; order. +- nzsimpl; apply mul_comm. Qed. @@ -187,10 +187,10 @@ Qed. Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. Proof. intros. destruct (le_gt_cases b a). -apply le_trans with b; auto. -apply lt_le_incl. destruct (mod_bound_pos a b); auto. -rewrite lt_eq_cases; right. -apply mod_small; auto. +- apply le_trans with b; auto. + apply lt_le_incl. destruct (mod_bound_pos a b); auto. +- rewrite lt_eq_cases; right. + apply mod_small; auto. Qed. @@ -219,9 +219,9 @@ Qed. Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b). Proof. intros a b Ha Hb; split; intros Hab. -destruct (lt_ge_cases a b); auto. -symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto. -apply div_small; auto. +- destruct (lt_ge_cases a b); auto. + symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto. +- apply div_small; auto. Qed. Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b). @@ -236,9 +236,9 @@ Qed. Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a). Proof. intros a b Ha Hb; split; intros Hab. -destruct (lt_ge_cases a b) as [LT|LE]; auto. -rewrite <- div_small_iff in LT; order. -apply div_str_pos; auto. +- destruct (lt_ge_cases a b) as [LT|LE]; auto. + rewrite <- div_small_iff in LT; order. +- apply div_str_pos; auto. Qed. @@ -250,14 +250,14 @@ Proof. intros. assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). destruct (lt_ge_cases a b). -rewrite div_small; try split; order. -rewrite (div_mod a b) at 2 by order. -apply lt_le_trans with (b*(a/b)). -rewrite <- (mul_1_l (a/b)) at 1. -rewrite <- mul_lt_mono_pos_r; auto. -apply div_str_pos; auto. -rewrite <- (add_0_r (b*(a/b))) at 1. -rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. +- rewrite div_small; try split; order. +- rewrite (div_mod a b) at 2 by order. + apply lt_le_trans with (b*(a/b)). + + rewrite <- (mul_1_l (a/b)) at 1. + rewrite <- mul_lt_mono_pos_r; auto. + apply div_str_pos; auto. + + rewrite <- (add_0_r (b*(a/b))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. Qed. (** [le] is compatible with a positive division. *) @@ -276,8 +276,8 @@ apply lt_le_trans with b; auto. rewrite (div_mod b c) at 1 by order. rewrite <- add_assoc, <- add_le_mono_l. apply le_trans with (c+0). -nzsimpl; destruct (mod_bound_pos b c); order. -rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. +- nzsimpl; destruct (mod_bound_pos b c); order. +- rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. Qed. (** The following two properties could be used as specification of div *) @@ -334,11 +334,11 @@ Theorem div_le_lower_bound: Proof. intros a b q Ha Hb H. destruct (lt_ge_cases 0 q). -rewrite <- (div_mul q b); try order. -apply div_le_mono; auto. -rewrite mul_comm; split; auto. -apply lt_le_incl, mul_pos_pos; auto. -apply le_trans with 0; auto; apply div_pos; auto. +- rewrite <- (div_mul q b); try order. + apply div_le_mono; auto. + rewrite mul_comm; split; auto. + apply lt_le_incl, mul_pos_pos; auto. +- apply le_trans with 0; auto; apply div_pos; auto. Qed. (** A division respects opposite monotonicity for the divisor *) @@ -350,10 +350,10 @@ Proof. apply div_le_lower_bound; auto. rewrite (div_mod p r) at 2 by order. apply le_trans with (r*(p/r)). - apply mul_le_mono_nonneg_r; try order. - apply div_pos; order. - rewrite <- (add_0_r (r*(p/r))) at 1. - rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. + - apply mul_le_mono_nonneg_r; try order. + apply div_pos; order. + - rewrite <- (add_0_r (r*(p/r))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. Qed. @@ -365,9 +365,9 @@ Proof. intros. symmetry. apply mod_unique with (a/c+b); auto. - apply mod_bound_pos; auto. - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. - now rewrite mul_comm. + - apply mod_bound_pos; auto. + - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. Qed. Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c -> @@ -396,14 +396,14 @@ Proof. intros. symmetry. apply div_unique with ((a mod b)*c). - apply mul_nonneg_nonneg; order. - split. - apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. - rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. - rewrite (div_mod a b) at 1 by order. - rewrite mul_add_distr_r. - rewrite add_cancel_r. - rewrite <- 2 mul_assoc. now rewrite (mul_comm c). + - apply mul_nonneg_nonneg; order. + - split. + + apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. + + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. + - rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). Qed. Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -418,10 +418,10 @@ Proof. intros. rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). rewrite <- div_mod. - rewrite div_mul_cancel_l; auto. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. - rewrite <- neq_mul_0; intuition; order. + - rewrite div_mul_cancel_l; auto. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. + - rewrite <- neq_mul_0; intuition; order. Qed. Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c -> @@ -447,8 +447,8 @@ Proof. rewrite add_comm, (mul_comm n), (mul_comm _ b). rewrite mul_add_distr_l, mul_assoc. intros. rewrite mod_add; auto. - now rewrite mul_comm. - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. + - now rewrite mul_comm. + - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. Qed. Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -460,8 +460,8 @@ Qed. Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a * b) mod n == ((a mod n) * (b mod n)) mod n. Proof. - intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity. - now destruct (mod_bound_pos b n). + intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. - reflexivity. + - now destruct (mod_bound_pos b n). Qed. Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -471,8 +471,8 @@ Proof. generalize (add_nonneg_nonneg _ _ Ha Hb). rewrite (div_mod a n) at 1 2 by order. rewrite <- add_assoc, add_comm, mul_comm. - intros. rewrite mod_add; trivial. reflexivity. - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. + intros. rewrite mod_add; trivial. - reflexivity. + - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. Qed. Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -484,8 +484,8 @@ Qed. Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a+b) mod n == (a mod n + b mod n) mod n. Proof. - intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity. - now destruct (mod_bound_pos b n). + intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. - reflexivity. + - now destruct (mod_bound_pos b n). Qed. Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -494,18 +494,18 @@ Proof. intros a b c Ha Hb Hc. apply div_unique with (b*((a/b) mod c) + a mod b); trivial. (* begin 0<= ... <b*c *) - destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos. - split. - apply add_nonneg_nonneg; auto. - apply mul_nonneg_nonneg; order. - apply lt_le_trans with (b*((a/b) mod c) + b). - rewrite <- add_lt_mono_l; auto. - rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto. - (* end 0<= ... < b*c *) - rewrite (div_mod a b) at 1 by order. - rewrite add_assoc, add_cancel_r. - rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. - apply div_mod; order. + - destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos. + split. + + apply add_nonneg_nonneg; auto. + apply mul_nonneg_nonneg; order. + + apply lt_le_trans with (b*((a/b) mod c) + b). + * rewrite <- add_lt_mono_l; auto. + * rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto. + (* end 0<= ... < b*c *) + - rewrite (div_mod a b) at 1 by order. + rewrite add_assoc, add_cancel_r. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. Qed. Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -527,10 +527,10 @@ Theorem div_mul_le: Proof. intros. apply div_le_lower_bound; auto. - apply mul_nonneg_nonneg; auto. - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. - apply mul_le_mono_nonneg_l; auto. - apply mul_div_le; auto. + - apply mul_nonneg_nonneg; auto. + - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. + apply mul_le_mono_nonneg_l; auto. + apply mul_div_le; auto. Qed. (** mod is related to divisibility *) @@ -539,9 +539,9 @@ Lemma mod_divides : forall a b, 0<=a -> 0<b -> (a mod b == 0 <-> exists c, a == b*c). Proof. split. - intros. exists (a/b). rewrite div_exact; auto. - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. - rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. + - intros. exists (a/b). rewrite div_exact; auto. + - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. + rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. Qed. End NZDivProp. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v index c38d1aac31..1ac89ce942 100644 --- a/theories/Numbers/NatInt/NZGcd.v +++ b/theories/Numbers/NatInt/NZGcd.v @@ -72,15 +72,15 @@ Lemma eq_mul_1_nonneg : forall n m, Proof. intros n m Hn H. le_elim Hn. - destruct (lt_ge_cases m 0) as [Hm|Hm]. - generalize (mul_pos_neg n m Hn Hm). order'. - le_elim Hm. - apply le_succ_l in Hn. rewrite <- one_succ in Hn. - le_elim Hn. - generalize (lt_1_mul_pos n m Hn Hm). order. - rewrite <- Hn, mul_1_l in H. now split. - rewrite <- Hm, mul_0_r in H. order'. - rewrite <- Hn, mul_0_l in H. order'. + - destruct (lt_ge_cases m 0) as [Hm|Hm]. + + generalize (mul_pos_neg n m Hn Hm). order'. + + le_elim Hm. + * apply le_succ_l in Hn. rewrite <- one_succ in Hn. + le_elim Hn. + -- generalize (lt_1_mul_pos n m Hn Hm). order. + -- rewrite <- Hn, mul_1_l in H. now split. + * rewrite <- Hm, mul_0_r in H. order'. + - rewrite <- Hn, mul_0_l in H. order'. Qed. Lemma eq_mul_1_nonneg' : forall n m, @@ -117,13 +117,13 @@ Lemma divide_antisym_nonneg : forall n m, Proof. intros n m Hn Hm (q,Hq) (r,Hr). le_elim Hn. - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - generalize (mul_neg_pos q n Hq' Hn). order. - rewrite Hq, mul_assoc in Hr. symmetry in Hr. - apply mul_id_l in Hr; [|order]. - destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. - now rewrite H, mul_1_l in Hq. - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. + - destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + rewrite Hq, mul_assoc in Hr. symmetry in Hr. + apply mul_id_l in Hr; [|order]. + destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. + now rewrite H, mul_1_l in Hq. + - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. Qed. Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m). @@ -140,8 +140,8 @@ Lemma mul_divide_cancel_l : forall n m p, p ~= 0 -> ((p * n | p * m) <-> (n | m)). Proof. intros n m p Hp. split. - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. - apply mul_divide_mono_l. + - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. + - apply mul_divide_mono_l. Qed. Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> @@ -179,14 +179,14 @@ Qed. Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m. Proof. intros n m Hm (q,Hq). - destruct (le_gt_cases n 0) as [Hn|Hn]. order. - rewrite Hq. - destruct (lt_ge_cases q 0) as [Hq'|Hq']. - generalize (mul_neg_pos q n Hq' Hn). order. - le_elim Hq'. - rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. - now rewrite one_succ, le_succ_l. - rewrite <- Hq', mul_0_l in Hq. order. + destruct (le_gt_cases n 0) as [Hn|Hn]. - order. + - rewrite Hq. + destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + le_elim Hq'. + * rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. + now rewrite one_succ, le_succ_l. + * rewrite <- Hq', mul_0_l in Hq. order. Qed. (** Basic properties of gcd *) @@ -197,28 +197,28 @@ Lemma gcd_unique : forall n m p, gcd n m == p. Proof. intros n m p Hp Hn Hm H. - apply divide_antisym_nonneg; trivial. apply gcd_nonneg. - apply H. apply gcd_divide_l. apply gcd_divide_r. - now apply gcd_greatest. + apply divide_antisym_nonneg; trivial. - apply gcd_nonneg. + - apply H. + apply gcd_divide_l. + apply gcd_divide_r. + - now apply gcd_greatest. Qed. Instance gcd_wd : Proper (eq==>eq==>eq) gcd. Proof. intros x x' Hx y y' Hy. apply gcd_unique. - apply gcd_nonneg. - rewrite Hx. apply gcd_divide_l. - rewrite Hy. apply gcd_divide_r. - intro. rewrite Hx, Hy. apply gcd_greatest. + - apply gcd_nonneg. + - rewrite Hx. apply gcd_divide_l. + - rewrite Hy. apply gcd_divide_r. + - intro. rewrite Hx, Hy. apply gcd_greatest. Qed. Lemma gcd_divide_iff : forall n m p, (p | gcd n m) <-> (p | n) /\ (p | m). Proof. - intros. split. split. - transitivity (gcd n m); trivial using gcd_divide_l. - transitivity (gcd n m); trivial using gcd_divide_r. - intros (H,H'). now apply gcd_greatest. + intros. split. - split. + + transitivity (gcd n m); trivial using gcd_divide_l. + + transitivity (gcd n m); trivial using gcd_divide_r. + - intros (H,H'). now apply gcd_greatest. Qed. Lemma gcd_unique_alt : forall n m p, 0<=p -> @@ -227,9 +227,9 @@ Lemma gcd_unique_alt : forall n m p, 0<=p -> Proof. intros n m p Hp H. apply gcd_unique; trivial. - apply H. apply divide_refl. - apply H. apply divide_refl. - intros. apply H. now split. + - apply H. apply divide_refl. + - apply H. apply divide_refl. + - intros. apply H. now split. Qed. Lemma gcd_comm : forall n m, gcd n m == gcd m n. @@ -247,8 +247,8 @@ Qed. Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n. Proof. intros. apply gcd_unique; trivial. - apply divide_0_r. - apply divide_refl. + - apply divide_0_r. + - apply divide_refl. Qed. Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n. @@ -284,24 +284,26 @@ Qed. Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. Proof. - intros. split. split. - now apply gcd_eq_0_l with m. - now apply gcd_eq_0_r with n. - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. + intros. split. + - split. + + now apply gcd_eq_0_l with m. + + now apply gcd_eq_0_r with n. + - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. Qed. Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n. Proof. intros n m Hn. apply gcd_unique_alt; trivial. - intros q. split. split; trivial. now apply divide_mul_l. - now destruct 1. + intros q. split. - split; trivial. now apply divide_mul_l. + - now destruct 1. Qed. Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n). Proof. - intros n m Hn. split. intros (q,Hq). rewrite Hq. - rewrite mul_comm. now apply gcd_mul_diag_l. - intros EQ. rewrite <- EQ. apply gcd_divide_r. + intros n m Hn. split. + - intros (q,Hq). rewrite Hq. + rewrite mul_comm. now apply gcd_mul_diag_l. + - intros EQ. rewrite <- EQ. apply gcd_divide_r. Qed. End NZGcdProp. diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v index 794851a9dd..1951cfc3ef 100644 --- a/theories/Numbers/NatInt/NZLog.v +++ b/theories/Numbers/NatInt/NZLog.v @@ -40,10 +40,10 @@ Module Type NZLog2Prop Lemma log2_nonneg : forall a, 0 <= log2 a. Proof. intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - now rewrite log2_nonpos. - destruct (log2_spec a Ha) as (_,LT). - apply lt_succ_r, (pow_gt_1 2). order'. - rewrite <- le_succ_l, <- one_succ in Ha. order. + - now rewrite log2_nonpos. + - destruct (log2_spec a Ha) as (_,LT). + apply lt_succ_r, (pow_gt_1 2). + order'. + + rewrite <- le_succ_l, <- one_succ in Ha. order. Qed. (** A tactic for proving positivity and non-negativity *) @@ -62,17 +62,17 @@ Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b. Proof. intros a b Hb (LEb,LTb). assert (Ha : 0 < a). - apply lt_le_trans with (2^b); trivial. - apply pow_pos_nonneg; order'. - assert (Hc := log2_nonneg a). - destruct (log2_spec a Ha) as (LEc,LTc). - assert (log2 a <= b). - apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - assert (b <= log2 a). - apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. - now apply le_le_succ_r. - order. + - apply lt_le_trans with (2^b); trivial. + apply pow_pos_nonneg; order'. + - assert (Hc := log2_nonneg a). + destruct (log2_spec a Ha) as (LEc,LTc). + assert (log2 a <= b). + + apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + + assert (b <= log2 a). + * apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + * order. Qed. (** Hence log2 is a morphism. *) @@ -81,9 +81,9 @@ Instance log2_wd : Proper (eq==>eq) log2. Proof. intros x x' Hx. destruct (le_gt_cases x 0). - rewrite 2 log2_nonpos; trivial. reflexivity. now rewrite <- Hx. - apply log2_unique. apply log2_nonneg. - rewrite Hx in *. now apply log2_spec. + - rewrite 2 log2_nonpos; trivial. + reflexivity. + now rewrite <- Hx. + - apply log2_unique. + apply log2_nonneg. + + rewrite Hx in *. now apply log2_spec. Qed. (** An alternate specification *) @@ -95,24 +95,24 @@ Proof. destruct (log2_spec _ Ha) as (LE,LT). destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). exists r. - split. now rewrite add_comm. - split. trivial. - apply (add_lt_mono_r _ _ (2^log2 a)). - rewrite <- Hr. generalize LT. - rewrite pow_succ_r by order_pos. - rewrite two_succ at 1. now nzsimpl. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_lt_mono_r _ _ (2^log2 a)). + rewrite <- Hr. generalize LT. + rewrite pow_succ_r by order_pos. + rewrite two_succ at 1. now nzsimpl. Qed. Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b -> a == 2^b + c -> log2 a == b. Proof. intros a b c Hb (Hc,H) EQ. - apply log2_unique. trivial. - rewrite EQ. - split. - rewrite <- add_0_r at 1. now apply add_le_mono_l. - rewrite pow_succ_r by order. - rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. + apply log2_unique. - trivial. + - rewrite EQ. + split. + + rewrite <- add_0_r at 1. now apply add_le_mono_l. + + rewrite pow_succ_r by order. + rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. Qed. (** log2 is exact on powers of 2 *) @@ -121,7 +121,7 @@ Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a. Proof. intros a Ha. apply log2_unique' with 0; trivial. - split; order_pos. now nzsimpl. + - split; order_pos. - now nzsimpl. Qed. (** log2 and predecessors of powers of 2 *) @@ -131,12 +131,12 @@ Proof. intros a Ha. assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0). apply log2_unique. - apply lt_succ_r; order. - rewrite <-le_succ_l, <-lt_succ_r, Ha'. - rewrite lt_succ_pred with 0. - split; try easy. apply pow_lt_mono_r_iff; try order'. - rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. - apply pow_pos_nonneg; order'. + - apply lt_succ_r; order. + - rewrite <-le_succ_l, <-lt_succ_r, Ha'. + rewrite lt_succ_pred with 0. + + split; try easy. apply pow_lt_mono_r_iff; try order'. + rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. + + apply pow_pos_nonneg; order'. Qed. (** log2 and basic constants *) @@ -167,11 +167,11 @@ Qed. Lemma log2_null : forall a, log2 a == 0 <-> a <= 1. Proof. intros a. split; intros H. - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_pos a Ha); order. - le_elim H. - apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. - rewrite H. apply log2_1. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_pos a Ha); order. + - le_elim H. + + apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. + + rewrite H. apply log2_1. Qed. (** log2 is a monotone function (but not a strict one) *) @@ -180,11 +180,11 @@ Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b. Proof. intros a b H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite log2_nonpos; order_pos. - assert (Hb : 0 < b) by order. - destruct (log2_spec a Ha) as (LEa,_). - destruct (log2_spec b Hb) as (_,LTb). - apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. + - rewrite log2_nonpos; order_pos. + - assert (Hb : 0 < b) by order. + destruct (log2_spec a Ha) as (LEa,_). + destruct (log2_spec b Hb) as (_,LTb). + apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. Qed. (** No reverse result for <=, consider for instance log2 3 <= log2 2 *) @@ -193,13 +193,13 @@ Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b. Proof. intros a b H. destruct (le_gt_cases b 0) as [Hb|Hb]. - rewrite (log2_nonpos b) in H; trivial. - generalize (log2_nonneg a); order. - destruct (le_gt_cases a 0) as [Ha|Ha]. order. - destruct (log2_spec a Ha) as (_,LTa). - destruct (log2_spec b Hb) as (LEb,_). - apply le_succ_l in H. - apply (pow_le_mono_r_iff 2) in H; order_pos. + - rewrite (log2_nonpos b) in H; trivial. + generalize (log2_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]. + order. + + destruct (log2_spec a Ha) as (_,LTa). + destruct (log2_spec b Hb) as (LEb,_). + apply le_succ_l in H. + apply (pow_le_mono_r_iff 2) in H; order_pos. Qed. (** When left side is a power of 2, we have an equivalence for <= *) @@ -208,12 +208,12 @@ Lemma log2_le_pow2 : forall a b, 0<a -> (2^b<=a <-> b <= log2 a). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - generalize (log2_nonneg a); order. - rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. - transitivity (2^(log2 a)). - apply pow_le_mono_r; order'. - now destruct (log2_spec a Ha). + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. + - transitivity (2^(log2 a)). + + apply pow_le_mono_r; order'. + + now destruct (log2_spec a Ha). Qed. (** When right side is a square, we have an equivalence for < *) @@ -222,15 +222,15 @@ Lemma log2_lt_pow2 : forall a b, 0<a -> (a<2^b <-> log2 a < b). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite pow_neg_r in H; order. - apply (pow_lt_mono_r_iff 2); try order_pos. - apply le_lt_trans with a; trivial. - now destruct (log2_spec a Ha). - destruct (lt_ge_cases b 0) as [Hb|Hb]. - generalize (log2_nonneg a); order. - apply log2_lt_cancel; try order. - now rewrite log2_pow2. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + apply (pow_lt_mono_r_iff 2); try order_pos. + apply le_lt_trans with a; trivial. + now destruct (log2_spec a Ha). + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + apply log2_lt_cancel; try order. + now rewrite log2_pow2. Qed. (** Comparing log2 and identity *) @@ -240,16 +240,16 @@ Proof. intros a Ha. apply (pow_lt_mono_r_iff 2); try order_pos. apply le_lt_trans with a. - now destruct (log2_spec a Ha). - apply pow_gt_lin_r; order'. + - now destruct (log2_spec a Ha). + - apply pow_gt_lin_r; order'. Qed. Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a. Proof. intros a Ha. le_elim Ha. - now apply lt_le_incl, log2_lt_lin. - rewrite <- Ha, log2_nonpos; order. + - now apply lt_le_incl, log2_lt_lin. + - rewrite <- Ha, log2_nonpos; order. Qed. (** Log2 and multiplication. *) @@ -271,14 +271,14 @@ Lemma log2_mul_above : forall a b, 0<=a -> 0<=b -> Proof. intros a b Ha Hb. le_elim Ha. - le_elim Hb. - apply lt_succ_r. - rewrite add_1_r, <- add_succ_r, <- add_succ_l. - apply log2_lt_pow2; try order_pos. - rewrite pow_add_r by order_pos. - apply mul_lt_mono_nonneg; try order; now apply log2_spec. - rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. + - le_elim Hb. + + apply lt_succ_r. + rewrite add_1_r, <- add_succ_r, <- add_succ_l. + apply log2_lt_pow2; try order_pos. + rewrite pow_add_r by order_pos. + apply mul_lt_mono_nonneg; try order; now apply log2_spec. + + rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. Qed. (** And we can't find better approximations in general. @@ -293,10 +293,10 @@ Lemma log2_mul_pow2 : forall a b, 0<a -> 0<=b -> log2 (a*2^b) == b + log2 a. Proof. intros a b Ha Hb. apply log2_unique; try order_pos. split. - rewrite pow_add_r, mul_comm; try order_pos. - apply mul_le_mono_nonneg_r. order_pos. now apply log2_spec. - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. - apply mul_lt_mono_pos_l. order_pos. now apply log2_spec. + - rewrite pow_add_r, mul_comm; try order_pos. + apply mul_le_mono_nonneg_r. + order_pos. + now apply log2_spec. + - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. + apply mul_lt_mono_pos_l. + order_pos. + now apply log2_spec. Qed. Lemma log2_double : forall a, 0<a -> log2 (2*a) == S (log2 a). @@ -323,13 +323,13 @@ Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a). Proof. intros a. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. - apply (pow_le_mono_r_iff 2); try order_pos. - transitivity (S a). - apply log2_spec. - apply lt_succ_r; order. - now apply le_succ_l, log2_spec. - rewrite <- EQ, <- one_succ, log2_1; order_pos. - rewrite 2 log2_nonpos. order_pos. order'. now rewrite le_succ_l. + - apply (pow_le_mono_r_iff 2); try order_pos. + transitivity (S a). + + apply log2_spec. + apply lt_succ_r; order. + + now apply le_succ_l, log2_spec. + - rewrite <- EQ, <- one_succ, log2_1; order_pos. + - rewrite 2 log2_nonpos. + order_pos. + order'. + now rewrite le_succ_l. Qed. Lemma log2_succ_or : forall a, @@ -337,8 +337,8 @@ Lemma log2_succ_or : forall a, Proof. intros. destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (log2_succ_le a); order. + - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_succ_le a); order. Qed. Lemma log2_eq_succ_is_pow2 : forall a, @@ -346,27 +346,27 @@ Lemma log2_eq_succ_is_pow2 : forall a, Proof. intros a H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite 2 (proj2 (log2_null _)) in H. generalize (lt_succ_diag_r 0); order. - order'. apply le_succ_l. order'. - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). - exists (log2 (S a)). - generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). - rewrite <- le_succ_l, <- H. order. + - rewrite 2 (proj2 (log2_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). + exists (log2 (S a)). + generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). + rewrite <- le_succ_l, <- H. order. Qed. Lemma log2_eq_succ_iff_pow2 : forall a, 0<a -> (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b). Proof. intros a Ha. - split. apply log2_eq_succ_is_pow2. - intros (b,Hb). - assert (Hb' : 0 < b). - apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. - rewrite Hb, log2_pow2; try order'. - setoid_replace a with (P (2^b)). rewrite log2_pred_pow2; trivial. - symmetry; now apply lt_succ_pred with 0. - apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. - rewrite <- Hb, lt_succ_r; order. + split. - apply log2_eq_succ_is_pow2. + - intros (b,Hb). + assert (Hb' : 0 < b). + + apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. + + rewrite Hb, log2_pow2; try order'. + setoid_replace a with (P (2^b)). * rewrite log2_pred_pow2; trivial. + symmetry; now apply lt_succ_pred with 0. + * apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. + rewrite <- Hb, lt_succ_r; order. Qed. Lemma log2_succ_double : forall a, 0<a -> log2 (2*a+1) == S (log2 a). @@ -376,18 +376,18 @@ Proof. destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double]. apply log2_eq_succ_is_pow2 in H. destruct H as (b,H). destruct (lt_trichotomy b 0) as [LT|[EQ|LT]]. - rewrite pow_neg_r in H; trivial. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - rewrite EQ, pow_0_r in H. - apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. - rewrite <- one_succ in Ha. order'. - assert (EQ:=lt_succ_pred 0 b LT). - rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. - destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. - generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. - rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. - rewrite <- H in LE'. apply le_succ_l in LE'. order. + - rewrite pow_neg_r in H; trivial. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - rewrite EQ, pow_0_r in H. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - assert (EQ:=lt_succ_pred 0 b LT). + rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. + destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. + + generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. + + rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. + rewrite <- H in LE'. apply le_succ_l in LE'. order. Qed. (** Log2 and addition *) @@ -396,25 +396,28 @@ Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b. Proof. intros a b Ha Hb. destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - rewrite one_succ, lt_succ_r in Ha'. - rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - rewrite one_succ, lt_succ_r in Hb'. - rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - clear Ha Hb. - apply lt_succ_r. - apply log2_lt_pow2; try order_pos. - rewrite pow_succ_r by order_pos. - rewrite two_succ, one_succ at 1. nzsimpl. - apply add_lt_mono. - apply lt_le_trans with (2^(S (log2 a))). apply log2_spec; order'. - apply pow_le_mono_r. order'. rewrite <- add_1_r. apply add_le_mono_l. - rewrite one_succ; now apply le_succ_l, log2_pos. - apply lt_le_trans with (2^(S (log2 b))). apply log2_spec; order'. - apply pow_le_mono_r. order'. rewrite <- add_1_l. apply add_le_mono_r. - rewrite one_succ; now apply le_succ_l, log2_pos. + - rewrite one_succ, lt_succ_r in Ha'. + rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite one_succ, lt_succ_r in Hb'. + rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + apply lt_succ_r. + apply log2_lt_pow2; try order_pos. + rewrite pow_succ_r by order_pos. + rewrite two_succ, one_succ at 1. nzsimpl. + apply add_lt_mono. + * apply lt_le_trans with (2^(S (log2 a))). -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_r. apply add_le_mono_l. + rewrite one_succ; now apply le_succ_l, log2_pos. + * apply lt_le_trans with (2^(S (log2 b))). + -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_l. apply add_le_mono_r. + rewrite one_succ; now apply le_succ_l, log2_pos. Qed. (** The sum of two log2 is less than twice the log2 of the sum. @@ -430,17 +433,17 @@ Lemma add_log2_lt : forall a b, 0<a -> 0<b -> Proof. intros a b Ha Hb. nzsimpl'. assert (H : log2 a <= log2 (a+b)). - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - assert (H' : log2 b <= log2 (a+b)). - apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - le_elim H. - apply lt_le_trans with (log2 (a+b) + log2 b). - now apply add_lt_mono_r. now apply add_le_mono_l. - rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'; trivial. - symmetry in H. apply log2_same in H; try order_pos. - symmetry in H'. apply log2_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. + - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2 b <= log2 (a+b)). + + apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2 (a+b) + log2 b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'; trivial. + symmetry in H. apply log2_same in H; try order_pos. + symmetry in H'. apply log2_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. Qed. End NZLog2Prop. @@ -493,9 +496,9 @@ Qed. Instance log2_up_wd : Proper (eq==>eq) log2_up. Proof. assert (Proper (eq==>eq==>Logic.eq) compare). - repeat red; intros; do 2 case compare_spec; trivial; order. - intros a a' Ha. unfold log2_up. rewrite Ha at 1. - case compare; now rewrite ?Ha. + - repeat red; intros; do 2 case compare_spec; trivial; order. + - intros a a' Ha. unfold log2_up. rewrite Ha at 1. + case compare; now rewrite ?Ha. Qed. (** [log2_up] is always non-negative *) @@ -512,22 +515,23 @@ Lemma log2_up_unique : forall a b, 0<b -> 2^(P b)<a<=2^b -> log2_up a == b. Proof. intros a b Hb (LEb,LTb). assert (Ha : 1 < a). - apply le_lt_trans with (2^(P b)); trivial. - rewrite one_succ. apply le_succ_l. - apply pow_pos_nonneg. order'. apply lt_succ_r. - now rewrite (lt_succ_pred 0 b Hb). - assert (Hc := log2_up_nonneg a). - destruct (log2_up_spec a Ha) as (LTc,LEc). - assert (b <= log2_up a). - apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - assert (Hc' : 0 < log2_up a) by order. - assert (log2_up a <= b). - apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). - rewrite <- succ_lt_mono. - apply (pow_lt_mono_r_iff 2); try order'. - order. + - apply le_lt_trans with (2^(P b)); trivial. + rewrite one_succ. apply le_succ_l. + apply pow_pos_nonneg. + order'. + + apply lt_succ_r. + now rewrite (lt_succ_pred 0 b Hb). + - assert (Hc := log2_up_nonneg a). + destruct (log2_up_spec a Ha) as (LTc,LEc). + assert (b <= log2_up a). + + apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + + assert (Hc' : 0 < log2_up a) by order. + assert (log2_up a <= b). + * apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + * order. Qed. (** [log2_up] is exact on powers of 2 *) @@ -536,12 +540,12 @@ Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a. Proof. intros a Ha. le_elim Ha. - apply log2_up_unique; trivial. - split; try order. - apply pow_lt_mono_r; try order'. - rewrite <- (lt_succ_pred 0 a Ha) at 2. - now apply lt_succ_r. - now rewrite <- Ha, pow_0_r, log2_up_eqn0. + - apply log2_up_unique; trivial. + split; try order. + apply pow_lt_mono_r; try order'. + rewrite <- (lt_succ_pred 0 a Ha) at 2. + now apply lt_succ_r. + - now rewrite <- Ha, pow_0_r, log2_up_eqn0. Qed. (** [log2_up] and successors of powers of 2 *) @@ -570,9 +574,9 @@ Qed. Lemma le_log2_log2_up : forall a, log2 a <= log2_up a. Proof. intros a. unfold log2_up. case compare_spec; intros H. - rewrite <- H, log2_1. order. - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. - rewrite log2_nonpos. order. now rewrite <-lt_succ_r, <-one_succ. + - rewrite <- H, log2_1. order. + - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. + - rewrite log2_nonpos. + order. + now rewrite <-lt_succ_r, <-one_succ. Qed. Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a). @@ -586,23 +590,24 @@ Lemma log2_log2_up_spec : forall a, 0<a -> 2^log2 a <= a <= 2^log2_up a. Proof. intros a H. split. - now apply log2_spec. - rewrite <-le_succ_l, <-one_succ in H. le_elim H. - now apply log2_up_spec. - now rewrite <-H, log2_up_1, pow_0_r. + - now apply log2_spec. + - rewrite <-le_succ_l, <-one_succ in H. le_elim H. + + now apply log2_up_spec. + + now rewrite <-H, log2_up_1, pow_0_r. Qed. Lemma log2_log2_up_exact : forall a, 0<a -> (log2 a == log2_up a <-> exists b, a == 2^b). Proof. intros a Ha. - split. intros. exists (log2 a). - generalize (log2_log2_up_spec a Ha). rewrite <-H. - destruct 1; order. - intros (b,Hb). rewrite Hb. - destruct (le_gt_cases 0 b). - now rewrite log2_pow2, log2_up_pow2. - rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. + split. + - intros. exists (log2 a). + generalize (log2_log2_up_spec a Ha). rewrite <-H. + destruct 1; order. + - intros (b,Hb). rewrite Hb. + destruct (le_gt_cases 0 b). + + now rewrite log2_pow2, log2_up_pow2. + + rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. Qed. (** [log2_up] n is strictly positive for 1<n *) @@ -617,9 +622,9 @@ Qed. Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1. Proof. intros a. split; intros H. - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. - generalize (log2_up_pos a Ha); order. - now apply log2_up_eqn0. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_up_pos a Ha); order. + - now apply log2_up_eqn0. Qed. (** [log2_up] is a monotone function (but not a strict one) *) @@ -628,10 +633,10 @@ Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b. Proof. intros a b H. destruct (le_gt_cases a 1) as [Ha|Ha]. - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. - rewrite 2 log2_up_eqn; try order. - rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. - rewrite 2 lt_succ_pred with 1; order. + - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. + - rewrite 2 log2_up_eqn; try order. + rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. + rewrite 2 lt_succ_pred with 1; order. Qed. (** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *) @@ -640,12 +645,12 @@ Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b. Proof. intros a b H. destruct (le_gt_cases b 1) as [Hb|Hb]. - rewrite (log2_up_eqn0 b) in H; trivial. - generalize (log2_up_nonneg a); order. - destruct (le_gt_cases a 1) as [Ha|Ha]. order. - rewrite 2 log2_up_eqn in H; try order. - rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. - rewrite 2 lt_succ_pred with 1 in H; order. + - rewrite (log2_up_eqn0 b) in H; trivial. + generalize (log2_up_nonneg a); order. + - destruct (le_gt_cases a 1) as [Ha|Ha]. + order. + + rewrite 2 log2_up_eqn in H; try order. + rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. + rewrite 2 lt_succ_pred with 1 in H; order. Qed. (** When left side is a power of 2, we have an equivalence for < *) @@ -654,16 +659,16 @@ Lemma log2_up_lt_pow2 : forall a b, 0<a -> (2^b<a <-> b < log2_up a). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - generalize (log2_up_nonneg a); order. - apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg. - apply lt_le_trans with a; trivial. - apply (log2_up_spec a). - apply le_lt_trans with (2^b); trivial. - rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - now rewrite pow_neg_r. - rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_up_nonneg a); order. + + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * apply lt_le_trans with a; trivial. + apply (log2_up_spec a). + apply le_lt_trans with (2^b); trivial. + rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + now rewrite pow_neg_r. + + rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. Qed. (** When right side is a square, we have an equivalence for <= *) @@ -672,12 +677,12 @@ Lemma log2_up_le_pow2 : forall a b, 0<a -> (a<=2^b <-> log2_up a <= b). Proof. intros a b Ha. split; intros H. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite pow_neg_r in H; order. - rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. - transitivity (2^(log2_up a)). - now apply log2_log2_up_spec. - apply pow_le_mono_r; order'. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. + - transitivity (2^(log2_up a)). + + now apply log2_log2_up_spec. + + apply pow_le_mono_r; order'. Qed. (** Comparing [log2_up] and identity *) @@ -688,15 +693,15 @@ Proof. assert (H : S (P a) == a) by (now apply lt_succ_pred with 0). rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial. rewrite <- H at 1. apply le_succ_l. - apply pow_gt_lin_r. order'. apply lt_succ_r; order. + apply pow_gt_lin_r. - order'. - apply lt_succ_r; order. Qed. Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a. Proof. intros a Ha. le_elim Ha. - now apply lt_le_incl, log2_up_lt_lin. - rewrite <- Ha, log2_up_nonpos; order. + - now apply lt_le_incl, log2_up_lt_lin. + - rewrite <- Ha, log2_up_nonpos; order. Qed. (** [log2_up] and multiplication. *) @@ -711,12 +716,12 @@ Proof. assert (Ha':=log2_up_nonneg a). assert (Hb':=log2_up_nonneg b). le_elim Ha. - le_elim Hb. - apply log2_up_le_pow2; try order_pos. - rewrite pow_add_r; trivial. - apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. - rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. + - le_elim Hb. + + apply log2_up_le_pow2; try order_pos. + rewrite pow_add_r; trivial. + apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. + + rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. Qed. Lemma log2_up_mul_below : forall a b, 0<a -> 0<b -> @@ -724,21 +729,21 @@ Lemma log2_up_mul_below : forall a b, 0<a -> 0<b -> Proof. intros a b Ha Hb. rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha. - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. - assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). - assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). - rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. - rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. - nzsimpl. rewrite <- succ_le_mono, le_succ_l. - apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg. - rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). - apply lt_le_trans with (a*b). - apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. - apply log2_up_spec. - setoid_replace 1 with (1*1) by now nzsimpl. - apply mul_lt_mono_nonneg; order'. - rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. + - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. + + assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). + assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). + rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. + rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. + nzsimpl. rewrite <- succ_le_mono, le_succ_l. + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). + apply lt_le_trans with (a*b). + -- apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. + -- apply log2_up_spec. + setoid_replace 1 with (1*1) by now nzsimpl. + apply mul_lt_mono_nonneg; order'. + + rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. + - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. Qed. (** And we can't find better approximations in general. @@ -754,16 +759,16 @@ Lemma log2_up_mul_pow2 : forall a b, 0<a -> 0<=b -> Proof. intros a b Ha Hb. rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha. - apply log2_up_unique. apply add_nonneg_pos; trivial. now apply log2_up_pos. - split. - assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). - rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. - apply mul_lt_mono_pos_r. order_pos. now apply log2_up_spec. - rewrite <- lt_succ_r, EQ. now apply log2_up_pos. - rewrite pow_add_r, mul_comm; trivial. - apply mul_le_mono_nonneg_l. order_pos. now apply log2_up_spec. - apply log2_up_nonneg. - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. + - apply log2_up_unique. + apply add_nonneg_pos; trivial. now apply log2_up_pos. + + split. + * assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). + rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. + -- apply mul_lt_mono_pos_r. ++ order_pos. ++ now apply log2_up_spec. + -- rewrite <- lt_succ_r, EQ. now apply log2_up_pos. + * rewrite pow_add_r, mul_comm; trivial. + -- apply mul_le_mono_nonneg_l. ++ order_pos. ++ now apply log2_up_spec. + -- apply log2_up_nonneg. + - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. Qed. Lemma log2_up_double : forall a, 0<a -> log2_up (2*a) == S (log2_up a). @@ -790,12 +795,12 @@ Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a). Proof. intros a. destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]]. - rewrite 2 log2_up_eqn; trivial. - rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. - apply log2_succ_le. - apply lt_succ_r; order. - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. - rewrite 2 log2_up_eqn0. order_pos. order'. now rewrite le_succ_l. + - rewrite 2 log2_up_eqn; trivial. + + rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. + apply log2_succ_le. + + apply lt_succ_r; order. + - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. + - rewrite 2 log2_up_eqn0. + order_pos. + order'. + now rewrite le_succ_l. Qed. Lemma log2_up_succ_or : forall a, @@ -803,8 +808,8 @@ Lemma log2_up_succ_or : forall a, Proof. intros. destruct (le_gt_cases (log2_up (S a)) (log2_up a)). - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. + - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. Qed. Lemma log2_up_eq_succ_is_pow2 : forall a, @@ -812,33 +817,33 @@ Lemma log2_up_eq_succ_is_pow2 : forall a, Proof. intros a H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite 2 (proj2 (log2_up_null _)) in H. generalize (lt_succ_diag_r 0); order. - order'. apply le_succ_l. order'. - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). - exists (log2_up a). - generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). - rewrite H, pred_succ, lt_succ_r. order. + - rewrite 2 (proj2 (log2_up_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). + exists (log2_up a). + generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). + rewrite H, pred_succ, lt_succ_r. order. Qed. Lemma log2_up_eq_succ_iff_pow2 : forall a, 0<a -> (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b). Proof. intros a Ha. - split. apply log2_up_eq_succ_is_pow2. - intros (b,Hb). - destruct (lt_ge_cases b 0) as [Hb'|Hb']. - rewrite pow_neg_r in Hb; order. - rewrite Hb, log2_up_pow2; try order'. - now rewrite log2_up_succ_pow2. + split. - apply log2_up_eq_succ_is_pow2. + - intros (b,Hb). + destruct (lt_ge_cases b 0) as [Hb'|Hb']. + + rewrite pow_neg_r in Hb; order. + + rewrite Hb, log2_up_pow2; try order'. + now rewrite log2_up_succ_pow2. Qed. Lemma log2_up_succ_double : forall a, 0<a -> log2_up (2*a+1) == 2 + log2 a. Proof. intros a Ha. - rewrite log2_up_eqn. rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. - apply le_lt_trans with (0+1). now nzsimpl'. - apply add_lt_mono_r. order_pos. + rewrite log2_up_eqn. - rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. + - apply le_lt_trans with (0+1). + now nzsimpl'. + + apply add_lt_mono_r. order_pos. Qed. (** [log2_up] and addition *) @@ -848,17 +853,17 @@ Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 -> Proof. intros a b Ha Hb. destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Ha'. - rewrite <- (add_0_l b) at 2. now apply add_le_mono. - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. - rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. - rewrite one_succ, lt_succ_r in Hb'. - rewrite <- (add_0_r a) at 2. now apply add_le_mono. - clear Ha Hb. - transitivity (log2_up (a*b)). - now apply log2_up_le_mono, add_le_mul. - apply log2_up_mul_above; order'. + - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Ha'. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Hb'. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + transitivity (log2_up (a*b)). + * now apply log2_up_le_mono, add_le_mul. + * apply log2_up_mul_above; order'. Qed. (** The sum of two [log2_up] is less than twice the [log2_up] of the sum. @@ -874,17 +879,17 @@ Lemma add_log2_up_lt : forall a b, 0<a -> 0<b -> Proof. intros a b Ha Hb. nzsimpl'. assert (H : log2_up a <= log2_up (a+b)). - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. - assert (H' : log2_up b <= log2_up (a+b)). - apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - le_elim H. - apply lt_le_trans with (log2_up (a+b) + log2_up b). - now apply add_lt_mono_r. now apply add_le_mono_l. - rewrite <- H at 1. apply add_lt_mono_l. - le_elim H'. trivial. - symmetry in H. apply log2_up_same in H; try order_pos. - symmetry in H'. apply log2_up_same in H'; try order_pos. - revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. + - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2_up b <= log2_up (a+b)). + + apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2_up (a+b) + log2_up b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'. -- trivial. + -- symmetry in H. apply log2_up_same in H; try order_pos. + symmetry in H'. apply log2_up_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. Qed. End NZLog2UpProp. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 44cbc51712..1492188452 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -22,24 +22,27 @@ Qed. Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. Proof. -intros n m; nzinduct n. now nzsimpl. -intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. -now rewrite add_cancel_r. + intros n m; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. + now rewrite add_cancel_r. Qed. Hint Rewrite mul_0_r mul_succ_r : nz. Theorem mul_comm : forall n m, n * m == m * n. Proof. -intros n m; nzinduct n. now nzsimpl. -intro. nzsimpl. now rewrite add_cancel_r. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite add_cancel_r. Qed. Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p. Proof. -intros n m p; nzinduct n. now nzsimpl. -intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. -now rewrite add_cancel_r. + intros n m p; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. + now rewrite add_cancel_r. Qed. Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p. @@ -51,9 +54,9 @@ Qed. Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p. Proof. -intros n m p; nzinduct n. now nzsimpl. -intro n. nzsimpl. rewrite mul_add_distr_r. -now rewrite add_cancel_r. + intros n m p; nzinduct n. - now nzsimpl. + - intro n. nzsimpl. rewrite mul_add_distr_r. + now rewrite add_cancel_r. Qed. Theorem mul_1_l : forall n, 1 * n == n. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index 292f0837c0..dc4167e96f 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -26,16 +26,16 @@ Qed. Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). Proof. -intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). solve_proper. -intros. now nzsimpl. -clear p Hp. intros p Hp IH n m. nzsimpl. -assert (LR : forall n m, n < m -> p * n + n < p * m + m) - by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). -split; intros H. -now apply LR. -destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -rewrite EQ in H. order. -apply LR in GT. order. + intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). - solve_proper. + - intros. now nzsimpl. + - clear p Hp. intros p Hp IH n m. nzsimpl. + assert (LR : forall n m, n < m -> p * n + n < p * m + m) + by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). + split; intros H. + + now apply LR. + + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + * rewrite EQ in H. order. + * apply LR in GT. order. Qed. Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). @@ -47,19 +47,20 @@ Qed. Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). Proof. nzord_induct p. -order. -intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. -intros p Hp IH n m _. apply le_succ_l in Hp. -le_elim Hp. -assert (LR : forall n m, n < m -> p * m < p * n). - intros n1 m1 H. apply (le_lt_add_lt n1 m1). - now apply lt_le_incl. rewrite <- 2 mul_succ_l. now rewrite <- IH. -split; intros H. -now apply LR. -destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -rewrite EQ in H. order. -apply LR in GT. order. -rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. +- order. +- intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. +- intros p Hp IH n m _. apply le_succ_l in Hp. + le_elim Hp. + + assert (LR : forall n m, n < m -> p * m < p * n). + * intros n1 m1 H. apply (le_lt_add_lt n1 m1). + -- now apply lt_le_incl. + -- rewrite <- 2 mul_succ_l. now rewrite <- IH. + * split; intros H. + -- now apply LR. + -- destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + ++ rewrite EQ in H. order. + ++ apply LR in GT. order. + + rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. Qed. Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). @@ -71,17 +72,17 @@ Qed. Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. Proof. intros n m p H1 H2. le_elim H1. -le_elim H2. apply lt_le_incl. now apply mul_lt_mono_pos_l. -apply eq_le_incl; now rewrite H2. -apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. +- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_pos_l. + + apply eq_le_incl; now rewrite H2. +- apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. Qed. Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. Proof. intros n m p H1 H2. le_elim H1. -le_elim H2. apply lt_le_incl. now apply mul_lt_mono_neg_l. -apply eq_le_incl; now rewrite H2. -apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. +- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_neg_l. + + apply eq_le_incl; now rewrite H2. +- apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. Qed. Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. @@ -101,10 +102,10 @@ Proof. intros n m p Hp; split; intro H; [|now f_equiv]. apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp]; destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. -apply (mul_lt_mono_neg_l p) in LT; order. -apply (mul_lt_mono_neg_l p) in GT; order. -apply (mul_lt_mono_pos_l p) in LT; order. -apply (mul_lt_mono_pos_l p) in GT; order. +- apply (mul_lt_mono_neg_l p) in LT; order. +- apply (mul_lt_mono_neg_l p) in GT; order. +- apply (mul_lt_mono_pos_l p) in LT; order. +- apply (mul_lt_mono_pos_l p) in GT; order. Qed. Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). @@ -155,8 +156,8 @@ Theorem mul_lt_mono_nonneg : Proof. intros n m p q H1 H2 H3 H4. apply le_lt_trans with (m * p). -apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. +- apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +- apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. Qed. (* There are still many variants of the theorem above. One can assume 0 < n @@ -167,10 +168,10 @@ Theorem mul_le_mono_nonneg : Proof. intros n m p q H1 H2 H3 H4. le_elim H2; le_elim H4. -apply lt_le_incl; now apply mul_lt_mono_nonneg. -rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. -rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. -rewrite H2; rewrite H4; now apply eq_le_incl. +- apply lt_le_incl; now apply mul_lt_mono_nonneg. +- rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +- rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. +- rewrite H2; rewrite H4; now apply eq_le_incl. Qed. Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. @@ -225,29 +226,29 @@ Qed. Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. Proof. intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. -rewrite mul_1_l in H1. now apply lt_1_l with m. -assumption. +- rewrite mul_1_l in H1. now apply lt_1_l with m. +- assumption. Qed. Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. Proof. intros n m; split. -intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; -destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; -try (now right); try (now left). -exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. -exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. -exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. -exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. -intros [H | H]. now rewrite H, mul_0_l. now rewrite H, mul_0_r. +- intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + try (now right); try (now left). + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. +- intros [H | H]. + now rewrite H, mul_0_l. + now rewrite H, mul_0_r. Qed. Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. Proof. intros n m; split; intro H. -intro H1; apply eq_mul_0 in H1. tauto. -split; intro H1; rewrite H1 in H; -(rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. +- intro H1; apply eq_mul_0 in H1. tauto. +- split; intro H1; rewrite H1 in H; + (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. Qed. Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. @@ -258,13 +259,13 @@ Qed. Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. Proof. intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -assumption. false_hyp H1 H2. +- assumption. - false_hyp H1 H2. Qed. Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. Proof. intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. -false_hyp H1 H2. assumption. +- false_hyp H1 H2. - assumption. Qed. (** Some alternative names: *) @@ -276,16 +277,16 @@ Definition mul_eq_0_r := eq_mul_0_r. Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). Proof. split; [intro H | intros [[H1 H2] | [H1 H2]]]. -destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; -[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; -(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; -[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); -try (left; now split); try (right; now split). -assert (H3 : n * m < 0) by now apply mul_neg_pos. -exfalso; now apply (lt_asymm (n * m) 0). -assert (H3 : n * m < 0) by now apply mul_pos_neg. -exfalso; now apply (lt_asymm (n * m) 0). -now apply mul_pos_pos. now apply mul_neg_neg. +- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; + (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); + try (left; now split); try (right; now split). + + assert (H3 : n * m < 0) by now apply mul_neg_pos. + exfalso; now apply (lt_asymm (n * m) 0). + + assert (H3 : n * m < 0) by now apply mul_pos_neg. + exfalso; now apply (lt_asymm (n * m) 0). +- now apply mul_pos_pos. - now apply mul_neg_neg. Qed. Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. @@ -304,38 +305,38 @@ other variable *) Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. Proof. intros n m H1 H2. destruct (lt_ge_cases n 0). -now apply lt_le_trans with 0. -destruct (lt_ge_cases n m) as [LT|LE]; trivial. -apply square_le_mono_nonneg in LE; order. +- now apply lt_le_trans with 0. +- destruct (lt_ge_cases n m) as [LT|LE]; trivial. + apply square_le_mono_nonneg in LE; order. Qed. Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. Proof. intros n m H1 H2. destruct (lt_ge_cases n 0). -apply lt_le_incl; now apply lt_le_trans with 0. -destruct (le_gt_cases n m) as [LE|LT]; trivial. -apply square_lt_mono_nonneg in LT; order. +- apply lt_le_incl; now apply lt_le_trans with 0. +- destruct (le_gt_cases n m) as [LE|LT]; trivial. + apply square_lt_mono_nonneg in LT; order. Qed. Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m. Proof. intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two). -rewrite two_succ. nzsimpl. now rewrite le_succ_l. -order'. +- rewrite two_succ. nzsimpl. now rewrite le_succ_l. +- order'. Qed. Lemma add_le_mul : forall a b, 1<a -> 1<b -> a+b <= a*b. Proof. assert (AUX : forall a b, 0<a -> 0<b -> (S a)+(S b) <= (S a)*(S b)). - intros a b Ha Hb. - nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. - rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). - apply add_lt_mono_r. - now apply mul_pos_pos. - intros a b Ha Hb. - assert (Ha' := lt_succ_pred 1 a Ha). - assert (Hb' := lt_succ_pred 1 b Hb). - rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. + - intros a b Ha Hb. + nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. + rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). + apply add_lt_mono_r. + now apply mul_pos_pos. + - intros a b Ha Hb. + assert (Ha' := lt_succ_pred 1 a Ha). + assert (Hb' := lt_succ_pred 1 b Hb). + rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. Qed. (** A few results about squares *) @@ -343,25 +344,25 @@ Qed. Lemma square_nonneg : forall a, 0 <= a * a. Proof. intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). - now apply mul_le_mono_nonpos_l. - apply mul_le_mono_nonneg_l; order. + - now apply mul_le_mono_nonpos_l. + - apply mul_le_mono_nonneg_l; order. Qed. Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b. Proof. assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b). - intros a b (Ha,H). - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. order. - intros a b Ha Hb. - destruct (le_gt_cases a b). - apply AUX; split; order. - rewrite (add_comm (b*a)), (add_comm (a*a)). - apply AUX; split; order. + - intros a b (Ha,H). + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. order. + - intros a b Ha Hb. + destruct (le_gt_cases a b). + + apply AUX; split; order. + + rewrite (add_comm (b*a)), (add_comm (a*a)). + apply AUX; split; order. Qed. Lemma add_square_le : forall a b, 0<=a -> 0<=b -> diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 60e1123b35..89bc5cfecb 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -60,19 +60,19 @@ Qed. Theorem nle_succ_diag_l : forall n, ~ S n <= n. Proof. intros n H; le_elim H. -false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l. ++ false_hyp H nlt_succ_diag_l. + false_hyp H neq_succ_diag_l. Qed. Theorem le_succ_l : forall n m, S n <= m <-> n < m. Proof. intro n; nzinduct m n. -split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl. -intro m. -rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. -rewrite or_cancel_r. -reflexivity. -intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. -intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. +- split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. +- intro m. + rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. + rewrite or_cancel_r. + + reflexivity. + + intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. + + intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. Qed. (** Trichotomy *) @@ -80,8 +80,8 @@ Qed. Theorem le_gt_cases : forall n m, n <= m \/ n > m. Proof. intros n m; nzinduct n m. -left; apply le_refl. -intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition. +- left; apply le_refl. +- intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition. Qed. Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. @@ -96,14 +96,14 @@ Notation lt_eq_gt_cases := lt_trichotomy (only parsing). Theorem lt_asymm : forall n m, n < m -> ~ m < n. Proof. intros n m; nzinduct n m. -intros H; false_hyp H lt_irrefl. -intro n; split; intros H H1 H2. -apply lt_succ_r in H2. le_elim H2. -apply H; auto. apply le_succ_l. now apply lt_le_incl. -rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. -apply le_succ_l in H1. le_elim H1. -apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. -rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. +- intros H; false_hyp H lt_irrefl. +- intro n; split; intros H H1 H2. + + apply lt_succ_r in H2. le_elim H2. + * apply H; auto. apply le_succ_l. now apply lt_le_incl. + * rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. + + apply le_succ_l in H1. le_elim H1. + * apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. + * rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. Qed. Notation lt_ngt := lt_asymm (only parsing). @@ -111,13 +111,15 @@ Notation lt_ngt := lt_asymm (only parsing). Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. Proof. intros n m p; nzinduct p m. -intros _ H; false_hyp H lt_irrefl. -intro p. rewrite 2 lt_succ_r. -split; intros H H1 H2. -apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. -assert (n <= p) as H3 by (auto using lt_le_incl). -le_elim H3. assumption. rewrite <- H3 in H2. -elim (lt_asymm n m); auto. +- intros _ H; false_hyp H lt_irrefl. +- intro p. rewrite 2 lt_succ_r. + split; intros H H1 H2. + + apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. + + assert (n <= p) as H3 by (auto using lt_le_incl). + le_elim H3. + * assumption. + * rewrite <- H3 in H2. + elim (lt_asymm n m); auto. Qed. Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. @@ -130,16 +132,16 @@ Qed. (** Some type classes about order *) Instance lt_strorder : StrictOrder lt. -Proof. split. exact lt_irrefl. exact lt_trans. Qed. +Proof. split. - exact lt_irrefl. - exact lt_trans. Qed. Instance le_preorder : PreOrder le. -Proof. split. exact le_refl. exact le_trans. Qed. +Proof. split. - exact le_refl. - exact le_trans. Qed. Instance le_partialorder : PartialOrder _ le. Proof. intros x y. compute. split. -intro EQ; now rewrite EQ. -rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y. +- intro EQ; now rewrite EQ. +- rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y. Qed. (** We know enough now to benefit from the generic [order] tactic. *) @@ -246,7 +248,7 @@ Qed. Theorem lt_0_2 : 0 < 2. Proof. -transitivity 1. apply lt_0_1. apply lt_1_2. + transitivity 1. - apply lt_0_1. - apply lt_1_2. Qed. Theorem le_0_2 : 0 <= 2. @@ -300,9 +302,9 @@ Qed. Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. Proof. intros n m; split; intro H. -destruct (eq_decidable n m) as [H1 | H1]. -assumption. false_hyp H1 H. -intro H1; now apply H1. +- destruct (eq_decidable n m) as [H1 | H1]. + + assumption. + false_hyp H1 H. +- intro H1; now apply H1. Qed. Theorem le_ngt : forall n m, n <= m <-> ~ n > m. @@ -321,8 +323,8 @@ Qed. Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. Proof. intros n m; split; intro H. -destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -intro H1; false_hyp H H1. +- destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +- intro H1; false_hyp H H1. Qed. Theorem nle_gt : forall n m, ~ n <= m <-> n > m. @@ -341,8 +343,8 @@ Qed. Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. Proof. intros n m; split; intro H. -destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. -intro H1; false_hyp H H1. +- destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +- intro H1; false_hyp H H1. Qed. Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. @@ -361,18 +363,18 @@ Lemma lt_exists_pred_strong : forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k. Proof. intro z; nzinduct n z. -order. -intro n; split; intros IH m H1 H2. -apply le_succ_r in H2. destruct H2 as [H2 | H2]. -now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. -apply IH. assumption. now apply le_le_succ_r. +- order. +- intro n; split; intros IH m H1 H2. + + apply le_succ_r in H2. destruct H2 as [H2 | H2]. + * now apply IH. * exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. + + apply IH. * assumption. * now apply le_le_succ_r. Qed. Theorem lt_exists_pred : forall z n, z < n -> exists k, n == S k /\ z <= k. Proof. intros z n H; apply lt_exists_pred_strong with (z := z) (n := n). -assumption. apply le_refl. +- assumption. - apply le_refl. Qed. Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n. @@ -404,18 +406,19 @@ Let right_step'' := forall n, A' n <-> A' (S n). Lemma rs_rs' : A z -> right_step -> right_step'. Proof. intros Az RS n H1 H2. -le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. -rewrite H3. apply RS; trivial. apply H2; trivial. -rewrite H3; apply lt_succ_diag_r. -rewrite <- H1; apply Az. +le_elim H1. +- apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. + rewrite H3. apply RS; trivial. apply H2; trivial. + rewrite H3; apply lt_succ_diag_r. +- rewrite <- H1; apply Az. Qed. Lemma rs'_rs'' : right_step' -> right_step''. Proof. intros RS' n; split; intros H1 m H2 H3. -apply lt_succ_r in H3; le_elim H3; -[now apply H1 | rewrite H3 in *; now apply RS']. -apply H1; [assumption | now apply lt_lt_succ_r]. +- apply lt_succ_r in H3; le_elim H3; + [now apply H1 | rewrite H3 in *; now apply RS']. +- apply H1; [assumption | now apply lt_lt_succ_r]. Qed. Lemma rbase : A' z. @@ -444,10 +447,12 @@ Theorem right_induction' : Proof. intros L R n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply L; now apply lt_le_incl. -apply L; now apply eq_le_incl. -apply right_induction. apply L; now apply eq_le_incl. assumption. -now apply lt_le_incl. +- apply L; now apply lt_le_incl. +- apply L; now apply eq_le_incl. +- apply right_induction. + + apply L; now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. Qed. Theorem strong_right_induction' : @@ -455,9 +460,10 @@ Theorem strong_right_induction' : Proof. intros L R n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply L; now apply lt_le_incl. -apply L; now apply eq_le_incl. -apply strong_right_induction. assumption. now apply lt_le_incl. +- apply L; now apply lt_le_incl. +- apply L; now apply eq_le_incl. +- apply strong_right_induction. + + assumption. + now apply lt_le_incl. Qed. End RightInduction. @@ -472,17 +478,17 @@ Let left_step'' := forall n, A' n <-> A' (S n). Lemma ls_ls' : A z -> left_step -> left_step'. Proof. intros Az LS n H1 H2. le_elim H1. -apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. -rewrite H1; apply Az. +- apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. +- rewrite H1; apply Az. Qed. Lemma ls'_ls'' : left_step' -> left_step''. Proof. intros LS' n; split; intros H1 m H2 H3. -apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1. -le_elim H3. -apply le_succ_l in H3. now apply H1. -rewrite <- H3 in *; now apply LS'. +- apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1. +- le_elim H3. + + apply le_succ_l in H3. now apply H1. + + rewrite <- H3 in *; now apply LS'. Qed. Lemma lbase : A' (S z). @@ -512,10 +518,12 @@ Theorem left_induction' : Proof. intros R L n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply left_induction. apply R. now apply eq_le_incl. assumption. -now apply lt_le_incl. -rewrite H; apply R; now apply eq_le_incl. -apply R; now apply lt_le_incl. +- apply left_induction. + + apply R. now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. +- rewrite H; apply R; now apply eq_le_incl. +- apply R; now apply lt_le_incl. Qed. Theorem strong_left_induction' : @@ -523,9 +531,9 @@ Theorem strong_left_induction' : Proof. intros R L n. destruct (lt_trichotomy n z) as [H | [H | H]]. -apply strong_left_induction; auto. now apply lt_le_incl. -rewrite H; apply R; now apply eq_le_incl. -apply R; now apply lt_le_incl. +- apply strong_left_induction; auto. now apply lt_le_incl. +- rewrite H; apply R; now apply eq_le_incl. +- apply R; now apply lt_le_incl. Qed. End LeftInduction. @@ -538,9 +546,9 @@ Theorem order_induction : Proof. intros Az RS LS n. destruct (lt_trichotomy n z) as [H | [H | H]]. -now apply left_induction; [| | apply lt_le_incl]. -now rewrite H. -now apply right_induction; [| | apply lt_le_incl]. +- now apply left_induction; [| | apply lt_le_incl]. +- now rewrite H. +- now apply right_induction; [| | apply lt_le_incl]. Qed. Theorem order_induction' : @@ -622,21 +630,24 @@ Theorem lt_wf : well_founded Rlt. Proof. unfold well_founded. apply strong_right_induction' with (z := z). -auto with typeclass_instances. -intros n H; constructor; intros y [H1 H2]. -apply nle_gt in H2. elim H2. now apply le_trans with z. -intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. +- auto with typeclass_instances. +- intros n H; constructor; intros y [H1 H2]. + apply nle_gt in H2. elim H2. now apply le_trans with z. +- intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. Qed. Theorem gt_wf : well_founded Rgt. Proof. unfold well_founded. apply strong_left_induction' with (z := z). -auto with typeclass_instances. -intros n H; constructor; intros y [H1 H2]. -apply nle_gt in H2. elim H2. now apply le_lt_trans with n. -intros n H1 H2; constructor; intros m [H3 H4]. -apply H2. assumption. now apply le_succ_l. +- auto with typeclass_instances. +- intros n H; constructor; intros y [H1 H2]. + apply nle_gt in H2. + + elim H2. + + now apply le_lt_trans with n. +- intros n H1 H2; constructor; intros m [H3 H4]. + apply H2. + + assumption. + now apply le_succ_l. Qed. End WF. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index 93d99f08f5..84b8a96e64 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -48,20 +48,20 @@ Qed. Lemma Even_or_Odd : forall x, Even x \/ Odd x. Proof. nzinduct x. - left. exists 0. now nzsimpl. - intros x. - split; intros [(y,H)|(y,H)]. - right. exists y. rewrite H. now nzsimpl. - left. exists (S y). rewrite H. now nzsimpl'. - right. - assert (LT : exists z, z<y). - destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x]. - rewrite <- le_succ_l, H. nzsimpl'. - rewrite <- (add_0_r y) at 3. now apply add_le_mono_l. - destruct LT as (z,LT). - destruct (lt_exists_pred z y LT) as (y' & Hy' & _). - exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'. - left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl. + - left. exists 0. now nzsimpl. + - intros x. + split; intros [(y,H)|(y,H)]. + + right. exists y. rewrite H. now nzsimpl. + + left. exists (S y). rewrite H. now nzsimpl'. + + right. + assert (LT : exists z, z<y). + * destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x]. + rewrite <- le_succ_l, H. nzsimpl'. + rewrite <- (add_0_r y) at 3. now apply add_le_mono_l. + * destruct LT as (z,LT). + destruct (lt_exists_pred z y LT) as (y' & Hy' & _). + exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'. + + left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl. Qed. Lemma double_below : forall n m, n<=m -> 2*n < 2*m+1. @@ -80,16 +80,16 @@ Lemma Even_Odd_False : forall x, Even x -> Odd x -> False. Proof. intros x (y,E) (z,O). rewrite O in E; clear O. destruct (le_gt_cases y z) as [LE|GT]. -generalize (double_below _ _ LE); order. -generalize (double_above _ _ GT); order. +- generalize (double_below _ _ LE); order. +- generalize (double_above _ _ GT); order. Qed. Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. Proof. intros. destruct (Even_or_Odd n) as [H|H]. - rewrite <- even_spec in H. now rewrite H. - rewrite <- odd_spec in H. now rewrite H, orb_true_r. + - rewrite <- even_spec in H. now rewrite H. + - rewrite <- odd_spec in H. now rewrite H, orb_true_r. Qed. Lemma negb_odd : forall n, negb (odd n) = even n. @@ -142,8 +142,8 @@ Qed. Lemma Odd_succ : forall n, Odd (S n) <-> Even n. Proof. split; intros (m,H). - exists m. apply succ_inj. now rewrite add_1_r in H. - exists m. rewrite add_1_r. now f_equiv. + - exists m. apply succ_inj. now rewrite add_1_r in H. + - exists m. rewrite add_1_r. now f_equiv. Qed. Lemma odd_succ : forall n, odd (S n) = even n. @@ -192,10 +192,10 @@ Proof. case_eq (even n); case_eq (even m); rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; intros (m',Hm) (n',Hn). - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. + - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. Qed. Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). @@ -210,14 +210,14 @@ Lemma even_mul : forall n m, even (mul n m) = even n || even m. Proof. intros. case_eq (even n); simpl; rewrite ?even_spec. - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. - case_eq (even m); simpl; rewrite ?even_spec. - intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). - (* odd / odd *) - rewrite <- !negb_true_iff, !negb_even, !odd_spec. - intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). - rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. - now rewrite add_shuffle1, add_assoc, !mul_assoc. + - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. + - case_eq (even m); simpl; rewrite ?even_spec. + + intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). + (* odd / odd *) + + rewrite <- !negb_true_iff, !negb_even, !odd_spec. + intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). + rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. + now rewrite add_shuffle1, add_assoc, !mul_assoc. Qed. Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index a1310667e1..830540bc66 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -60,8 +60,8 @@ Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0. Proof. intros a Ha. destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order. - now rewrite pow_neg_r. - now apply pow_0_l. + - now rewrite pow_neg_r. + - now apply pow_0_l. Qed. Lemma pow_1_r : forall a, a^1 == a. @@ -71,9 +71,9 @@ Qed. Lemma pow_1_l : forall a, 0<=a -> 1^a == 1. Proof. - apply le_ind; intros. solve_proper. - now nzsimpl. - now nzsimpl. + apply le_ind; intros. - solve_proper. + - now nzsimpl. + - now nzsimpl. Qed. Hint Rewrite pow_1_r pow_1_l : nz. @@ -90,12 +90,12 @@ Hint Rewrite pow_2_r : nz. Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0. Proof. intros a b Hb. apply le_ind with (4:=Hb). - solve_proper. - rewrite pow_0_r. order'. - clear b Hb. intros b Hb IH. - rewrite pow_succ_r by trivial. - intros H. apply eq_mul_0 in H. destruct H; trivial. - now apply IH. + - solve_proper. + - rewrite pow_0_r. order'. + - clear b Hb. intros b Hb IH. + rewrite pow_succ_r by trivial. + intros H. apply eq_mul_0 in H. destruct H; trivial. + now apply IH. Qed. Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0. @@ -106,13 +106,13 @@ Qed. Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0<b /\ a==0). Proof. intros a b. split. - intros H. - destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]]. - now left. - rewrite Hb, pow_0_r in H; order'. - right. split; trivial. apply pow_eq_0 with b; order. - intros [Hb|[Hb Ha]]. now rewrite pow_neg_r. - rewrite Ha. apply pow_0_l'. order. + - intros H. + destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]]. + + now left. + + rewrite Hb, pow_0_r in H; order'. + + right. split; trivial. apply pow_eq_0 with b; order. + - intros [Hb|[Hb Ha]]. + now rewrite pow_neg_r. + + rewrite Ha. apply pow_0_l'. order. Qed. (** Power and addition, multiplication *) @@ -120,12 +120,12 @@ Qed. Lemma pow_add_r : forall a b c, 0<=b -> 0<=c -> a^(b+c) == a^b * a^c. Proof. - intros a b c Hb. apply le_ind with (4:=Hb). solve_proper. - now nzsimpl. - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - rewrite IH; trivial. apply mul_assoc. - now apply add_nonneg_nonneg. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + + rewrite IH; trivial. apply mul_assoc. + + now apply add_nonneg_nonneg. Qed. Lemma pow_mul_l : forall a b c, @@ -133,23 +133,23 @@ Lemma pow_mul_l : forall a b c, Proof. intros a b c. destruct (lt_ge_cases c 0) as [Hc|Hc]. - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. - apply le_ind with (4:=Hc). solve_proper. - now nzsimpl. - clear c Hc. intros c Hc IH. - nzsimpl; trivial. - rewrite IH; trivial. apply mul_shuffle1. + - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. + - apply le_ind with (4:=Hc). + solve_proper. + + now nzsimpl. + + clear c Hc. intros c Hc IH. + nzsimpl; trivial. + rewrite IH; trivial. apply mul_shuffle1. Qed. Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c -> a^(b*c) == (a^b)^c. Proof. - intros a b c Hb. apply le_ind with (4:=Hb). solve_proper. - intros. now nzsimpl. - clear b Hb. intros b Hb IH Hc. - nzsimpl; trivial. - rewrite pow_add_r, IH, pow_mul_l; trivial. apply mul_comm. - now apply mul_nonneg_nonneg. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - intros. now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + rewrite pow_add_r, IH, pow_mul_l; trivial. + apply mul_comm. + + now apply mul_nonneg_nonneg. Qed. (** Positivity *) @@ -158,67 +158,67 @@ Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b. Proof. intros a b Ha. destruct (lt_ge_cases b 0) as [Hb|Hb]. - now rewrite !(pow_neg_r _ _ Hb). - apply le_ind with (4:=Hb). solve_proper. - nzsimpl; order'. - clear b Hb. intros b Hb IH. - nzsimpl; trivial. now apply mul_nonneg_nonneg. + - now rewrite !(pow_neg_r _ _ Hb). + - apply le_ind with (4:=Hb). + solve_proper. + + nzsimpl; order'. + + clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_nonneg_nonneg. Qed. Lemma pow_pos_nonneg : forall a b, 0<a -> 0<=b -> 0<a^b. Proof. - intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper. - nzsimpl; order'. - clear b Hb. intros b Hb IH. - nzsimpl; trivial. now apply mul_pos_pos. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl; order'. + - clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_pos_pos. Qed. (** Monotonicity *) Lemma pow_lt_mono_l : forall a b c, 0<c -> 0<=a<b -> a^c < b^c. Proof. - intros a b c Hc. apply lt_ind with (4:=Hc). solve_proper. - intros (Ha,H). nzsimpl; trivial; order. - clear c Hc. intros c Hc IH (Ha,H). - nzsimpl; try order. - apply mul_lt_mono_nonneg; trivial. - apply pow_nonneg; try order. - apply IH. now split. + intros a b c Hc. apply lt_ind with (4:=Hc). - solve_proper. + - intros (Ha,H). nzsimpl; trivial; order. + - clear c Hc. intros c Hc IH (Ha,H). + nzsimpl; try order. + apply mul_lt_mono_nonneg; trivial. + + apply pow_nonneg; try order. + + apply IH. now split. Qed. Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c. Proof. intros a b c (Ha,H). destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]]. - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. - rewrite Hc; now nzsimpl. - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_l; now try split. + - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. + - rewrite Hc; now nzsimpl. + - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_l; now try split. Qed. Lemma pow_gt_1 : forall a b, 1<a -> (0<b <-> 1<a^b). Proof. intros a b Ha. split; intros Hb. - rewrite <- (pow_1_l b) by order. - apply pow_lt_mono_l; try split; order'. - destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial. - rewrite pow_neg_r in Hb; order'. - rewrite H, pow_0_r in Hb. order. + - rewrite <- (pow_1_l b) by order. + apply pow_lt_mono_l; try split; order'. + - destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial. + + rewrite pow_neg_r in Hb; order'. + + rewrite H, pow_0_r in Hb. order. Qed. Lemma pow_lt_mono_r : forall a b c, 1<a -> 0<=c -> b<c -> a^b < a^c. Proof. intros a b c Ha Hc H. destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. - assert (H' : b<=c) by order. - destruct (le_exists_sub _ _ H') as (d & EQ & Hd). - rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. - apply mul_lt_mono_pos_r. - apply pow_pos_nonneg; order'. - apply pow_gt_1; trivial. - apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. - rewrite <- EQ' in *. rewrite add_0_l in EQ. order. + - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. + - assert (H' : b<=c) by order. + destruct (le_exists_sub _ _ H') as (d & EQ & Hd). + rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. + apply mul_lt_mono_pos_r. + + apply pow_pos_nonneg; order'. + + apply pow_gt_1; trivial. + apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. + rewrite <- EQ' in *. rewrite add_0_l in EQ. order. Qed. (** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) @@ -227,20 +227,20 @@ Lemma pow_le_mono_r : forall a b c, 0<a -> b<=c -> a^b <= a^c. Proof. intros a b c Ha H. destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. - apply le_succ_l in Ha; rewrite <- one_succ in Ha. - apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. - apply lt_le_incl, pow_lt_mono_r; order. - nzsimpl; order. + - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. + - apply le_succ_l in Ha; rewrite <- one_succ in Ha. + apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. + + apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_r; order. + + nzsimpl; order. Qed. Lemma pow_le_mono : forall a b c d, 0<a<=c -> b<=d -> a^b <= c^d. Proof. intros. transitivity (a^d). - apply pow_le_mono_r; intuition order. - apply pow_le_mono_l; intuition order. + - apply pow_le_mono_r; intuition order. + - apply pow_le_mono_l; intuition order. Qed. Lemma pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d -> @@ -249,10 +249,10 @@ Proof. intros a b c d (Ha,Hac) (Hb,Hbd). apply le_succ_l in Ha; rewrite <- one_succ in Ha. apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. - transitivity (a^d). - apply pow_lt_mono_r; intuition order. - apply pow_lt_mono_l; try split; order'. - nzsimpl; try order. apply pow_gt_1; order. + - transitivity (a^d). + + apply pow_lt_mono_r; intuition order. + + apply pow_lt_mono_l; try split; order'. + - nzsimpl; try order. apply pow_gt_1; order. Qed. (** Injectivity *) @@ -262,10 +262,10 @@ Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0<c -> Proof. intros a b c Ha Hb Hc EQ. destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial. - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). - order. - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. + - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). + order. + - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. Qed. Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c -> @@ -273,10 +273,10 @@ Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c -> Proof. intros a b c Ha Hb Hc EQ. destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial. - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). - order. - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). - order. + - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). + order. + - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). + order. Qed. (** Monotonicity results, both ways *) @@ -286,10 +286,10 @@ Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> Proof. intros a b c Ha Hb Hc. split; intro LT. - apply pow_lt_mono_l; try split; trivial. - destruct (le_gt_cases b a) as [LE|GT]; trivial. - assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). - order. + - apply pow_lt_mono_l; try split; trivial. + - destruct (le_gt_cases b a) as [LE|GT]; trivial. + assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). + order. Qed. Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> @@ -297,10 +297,10 @@ Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> Proof. intros a b c Ha Hb Hc. split; intro LE. - apply pow_le_mono_l; try split; trivial. - destruct (le_gt_cases a b) as [LE'|GT]; trivial. - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). - order. + - apply pow_le_mono_l; try split; trivial. + - destruct (le_gt_cases a b) as [LE'|GT]; trivial. + assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. Qed. Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c -> @@ -308,10 +308,10 @@ Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c -> Proof. intros a b c Ha Hc. split; intro LT. - now apply pow_lt_mono_r. - destruct (le_gt_cases c b) as [LE|GT]; trivial. - assert (a^c <= a^b) by (apply pow_le_mono_r; order'). - order. + - now apply pow_lt_mono_r. + - destruct (le_gt_cases c b) as [LE|GT]; trivial. + assert (a^c <= a^b) by (apply pow_le_mono_r; order'). + order. Qed. Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c -> @@ -319,26 +319,26 @@ Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c -> Proof. intros a b c Ha Hc. split; intro LE. - apply pow_le_mono_r; order'. - destruct (le_gt_cases b c) as [LE'|GT]; trivial. - assert (a^c < a^b) by (apply pow_lt_mono_r; order'). - order. + - apply pow_le_mono_r; order'. + - destruct (le_gt_cases b c) as [LE'|GT]; trivial. + assert (a^c < a^b) by (apply pow_lt_mono_r; order'). + order. Qed. (** For any a>1, the a^x function is above the identity function *) Lemma pow_gt_lin_r : forall a b, 1<a -> 0<=b -> b < a^b. Proof. - intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper. - nzsimpl. order'. - clear b Hb. intros b Hb IH. nzsimpl; trivial. - rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. - transitivity (2*(S b)). - nzsimpl'. rewrite <- 2 succ_le_mono. - rewrite <- (add_0_l b) at 1. apply add_le_mono; order. - apply mul_le_mono_nonneg; trivial. - order'. - now apply lt_le_incl, lt_succ_r. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl. order'. + - clear b Hb. intros b Hb IH. nzsimpl; trivial. + rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. + transitivity (2*(S b)). + + nzsimpl'. rewrite <- 2 succ_le_mono. + rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + apply mul_le_mono_nonneg; trivial. + * order'. + * now apply lt_le_incl, lt_succ_r. Qed. (** Someday, we should say something about the full Newton formula. @@ -349,22 +349,22 @@ Qed. Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0<c -> a^c + b^c <= (a+b)^c. Proof. - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper. - nzsimpl; order. - clear c Hc. intros c Hc IH. - assert (0<=c) by order'. - nzsimpl; trivial. - transitivity ((a+b)*(a^c + b^c)). - rewrite mul_add_distr_r, !mul_add_distr_l. - apply add_le_mono. - rewrite <- add_0_r at 1. apply add_le_mono_l. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - rewrite <- add_0_l at 1. apply add_le_mono_r. - apply mul_nonneg_nonneg; trivial. - apply pow_nonneg; trivial. - apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. + intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). - solve_proper. + - nzsimpl; order. + - clear c Hc. intros c Hc IH. + assert (0<=c) by order'. + nzsimpl; trivial. + transitivity ((a+b)*(a^c + b^c)). + + rewrite mul_add_distr_r, !mul_add_distr_l. + apply add_le_mono. + * rewrite <- add_0_r at 1. apply add_le_mono_l. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + * rewrite <- add_0_l at 1. apply add_le_mono_r. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + + apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. Qed. (** This upper bound can also be seen as a convexity proof for x^c : @@ -377,37 +377,37 @@ Proof. assert (aux : forall a b c, 0<=a<=b -> 0<c -> (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)). (* begin *) - intros a b c (Ha,H) Hc. - rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. - rewrite <- !add_assoc. apply add_le_mono_l. - rewrite !add_assoc. apply add_le_mono_r. - destruct (le_exists_sub _ _ H) as (d & EQ & Hd). - rewrite EQ. - rewrite 2 mul_add_distr_r. - rewrite !add_assoc. apply add_le_mono_r. - rewrite add_comm. apply add_le_mono_l. - apply mul_le_mono_nonneg_l; trivial. - apply pow_le_mono_l; try split; order. - (* end *) - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper. - nzsimpl; order. - clear c Hc. intros c Hc IH. - assert (0<=c) by order. - nzsimpl; trivial. - transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). - apply mul_le_mono_nonneg_l; trivial. - now apply add_nonneg_nonneg. - rewrite mul_assoc. rewrite (mul_comm (a+b)). - assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). - assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). - assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). - rewrite EQ', <- !mul_assoc. - apply mul_le_mono_nonneg_l. - apply pow_nonneg; order'. - destruct (le_gt_cases a b). - apply aux; try split; order'. - rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). - apply aux; try split; order'. + - intros a b c (Ha,H) Hc. + rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. + rewrite <- !add_assoc. apply add_le_mono_l. + rewrite !add_assoc. apply add_le_mono_r. + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. + apply pow_le_mono_l; try split; order. + (* end *) + - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). + solve_proper. + + nzsimpl; order. + + clear c Hc. intros c Hc IH. + assert (0<=c) by order. + nzsimpl; trivial. + transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). + * apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. + * rewrite mul_assoc. rewrite (mul_comm (a+b)). + assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). + assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). + assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). + rewrite EQ', <- !mul_assoc. + apply mul_le_mono_nonneg_l. + -- apply pow_nonneg; order'. + -- destruct (le_gt_cases a b). + ++ apply aux; try split; order'. + ++ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). + apply aux; try split; order'. Qed. End NZPowProp. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index c2d2c4ae19..85ed71b8a4 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -49,18 +49,18 @@ Proof. intros b LT. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso. assert ((S b)² < b²). - rewrite mul_succ_l, <- (add_0_r b²). - apply add_lt_le_mono. - apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. - now apply le_succ_l. - order. + - rewrite mul_succ_l, <- (add_0_r b²). + apply add_lt_le_mono. + + apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. + + now apply le_succ_l. + - order. Qed. Lemma sqrt_nonneg : forall a, 0<=√a. Proof. intros. destruct (lt_ge_cases a 0) as [Ha|Ha]. - now rewrite (sqrt_neg _ Ha). - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. + - now rewrite (sqrt_neg _ Ha). + - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. Qed. (** The spec of sqrt indeed determines it *) @@ -73,12 +73,12 @@ Proof. assert (Ha': 0<=√a) by now apply sqrt_nonneg. destruct (sqrt_spec a Ha) as (LEa,LTa). assert (b <= √a). - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - assert (√a <= b). - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. - now apply lt_le_incl, lt_succ_r. - order. + - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + - assert (√a <= b). + + apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + + order. Qed. (** Hence sqrt is a morphism *) @@ -87,9 +87,9 @@ Instance sqrt_wd : Proper (eq==>eq) sqrt. Proof. intros x x' Hx. destruct (lt_ge_cases x 0) as [H|H]. - rewrite 2 sqrt_neg; trivial. reflexivity. - now rewrite <- Hx. - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. + - rewrite 2 sqrt_neg; trivial. + reflexivity. + + now rewrite <- Hx. + - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. Qed. (** An alternate specification *) @@ -101,11 +101,11 @@ Proof. destruct (sqrt_spec _ Ha) as (LE,LT). destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). exists r. - split. now rewrite add_comm. - split. trivial. - apply (add_le_mono_r _ _ (√a)²). - rewrite <- Hr, add_comm. - generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_le_mono_r _ _ (√a)²). + rewrite <- Hr, add_comm. + generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. Qed. Lemma sqrt_unique' : forall a b c, 0<=c<=2*b -> @@ -115,10 +115,10 @@ Proof. apply sqrt_unique. rewrite EQ. split. - rewrite <- add_0_r at 1. now apply add_le_mono_l. - nzsimpl. apply lt_succ_r. - rewrite <- add_assoc. apply add_le_mono_l. - generalize H; now nzsimpl'. + - rewrite <- add_0_r at 1. now apply add_le_mono_l. + - nzsimpl. apply lt_succ_r. + rewrite <- add_assoc. apply add_le_mono_l. + generalize H; now nzsimpl'. Qed. (** Sqrt is exact on squares *) @@ -127,7 +127,7 @@ Lemma sqrt_square : forall a, 0<=a -> √(a²) == a. Proof. intros a Ha. apply sqrt_unique' with 0. - split. order. apply mul_nonneg_nonneg; order'. now nzsimpl. + - split. + order. + apply mul_nonneg_nonneg; order'. - now nzsimpl. Qed. (** Sqrt and predecessors of squares *) @@ -138,14 +138,14 @@ Proof. apply sqrt_unique. assert (EQ := lt_succ_pred 0 a Ha). rewrite EQ. split. - apply lt_succ_r. - rewrite (lt_succ_pred 0). - assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). - assert (P a < a) by (now rewrite <- le_succ_l, EQ). - apply mul_lt_mono_nonneg; trivial. - now apply mul_pos_pos. - apply le_succ_l. - rewrite (lt_succ_pred 0). reflexivity. now apply mul_pos_pos. + - apply lt_succ_r. + rewrite (lt_succ_pred 0). + + assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). + assert (P a < a) by (now rewrite <- le_succ_l, EQ). + apply mul_lt_mono_nonneg; trivial. + + now apply mul_pos_pos. + - apply le_succ_l. + rewrite (lt_succ_pred 0). + reflexivity. + now apply mul_pos_pos. Qed. (** Sqrt is a monotone function (but not a strict one) *) @@ -154,13 +154,13 @@ Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b. Proof. intros a b Hab. destruct (lt_ge_cases a 0) as [Ha|Ha]. - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. - assert (Hb : 0 <= b) by order. - destruct (sqrt_spec a Ha) as (LE,_). - destruct (sqrt_spec b Hb) as (_,LT). - apply lt_succ_r. - apply square_lt_simpl_nonneg; try order. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. + - assert (Hb : 0 <= b) by order. + destruct (sqrt_spec a Ha) as (LE,_). + destruct (sqrt_spec b Hb) as (_,LT). + apply lt_succ_r. + apply square_lt_simpl_nonneg; try order. + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. Qed. (** No reverse result for <=, consider for instance √2 <= √1 *) @@ -169,16 +169,16 @@ Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b. Proof. intros a b H. destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. - destruct (sqrt_spec a Ha) as (_,LT). - destruct (sqrt_spec b Hb) as (LE,_). - apply le_succ_l in H. - assert ((S (√a))² <= (√b)²). - apply mul_le_mono_nonneg; trivial. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - order. + - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. + - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. + destruct (sqrt_spec a Ha) as (_,LT). + destruct (sqrt_spec b Hb) as (LE,_). + apply le_succ_l in H. + assert ((S (√a))² <= (√b)²). + + apply mul_le_mono_nonneg; trivial. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + order. Qed. (** When left side is a square, we have an equivalence for <= *) @@ -186,11 +186,11 @@ Qed. Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a). Proof. intros a b Ha Hb. split; intros H. - rewrite <- (sqrt_square b); trivial. - now apply sqrt_le_mono. - destruct (sqrt_spec a Ha) as (LE,LT). - transitivity (√a)²; trivial. - now apply mul_le_mono_nonneg. + - rewrite <- (sqrt_square b); trivial. + now apply sqrt_le_mono. + - destruct (sqrt_spec a Ha) as (LE,LT). + transitivity (√a)²; trivial. + now apply mul_le_mono_nonneg. Qed. (** When right side is a square, we have an equivalence for < *) @@ -198,10 +198,10 @@ Qed. Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a<b² <-> √a < b). Proof. intros a b Ha Hb. split; intros H. - destruct (sqrt_spec a Ha) as (LE,_). - apply square_lt_simpl_nonneg; try order. - rewrite <- (sqrt_square b Hb) in H. - now apply sqrt_lt_cancel. + - destruct (sqrt_spec a Ha) as (LE,_). + apply square_lt_simpl_nonneg; try order. + - rewrite <- (sqrt_square b Hb) in H. + now apply sqrt_lt_cancel. Qed. (** Sqrt and basic constants *) @@ -218,14 +218,14 @@ Qed. Lemma sqrt_2 : √2 == 1. Proof. - apply sqrt_unique' with 1. nzsimpl; split; order'. now nzsimpl'. + apply sqrt_unique' with 1. - nzsimpl; split; order'. - now nzsimpl'. Qed. Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a. Proof. - intros a. split; intros Ha. apply sqrt_lt_cancel. now rewrite sqrt_0. - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. - now rewrite one_succ, le_succ_l. + intros a. split; intros Ha. - apply sqrt_lt_cancel. now rewrite sqrt_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. + now rewrite one_succ, le_succ_l. Qed. Lemma sqrt_lt_lin : forall a, 1<a -> √a<a. @@ -239,11 +239,11 @@ Lemma sqrt_le_lin : forall a, 0<=a -> √a<=a. Proof. intros a Ha. destruct (le_gt_cases a 0) as [H|H]. - setoid_replace a with 0 by order. now rewrite sqrt_0. - destruct (le_gt_cases a 1) as [H'|H']. - rewrite <- le_succ_l, <- one_succ in H. - setoid_replace a with 1 by order. now rewrite sqrt_1. - now apply lt_le_incl, sqrt_lt_lin. + - setoid_replace a with 0 by order. now rewrite sqrt_0. + - destruct (le_gt_cases a 1) as [H'|H']. + + rewrite <- le_succ_l, <- one_succ in H. + setoid_replace a with 1 by order. now rewrite sqrt_1. + + now apply lt_le_incl, sqrt_lt_lin. Qed. (** Sqrt and multiplication. *) @@ -255,28 +255,28 @@ Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b). Proof. intros a b. destruct (lt_ge_cases a 0) as [Ha|Ha]. - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. - assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - apply sqrt_le_square; try now apply mul_nonneg_nonneg. - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. - now apply sqrt_spec. - now apply sqrt_spec. + - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. + + assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + apply sqrt_le_square; try now apply mul_nonneg_nonneg. + rewrite mul_shuffle1. + apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. + * now apply sqrt_spec. + * now apply sqrt_spec. Qed. Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b). Proof. intros a b Ha Hb. apply sqrt_lt_square. - now apply mul_nonneg_nonneg. - apply mul_nonneg_nonneg. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - now apply lt_le_incl, lt_succ_r, sqrt_nonneg. - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. Qed. (** And we can't find better approximations in general. @@ -296,73 +296,73 @@ Proof. intros a Ha. apply lt_succ_r. apply sqrt_lt_square. - now apply le_le_succ_r. - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. - rewrite <- (add_1_l (S (√a))). - apply lt_le_trans with (1²+(S (√a))²). - rewrite mul_1_l, add_1_l, <- succ_lt_mono. - now apply sqrt_spec. - apply add_square_le. order'. apply le_le_succ_r, sqrt_nonneg. + - now apply le_le_succ_r. + - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. + - rewrite <- (add_1_l (S (√a))). + apply lt_le_trans with (1²+(S (√a))²). + + rewrite mul_1_l, add_1_l, <- succ_lt_mono. + now apply sqrt_spec. + + apply add_square_le. * order'. * apply le_le_succ_r, sqrt_nonneg. Qed. Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a. Proof. intros a Ha. destruct (le_gt_cases (√(S a)) (√a)) as [H|H]. - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. + - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. Qed. Lemma sqrt_eq_succ_iff_square : forall a, 0<=a -> (√(S a) == S (√a) <-> exists b, 0<b /\ S a == b²). Proof. intros a Ha. split. - intros EQ. exists (S (√a)). - split. apply lt_succ_r, sqrt_nonneg. - generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l. - assert (Ha' : 0 <= S a) by now apply le_le_succ_r. - generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order. - intros (b & Hb & H). - rewrite H. rewrite sqrt_square; try order. - symmetry. - rewrite <- (lt_succ_pred 0 b Hb). f_equiv. - rewrite <- (lt_succ_pred 0 b²) in H. apply succ_inj in H. - now rewrite H, sqrt_pred_square. - now apply mul_pos_pos. + - intros EQ. exists (S (√a)). + split. + apply lt_succ_r, sqrt_nonneg. + + generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l. + assert (Ha' : 0 <= S a) by now apply le_le_succ_r. + generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order. + - intros (b & Hb & H). + rewrite H. rewrite sqrt_square; try order. + symmetry. + rewrite <- (lt_succ_pred 0 b Hb). f_equiv. + rewrite <- (lt_succ_pred 0 b²) in H. + apply succ_inj in H. + now rewrite H, sqrt_pred_square. + + now apply mul_pos_pos. Qed. (** Sqrt and addition *) Lemma sqrt_add_le : forall a b, √(a+b) <= √a + √b. Proof. - assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b). - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. - apply sqrt_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - intros a b. - destruct (lt_ge_cases a 0) as [Ha|Ha]. now apply AUX. - destruct (lt_ge_cases b 0) as [Hb|Hb]. - rewrite (add_comm a), (add_comm (√a)); now apply AUX. - assert (Ha':=sqrt_nonneg a). - assert (Hb':=sqrt_nonneg b). - rewrite <- lt_succ_r. - apply sqrt_lt_square. - now apply add_nonneg_nonneg. - now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. - destruct (sqrt_spec a Ha) as (_,LTa). - destruct (sqrt_spec b Hb) as (_,LTb). - revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. - intros LTa LTb. - assert (H:=add_le_mono _ _ _ _ LTa LTb). - etransitivity; [eexact H|]. clear LTa LTb H. - rewrite <- (add_assoc _ (√a) (√a)). - rewrite <- (add_assoc _ (√b) (√b)). - rewrite add_shuffle1. - rewrite <- (add_assoc _ (√a + √b)). - rewrite (add_shuffle1 (√a) (√b)). - apply add_le_mono_r. - now apply add_square_le. + assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b). + - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. + apply sqrt_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (lt_ge_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√a)); now apply AUX. + * assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + rewrite <- lt_succ_r. + apply sqrt_lt_square. + -- now apply add_nonneg_nonneg. + -- now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. + -- destruct (sqrt_spec a Ha) as (_,LTa). + destruct (sqrt_spec b Hb) as (_,LTb). + revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. + intros LTa LTb. + assert (H:=add_le_mono _ _ _ _ LTa LTb). + etransitivity; [eexact H|]. clear LTa LTb H. + rewrite <- (add_assoc _ (√a) (√a)). + rewrite <- (add_assoc _ (√b) (√b)). + rewrite add_shuffle1. + rewrite <- (add_assoc _ (√a + √b)). + rewrite (add_shuffle1 (√a) (√b)). + apply add_le_mono_r. + now apply add_square_le. Qed. (** convexity inequality for sqrt: sqrt of middle is above middle @@ -374,12 +374,12 @@ Proof. assert (Ha':=sqrt_nonneg a). assert (Hb':=sqrt_nonneg b). apply sqrt_le_square. - apply mul_nonneg_nonneg. order'. now apply add_nonneg_nonneg. - now apply add_nonneg_nonneg. - transitivity (2*((√a)² + (√b)²)). - now apply square_add_le. - apply mul_le_mono_nonneg_l. order'. - apply add_le_mono; now apply sqrt_spec. + - apply mul_nonneg_nonneg. + order'. + now apply add_nonneg_nonneg. + - now apply add_nonneg_nonneg. + - transitivity (2*((√a)² + (√b)²)). + + now apply square_add_le. + + apply mul_le_mono_nonneg_l. * order'. + * apply add_le_mono; now apply sqrt_spec. Qed. End NZSqrtProp. @@ -430,8 +430,8 @@ Qed. Lemma sqrt_up_nonneg : forall a, 0<=√°a. Proof. intros. destruct (le_gt_cases a 0) as [Ha|Ha]. - now rewrite sqrt_up_eqn0. - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. + - now rewrite sqrt_up_eqn0. + - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. Qed. (** [sqrt_up] is a morphism *) @@ -439,8 +439,8 @@ Qed. Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. Proof. assert (Proper (eq==>eq==>Logic.eq) compare). - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. + - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. + - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. Qed. (** The spec of [sqrt_up] indeed determines it *) @@ -463,9 +463,9 @@ Lemma sqrt_up_square : forall a, 0<=a -> √°(a²) == a. Proof. intros a Ha. le_elim Ha. - rewrite sqrt_up_eqn by (now apply mul_pos_pos). - rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. + - rewrite sqrt_up_eqn by (now apply mul_pos_pos). + rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. + - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. Qed. (** [sqrt_up] and successors of squares *) @@ -500,10 +500,10 @@ Qed. Lemma le_sqrt_sqrt_up : forall a, √a <= √°a. Proof. intros a. unfold sqrt_up. case compare_spec; intros H. - rewrite <- H, sqrt_0. order. - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. - apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). - now rewrite sqrt_neg. + - rewrite <- H, sqrt_0. order. + - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. + apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). + - now rewrite sqrt_neg. Qed. Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a). @@ -517,21 +517,21 @@ Qed. Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)². Proof. intros a H. split. - now apply sqrt_spec. - le_elim H. - now apply sqrt_up_spec. - now rewrite <-H, sqrt_up_0, mul_0_l. + - now apply sqrt_spec. + - le_elim H. + + now apply sqrt_up_spec. + + now rewrite <-H, sqrt_up_0, mul_0_l. Qed. Lemma sqrt_sqrt_up_exact : forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²). Proof. intros a Ha. - split. intros. exists √a. - split. apply sqrt_nonneg. - generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. - intros (b & Hb & Hb'). rewrite Hb'. - now rewrite sqrt_square, sqrt_up_square. + split. - intros. exists √a. + split. + apply sqrt_nonneg. + + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. + - intros (b & Hb & Hb'). rewrite Hb'. + now rewrite sqrt_square, sqrt_up_square. Qed. (** [sqrt_up] is a monotone function (but not a strict one) *) @@ -540,9 +540,9 @@ Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b. Proof. intros a b H. destruct (le_gt_cases a 0) as [Ha|Ha]. - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. - apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. + - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. + - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. + apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. Qed. (** No reverse result for <=, consider for instance √°3 <= √°2 *) @@ -551,10 +551,10 @@ Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b. Proof. intros a b H. destruct (le_gt_cases b 0) as [Hb|Hb]. - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. - rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. - apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. + - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. + rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. + apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. Qed. (** When left side is a square, we have an equivalence for < *) @@ -562,10 +562,10 @@ Qed. Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a). Proof. intros a b Ha Hb. split; intros H. - destruct (sqrt_up_spec a) as (LE,LT). - apply le_lt_trans with b²; trivial using square_nonneg. - apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. + - destruct (sqrt_up_spec a) as (LE,LT). + + apply le_lt_trans with b²; trivial using square_nonneg. + + apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. + - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. Qed. (** When right side is a square, we have an equivalence for <= *) @@ -573,17 +573,17 @@ Qed. Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b). Proof. intros a b Ha Hb. split; intros H. - rewrite <- (sqrt_up_square b Hb). - now apply sqrt_up_le_mono. - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. - transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. + - rewrite <- (sqrt_up_square b Hb). + now apply sqrt_up_le_mono. + - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. + transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. Qed. Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a. Proof. - intros a. split; intros Ha. apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. - now rewrite one_succ, le_succ_l. + intros a. split; intros Ha. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. + now rewrite one_succ, le_succ_l. Qed. Lemma sqrt_up_lt_lin : forall a, 2<a -> √°a < a. @@ -599,11 +599,11 @@ Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a. Proof. intros a Ha. le_elim Ha. - rewrite sqrt_up_eqn; trivial. apply le_succ_l. - apply le_lt_trans with (P a). apply sqrt_le_lin. - now rewrite <- lt_succ_r, (lt_succ_pred 0). - rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. - now rewrite <- Ha, sqrt_up_0. + - rewrite sqrt_up_eqn; trivial. apply le_succ_l. + apply le_lt_trans with (P a). + apply sqrt_le_lin. + now rewrite <- lt_succ_r, (lt_succ_pred 0). + + rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. + - now rewrite <- Ha, sqrt_up_0. Qed. (** [sqrt_up] and multiplication. *) @@ -615,23 +615,23 @@ Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √ Proof. intros a b Ha Hb. apply sqrt_up_le_square. - now apply mul_nonneg_nonneg. - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. - rewrite mul_shuffle1. - apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. + - rewrite mul_shuffle1. + apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. Qed. Lemma sqrt_up_mul_below : forall a b, 0<a -> 0<b -> (P √°a)*(P √°b) < √°(a*b). Proof. intros a b Ha Hb. apply sqrt_up_lt_square. - apply mul_nonneg_nonneg; order. - apply mul_nonneg_nonneg; apply lt_succ_r. - rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. - rewrite mul_shuffle1. - apply mul_lt_mono_nonneg; trivial using square_nonneg; - now apply sqrt_up_spec. + - apply mul_nonneg_nonneg; order. + - apply mul_nonneg_nonneg; apply lt_succ_r. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial using square_nonneg; + now apply sqrt_up_spec. Qed. (** And we can't find better approximations in general. @@ -650,37 +650,37 @@ Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a). Proof. intros a Ha. apply sqrt_up_le_square. - now apply le_le_succ_r. - apply le_le_succ_r, sqrt_up_nonneg. - rewrite <- (add_1_l (√°a)). - apply le_trans with (1²+(√°a)²). - rewrite mul_1_l, add_1_l, <- succ_le_mono. - now apply sqrt_sqrt_up_spec. - apply add_square_le. order'. apply sqrt_up_nonneg. + - now apply le_le_succ_r. + - apply le_le_succ_r, sqrt_up_nonneg. + - rewrite <- (add_1_l (√°a)). + apply le_trans with (1²+(√°a)²). + + rewrite mul_1_l, add_1_l, <- succ_le_mono. + now apply sqrt_sqrt_up_spec. + + apply add_square_le. * order'. * apply sqrt_up_nonneg. Qed. Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a. Proof. intros a Ha. destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H]. - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. + - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. Qed. Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a -> (√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²). Proof. intros a Ha. split. - intros EQ. - le_elim Ha. - exists (√°a). split. apply sqrt_up_nonneg. - generalize (proj2 (sqrt_up_spec a Ha)). - assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). - generalize (proj1 (sqrt_up_spec (S a) Ha')). - rewrite EQ, pred_succ, lt_succ_r. order. - exists 0. nzsimpl. now split. - intros (b & Hb & H). - now rewrite H, sqrt_up_succ_square, sqrt_up_square. + - intros EQ. + le_elim Ha. + + exists (√°a). split. * apply sqrt_up_nonneg. + * generalize (proj2 (sqrt_up_spec a Ha)). + assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). + generalize (proj1 (sqrt_up_spec (S a) Ha')). + rewrite EQ, pred_succ, lt_succ_r. order. + + exists 0. nzsimpl. now split. + - intros (b & Hb & H). + now rewrite H, sqrt_up_succ_square, sqrt_up_square. Qed. (** [sqrt_up] and addition *) @@ -688,21 +688,21 @@ Qed. Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b. Proof. assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b). - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. - apply sqrt_up_le_mono. - rewrite <- (add_0_l b) at 2. - apply add_le_mono_r; order. - intros a b. - destruct (le_gt_cases a 0) as [Ha|Ha]. now apply AUX. - destruct (le_gt_cases b 0) as [Hb|Hb]. - rewrite (add_comm a), (add_comm (√°a)); now apply AUX. - rewrite 2 sqrt_up_eqn; trivial. - nzsimpl. rewrite <- succ_le_mono. - transitivity (√(P a) + √b). - rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. - apply add_le_mono_l. - apply le_sqrt_sqrt_up. - now apply add_pos_pos. + - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. + apply sqrt_up_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (le_gt_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (le_gt_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√°a)); now apply AUX. + * rewrite 2 sqrt_up_eqn; trivial. + -- nzsimpl. rewrite <- succ_le_mono. + transitivity (√(P a) + √b). + ++ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. + ++ apply add_le_mono_l. + apply le_sqrt_sqrt_up. + -- now apply add_pos_pos. Qed. (** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle @@ -712,25 +712,24 @@ Qed. Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)). Proof. intros a b Ha Hb. - le_elim Ha. - le_elim Hb. - rewrite 3 sqrt_up_eqn; trivial. - nzsimpl. rewrite <- 2 succ_le_mono. - etransitivity; [eapply add_sqrt_le|]. - apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). - apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). - apply sqrt_le_mono. - apply lt_succ_r. rewrite (lt_succ_pred 0). - apply mul_lt_mono_pos_l. order'. - apply add_lt_mono. - apply le_succ_l. now rewrite (lt_succ_pred 0). - apply le_succ_l. now rewrite (lt_succ_pred 0). - apply mul_pos_pos. order'. now apply add_pos_pos. - apply mul_pos_pos. order'. now apply add_pos_pos. - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. - rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. + le_elim Ha;[le_elim Hb|]. + - rewrite 3 sqrt_up_eqn; trivial. + + nzsimpl. rewrite <- 2 succ_le_mono. + etransitivity; [eapply add_sqrt_le|]. + * apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). + * apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). + * apply sqrt_le_mono. + apply lt_succ_r. rewrite (lt_succ_pred 0). + -- apply mul_lt_mono_pos_l. ++ order'. + ++ apply add_lt_mono. + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + -- apply mul_pos_pos. ++ order'. ++ now apply add_pos_pos. + + apply mul_pos_pos. * order'. * now apply add_pos_pos. + - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. + - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. Qed. End NZSqrtUpProp. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 1c89b6c3b1..ae366204ac 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -73,10 +73,10 @@ Proof. simpl. split ; intros ; subst. - inversion H. - reflexivity. + - inversion H. + reflexivity. - pi. + - pi. Qed. (* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index f9d23e3cf6..092c1d6f48 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -97,15 +97,15 @@ Section Measure_well_founded. Proof with auto. unfold well_founded. cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0). - intros. + + intros. apply (H (m a))... - apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). - intros. - apply Acc_intro. - intros. - unfold MR in H1. - rewrite H0 in H1. - apply (H (m y))... + + apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). + intros. + apply Acc_intro. + intros. + unfold MR in H1. + rewrite H0 in H1. + apply (H (m y))... Defined. End Measure_well_founded. @@ -245,8 +245,8 @@ Module WfExtensionality. intros ; apply Fix_eq ; auto. intros. assert(f = g). - extensionality y ; apply H. - rewrite H0 ; auto. + - extensionality y ; apply H. + - rewrite H0 ; auto. Qed. (** Tactic to unfold once a definition based on [Fix_sub]. *) diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index e82a673445..0a60d96afc 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -45,9 +45,8 @@ Section Properties. Lemma clos_rt_is_preorder : preorder R*. Proof. apply Build_preorder. - exact (rt_refl A R). - - exact (rt_trans A R). + - exact (rt_refl A R). + - exact (rt_trans A R). Qed. (** Idempotency of the reflexive-transitive closure operator *) @@ -82,8 +81,8 @@ Section Properties. inclusion (clos_refl R) (clos_refl_trans R). Proof. induction 1 as [? ?| ]. - constructor; auto. - constructor 2. + - constructor; auto. + - constructor 2. Qed. Lemma clos_rt_t : forall x y z, @@ -100,9 +99,9 @@ Section Properties. Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R). Proof. apply Build_equivalence. - exact (rst_refl A R). - exact (rst_trans A R). - exact (rst_sym A R). + - exact (rst_refl A R). + - exact (rst_trans A R). + - exact (rst_sym A R). Qed. (** Idempotency of the reflexive-symmetric-transitive closure operator *) @@ -130,18 +129,18 @@ Section Properties. Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y. Proof. induction 1. - left; assumption. - right with y; auto. - left; auto. + - left; assumption. + - right with y; auto. + left; auto. Qed. Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. Proof. induction 1. - left; assumption. - generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. - right with y; auto. - right with y; auto. + - left; assumption. + - generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. + + right with y; auto. + + right with y; auto. eapply IHIHclos_trans1; auto. apply clos_t1n_trans; auto. Qed. @@ -150,8 +149,8 @@ Section Properties. clos_trans R x y <-> clos_trans_1n R x y. Proof. split. - apply clos_trans_t1n. - apply clos_t1n_trans. + - apply clos_trans_t1n. + - apply clos_t1n_trans. Qed. (** Direct transitive closure vs right-step extension *) @@ -159,29 +158,29 @@ Section Properties. Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y. Proof. induction 1. - left; assumption. - right with y; auto. - left; assumption. + - left; assumption. + - right with y; auto. + left; assumption. Qed. Lemma clos_trans_tn1 : forall x y, clos_trans R x y -> clos_trans_n1 R x y. Proof. induction 1. - left; assumption. - elim IHclos_trans2. - intro y0; right with y. - auto. - auto. - intros. - right with y0; auto. + - left; assumption. + - elim IHclos_trans2. + + intro y0; right with y. + * auto. + * auto. + + intros. + right with y0; auto. Qed. Lemma clos_trans_tn1_iff : forall x y, clos_trans R x y <-> clos_trans_n1 R x y. Proof. split. - apply clos_trans_tn1. - apply clos_tn1_trans. + - apply clos_trans_tn1. + - apply clos_tn1_trans. Qed. (** Direct reflexive-transitive closure is equivalent to @@ -203,31 +202,31 @@ Section Properties. clos_refl_trans_1n R x y -> clos_refl_trans R x y. Proof. induction 1. - constructor 2. - constructor 3 with y; auto. - constructor 1; auto. + - constructor 2. + - constructor 3 with y; auto. + constructor 1; auto. Qed. Lemma clos_rt_rt1n : forall x y, clos_refl_trans R x y -> clos_refl_trans_1n R x y. Proof. induction 1. - apply clos_rt1n_step; assumption. - left. - generalize IHclos_refl_trans2; clear IHclos_refl_trans2; - induction IHclos_refl_trans1; auto. + - apply clos_rt1n_step; assumption. + - left. + - generalize IHclos_refl_trans2; clear IHclos_refl_trans2; + induction IHclos_refl_trans1; auto. - right with y; auto. - eapply IHIHclos_refl_trans1; auto. - apply clos_rt1n_rt; auto. + right with y; auto. + eapply IHIHclos_refl_trans1; auto. + apply clos_rt1n_rt; auto. Qed. Lemma clos_rt_rt1n_iff : forall x y, clos_refl_trans R x y <-> clos_refl_trans_1n R x y. Proof. split. - apply clos_rt_rt1n. - apply clos_rt1n_rt. + - apply clos_rt_rt1n. + - apply clos_rt1n_rt. Qed. (** Direct reflexive-transitive closure is equivalent to @@ -237,28 +236,28 @@ Section Properties. clos_refl_trans_n1 R x y -> clos_refl_trans R x y. Proof. induction 1. - constructor 2. - constructor 3 with y; auto. - constructor 1; assumption. + - constructor 2. + - constructor 3 with y; auto. + constructor 1; assumption. Qed. Lemma clos_rt_rtn1 : forall x y, clos_refl_trans R x y -> clos_refl_trans_n1 R x y. Proof. induction 1. - apply clos_rtn1_step; auto. - left. - elim IHclos_refl_trans2; auto. - intros. - right with y0; auto. + - apply clos_rtn1_step; auto. + - left. + - elim IHclos_refl_trans2; auto. + intros. + right with y0; auto. Qed. Lemma clos_rt_rtn1_iff : forall x y, clos_refl_trans R x y <-> clos_refl_trans_n1 R x y. Proof. split. - apply clos_rt_rtn1. - apply clos_rtn1_rt. + - apply clos_rt_rtn1. + - apply clos_rtn1_rt. Qed. (** Induction on the left transitive step *) @@ -271,14 +270,14 @@ Section Properties. intros. revert H H0. induction H1; intros; auto with sets. - apply H1 with x; auto with sets. + - apply H1 with x; auto with sets. - apply IHclos_refl_trans2. - apply IHclos_refl_trans1; auto with sets. + - apply IHclos_refl_trans2. + + apply IHclos_refl_trans1; auto with sets. - intros. - apply H0 with y0; auto with sets. - apply rt_trans with y; auto with sets. + + intros. + apply H0 with y0; auto with sets. + apply rt_trans with y; auto with sets. Qed. (** Induction on the right transitive step *) @@ -311,45 +310,45 @@ Section Properties. clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y. Proof. induction 1. - constructor 2. - constructor 4 with y; auto. - case H;[constructor 1|constructor 3; constructor 1]; auto. + - constructor 2. + - constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. induction 1. - auto. - intros; right with y; eauto. + - auto. + - intros; right with y; eauto. Qed. Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y x. Proof. intros x y H; elim H. - constructor 1. - intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. - right with x0. - tauto. - left. + - constructor 1. + - intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. + right with x0. + + tauto. + + left. Qed. Lemma clos_rst_rst1n : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. induction 1. - constructor 2 with y; auto. - constructor 1. - constructor 1. - apply clos_rst1n_sym; auto. - eapply clos_rst1n_trans; eauto. + - constructor 2 with y; auto. + constructor 1. + - constructor 1. + - apply clos_rst1n_sym; auto. + - eapply clos_rst1n_trans; eauto. Qed. Lemma clos_rst_rst1n_iff : forall x y, clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y. Proof. split. - apply clos_rst_rst1n. - apply clos_rst1n_rst. + - apply clos_rst_rst1n. + - apply clos_rst1n_rst. Qed. (** Direct reflexive-symmetric-transitive closure is equivalent to @@ -359,9 +358,9 @@ Section Properties. clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y. Proof. induction 1. - constructor 2. - constructor 4 with y; auto. - case H;[constructor 1|constructor 3; constructor 1]; auto. + - constructor 2. + - constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y -> @@ -369,39 +368,39 @@ Section Properties. Proof. intros x y z H1 H2. induction H2. - auto. - intros. - right with y0; eauto. + - auto. + - intros. + right with y0; eauto. Qed. Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans_n1 R y x. Proof. intros x y H; elim H. - constructor 1. - intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. - right with z. - tauto. - left. + - constructor 1. + - intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. + right with z. + + tauto. + + left. Qed. Lemma clos_rst_rstn1 : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y. Proof. induction 1. - constructor 2 with x; auto. - constructor 1. - constructor 1. - apply clos_rstn1_sym; auto. - eapply clos_rstn1_trans; eauto. + - constructor 2 with x; auto. + constructor 1. + - constructor 1. + - apply clos_rstn1_sym; auto. + - eapply clos_rstn1_trans; eauto. Qed. Lemma clos_rst_rstn1_iff : forall x y, clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y. Proof. split. - apply clos_rst_rstn1. - apply clos_rstn1_rst. + - apply clos_rst_rstn1. + - apply clos_rstn1_rst. Qed. End Equivalences. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index f2475af124..862c3238e7 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -103,8 +103,8 @@ Section Ensembles_facts. forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y. Proof. intros A x y H'; induction H'. - left; assumption. - right; apply Singleton_inv; assumption. + - left; assumption. + - right; apply Singleton_inv; assumption. Qed. Lemma Intersection_inv : diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 5b51c7b953..811e42f091 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -71,11 +71,11 @@ Section Partial_order_facts. elim D; simpl. intros C R H' H'0; elim H'0. intros H'1 H'2 H'3 x y z H'4 H'5; split. - apply H'2 with (y := y); tauto. - red; intro H'6. - elim H'4; intros H'7 H'8; apply H'8; clear H'4. - apply H'3; auto. - rewrite H'6; tauto. + - apply H'2 with (y := y); tauto. + - red; intro H'6. + elim H'4; intros H'7 H'8; apply H'8; clear H'4. + apply H'3; auto. + rewrite H'6; tauto. Qed. Lemma Strict_Rel_Transitive_with_Rel_left : @@ -87,11 +87,11 @@ Section Partial_order_facts. elim D; simpl. intros C R H' H'0; elim H'0. intros H'1 H'2 H'3 x y z H'4 H'5; split. - apply H'2 with (y := y); tauto. - red; intro H'6. - elim H'5; intros H'7 H'8; apply H'8; clear H'5. - apply H'3; auto. - rewrite <- H'6; auto. + - apply H'2 with (y := y); tauto. + - red; intro H'6. + elim H'5; intros H'7 H'8; apply H'8; clear H'5. + apply H'3; auto. + rewrite <- H'6; auto. Qed. Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D). diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index 86a500dfdd..5cd9f52c6b 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -33,8 +33,8 @@ Section Axiomatisation. forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t). Proof. intros; apply cong_trans with (op y z). - apply cong_left; trivial. - apply cong_right; trivial. + - apply cong_left; trivial. + - apply cong_right; trivial. Qed. Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)). @@ -51,27 +51,27 @@ Section Axiomatisation. Proof. intros. apply cong_trans with (op x (op y z)). - apply op_ass. - apply cong_trans with (op x (op z y)). - apply cong_right; apply op_comm. - apply cong_sym; apply op_ass. + - apply op_ass. + - apply cong_trans with (op x (op z y)). + + apply cong_right; apply op_comm. + + apply cong_sym; apply op_ass. Qed. Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)). Proof. intros. apply cong_trans with (op (op x y) z). - apply cong_sym; apply op_ass. - apply cong_trans with (op (op y x) z). - apply cong_left; apply op_comm. - apply op_ass. + - apply cong_sym; apply op_ass. + - apply cong_trans with (op (op y x) z). + + apply cong_left; apply op_comm. + + apply op_ass. Qed. Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)). Proof. intros; apply cong_trans with (op (op x y) z). - apply cong_sym; apply op_ass. - apply op_comm. + - apply cong_sym; apply op_ass. + - apply op_comm. Qed. (** Needed for treesort ... *) @@ -80,10 +80,10 @@ Section Axiomatisation. Proof. intros. apply cong_trans with (op x (op (op y t) z)). - apply cong_right; apply perm_right. - apply cong_trans with (op (op x (op y t)) z). - apply cong_sym; apply op_ass. - apply cong_left; apply perm_left. + - apply cong_right; apply perm_right. + - apply cong_trans with (op (op x (op y t)) z). + + apply cong_sym; apply op_ass. + + apply cong_left; apply perm_left. Qed. End Axiomatisation. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 50a7e401f8..5b352f05fa 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -154,9 +154,9 @@ Theorem Union_is_Lub : Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b). intros A a b H' H'0. apply Lub_definition; simpl. -apply Upper_Bound_definition; simpl; auto with sets. -intros y H'1; elim H'1; auto with sets. -intros y H'1; elim H'1; simpl; auto with sets. +- apply Upper_Bound_definition; simpl; auto with sets. + intros y H'1; elim H'1; auto with sets. +- intros y H'1; elim H'1; simpl; auto with sets. Qed. Theorem Intersection_is_Glb : @@ -167,12 +167,12 @@ Theorem Intersection_is_Glb : (Intersection U a b). intros A a b H' H'0. apply Glb_definition; simpl. -apply Lower_Bound_definition; simpl; auto with sets. -apply Definition_of_Power_set. -generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; - auto with sets. -intros y H'1; elim H'1; auto with sets. -intros y H'1; elim H'1; simpl; auto with sets. +- apply Lower_Bound_definition; simpl; auto with sets. + + apply Definition_of_Power_set. + generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a; + auto with sets. + + intros y H'1; elim H'1; auto with sets. +- intros y H'1; elim H'1; simpl; auto with sets. Qed. End The_power_set_partial_order. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 81b475ac6e..784f2ce0ff 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -84,8 +84,8 @@ Section Sets_as_an_algebra. forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y. Proof. intros x y; apply Extensionality_Ensembles; split; red. - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). - intros x0 H'; elim H'; auto with sets. + - intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). + - intros x0 H'; elim H'; auto with sets. Qed. Theorem Triple_as_union : @@ -94,10 +94,10 @@ Section Sets_as_an_algebra. Triple U x y z. Proof. intros x y z; apply Extensionality_Ensembles; split; red. - intros x0 H'; elim H'. - intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). - intros x1 H'0; elim H'0; auto with sets. - intros x0 H'; elim H'; auto with sets. + - intros x0 H'; elim H'. + + intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets). + + intros x1 H'0; elim H'0; auto with sets. + - intros x0 H'; elim H'; auto with sets. Qed. Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. @@ -132,10 +132,10 @@ Section Sets_as_an_algebra. intros A B C. apply Extensionality_Ensembles. split; red; intros x H'. - elim H'. - intros x0 H'0 H'1; generalize H'0. - elim H'1; auto with sets. - elim H'; intros x0 H'0; elim H'0; auto with sets. + - elim H'. + intros x0 H'0 H'1; generalize H'0. + elim H'1; auto with sets. + - elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. Lemma Distributivity_l @@ -157,13 +157,13 @@ Section Sets_as_an_algebra. intros A B C. apply Extensionality_Ensembles. split; red; intros x H'. - elim H'; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - elim H'. - intros x0 H'0; elim H'0; auto with sets. - intros x1 H'1 H'2; try exact H'2. - generalize H'1. - elim H'2; auto with sets. + - elim H'; auto with sets. + intros x0 H'0; elim H'0; auto with sets. + - elim H'. + intros x0 H'0; elim H'0; auto with sets. + intros x1 H'1 H'2; try exact H'2. + generalize H'1. + elim H'2; auto with sets. Qed. Theorem Union_add : @@ -188,11 +188,11 @@ Section Sets_as_an_algebra. intros X x H'; unfold Subtract. apply Extensionality_Ensembles. split; red; auto with sets. - intros x0 H'0; elim H'0; auto with sets. - intros x0 H'0; apply Setminus_intro; auto with sets. - red; intro H'1; elim H'1. - lapply (Singleton_inv U x x0); auto with sets. - intro H'4; apply H'; rewrite H'4; auto with sets. + - intros x0 H'0; elim H'0; auto with sets. + - intros x0 H'0; apply Setminus_intro; auto with sets. + red; intro H'1; elim H'1. + lapply (Singleton_inv U x x0); auto with sets. + intro H'4; apply H'; rewrite H'4; auto with sets. Qed. Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. @@ -320,7 +320,9 @@ Section Sets_as_an_algebra. Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. Proof. intros. apply Extensionality_Ensembles. split. - * intros x H. inversion H. constructor. intuition. contradict H1. intuition. + * intros x H. inversion H. constructor. + -- intuition. + -- contradict H1. intuition. * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. Qed. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index d275487e15..17bdefcdbf 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -45,12 +45,12 @@ Theorem Equiv_from_preorder : Proof. intros U R H'; elim H'; intros H'0 H'1. apply Definition_of_equivalence. -red in H'0; auto 10 with sets. -2: red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. -red in H'1; red; auto 10 with sets. -intros x y z h; elim h; intros H'3 H'4; clear h. -intro h; elim h; intros H'5 H'6; clear h. -split; apply H'1 with y; auto 10 with sets. +- red in H'0; auto 10 with sets. +- red in H'1; red; auto 10 with sets. + intros x y z h; elim h; intros H'3 H'4; clear h. + intro h; elim h; intros H'5 H'6; clear h. + split; apply H'1 with y; auto 10 with sets. +- red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. Qed. Hint Resolve Equiv_from_preorder : core. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 36da368447..48d0ea55c9 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -53,8 +53,8 @@ Theorem Rstar_contains_Rplus : Proof. intros U R; red. intros x y H'; elim H'. -generalize Rstar_contains_R; intro T; red in T; auto with sets. -intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets. +- generalize Rstar_contains_R; intro T; red in T; auto with sets. +- intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets. Qed. Theorem Rstar_transitive : @@ -79,9 +79,9 @@ Proof. generalize Rstar_contains_R; intro T; red in T. intros U R; unfold same_relation, contains. split; intros x y H'; elim H'; auto with sets. -generalize Rstar_transitive; intro T1; red in T1. -intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. -intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. +- generalize Rstar_transitive; intro T1; red in T1. + intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets. +- intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets. Qed. Theorem Rsym_imp_Rstarsym : @@ -121,12 +121,12 @@ Proof. generalize Rstar_contains_Rplus; intro T; red in T. generalize Rstar_transitive; intro T1; red in T1. intros U R x y z H'; elim H'. -intros x0 H'0; elim H'0. -intros x1 y0 H'1; exists y0; auto with sets. -intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. -intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. -split; [ try assumption | idtac ]. -apply T1 with z0; auto with sets. +- intros x0 H'0; elim H'0. + + intros x1 y0 H'1; exists y0; auto with sets. + + intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets. +- intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0. + split; [ try assumption | idtac ]. + apply T1 with z0; auto with sets. Qed. Theorem Lemma1 : @@ -137,17 +137,17 @@ Theorem Lemma1 : forall a:U, R x a -> exists z : _, Rstar U R a z /\ R b z. Proof. intros U R H' x b H'0; elim H'0. -intros x0 a H'1; exists a; auto with sets. -intros x0 y z H'1 H'2 H'3 a H'4. -red in H'. -specialize H' with (x := x0) (a := a) (b := y); lapply H'; - [ intro H'8; lapply H'8; - [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] - | clear H' ]; auto with sets. -elim H'9. -intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. -elim (H'3 t); auto with sets. -intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. -exists z1; split; [ idtac | assumption ]. -apply Rstar_n with t; auto with sets. +- intros x0 a H'1; exists a; auto with sets. +- intros x0 y z H'1 H'2 H'3 a H'4. + red in H'. + specialize H' with (x := x0) (a := a) (b := y); lapply H'; + [ intro H'8; lapply H'8; + [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] + | clear H' ]; auto with sets. + elim H'9. + intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. + elim (H'3 t); auto with sets. + intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5. + exists z1; split; [ idtac | assumption ]. + apply Rstar_n with t; auto with sets. Qed. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 18ea019526..a4806ea0a6 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -57,21 +57,21 @@ intro x; red; intros a b H'0. unfold coherent at 1. generalize b; clear b. elim H'0; clear H'0. -intros x0 b H'1; exists b; auto with sets. -intros x0 y z H'1 H'2 H'3 b H'4. -generalize (Lemma1 U R); intro h; lapply h; - [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; - [ intro H'5; generalize (H'5 y); intro h1; lapply h1; - [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; +- intros x0 b H'1; exists b; auto with sets. +- intros x0 y z H'1 H'2 H'3 b H'4. + generalize (Lemma1 U R); intro h; lapply h; + [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0; + [ intro H'5; generalize (H'5 y); intro h1; lapply h1; + [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7; clear h h0 h1 h2 h3 - | clear h h0 h1 ] - | clear h h0 ] - | clear h ]; auto with sets. -generalize (H'3 z0); intro h; lapply h; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 - | clear h ]; auto with sets. -exists z1; split; auto with sets. -apply Rstar_n with z0; auto with sets. + | clear h h0 h1 ] + | clear h h0 ] + | clear h ]; auto with sets. + generalize (H'3 z0); intro h; lapply h; + [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1 + | clear h ]; auto with sets. + exists z1; split; auto with sets. + apply Rstar_n with z0; auto with sets. Qed. Theorem Strong_confluence_direct : @@ -82,31 +82,31 @@ intro x; red; intros a b H'0. unfold coherent at 1. generalize b; clear b. elim H'0; clear H'0. -intros x0 b H'1; exists b; auto with sets. -intros x0 y z H'1 H'2 H'3 b H'4. -cut (ex (fun t:U => Rstar U R y t /\ R b t)). -intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. -generalize (H'3 t); intro h; lapply h; - [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 - | clear h ]; auto with sets. -exists z0; split; [ assumption | idtac ]. -apply Rstar_n with t; auto with sets. -generalize H'1; generalize y; clear H'1. -elim H'4. -intros x1 y0 H'0; exists y0; auto with sets. -intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. -red in H'. -generalize (H' x1 y0 y1); intro h; lapply h; - [ intro H'7; lapply H'7; - [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; - clear h H'7 h0 h1 - | clear h ] - | clear h ]; auto with sets. -generalize (H'5 z1); intro h; lapply h; - [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 - | clear h ]; auto with sets. -exists t; split; auto with sets. -apply Rstar_n with z1; auto with sets. +- intros x0 b H'1; exists b; auto with sets. +- intros x0 y z H'1 H'2 H'3 b H'4. + cut (ex (fun t:U => Rstar U R y t /\ R b t)). + + intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0. + generalize (H'3 t); intro h; lapply h; + [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1 + | clear h ]; auto with sets. + exists z0; split; [ assumption | idtac ]. + apply Rstar_n with t; auto with sets. + + generalize H'1; generalize y; clear H'1. + elim H'4. + * intros x1 y0 H'0; exists y0; auto with sets. + * intros x1 y0 z0 H'0 H'1 H'5 y1 H'6. + red in H'. + generalize (H' x1 y0 y1); intro h; lapply h; + [ intro H'7; lapply H'7; + [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; + clear h H'7 h0 h1 + | clear h ] + | clear h ]; auto with sets. + generalize (H'5 z1); intro h; lapply h; + [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1 + | clear h ]; auto with sets. + exists t; split; auto with sets. + apply Rstar_n with z1; auto with sets. Qed. Theorem Noetherian_contains_Noetherian : @@ -131,41 +131,41 @@ generalize (Rstar_cases U R x0 y); intro h; lapply h; | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6; clear h h0 h1 h2 ] | clear h ]; auto with sets. -elim h1; auto with sets. -generalize (Rstar_cases U R x0 z); intro h; lapply h; - [ intro h0; elim h0; - [ clear h h0; intro h1 - | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; - clear h h0 h1 h2 ] - | clear h ]; auto with sets. -elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. -unfold Locally_confluent, locally_confluent, coherent in H'0. -generalize (H'0 x0 u v); intro h; lapply h; - [ intro H'9; lapply H'9; - [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; - clear h H'9 h0 h1 - | clear h ] - | clear h ]; auto with sets. -clear H'0. -unfold coherent at 1 in H'2. -generalize (H'2 u); intro h; lapply h; - [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; - [ intro H'9; lapply H'9; - [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; - clear h h0 H'9 h1 h2 - | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. -generalize Rstar_transitive; intro T; red in T. -generalize (H'2 v); intro h; lapply h; - [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; - [ intro H'14; lapply H'14; - [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; - clear h h0 H'14 h1 h2 - | clear h h0 ] - | clear h h0 ] - | clear h ]; auto with sets. -red; (exists z1; split); auto with sets. -apply T with y1; auto with sets. -apply T with t; auto with sets. +- elim h1; auto with sets. +- generalize (Rstar_cases U R x0 z); intro h; lapply h; + [ intro h0; elim h0; + [ clear h h0; intro h1 + | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8; + clear h h0 h1 h2 ] + | clear h ]; auto with sets. + + elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets. + + unfold Locally_confluent, locally_confluent, coherent in H'0. + generalize (H'0 x0 u v); intro h; lapply h; + [ intro H'9; lapply H'9; + [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11; + clear h H'9 h0 h1 + | clear h ] + | clear h ]; auto with sets. + clear H'0. + unfold coherent at 1 in H'2. + generalize (H'2 u); intro h; lapply h; + [ intro H'0; generalize (H'0 y t); intro h0; lapply h0; + [ intro H'9; lapply H'9; + [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13; + clear h h0 H'9 h1 h2 + | clear h h0 ] + | clear h h0 ] + | clear h ]; auto with sets. + generalize Rstar_transitive; intro T; red in T. + generalize (H'2 v); intro h; lapply h; + [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0; + [ intro H'14; lapply H'14; + [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16; + clear h h0 H'14 h1 h2 + | clear h h0 ] + | clear h h0 ] + | clear h ]; auto with sets. + * red; (exists z1; split); auto with sets. + apply T with y1; auto with sets. + * apply T with t; auto with sets. Qed. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 0ff304ed6b..edfffe6ce9 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -174,8 +174,8 @@ Lemma uniset_twist2 : seq (union x (union (union y z) t)) (union (union y (union x z)) t). Proof. intros; apply seq_trans with (union (union x (union y z)) t). -apply seq_sym; apply union_ass. -apply seq_left; apply union_perm_left. +- apply seq_sym; apply union_ass. +- apply seq_left; apply union_perm_left. Qed. (** specific for treesort *) @@ -186,8 +186,8 @@ Lemma treesort_twist1 : seq (union x (union u t)) (union (union y (union x t)) z). Proof. intros; apply seq_trans with (union x (union (union y z) t)). -apply seq_right; apply seq_left; trivial. -apply uniset_twist1. +- apply seq_right; apply seq_left; trivial. +- apply uniset_twist1. Qed. Lemma treesort_twist2 : @@ -196,8 +196,8 @@ Lemma treesort_twist2 : seq (union x (union u t)) (union (union y (union x z)) t). Proof. intros; apply seq_trans with (union x (union (union y z) t)). -apply seq_right; apply seq_left; trivial. -apply uniset_twist2. +- apply seq_right; apply seq_left; trivial. +- apply uniset_twist2. Qed. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 4143dba547..346c300ee5 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -158,8 +158,10 @@ Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E. Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y. Proof. intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ]. - auto with *. - split. discriminate. intro EQ; elim NEQ; auto. + - auto with *. + - split. + + discriminate. + + intro EQ; elim NEQ; auto. Qed. End HasEqDec2Bool. @@ -168,8 +170,8 @@ Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E. Proof. intros x y. assert (H:=F.eqb_eq x y). destruct (F.eqb x y); [left|right]. - apply -> H; auto. - intro EQ. apply H in EQ. discriminate. + - apply -> H; auto. + - intro EQ. apply H in EQ. discriminate. Defined. End HasEqBool2Dec. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index 4d04667c01..c314f3f982 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -47,8 +47,8 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. intros H H'. apply (StrictOrder_Irreflexive x). rewrite le_lteq in *; destruct H as [H|H]. - transitivity y; auto. - rewrite H in H'; auto. + - transitivity y; auto. + - rewrite H in H'; auto. Qed. Lemma max_l x y : y<=x -> max x y == x. @@ -142,8 +142,8 @@ Proof. intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f x <= f y) by (apply Lef; order). order. - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. Qed. (** *** Semi-lattice algebraic properties of [max] *) @@ -194,7 +194,11 @@ Proof. Qed. Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m. -Proof. split. apply max_le. solve_max. Qed. +Proof. + split. + - apply max_le. + - solve_max. +Qed. Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m. Proof. @@ -282,8 +286,8 @@ Proof. intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f x <= f y) by (apply Lef; order). order. - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. Qed. Lemma min_id n : min n n == n. @@ -330,7 +334,11 @@ Proof. Qed. Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p. -Proof. split. apply min_le. solve_min. Qed. +Proof. + split. + - apply min_le. + - solve_min. +Qed. Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p. Proof. @@ -377,16 +385,16 @@ Lemma min_max_absorption n m : max n (min n m) == n. Proof. intros. destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. - apply max_l. order. - destruct (max_spec n m); intuition; order. + - apply max_l. order. + - destruct (max_spec n m); intuition; order. Qed. Lemma max_min_absorption n m : min n (max n m) == n. Proof. intros. destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. - destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. - apply min_l; auto. order. + - destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. + - apply min_l; auto. order. Qed. (** Distributivity *) @@ -395,16 +403,16 @@ Lemma max_min_distr n m p : max n (min m p) == min (max n m) (max n p). Proof. symmetry. apply min_mono. - eauto with *. - repeat red; intros. apply max_le_compat_l; auto. + - eauto with *. + - repeat red; intros. apply max_le_compat_l; auto. Qed. Lemma min_max_distr n m p : min n (max m p) == max (min n m) (min n p). Proof. symmetry. apply max_mono. - eauto with *. - repeat red; intros. apply min_le_compat_l; auto. + - eauto with *. + - repeat red; intros. apply min_le_compat_l; auto. Qed. (** Modularity *) @@ -415,8 +423,8 @@ Proof. rewrite <- max_min_distr. destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. - rewrite 2 max_l; try order. rewrite min_le_iff; auto. - rewrite 2 max_l; try order. rewrite min_le_iff; auto. + - rewrite 2 max_l; try order. rewrite min_le_iff; auto. + - rewrite 2 max_l; try order. rewrite min_le_iff; auto. Qed. Lemma min_max_modular n m p : @@ -425,8 +433,8 @@ Proof. intros. rewrite <- min_max_distr. destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'. - rewrite 2 min_l; try order. rewrite max_le_iff; right; order. - rewrite 2 min_l; try order. rewrite max_le_iff; auto. + - rewrite 2 min_l; try order. rewrite max_le_iff; right; order. + - rewrite 2 min_l; try order. rewrite max_le_iff; auto. Qed. (** Disassociativity *) @@ -448,8 +456,8 @@ Proof. intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f y <= f x) by (apply Lef; order). order. - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. Qed. Lemma min_max_antimono f : @@ -460,8 +468,8 @@ Proof. intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. - assert (f y <= f x) by (apply Lef; order). order. - assert (f x <= f y) by (apply Lef; order). order. + - assert (f y <= f x) by (apply Lef; order). order. + - assert (f x <= f y) by (apply Lef; order). order. Qed. End MinMaxLogicalProperties. @@ -479,12 +487,12 @@ Lemma max_case_strong n m (P:t -> Type) : Proof. intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat m), Hr; auto. symmetry; apply max_r; auto. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat m), Hr; auto. symmetry; apply max_r; auto. -assert (m<=n) by (rewrite le_lteq; auto). -apply (Compat n), Hl; auto. symmetry; apply max_l; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat m), Hr; auto. symmetry; apply max_r; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat m), Hr; auto. symmetry; apply max_r; auto. +- assert (m<=n) by (rewrite le_lteq; auto). + apply (Compat n), Hl; auto. symmetry; apply max_l; auto. Defined. Lemma max_case n m (P:t -> Type) : @@ -508,12 +516,12 @@ Lemma min_case_strong n m (P:O.t -> Type) : Proof. intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat n), Hl; auto. symmetry; apply min_l; auto. -assert (n<=m) by (rewrite le_lteq; auto). -apply (Compat n), Hl; auto. symmetry; apply min_l; auto. -assert (m<=n) by (rewrite le_lteq; auto). -apply (Compat m), Hr; auto. symmetry; apply min_r; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat n), Hl; auto. symmetry; apply min_l; auto. +- assert (n<=m) by (rewrite le_lteq; auto). + apply (Compat n), Hl; auto. symmetry; apply min_l; auto. +- assert (m<=n) by (rewrite le_lteq; auto). + apply (Compat m), Hr; auto. symmetry; apply min_r; auto. Defined. Lemma min_case n m (P:O.t -> Type) : @@ -624,11 +632,11 @@ Module TOMaxEqDec_to_Compare Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. intros; unfold compare; repeat destruct eq_dec; auto; constructor. - destruct (lt_total x y); auto. - absurd (x==y); auto. transitivity (max x y); auto. - symmetry. apply max_l. rewrite le_lteq; intuition. - destruct (lt_total y x); auto. - absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition. + - destruct (lt_total x y); auto. + absurd (x==y); auto. transitivity (max x y); auto. + symmetry. apply max_l. rewrite le_lteq; intuition. + - destruct (lt_total y x); auto. + absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition. Qed. End TOMaxEqDec_to_Compare. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 310a22a0a4..7fcf517457 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -143,8 +143,8 @@ Module Compare2EqBool (Import O:DecStrOrder') <: HasEqBool O. Proof. unfold eqb. intros x y. destruct (compare_spec x y) as [H|H|H]; split; auto; try discriminate. - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). + - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). + - intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). Qed. End Compare2EqBool. @@ -252,9 +252,11 @@ Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. Proof. intros. unfold leb. rewrite le_lteq. destruct (compare_spec x y) as [EQ|LT|GT]; split; auto. - discriminate. - intros LE. elim (StrictOrder_Irreflexive x). - destruct LE as [LT|EQ]. now transitivity y. now rewrite <- EQ in GT. + - discriminate. + - intros LE. elim (StrictOrder_Irreflexive x). + destruct LE as [LT|EQ]. + + now transitivity y. + + now rewrite <- EQ in GT. Qed. Lemma leb_total : forall x y, leb x y \/ leb y x. @@ -267,10 +269,10 @@ Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. Proof. intros x y z. rewrite !leb_le, !le_lteq. intros [Hxy|Hxy] [Hyz|Hyz]. - left; transitivity y; auto. - left; rewrite <- Hyz; auto. - left; rewrite Hxy; auto. - right; transitivity y; auto. + - left; transitivity y; auto. + - left; rewrite <- Hyz; auto. + - left; rewrite Hxy; auto. + - right; transitivity y; auto. Qed. Definition t := t. @@ -302,10 +304,10 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. Proof. intros. unfold compare. case_eq (x <=? y). - case_eq (y <=? x). - constructor. split; auto. - constructor. split; congruence. - constructor. destruct (leb_total x y); split; congruence. + - case_eq (y <=? x). + + constructor. split; auto. + + constructor. split; congruence. + - constructor. destruct (leb_total x y); split; congruence. Qed. Definition eqb x y := (x <=? y) && (y <=? x). @@ -321,19 +323,19 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. Instance eq_equiv : Equivalence eq. Proof. split. - intros x; unfold eq, le. destruct (leb_total x x); auto. - intros x y; unfold eq, le. intuition. - intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto. + - intros x; unfold eq, le. destruct (leb_total x x); auto. + - intros x y; unfold eq, le. intuition. + - intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto. Qed. Instance lt_strorder : StrictOrder lt. Proof. split. - intros x. unfold lt; red; intuition. - intros x y z; unfold lt, le. intuition. - apply leb_trans with y; auto. - absurd (z <=? y); auto. - apply leb_trans with x; auto. + - intros x. unfold lt; red; intuition. + - intros x y z; unfold lt, le. intuition. + + apply leb_trans with y; auto. + + absurd (z <=? y); auto. + apply leb_trans with x; auto. Qed. Instance lt_compat : Proper (eq ==> eq ==> iff) lt. @@ -341,11 +343,11 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy' H. unfold eq, lt, le in *. intuition. - apply leb_trans with x; auto. - apply leb_trans with y; auto. - absurd (y <=? x); auto. - apply leb_trans with x'; auto. - apply leb_trans with y'; auto. + - apply leb_trans with x; auto. + apply leb_trans with y; auto. + - absurd (y <=? x); auto. + apply leb_trans with x'; auto. + apply leb_trans with y'; auto. Qed. Definition le_lteq : forall x y, le x y <-> lt x y \/ eq x y. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 1fb0a37e16..182b781fe1 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -290,9 +290,9 @@ Module Type CompareBasedOrderFacts Lemma compare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x?=y). Proof. case_eq (compare x y); intros H; constructor. - now apply compare_eq_iff. - now apply compare_lt_iff. - rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff. + - now apply compare_eq_iff. + - now apply compare_lt_iff. + - rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff. Qed. Lemma compare_eq x y : (x ?= y) = Eq -> x==y. diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index 10d9027435..ea7769a994 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -45,11 +45,11 @@ Section Wf_Disjoint_Union. intros. unfold well_founded. destruct a as [a| b]. - apply (acc_A_sum a). - apply (H a). + - apply (acc_A_sum a). + apply (H a). - apply (acc_B_sum H b). - apply (H0 b). + - apply (acc_B_sum H b). + apply (H0 b). Qed. End Wf_Disjoint_Union. diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 37fd2fb23f..b2d08186ea 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -36,23 +36,23 @@ Section WfLexicographic_Product. apply Acc_intro. destruct y as [x2 y1]; intro H6. simple inversion H6; intro. - cut (leA x2 x); intros. - apply IHAcc; auto with sets. - intros. - apply H2. - apply t_trans with x2; auto with sets. - - red in H2. - apply H2. - auto with sets. - - injection H1 as <- _. - injection H3 as <- _; auto with sets. - - rewrite <- H1. - injection H3 as -> H3. - apply IHAcc0. - elim inj_pair2 with A B x y' x0; assumption. + - cut (leA x2 x); intros. + + apply IHAcc; auto with sets. + * intros. + apply H2. + apply t_trans with x2; auto with sets. + + * red in H2. + apply H2. + auto with sets. + + + injection H1 as <- _. + injection H3 as <- _; auto with sets. + + - rewrite <- H1. + injection H3 as -> H3. + apply IHAcc0. + elim inj_pair2 with A B x y' x0; assumption. Defined. Theorem wf_lexprod : @@ -116,17 +116,17 @@ Section Swap. apply Acc_intro. destruct y0; intros. inversion_clear H; inversion_clear H1; apply H0. - apply sp_swap. - apply right_sym; auto with sets. + - apply sp_swap. + apply right_sym; auto with sets. - apply sp_swap. - apply left_sym; auto with sets. + - apply sp_swap. + apply left_sym; auto with sets. - apply sp_noswap. - apply right_sym; auto with sets. + - apply sp_noswap. + apply right_sym; auto with sets. - apply sp_noswap. - apply left_sym; auto with sets. + - apply sp_noswap. + apply left_sym; auto with sets. Defined. @@ -135,26 +135,26 @@ Section Swap. Proof. induction 1 as [x0 _ IHAcc0]; intros H2. cut (forall y0:A, R y0 x0 -> Acc SwapProd (y0, y)). - clear IHAcc0. - induction H2 as [x1 _ IHAcc1]; intros H4. - cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)). - clear IHAcc1. - intro. - apply Acc_intro. - destruct y; intro H5. - inversion_clear H5. - inversion_clear H0; auto with sets. - - apply swap_Acc. - inversion_clear H0; auto with sets. - - intros. - apply IHAcc1; auto with sets; intros. - apply Acc_inv with (y0, x1); auto with sets. - apply sp_noswap. - apply right_sym; auto with sets. - - auto with sets. + - clear IHAcc0. + induction H2 as [x1 _ IHAcc1]; intros H4. + cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)). + + clear IHAcc1. + intro. + apply Acc_intro. + destruct y; intro H5. + inversion_clear H5. + * inversion_clear H0; auto with sets. + + * apply swap_Acc. + inversion_clear H0; auto with sets. + + + intros. + apply IHAcc1; auto with sets; intros. + apply Acc_inv with (y0, x1); auto with sets. + apply sp_noswap. + apply right_sym; auto with sets. + + - auto with sets. Defined. diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index 9e671651fa..14d425b811 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -27,13 +27,13 @@ Section WfUnion. forall z:A, R2 z y -> exists2 y' : A, R2 y' x & clos_trans A R1 z y'. Proof. induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros. - elim H with y x z; auto with sets; intros x0 H2 H3. - exists x0; auto with sets. + - elim H with y x z; auto with sets; intros x0 H2 H3. + exists x0; auto with sets. - elim IH1 with z0; auto with sets; intros. - elim IH2 with x0; auto with sets; intros. - exists x1; auto with sets. - apply t_trans with x0; auto with sets. + - elim IH1 with z0; auto with sets; intros. + elim IH2 with x0; auto with sets; intros. + exists x1; auto with sets. + apply t_trans with x0; auto with sets. Qed. @@ -46,21 +46,21 @@ Section WfUnion. elim H3; intros; auto with sets. cut (clos_trans A R1 y x); auto with sets. elimtype (Acc (clos_trans A R1) y); intros. - apply Acc_intro; intros. - elim H8; intros. - apply H6; auto with sets. - apply t_trans with x0; auto with sets. + - apply Acc_intro; intros. + elim H8; intros. + + apply H6; auto with sets. + apply t_trans with x0; auto with sets. - elim strip_commut with x x0 y0; auto with sets; intros. - apply Acc_inv_trans with x1; auto with sets. - unfold union. - elim H11; auto with sets; intros. - apply t_trans with y1; auto with sets. + + elim strip_commut with x x0 y0; auto with sets; intros. + apply Acc_inv_trans with x1; auto with sets. + unfold union. + elim H11; auto with sets; intros. + apply t_trans with y1; auto with sets. - apply (Acc_clos_trans A). - apply Acc_inv with x; auto with sets. - apply H0. - apply Acc_intro; auto with sets. + - apply (Acc_clos_trans A). + apply Acc_inv with x; auto with sets. + apply H0. + apply Acc_intro; auto with sets. Qed. diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index cf46657d36..eb98fb2aba 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -39,9 +39,9 @@ Section WellOrdering. intros. apply (H v0 y0). cut (f = f1). - intros E; rewrite E; auto. - symmetry . - apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5). + - intros E; rewrite E; auto. + - symmetry . + apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5). Qed. End WellOrdering. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 9ecd8f19ce..68371edcb1 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -186,7 +186,7 @@ let pp_vo_dep dir fmt vo = (* We explicitly include the location of coqlib to avoid tricky issues with coqlib location *) let libflag = "-coqlib %{project_root}" in (* The final build rule *) - let action = sprintf "(chdir %%{project_root} (run coqtop -boot %s %s %s -compile %s))" libflag eflag cflag source in + let action = sprintf "(chdir %%{project_root} (run coqc -boot %s %s %s %s))" libflag eflag cflag source in let all_targets = gen_coqc_targets vo in pp_rule fmt all_targets deps action @@ -271,8 +271,13 @@ let exec_ifile f = match Array.length Sys.argv with | 1 -> f stdin | 2 -> - let ic = open_in Sys.argv.(1) in - (try f ic with _ -> close_in ic) + let in_file = Sys.argv.(1) in + begin try + let ic = open_in in_file in + (try f ic + with _ -> eprintf "Error: exec_ifile@\n%!"; close_in ic) + with _ -> eprintf "Error: cannot open input file %s@\n%!" in_file + end | _ -> eprintf "Error: wrong number of arguments@\n%!"; exit 1 let _ = diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 5fd894e908..4f01a6bd87 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -424,7 +424,7 @@ let _ = end; let project = ensure_root_dir project in - + if project.install_kind <> (Some CoqProject_file.NoInstall) then begin warn_install_at_root_directory project; end; @@ -432,7 +432,7 @@ let _ = check_overlapping_include project; Envars.set_coqlib ~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; close_out ocm; diff --git a/tools/coqc.ml b/tools/coqc.ml deleted file mode 100644 index ae841212a7..0000000000 --- a/tools/coqc.ml +++ /dev/null @@ -1,163 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Coq compiler : coqc *) - -(** For improving portability, coqc is now an OCaml program instead - of a shell script. We use as much as possible the Sys and Filename - module for better portability, but the Unix module is still used - here and there (with explicitly qualified function names Unix.foo). - - We process here the commmand line to extract names of files to compile, - then we compile them one by one while passing by the rest of the command - line to a process running "coqtop -batch -compile <file>". -*) - -(* Environment *) - -let environment = Unix.environment () - -let use_bytecode = ref false -let image = ref "" - -let verbose = ref false - -let rec make_compilation_args = function - | [] -> [] - | file :: fl -> - (if !verbose then "-compile-verbose" else "-compile") - :: file :: (make_compilation_args fl) - -(* compilation of files [files] with command [command] and args [args] *) - -let compile command args files = - let args' = command :: args @ (make_compilation_args files) in - match Sys.os_type with - | "Win32" -> - let pid = - Unix.create_process_env command (Array.of_list args') environment - Unix.stdin Unix.stdout Unix.stderr - in - let status = snd (Unix.waitpid [] pid) in - let errcode = - match status with Unix.WEXITED c|Unix.WSTOPPED c|Unix.WSIGNALED c -> c - in - exit errcode - | _ -> - Unix.execvpe command (Array.of_list args') environment - -let usage () = - Usage.print_usage_coqc () ; - flush stderr ; - exit 1 - -(* parsing of the command line *) -let extra_arg_needed = ref true - -let parse_args () = - let rec parse (cfiles,args) = function - | [] -> - List.rev cfiles, List.rev args - | ("-verbose" | "--verbose") :: rem -> - verbose := true ; parse (cfiles,args) rem - | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem - | "-image" :: [] -> usage () - | "-byte" :: rem -> use_bytecode := true; parse (cfiles,args) rem - | "-opt" :: rem -> use_bytecode := false; parse (cfiles,args) rem - -(* Informative options *) - - | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () - - | ("-v"|"--version") :: _ -> Usage.version 0 - - | ("-where") :: _ -> - Envars.set_coqlib ~fail:(fun x -> x); - print_endline (Envars.coqlib ()); - exit 0 - - | ("-config" | "--config") :: _ -> - Envars.set_coqlib ~fail:(fun x -> x); - Envars.print_config stdout Coq_config.all_src_dirs; - exit 0 - - | ("-print-version" | "--print-version") :: _ -> - Usage.machine_readable_version 0 - -(* Options for coqtop : a) options with 0 argument *) - - | ("-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" - |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" - |"-q"|"-profile"|"-echo" |"-quiet" - |"-silent"|"-m"|"-beautify"|"-strict-implicit" - |"-impredicative-set"|"-vm" - |"-indices-matter"|"-quick"|"-type-in-type" - |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" - |"-stm-debug" - as o) :: rem -> - parse (cfiles,o::args) rem - -(* Options for coqtop : b) options with 1 argument *) - - | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"|"-color" - |"-load-vernac-source"|"-l"|"-load-vernac-object" - |"-load-ml-source"|"-require"|"-load-ml-object" - |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"|"-topfile" - |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o"|"-profile-ltac-cutoff"|"-mangle-names"|"-bytecode-compiler"|"-native-compiler" - as o) :: rem -> - begin - match rem with - | s :: rem' -> parse (cfiles,s::o::args) rem' - | [] -> usage () - end - | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem - -(* Options for coqtop : c) options with 1 argument and possibly more *) - - | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem - | ("-schedule-vio-checking" - |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> - let nodash, rem = - CList.split_when (fun x -> String.length x > 1 && x.[0] = '-') rem in - extra_arg_needed := false; - parse (cfiles, List.rev nodash @ s :: o :: args) rem - - | f :: rem -> - if Sys.file_exists f then - parse (f::cfiles,args) rem - else - let fv = f ^ ".v" in - if Sys.file_exists fv then - parse (fv::cfiles,args) rem - else begin - prerr_endline ("coqc: "^f^": no such file or directory") ; - exit 1 - end - in - parse ([],[]) (List.tl (Array.to_list Sys.argv)) - -(* main: we parse the command line, define the command to compile files - * and then call the compilation on each file *) - -let main () = - let cfiles, args = parse_args () in - if cfiles = [] && !extra_arg_needed then begin - prerr_endline "coqc: too few arguments" ; - usage () - end; - let coqtopname = - if !image <> "" then !image - else System.get_toplevel_path ~byte:!use_bytecode "coqtop" - in - (* List.iter (compile coqtopname args) cfiles*) - Unix.handle_unix_error (compile coqtopname args) cfiles - -let _ = Printexc.print main () diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 4e80caa4cc..66f1f257b8 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -530,6 +530,7 @@ 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 + (* option_boot is actually always false in this branch *) Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); let coqlib = Envars.coqlib () in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; diff --git a/tools/dune b/tools/dune index 31b70fb06c..204bd09535 100644 --- a/tools/dune +++ b/tools/dune @@ -16,13 +16,6 @@ (libraries coq.lib)) (executable - (name coqc) - (public_name coqc) - (package coq) - (modules coqc) - (libraries coq.toplevel)) - -(executable (name coqworkmgr) (public_name coqworkmgr) (package coq) diff --git a/topbin/coqc_bin.ml b/topbin/coqc_bin.ml new file mode 100644 index 0000000000..d711c81124 --- /dev/null +++ b/topbin/coqc_bin.ml @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Main coqc initialization *) +let _ = + Coqc.main () diff --git a/topbin/dune b/topbin/dune index 52f472d149..f42e4d6fc2 100644 --- a/topbin/dune +++ b/topbin/dune @@ -20,11 +20,19 @@ (modes byte) (link_flags -linkall)) +(executable + (name coqc_bin) + (public_name coqc) + (package coq) + (modules coqc_bin) + (libraries coq.toplevel) + (link_flags -linkall)) + ; Workers (executables (names coqqueryworker_bin coqtacticworker_bin coqproofworker_bin) (public_names coqqueryworker.opt coqtacticworker.opt coqproofworker.opt) (package coq) - (modules :standard \ coqtop_byte_bin coqtop_bin) + (modules :standard \ coqtop_byte_bin coqtop_bin coqc_bin) (libraries coq.toplevel) (link_flags -linkall)) diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index b248b87880..8064ee8880 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -10,6 +10,7 @@ open Pp open Coqargs +open Coqcargs let fatal_error msg = Topfmt.std_logger Feedback.Error msg; @@ -81,7 +82,7 @@ let ensure_exists f = fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) (* Compile a vernac file *) -let compile opts ~echo ~f_in ~f_out = +let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = let pfs = Proof_global.get_all_proof_names () in @@ -95,7 +96,10 @@ let compile opts ~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 - match opts.compilation_mode with + 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; let long_f_dot_v = ensure_v f_in in @@ -108,6 +112,7 @@ let compile opts ~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 @@ -124,7 +129,7 @@ let compile opts ~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 (); @@ -158,6 +163,7 @@ let compile opts ~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 @@ -167,7 +173,7 @@ let compile opts ~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 -> @@ -179,47 +185,47 @@ let compile opts ~echo ~f_in ~f_out = let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile opts ~echo ~f_in ~f_out = +let compile opts copts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile opts ~echo ~f_in ~f_out; + compile opts copts ~echo ~f_in ~f_out; CoqworkmgrApi.giveback 1 -let compile_file opts (f_in, echo) = - let f_out = opts.compilation_output_name in +let compile_file opts copts (f_in, echo) = + let f_out = copts.compilation_output_name in if !Flags.beautify then Flags.with_option Flags.beautify_file - (fun f_in -> compile opts ~echo ~f_in ~f_out) f_in + (fun f_in -> compile opts copts ~echo ~f_in ~f_out) f_in else - compile opts ~echo ~f_in ~f_out + compile opts copts ~echo ~f_in ~f_out -let compile_files opts = - let compile_list = List.rev opts.compile_list in - List.iter (compile_file opts) compile_list +let compile_files opts copts = + let compile_list = List.rev copts.compile_list in + List.iter (compile_file opts copts) compile_list (******************************************************************************) (* VIO Dispatching *) (******************************************************************************) -let check_vio_tasks opts = +let check_vio_tasks copts = let rc = List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) - true (List.rev opts.vio_tasks) in + true (List.rev copts.vio_tasks) in if not rc then fatal_error Pp.(str "VIO Task Check failed") (* vio files *) -let schedule_vio opts = - if opts.vio_checking then - Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files +let schedule_vio copts = + if copts.vio_checking then + Vio_checking.schedule_vio_checking copts.vio_files_j copts.vio_files else - Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files + Vio_checking.schedule_vio_compilation copts.vio_files_j copts.vio_files -let do_vio opts = +let do_vio opts copts = (* We must initialize the loadpath here as the vio scheduling process happens outside of the STM *) - if opts.vio_files <> [] || opts.vio_tasks <> [] then + if copts.vio_files <> [] || copts.vio_tasks <> [] then let iload_path = build_load_path opts in List.iter Mltop.add_coq_path iload_path; (* Vio compile pass *) - if opts.vio_files <> [] then schedule_vio opts; + if copts.vio_files <> [] then schedule_vio copts; (* Vio task pass *) - if opts.vio_tasks <> [] then check_vio_tasks opts + if copts.vio_tasks <> [] then check_vio_tasks copts diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index 757c91c408..29a76eb966 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -10,10 +10,10 @@ (** [load_init_vernaculars opts ~state] Load vernaculars from the init (rc) file *) -val load_init_vernaculars : Coqargs.coq_cmdopts -> state:Vernac.State.t-> Vernac.State.t +val load_init_vernaculars : Coqargs.t -> state:Vernac.State.t-> Vernac.State.t (** [compile_files opts] compile files specified in [opts] *) -val compile_files : Coqargs.coq_cmdopts -> unit +val compile_files : Coqargs.t -> Coqcargs.t -> unit (** [do_vio opts] process [.vio] files in [opts] *) -val do_vio : Coqargs.coq_cmdopts -> unit +val do_vio : Coqargs.t -> Coqcargs.t -> unit diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index eaa050bdce..0c9201c3a5 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"; @@ -31,10 +34,13 @@ let set_type_in_type () = (******************************************************************************) -type compilation_mode = BuildVo | BuildVio | Vio2Vo type color = [`ON | `AUTO | `OFF] -type coq_cmdopts = { +type native_compiler = NativeOff | NativeOn of { ondemand : bool } + +type t = { + + boot : bool; load_init : bool; load_rcfile : bool; @@ -45,28 +51,18 @@ type coq_cmdopts = { vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) - (* XXX: Fusion? *) - batch_mode : bool; - compilation_mode : compilation_mode; - toplevel_name : Stm.interactive_top; - compile_list: (string * bool) list; (* bool is verbosity *) - compilation_output_name : string option; - load_vernacular_list : (string * bool) list; - - vio_checking: bool; - vio_tasks : (int list * string) list; - vio_files : string list; - vio_files_j : int; + batch : bool; color : color; 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; @@ -85,13 +81,19 @@ type coq_cmdopts = { print_emacs : bool; inputstate : string option; - outputstate : string option; } let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) -let default_opts = { +let default_native = + if Coq_config.native_compiler + then NativeOn {ondemand=true} + else NativeOff + +let default = { + + boot = false; load_init = true; load_rcfile = true; @@ -101,27 +103,18 @@ let default_opts = { vo_includes = []; vo_requires = []; - batch_mode = false; - compilation_mode = BuildVo; - toplevel_name = Stm.TopLogical default_toplevel; - compile_list = []; - compilation_output_name = None; - load_vernacular_list = []; - - vio_checking = false; - vio_tasks = []; - vio_files = []; - vio_files_j = 0; + batch = false; color = `AUTO; 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; @@ -142,7 +135,6 @@ let default_opts = { (* Quiet / verbosity options should be here *) inputstate = None; - outputstate = None; } (******************************************************************************) @@ -168,44 +160,9 @@ let add_compat_require opts v = | Flags.V8_9 -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) | Flags.Current -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) -let set_batch_mode opts = - (* XXX: This should be in the argument record *) - Flags.quiet := true; - System.trust_file_cache := true; - { opts with batch_mode = true } - -let add_compile opts verbose s = - let opts = set_batch_mode opts in - if not opts.glob_opt then Dumpglob.dump_to_dotglob (); - (* make the file name explicit; needed not to break up Coq loadpath stuff. *) - let s = - let open Filename in - if is_implicit s - then concat current_dir_name s - else s - in - { opts with compile_list = (s,verbose) :: opts.compile_list } - let add_load_vernacular opts verb s = { opts with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.load_vernacular_list } -let add_vio_task opts f = - let opts = set_batch_mode opts in - { opts with vio_tasks = f :: opts.vio_tasks } - -let add_vio_file opts f = - let opts = set_batch_mode opts in - { opts with vio_files = f :: opts.vio_files } - -let set_vio_checking_j opts opt j = - try { opts with vio_files_j = int_of_string j } - with Failure _ -> - prerr_endline ("The first argument of " ^ opt ^ " must the number"); - prerr_endline "of concurrent workers to be used (a positive integer)."; - prerr_endline "Makefiles generated by coq_makefile should be called"; - prerr_endline "setting the J variable like in 'make vio2vo J=3'"; - exit 1 - (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; @@ -215,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" @@ -225,45 +183,34 @@ let set_inputstate opts s = warn_deprecated_inputstate (); { opts with inputstate = Some s } -let warn_deprecated_outputstate = - CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated" - (fun () -> - Pp.strbrk "The outputstate option is deprecated and discouraged.") - -let set_outputstate opts s = - warn_deprecated_outputstate (); - { opts with outputstate = Some s } - let exitcode opts = if opts.filter_opts then 2 else 0 (******************************************************************************) (* Parsing helpers *) (******************************************************************************) -let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) - 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 @@ -273,27 +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 - -let is_not_dash_option = function - | Some f when String.length f > 0 && f.[0] <> '-' -> true - | _ -> false + | _ -> + error_wrong_arg ("Error: force expected after "^opt) -let rec add_vio_args peek next oval = - if is_not_dash_option (peek ()) then - let oval = add_vio_file oval (next ()) in - add_vio_args peek next oval - else oval let get_native_name s = (* We ignore even critical errors because this mode has to be super silent *) @@ -311,7 +251,7 @@ let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesy exception NoCoqLib -let usage batch = +let usage help = begin try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib) with NoCoqLib -> usage_no_coqlib () @@ -319,12 +259,10 @@ let usage batch = let lp = Coqinit.toplevel_init_load_path () in (* Necessary for finding the toplevels below *) List.iter Mltop.add_coq_path lp; - if batch - then Usage.print_usage_coqc () - else Usage.print_usage_coqtop () + help () (* Main parsing routine *) -let parse_args init_opts arglist : coq_cmdopts * string list = +let parse_args ~help ~init arglist : t * string list = let args = ref arglist in let extras = ref [] in let rec parse oval = match !args with @@ -336,10 +274,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = | x::rem -> args := rem; x | [] -> error_missing_arg opt in - let peek_next () = match !args with - | x::_ -> Some x - | [] -> None - in let noval = begin match opt with (* Complex options with many args *) @@ -365,23 +299,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = | _ -> error_missing_arg opt end - (* Options with two arg *) - |"-check-vio-tasks" -> - let tno = get_task_list (next ()) in - let tfile = next () in - add_vio_task oval (tno,tfile) - - |"-schedule-vio-checking" -> - let oval = { oval with vio_checking = true } in - let oval = set_vio_checking_j oval opt (next ()) in - let oval = add_vio_file oval (next ()) in - add_vio_args peek_next next oval - - |"-schedule-vio2vo" -> - let oval = set_vio_checking_j oval opt (next ()) in - let oval = add_vio_file oval (next ()) in - add_vio_args peek_next next oval - (* Options with one arg *) |"-coqlib" -> Envars.set_user_coqlib (next ()); @@ -401,8 +318,12 @@ let parse_args init_opts arglist : coq_cmdopts * 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" -> @@ -436,12 +357,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = Flags.compat_version := v; add_compat_require oval v - |"-compile" -> - add_compile oval false (next ()) - - |"-compile-verbose" -> - add_compile oval true (next ()) - |"-dump-glob" -> Dumpglob.dump_into_file (next ()); { oval with glob_opt = true } @@ -458,9 +373,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = |"-inputstate"|"-is" -> set_inputstate oval (next ()) - |"-outputstate" -> - set_outputstate oval (next ()) - |"-load-ml-object" -> Mltop.dir_ml_load (next ()); oval @@ -506,10 +418,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()); oval - |"-vio2vo" -> - let oval = add_compile oval false (next ()) in - { oval with compilation_mode = Vio2Vo } - |"-w" | "-W" -> let w = next () in if w = "none" then @@ -519,8 +427,6 @@ let parse_args init_opts arglist : coq_cmdopts * string list = CWarnings.set_flags (CWarnings.normalize_flags_string w); oval - |"-o" -> { oval with compilation_output_name = Some (next()) } - |"-bytecode-compiler" -> { oval with enable_VM = get_bool opt (next ()) } @@ -531,15 +437,15 @@ let parse_args init_opts arglist : coq_cmdopts * 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" @@ -548,10 +454,12 @@ let parse_args init_opts arglist : coq_cmdopts * string list = { oval with stm_flags = { oval.stm_flags with Stm.AsyncOpts.async_proofs_never_reopen_branch = true }} - |"-batch" -> set_batch_mode oval + |"-batch" -> + Flags.quiet := true; + { 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 } @@ -560,7 +468,7 @@ let parse_args init_opts arglist : coq_cmdopts * 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 @@ -578,13 +486,12 @@ let parse_args init_opts arglist : coq_cmdopts * string list = Flags.quiet := true; Flags.make_warn false; oval - |"-quick" -> { oval with compilation_mode = BuildVio } |"-list-tags" -> { oval with print_tags = true } |"-time" -> { oval with time = true } |"-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 oval.batch_mode; oval + |"-h"|"-H"|"-?"|"-help"|"--help" -> usage help; oval |"-v"|"--version" -> Usage.version (exitcode oval) |"-print-version"|"--print-version" -> Usage.machine_readable_version (exitcode oval) @@ -597,13 +504,13 @@ let parse_args init_opts arglist : coq_cmdopts * string list = parse noval in try - parse init_opts + parse init with any -> fatal_error any (******************************************************************************) (* Startup LoadPath and Modules *) (******************************************************************************) -(* prelude_data == From Coq Require Export Prelude. *) +(* prelude_data == From Coq Require Import Prelude. *) let prelude_data = "Prelude", Some "Coq", Some false let require_libs opts = diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index e645b0c126..9cc846edea 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -8,12 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type compilation_mode = BuildVo | BuildVio | Vio2Vo type color = [`ON | `AUTO | `OFF] val default_toplevel : Names.DirPath.t -type coq_cmdopts = { +type native_compiler = NativeOff | NativeOn of { ondemand : bool } + +type t = { + + boot : bool; load_init : bool; load_rcfile : bool; @@ -23,29 +26,18 @@ type coq_cmdopts = { vo_includes : Mltop.coq_path list; vo_requires : (string * string option * bool option) list; - (* Fuse these two? Currently, [batch_mode] is only used to - distinguish coqc / coqtop in help display. *) - batch_mode : bool; - compilation_mode : compilation_mode; - toplevel_name : Stm.interactive_top; - compile_list: (string * bool) list; (* bool is verbosity *) - compilation_output_name : string option; - load_vernacular_list : (string * bool) list; - - vio_checking: bool; - vio_tasks : (int list * string) list; - vio_files : string list; - vio_files_j : int; + batch : bool; color : color; 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; @@ -63,18 +55,14 @@ type coq_cmdopts = { print_emacs : bool; - (* Quiet / verbosity options should be here *) - inputstate : string option; - outputstate : string option; - } (* Default options *) -val default_opts : coq_cmdopts +val default : t -val parse_args : coq_cmdopts -> string list -> coq_cmdopts * string list -val exitcode : coq_cmdopts -> int +val parse_args : help:(unit -> unit) -> init:t -> string list -> t * string list +val exitcode : t -> int -val require_libs : coq_cmdopts -> (string * string option * bool option) list -val build_load_path : coq_cmdopts -> Mltop.coq_path list +val require_libs : t -> (string * string option * bool option) list +val build_load_path : t -> Mltop.coq_path list diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml new file mode 100644 index 0000000000..d4107177a7 --- /dev/null +++ b/toplevel/coqc.ml @@ -0,0 +1,67 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let set_noninteractive_mode () = + Flags.quiet := true; + System.trust_file_cache := true + +let outputstate opts = + Option.iter (fun ostate_file -> + let fname = CUnix.make_suffix ostate_file ".coq" in + States.extern_state fname) opts.Coqcargs.outputstate + +let coqc_main () = + (* Careful because init_toplevel will call Summary.init_summaries, + thus options such as `quiet` have to be set after the main + initialisation is run. *) + let coqc_init ~opts args = + set_noninteractive_mode (); + let opts, args = Coqtop.(coqtop_toplevel.init) ~opts args in + opts, args + in + let opts, extras = + Topfmt.(in_phase ~phase:Initialization) + Coqtop.(init_toplevel ~help:Usage.print_usage_coqc ~init:Coqargs.default coqc_init) List.(tl (Array.to_list Sys.argv)) in + + let copts = Coqcargs.parse extras in + + if not opts.Coqargs.glob_opt then Dumpglob.dump_to_dotglob (); + + Topfmt.(in_phase ~phase:CompilationPhase) + Ccompile.compile_files opts copts; + + (* Careful this will modify the load-path and state so after this + point some stuff may not be safe anymore. *) + Topfmt.(in_phase ~phase:CompilationPhase) + Ccompile.do_vio opts copts; + + (* Allow the user to output an arbitrary state *) + outputstate copts; + + flush_all(); + if opts.Coqargs.output_context then begin + let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) + end; + CProfile.print_profile () + +let main () = + let _feeder = Feedback.add_feeder Coqloop.coqloop_feed in + try + coqc_main (); + exit 0 + with exn -> + flush_all(); + Topfmt.print_err_exn exn; + flush_all(); + let exit_code = + if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 + in + exit exit_code diff --git a/toplevel/coqc.mli b/toplevel/coqc.mli new file mode 100644 index 0000000000..6049c5e188 --- /dev/null +++ b/toplevel/coqc.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val main : unit -> unit diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml new file mode 100644 index 0000000000..7445619d26 --- /dev/null +++ b/toplevel/coqcargs.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo + +type t = + { compilation_mode : compilation_mode + + ; compile_list: (string * bool) list (* bool is verbosity *) + ; compilation_output_name : string option + + ; vio_checking : bool + ; vio_tasks : (int list * string) list + ; vio_files : string list + ; vio_files_j : int + + ; echo : bool + + ; outputstate : string option; + } + +let default = + { compilation_mode = BuildVo + + ; compile_list = [] + ; compilation_output_name = None + + ; vio_checking = false + ; vio_tasks = [] + ; vio_files = [] + ; vio_files_j = 0 + + ; echo = false + + ; outputstate = None + } + +let depr opt = + Feedback.msg_warning Pp.(seq[str "Option "; str opt; str " is a noop and deprecated"]) + +(* XXX Remove this duplication with Coqargs *) +let fatal_error exn = + Topfmt.(in_phase ~phase:ParsingCommandLine print_err_exn exn); + let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in + exit exit_code + +let error_missing_arg s = + prerr_endline ("Error: extra argument expected after option "^s); + prerr_endline "See -help for the syntax of supported options"; + exit 1 + +let add_compile ?echo copts s = + (* make the file name explicit; needed not to break up Coq loadpath stuff. *) + let echo = Option.default copts.echo echo in + let s = + let open Filename in + if is_implicit s + then concat current_dir_name s + else s + in + { copts with compile_list = (s,echo) :: copts.compile_list } + +let add_vio_task opts f = + { opts with vio_tasks = f :: opts.vio_tasks } + +let add_vio_file opts f = + { opts with vio_files = f :: opts.vio_files } + +let set_vio_checking_j opts opt j = + try { opts with vio_files_j = int_of_string j } + with Failure _ -> + prerr_endline ("The first argument of " ^ opt ^ " must the number"); + prerr_endline "of concurrent workers to be used (a positive integer)."; + prerr_endline "Makefiles generated by coq_makefile should be called"; + prerr_endline "setting the J variable like in 'make vio2vo J=3'"; + exit 1 + +let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) + +let is_not_dash_option = function + | Some f when String.length f > 0 && f.[0] <> '-' -> true + | _ -> false + +let rec add_vio_args peek next oval = + if is_not_dash_option (peek ()) then + let oval = add_vio_file oval (next ()) in + add_vio_args peek next oval + else oval + +let warn_deprecated_outputstate = + CWarnings.create ~name:"deprecated-outputstate" ~category:"deprecated" + (fun () -> + Pp.strbrk "The outputstate option is deprecated and discouraged.") + +let set_outputstate opts s = + warn_deprecated_outputstate (); + { opts with outputstate = Some s } + +let parse arglist : t = + let echo = ref false in + let args = ref arglist in + let extras = ref [] in + let rec parse (oval : t) = match !args with + | [] -> + (oval, List.rev !extras) + | opt :: rem -> + args := rem; + let next () = match !args with + | x::rem -> args := rem; x + | [] -> error_missing_arg opt + in + let peek_next () = match !args with + | x::_ -> Some x + | [] -> None + in + let noval : t = begin match opt with + (* Deprecated options *) + | "-opt" + | "-byte" as opt -> + depr opt; + oval + | "-image" as opt -> + depr opt; + let _ = next () in + oval + (* Verbose == echo mode *) + | "-verbose" -> + echo := true; + oval + (* Output filename *) + | "-o" -> + { oval with compilation_output_name = Some (next ()) } + | "-quick" -> + { oval with compilation_mode = BuildVio } + | "-check-vio-tasks" -> + let tno = get_task_list (next ()) in + let tfile = next () in + add_vio_task oval (tno,tfile) + + | "-schedule-vio-checking" -> + let oval = { oval with vio_checking = true } in + let oval = set_vio_checking_j oval opt (next ()) in + let oval = add_vio_file oval (next ()) in + add_vio_args peek_next next oval + + | "-schedule-vio2vo" -> + let oval = set_vio_checking_j oval opt (next ()) in + let oval = add_vio_file oval (next ()) in + add_vio_args peek_next next oval + + | "-vio2vo" -> + let oval = add_compile ~echo:false oval (next ()) in + { oval with compilation_mode = Vio2Vo } + + | "-outputstate" -> + set_outputstate oval (next ()) + + | s -> + extras := s :: !extras; + oval + end in + parse noval + in + try + let opts, extra = parse default in + List.fold_left add_compile opts extra + with any -> fatal_error any diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli new file mode 100644 index 0000000000..7792056b24 --- /dev/null +++ b/toplevel/coqcargs.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type compilation_mode = BuildVo | BuildVio | Vio2Vo + +type t = + { compilation_mode : compilation_mode + + ; compile_list: (string * bool) list (* bool is verbosity *) + ; compilation_output_name : string option + + ; vio_checking : bool + ; vio_tasks : (int list * string) list + ; vio_files : string list + ; vio_files_j : int + + ; echo : bool + + ; outputstate : string option + } + +val default : t +val parse : string list -> t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index cdbe444e5b..1094fc86b4 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 = @@ -366,6 +366,11 @@ let top_goal_print ~doc c oldp newp = let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer +let exit_on_error = + let open Goptions in + declare_bool_option_and_ref ~depr:false ~name:"coqtop-exit-on-error" ~key:["Coqtop";"Exit";"On";"Error"] + ~value:false + let rec vernac_loop ~state = let open CAst in let open Vernac.State in @@ -410,6 +415,7 @@ let rec vernac_loop ~state = let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer; + if exit_on_error () then exit 1; vernac_loop ~state let rec loop ~state = diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 7d03484412..0cc22ba31d 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -31,7 +31,7 @@ val coqloop_feed : Feedback.feedback -> unit (** Last document seen after `Drop` *) val drop_last_doc : Vernac.State.t option ref -val drop_args : Coqargs.coq_cmdopts option ref +val drop_args : Coqargs.t option ref (** Main entry point of Coq: read and execute vernac commands. *) -val loop : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit +val loop : opts:Coqargs.t -> state:Vernac.State.t -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 56622abc92..9115fbb726 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -58,11 +58,6 @@ let inputstate opts = let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in States.intern_state fname) opts.inputstate -let outputstate opts = - Option.iter (fun ostate_file -> - let fname = CUnix.make_suffix ostate_file ".coq" in - States.extern_state fname) opts.outputstate - (******************************************************************************) (* Fatal Errors *) (******************************************************************************) @@ -102,7 +97,7 @@ let init_color opts = else false in - if Proof_diffs.show_diffs () && not term_color && not opts.batch_mode then + if Proof_diffs.show_diffs () && not term_color then (prerr_endline "Error: -diffs requires enabling -color"; exit 1); Topfmt.init_terminal_output ~color:term_color @@ -148,116 +143,115 @@ let init_gc () = Gc.space_overhead = 120} (** Main init routine *) -let init_toplevel init_opts custom_init arglist = +let init_toplevel ~help ~init custom_init arglist = (* Coq's init process, phase 1: OCaml parameters, basic structures, and IO *) CProfile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in Lib.init(); (* Coq's init process, phase 2: Basic Coq environment, load-path, plugins. *) - let res = begin - try - let opts,extras = parse_args init_opts arglist in - memory_stat := opts.memory_stat; - - (* 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)); - if opts.print_where then begin - print_endline (Envars.coqlib ()); - exit (exitcode opts) - end; - if opts.print_config then begin - Envars.print_config stdout Coq_config.all_src_dirs; - exit (exitcode opts) - end; - if opts.print_tags then begin - print_style_tags opts; - exit (exitcode opts) - end; - if opts.filter_opts then begin - print_string (String.concat "\n" extras); - exit 0; - end; - let top_lp = Coqinit.toplevel_init_load_path () in - List.iter Mltop.add_coq_path top_lp; - let opts, extras = custom_init ~opts extras in - if not (CList.is_empty extras) then begin - prerr_endline ("Don't know what to do with "^String.concat " " extras); - prerr_endline "See -help for the list of supported options"; - exit 1 - end; - Flags.if_verbose print_header (); - Mltop.init_known_plugins (); - 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; - - (* Allow the user to load an arbitrary state here *) - inputstate opts; - - (* This state will be shared by all the documents *) - Stm.init_core (); - - (* Coq init process, phase 3: Stm initialization, backtracking state. - - It is essential that the module system is in a consistent - state before we take the first snapshot. This was not - guaranteed in the past, but now is thanks to the STM API. - - We split the codepath here depending whether coqtop is called - in interactive mode or not. *) - - (* The condition for starting the interactive mode is a bit - convoluted, we should really refactor batch/compilation_mode - more. *) - if (not opts.batch_mode - || CList.(is_empty opts.compile_list && is_empty opts.vio_files && is_empty opts.vio_tasks)) - (* Interactive *) - then begin - let iload_path = build_load_path opts in - let require_libs = require_libs opts in - let stm_options = opts.stm_flags in - let open Vernac.State in - let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) - Stm.new_doc - Stm.{ doc_type = Interactive opts.toplevel_name; - iload_path; require_libs; stm_options; - } in - let state = { doc; sid; proof = None; time = opts.time } in - Some (Ccompile.load_init_vernaculars opts ~state), opts - (* Non interactive: we perform a sequence of compilation steps *) - end else begin - Ccompile.compile_files opts; - (* Careful this will modify the load-path and state so after - this point some stuff may not be safe anymore. *) - Ccompile.do_vio opts; - (* Allow the user to output an arbitrary state *) - outputstate opts; - None, opts - end; - with any -> - flush_all(); - fatal_error_exn any - end in - Feedback.del_feeder init_feeder; - res + let opts, extras = parse_args ~help ~init arglist in + memory_stat := opts.memory_stat; + + (* 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)); + if opts.print_where then begin + print_endline (Envars.coqlib ()); + exit (exitcode opts) + end; + if opts.print_config then begin + Envars.print_config stdout Coq_config.all_src_dirs; + exit (exitcode opts) + end; + if opts.print_tags then begin + print_style_tags opts; + exit (exitcode opts) + end; + if opts.filter_opts then begin + print_string (String.concat "\n" extras); + exit 0; + end; + let top_lp = Coqinit.toplevel_init_load_path () in + List.iter Mltop.add_coq_path top_lp; + let opts, extras = custom_init ~opts extras in + Flags.if_verbose print_header (); + Mltop.init_known_plugins (); + + Global.set_engagement opts.impredicative_set; + Global.set_indices_matter opts.indices_matter; + Global.set_VM opts.enable_VM; + Global.set_native_compiler (match opts.native_compiler with NativeOff -> false | NativeOn _ -> true); + + (* Allow the user to load an arbitrary state here *) + inputstate opts; + + (* This state will be shared by all the documents *) + Stm.init_core (); + + (* Coq init process, phase 3: Stm initialization, backtracking state. + + It is essential that the module system is in a consistent + state before we take the first snapshot. This was not + guaranteed in the past, but now is thanks to the STM API. + *) + opts, extras + +type init_fn = opts:Coqargs.t -> string list -> Coqargs.t * string list type custom_toplevel = - { init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list - ; run : opts:coq_cmdopts -> state:Vernac.State.t -> unit - ; opts : Coqargs.coq_cmdopts + { init : init_fn + ; run : opts:Coqargs.t -> state:Vernac.State.t -> unit + ; opts : Coqargs.t } + +let init_toploop opts = + let iload_path = build_load_path opts in + let require_libs = require_libs opts in + let stm_options = opts.stm_flags in + let open Vernac.State in + 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 + Ccompile.load_init_vernaculars opts ~state, opts + +(* To remove in 8.11 *) +let call_coqc args = + let remove str arr = Array.(of_list List.(filter (fun l -> not String.(equal l str)) (to_list arr))) in + let coqc_name = Filename.remove_extension (System.get_toplevel_path "coqc") in + let args = remove "-compile" args in + Unix.execv coqc_name args + +let deprecated_coqc_warning = CWarnings.(create + ~name:"deprecate-compile-arg" + ~category:"toplevel" + ~default:Enabled + (fun opt_name -> Pp.(seq [str "The option "; str opt_name; str" is deprecated, please use coqc."]))) + +let rec coqc_deprecated_check args acc extras = + match extras with + | [] -> acc + | "-o" :: _ :: rem -> + deprecated_coqc_warning "-o"; + coqc_deprecated_check args acc rem + | ("-compile"|"-compile-verbose") :: file :: rem -> + deprecated_coqc_warning "-compile"; + call_coqc args + | x :: rem -> + coqc_deprecated_check args (x::acc) rem + let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); @@ -266,20 +260,28 @@ let coqtop_init ~opts extra = let coqtop_toplevel = { init = coqtop_init ; run = Coqloop.loop - ; opts = Coqargs.default_opts + ; opts = Coqargs.default } let start_coq custom = - match init_toplevel custom.opts custom.init (List.tl (Array.to_list Sys.argv)) with - (* Batch mode *) - | Some state, opts when not opts.batch_mode -> - custom.run ~opts ~state; - exit 1 - | _ , opts -> - flush_all(); - if opts.output_context then begin - let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) - end; - CProfile.print_profile (); - exit 0 + let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in + (* Init phase *) + let state, opts = + try + let opts, extras = + init_toplevel + ~help:Usage.print_usage_coqtop ~init:default custom.init + (List.tl (Array.to_list Sys.argv)) in + let extras = coqc_deprecated_check Sys.argv [] extras in + if not (CList.is_empty extras) then begin + prerr_endline ("Don't know what to do with "^String.concat " " extras); + prerr_endline "See -help for the list of supported options"; + exit 1 + end; + init_toploop opts + with any -> + flush_all(); + fatal_error_exn any in + Feedback.del_feeder init_feeder; + if not opts.batch then custom.run ~opts ~state; + exit 0 diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index c95d0aca55..300a7a039b 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -12,14 +12,24 @@ [init] is used to do custom command line argument parsing. [run] launches a custom toplevel. *) -open Coqargs + +type init_fn = opts:Coqargs.t -> string list -> Coqargs.t * string list type custom_toplevel = - { init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list - ; run : opts:coq_cmdopts -> state:Vernac.State.t -> unit - ; opts : Coqargs.coq_cmdopts + { init : init_fn + ; run : opts:Coqargs.t -> state:Vernac.State.t -> unit + ; opts : Coqargs.t } +(** [init_toplevel ~help ~init custom_init arg_list] + Common Coq initialization and argument parsing *) +val init_toplevel + : help:(unit -> unit) + -> init:Coqargs.t + -> init_fn + -> string list + -> Coqargs.t * string list + val coqtop_toplevel : custom_toplevel (** The Coq main module. [start custom] will parse the command line, 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/toplevel.mllib b/toplevel/toplevel.mllib index 732744eb42..ddd11fd160 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -2,8 +2,10 @@ Vernac Usage Coqinit Coqargs +Coqcargs G_toplevel Coqloop Ccompile Coqtop WorkerLoop +Coqc diff --git a/toplevel/usage.ml b/toplevel/usage.ml index c43538017c..0d17218a56 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -23,7 +23,7 @@ let machine_readable_version ret = let extra_usage = ref [] let add_to_usage name text = extra_usage := (name,text) :: !extra_usage -let print_usage_channel co command = +let print_usage_common co command = output_string co command; output_string co "Coq options are:\n"; output_string co @@ -48,14 +48,6 @@ let print_usage_channel co command = \n -lv f (idem)\ \n -load-vernac-object f load Coq object file f.vo\ \n -require path load Coq library path and import it (Require Import path.)\ -\n -compile f.v compile Coq file f.v (implies -batch)\ -\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ -\n -o f.vo use f.vo as the output file name\ -\n -quick quickly compile .v files to .vio files (skip proofs)\ -\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ -\n into fi.vo\ -\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ -\n proofs in each fi.vio\ \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ @@ -66,16 +58,15 @@ let print_usage_channel co command = \n -quiet unset display of extra information (implies -w \"-all\")\ \n -w (w1,..,wn) configure display of warnings\ \n -color (yes|no|auto) configure color output\ +\n -emacs tells Coq it is executed under Emacs\ \n\ \n -q skip loading of rcfile\ \n -init-file f set the rcfile to f\ -\n -batch batch mode (exits just after arguments parsing)\ -\n -boot boot mode (implies -q and -batch)\ +\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\ \n -stm-debug STM debug mode (will trace every transaction)\ -\n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ @@ -88,8 +79,8 @@ let print_usage_channel co command = \n (use environment variable\ \n OCAML_GC_STATS=\"/tmp/gclog.txt\"\ \n for full Gc stats dump)\ -\n -bytecode-compiler (yes|no) controls the vm_compute machinery\ -\n -native-compiler (yes|no|ondemand) controls the native_compute machinery\ +\n -bytecode-compiler (yes|no) enable the vm_compute reduction machine\ +\n -native-compiler (yes|no|ondemand) enable the native_compute reduction machine\ \n -h, -help, --help print this list of options\ \n"; List.iter (fun (name, text) -> @@ -101,21 +92,46 @@ let print_usage_channel co command = (* print the usage on standard error *) -let print_usage = print_usage_channel stderr - let print_usage_coqtop () = - print_usage "Usage: coqtop <options>\n\n"; + print_usage_common stderr "Usage: coqtop <options>\n\n"; + output_string stderr "\n\ +coqtop specific options:\ +\n\ +\n -batch batch mode (exits just after argument parsing)\ +\n\ +\nDeprecated options [use coqc instead]:\ +\n\ +\n -compile f.v compile Coq file f.v (implies -batch)\ +\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ +\n -o f.vo use f.vo as the output file name\ +\n"; flush stderr ; exit 1 let print_usage_coqc () = - print_usage "Usage: coqc <options> <Coq options> file...\n\ -\noptions are:\ -\n -verbose compile verbosely\ -\n -image f specify an alternative executable for Coq\ -\n -opt run the native-code version of Coq\ -\n -byte run the bytecode version of Coq\ -\n -t keep temporary files\n\n"; + print_usage_common stderr "Usage: coqc <options> <Coq options> file..."; + output_string stderr "\n\ +coqc specific options:\ +\n\ +\n -o f.vo use f.vo as the output file name\ +\n -verbose compile and output the input file\ +\n -quick quickly compile .v files to .vio files (skip proofs)\ +\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ +\n into fi.vo\ +\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ +\n proofs in each fi.vio\ +\n\ +\nUndocumented:\ +\n -vio2vo [see manual]\ +\n -check-vio-tasks [see manual]\ +\n\ +\nDeprecated options:\ +\n\ +\n -image f specify an alternative executable for Coq\ +\n -opt run the native-code version of Coq\ +\n -byte run the bytecode version of Coq\ +\n -t keep temporary files\ +\n -outputstate file save summary state in file \ +\n"; flush stderr ; exit 1 - diff --git a/toplevel/usage.mli b/toplevel/usage.mli index fbb0117d45..64170adaa4 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -13,9 +13,6 @@ val version : int -> 'a val machine_readable_version : int -> 'a -(** {6 Prints the usage on the error output, preceeded by a user-provided message. } *) -val print_usage : string -> unit - (** {6 Enable toploop plugins to insert some text in the usage message. } *) val add_to_usage : string -> string -> unit 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/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index e4e9a87365..f922ad8fee 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -23,7 +23,7 @@ let arg_init init ~opts extra_args = let start ~init ~loop = let open Coqtop in let custom = { - opts = Coqargs.default_opts; + opts = Coqargs.default; init = arg_init init; run = (fun ~opts:_ ~state:_ -> loop ()); } in 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/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index d9787bc73c..868a6ed3e9 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -245,6 +245,7 @@ let build_beq_scheme mode kn = | Fix _ -> raise (EqUnknown "fix") | Meta _ -> raise (EqUnknown "meta-variable") | Evar _ -> raise (EqUnknown "existential variable") + | Int _ -> raise (EqUnknown "int") in aux t in diff --git a/vernac/class.ml b/vernac/class.ml index 8374a5c84f..823177d4d1 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -215,7 +215,7 @@ let build_id_coercion idf_opt source poly = Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in - let univs = Evd.const_univ_entry ~poly sigma in + let univs = Evd.univ_entry ~poly sigma in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry (definition_entry ~types:typ_f ~univs diff --git a/vernac/classes.ml b/vernac/classes.ml index 5cac6af4b2..27d8b7390d 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 @@ -374,24 +374,29 @@ let context poly l = let univs = match ctx with | [] -> assert false - | [_] -> Evd.const_univ_entry ~poly sigma + | [_] -> Evd.univ_entry ~poly sigma | _::_::_ -> - (* TODO: explain this little belly dance *) if Lib.sections_are_opened () then + (* More than 1 variable in a section: we can't associate + universes to any specific variable so we declare them + separately. *) begin let uctx = Evd.universe_context_set sigma in Declare.declare_universe_context poly uctx; - if poly then Polymorphic_const_entry ([||], Univ.UContext.empty) - else Monomorphic_const_entry Univ.ContextSet.empty + if poly then Polymorphic_entry ([||], Univ.UContext.empty) + else Monomorphic_entry Univ.ContextSet.empty end else if poly then - Evd.const_univ_entry ~poly sigma + (* Multiple polymorphic axioms: they are all polymorphic the same way. *) + Evd.univ_entry ~poly sigma else + (* Multiple monomorphic axioms: declare universes separately + to avoid redeclaring them. *) begin let uctx = Evd.universe_context_set sigma in Declare.declare_universe_context poly uctx; - Monomorphic_const_entry Univ.ContextSet.empty + Monomorphic_entry Univ.ContextSet.empty end in let fn status (id, b, t) = 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 4b8371f5c3..466757c6bd 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -46,8 +46,8 @@ let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ide match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with - | Monomorphic_const_entry ctx -> ctx - | Polymorphic_const_entry (_, ctx) -> Univ.ContextSet.of_context ctx + | Monomorphic_entry ctx -> ctx + | Polymorphic_entry (_, ctx) -> Univ.ContextSet.of_context ctx in let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in @@ -79,21 +79,21 @@ match local with let () = if do_instance then Typeclasses.declare_instance None false gr in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with - | Polymorphic_const_entry (_, ctx) -> Univ.UContext.instance ctx - | Monomorphic_const_entry _ -> Univ.Instance.empty + | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx + | Monomorphic_entry _ -> Univ.Instance.empty 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. *) let next_uctx = - let empty_uctx = Monomorphic_const_entry Univ.ContextSet.empty in + let empty_uctx = Monomorphic_entry Univ.ContextSet.empty in function - | Polymorphic_const_entry _ as uctx -> uctx - | Monomorphic_const_entry _ -> empty_uctx + | Polymorphic_entry _ as uctx -> uctx + | Monomorphic_entry _ -> empty_uctx let declare_assumptions idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = @@ -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 -> @@ -178,3 +178,29 @@ let do_assumptions kind nl l = in subst'@subst, status' && status, next_uctx uctx) ([], true, uctx) l) + +let do_primitive id prim typopt = + if Lib.sections_are_opened () then + CErrors.user_err Pp.(str "Declaring a primitive is not allowed in sections."); + if Dumpglob.dump () then Dumpglob.dump_definition id false "ax"; + let env = Global.env () in + let evd = Evd.from_env env in + let evd, typopt = Option.fold_left_map + (interp_type_evars_impls ~impls:empty_internalization_env env) + evd typopt + in + let evd = Evd.minimize_universes evd in + let uvars, impls, typopt = match typopt with + | None -> Univ.LSet.empty, [], None + | Some (ty,impls) -> + EConstr.universes_of_constr evd ty, impls, Some (EConstr.to_constr evd ty) + in + let evd = Evd.restrict_universe_context evd uvars in + let uctx = UState.check_mono_univ_decl (Evd.evar_universe_context evd) UState.default_univ_decl in + let entry = { prim_entry_type = typopt; + prim_entry_univs = uctx; + prim_entry_content = prim; + } + in + let _kn = declare_constant id.CAst.v (PrimitiveEntry entry,IsPrimitive) in + register_message id.CAst.v diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 56932360a9..2b794b001a 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 (************************************************************************) @@ -29,7 +29,9 @@ val do_assumptions : locality * polymorphic * assumption_object_kind -> (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) val declare_assumption : coercion_flag -> assumption_kind -> - types in_constant_universes_entry -> + types in_universes_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> bool (** implicit *) -> Declaremods.inline -> variable CAst.t -> GlobRef.t * Univ.Instance.t * bool + +val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 79d45880fc..5eb19eef54 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -35,32 +35,32 @@ let check_imps ~impsty ~impsbody = try List.for_all (fun (key, (va:bool*bool*bool)) -> (* Pervasives.(=) is OK for this type *) - Pervasives.(=) (List.assoc_f Impargs.explicitation_eq key impsty) va) + Pervasives.(=) (List.assoc_f Constrexpr_ops.explicitation_eq key impsty) va) impsbody with Not_found -> false 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 92b1ff7572..9bbfb8eec6 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -83,10 +83,9 @@ type structured_one_inductive_expr = { type structured_inductive_expr = local_binder_expr list * structured_one_inductive_expr list -let minductive_message warn = function +let minductive_message = function | [] -> user_err Pp.(str "No inductive definition.") - | [x] -> (Id.print x ++ str " is defined" ++ - if warn then str " as a non-primitive record" else mt()) + | [x] -> (Id.print x ++ str " is defined") | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ spc () ++ str "are defined") @@ -163,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 = @@ -359,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 @@ -458,15 +457,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not indimpls, List.map (fun impls -> userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors in - let univs = - match uctx with - | Polymorphic_const_entry (nas, uctx) -> - if cum then - Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context uctx) - else Polymorphic_ind_entry (nas, uctx) - | Monomorphic_const_entry uctx -> - Monomorphic_ind_entry uctx - in + let variance = if poly && cum then Some (InferCumulativity.dummy_variance uctx) else None in (* Build the mutual inductive entry *) let mind_ent = { mind_entry_params = ctx_params; @@ -474,7 +465,8 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not mind_entry_finite = finite; mind_entry_inds = entries; mind_entry_private = if prv then Some false else None; - mind_entry_universes = univs; + mind_entry_universes = uctx; + mind_entry_variance = variance; } in (if poly && cum then @@ -531,6 +523,12 @@ let is_recursive mie = List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc | _ -> false +let warn_non_primitive_record = + CWarnings.create ~name:"non-primitive-record" ~category:"record" + (fun indsp -> + (hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (IndRef indsp) ++ + strbrk" could not be defined as a primitive record"))) + let declare_mutual_inductive_with_eliminations mie pl impls = (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) @@ -545,6 +543,8 @@ let declare_mutual_inductive_with_eliminations mie pl impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in + if match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false + then warn_non_primitive_record (mind,0); Declare.declare_univ_binders (IndRef (mind,0)) pl; List.iteri (fun i (indimpls, constrimpls) -> let ind = (mind,i) in @@ -556,8 +556,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = (ConstructRef (ind, succ j)) impls) constrimpls) impls; - let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in - Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); + Flags.if_verbose Feedback.msg_info (minductive_message names); if mie.mind_entry_private == None then declare_default_schemes mind; mind 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/declareDef.mli b/vernac/declareDef.mli index 1e3644c371..e455b59ab2 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -19,7 +19,7 @@ val declare_definition : Id.t -> definition_kind -> GlobRef.t val declare_fix : ?opaque:bool -> definition_kind -> - UnivNames.universe_binders -> Entries.constant_universes_entry -> + UnivNames.universe_binders -> Entries.universes_entry -> Id.t -> Safe_typing.private_constants Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> GlobRef.t diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 71770a21ca..06428b53f2 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.") @@ -59,7 +58,7 @@ let process_vernac_interp_error exn = match fst exn with mt() in wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> - let te = Himsg.map_ptype_error EConstr.of_constr te in + let te = map_ptype_error EConstr.of_constr te in wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 79adefdcf7..42bee25da3 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -219,12 +219,51 @@ GRAMMAR EXTEND Gram { VernacRegister(g, RegisterCoqlib quid) } | IDENT "Register"; IDENT "Inline"; g = global -> { VernacRegister(g, RegisterInline) } + | IDENT "Primitive"; id = identref; typopt = OPT [ ":"; typ = lconstr -> { typ } ]; ":="; r = register_token -> + { VernacPrimitive(id, r, typopt) } | IDENT "Universe"; l = LIST1 identref -> { VernacUniverse l } | IDENT "Universes"; l = LIST1 identref -> { VernacUniverse l } | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> { VernacConstraint l } ] ] ; + register_token: + [ [ r = register_prim_token -> { CPrimitives.OT_op r } + | r = register_type_token -> { CPrimitives.OT_type r } ] ] + ; + + register_type_token: + [ [ "#int63_type" -> { CPrimitives.PT_int63 } ] ] + ; + + register_prim_token: + [ [ "#int63_head0" -> { CPrimitives.Int63head0 } + | "#int63_tail0" -> { CPrimitives.Int63tail0 } + | "#int63_add" -> { CPrimitives.Int63add } + | "#int63_sub" -> { CPrimitives.Int63sub } + | "#int63_mul" -> { CPrimitives.Int63mul } + | "#int63_div" -> { CPrimitives.Int63div } + | "#int63_mod" -> { CPrimitives.Int63mod } + | "#int63_lsr" -> { CPrimitives.Int63lsr } + | "#int63_lsl" -> { CPrimitives.Int63lsl } + | "#int63_land" -> { CPrimitives.Int63land } + | "#int63_lor" -> { CPrimitives.Int63lor } + | "#int63_lxor" -> { CPrimitives.Int63lxor } + | "#int63_addc" -> { CPrimitives.Int63addc } + | "#int63_subc" -> { CPrimitives.Int63subc } + | "#int63_addcarryc" -> { CPrimitives.Int63addCarryC } + | "#int63_subcarryc" -> { CPrimitives.Int63subCarryC } + | "#int63_mulc" -> { CPrimitives.Int63mulc } + | "#int63_diveucl" -> { CPrimitives.Int63diveucl } + | "#int63_div21" -> { CPrimitives.Int63div21 } + | "#int63_addmuldiv" -> { CPrimitives.Int63addMulDiv } + | "#int63_eq" -> { CPrimitives.Int63eq } + | "#int63_lt" -> { CPrimitives.Int63lt } + | "#int63_le" -> { CPrimitives.Int63le } + | "#int63_compare" -> { CPrimitives.Int63compare } + ] ] + ; + thm_token: [ [ "Theorem" -> { Theorem } | IDENT "Lemma" -> { Lemma } @@ -654,18 +693,20 @@ GRAMMAR EXTEND Gram LIST1 [ v=strategy_level; "["; q=LIST1 smart_global; "]" -> { (v,q) } ] -> { VernacSetStrategy l } (* Canonical structure *) - | IDENT "Canonical"; IDENT "Structure"; qid = global -> - { VernacCanonical CAst.(make ~loc @@ AN qid) } - | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation -> + | IDENT "Canonical"; OPT [ IDENT "Structure" -> {()} ]; qid = global; ud = OPT [ u = OPT univ_decl; d = def_body -> { (u,d) } ] -> + { match ud with + | None -> + VernacCanonical CAst.(make ~loc @@ AN qid) + | Some (u,d) -> + let s = coerce_reference_to_id qid in + VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make (Name s)),u),d) } + | IDENT "Canonical"; OPT [ IDENT "Structure" -> {()} ]; ntn = by_notation -> { VernacCanonical CAst.(make ~loc @@ ByNotation ntn) } - | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> - { let s = coerce_reference_to_id qid in - VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make (Name s)),None),d) } (* Coercions *) - | IDENT "Coercion"; qid = global; d = def_body -> + | IDENT "Coercion"; qid = global; u = OPT univ_decl; d = def_body -> { let s = coerce_reference_to_id qid in - VernacDefinition ((NoDischarge,Coercion),((CAst.make (Name s)),None),d) } + VernacDefinition ((NoDischarge,Coercion),((CAst.make (Name s)),u),d) } | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> { VernacIdentityCoercion (f, s, t) } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ebbec86b9c..9dd321be51 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -598,6 +598,20 @@ let explain_var_not_found env id = spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." + +let explain_evar_not_found env sigma id = + let undef = Evar.Map.domain (Evd.undefined_map sigma) in + let all_undef_evars = Evar.Set.elements undef in + let f ev = Id.equal id (Termops.evar_suggested_name ev sigma) in + if List.exists f all_undef_evars then + (* The name is used for printing but is not user-given *) + str "?" ++ Id.print id ++ + strbrk " is a generated name. Only user-given names for existential variables" ++ + strbrk " can be referenced. To give a user name to an existential variable," ++ + strbrk " introduce it with the ?[name] syntax." + else + str "Unknown existential variable." + let explain_wrong_case_info env (ind,u) ci = let pi = pr_inductive env ind in if eq_ind ci.ci_ind ind then @@ -812,6 +826,7 @@ let explain_pretype_error env sigma err = | UnifOccurCheck (ev,rhs) -> explain_occur_check env sigma ev rhs | UnsolvableImplicit (evk,exp) -> explain_unsolvable_implicit env sigma evk exp | VarNotFound id -> explain_var_not_found env id + | EvarNotFound id -> explain_evar_not_found env sigma id | UnexpectedType (actual,expect) -> let env, actual, expect = contract2 env sigma actual expect in explain_unexpected_type env sigma actual expect @@ -833,6 +848,7 @@ let explain_pretype_error env sigma err = | TypingError t -> explain_type_error env sigma t | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp + (* Module errors *) open Modops @@ -907,6 +923,8 @@ let explain_not_match_error = function str "but expected" ++ spc() ++ h 0 (pr_auctx expect) ++ (if not (Int.equal (AUContext.size got) (AUContext.size expect)) then mt() else fnl() ++ str "(incompatible constraints)") + | IncompatibleVariance -> + str "incompatible variance information" let explain_signature_mismatch l spec why = str "Signature components for label " ++ Label.print l ++ @@ -1281,45 +1299,8 @@ let explain_pattern_matching_error env sigma = function | CannotInferPredicate typs -> explain_cannot_infer_predicate env sigma typs -let map_pguard_error f = function -| NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody -| RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) -| RecursionOnIllegalTerm (n, (env, c), l1, l2) -> RecursionOnIllegalTerm (n, (env, f c), l1, l2) -| NotEnoughArgumentsForFixCall n -> NotEnoughArgumentsForFixCall n -| CodomainNotInductiveType c -> CodomainNotInductiveType (f c) -| NestedRecursiveOccurrences -> NestedRecursiveOccurrences -| UnguardedRecursiveCall c -> UnguardedRecursiveCall (f c) -| RecCallInTypeOfAbstraction c -> RecCallInTypeOfAbstraction (f c) -| RecCallInNonRecArgOfConstructor c -> RecCallInNonRecArgOfConstructor (f c) -| RecCallInTypeOfDef c -> RecCallInTypeOfDef (f c) -| RecCallInCaseFun c -> RecCallInCaseFun (f c) -| RecCallInCaseArg c -> RecCallInCaseArg (f c) -| RecCallInCasePred c -> RecCallInCasePred (f c) -| NotGuardedForm c -> NotGuardedForm (f c) -| ReturnPredicateNotCoInductive c -> ReturnPredicateNotCoInductive (f c) - -let map_ptype_error f = function -| UnboundRel n -> UnboundRel n -| UnboundVar id -> UnboundVar id -| NotAType j -> NotAType (on_judgment f j) -| BadAssumption j -> BadAssumption (on_judgment f j) -| ReferenceVariables (id, c) -> ReferenceVariables (id, f c) -| ElimArity (pi, dl, c, j, ar) -> ElimArity (pi, dl, f c, on_judgment f j, ar) -| CaseNotInductive j -> CaseNotInductive (on_judgment f j) -| WrongCaseInfo (pi, ci) -> WrongCaseInfo (pi, ci) -| NumberBranches (j, n) -> NumberBranches (on_judgment f j, n) -| IllFormedBranch (c, pc, t1, t2) -> IllFormedBranch (f c, pc, f t1, f t2) -| Generalization ((na, t), j) -> Generalization ((na, f t), on_judgment f j) -| ActualType (j, t) -> ActualType (on_judgment f j, f t) -| CantApplyBadType ((n, c1, c2), j, vj) -> - CantApplyBadType ((n, f c1, f c2), on_judgment f j, Array.map (on_judgment f) vj) -| CantApplyNonFunctional (j, jv) -> CantApplyNonFunctional (on_judgment f j, Array.map (on_judgment f) jv) -| IllFormedRecBody (ge, na, n, env, jv) -> - IllFormedRecBody (map_pguard_error f ge, na, n, env, Array.map (on_judgment f) jv) -| IllTypedRecBody (n, na, jv, t) -> - IllTypedRecBody (n, na, Array.map (on_judgment f) jv, Array.map f t) -| UnsatisfiedConstraints g -> UnsatisfiedConstraints g -| UndeclaredUniverse l -> UndeclaredUniverse l +let map_pguard_error = map_pguard_error +let map_ptype_error = map_ptype_error let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) -> diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 986906d303..f22354cdbf 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -44,6 +44,8 @@ val explain_module_internalization_error : Modintern.module_internalization_error -> Pp.t val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error +[@@ocaml.deprecated "Use [Type_errors.map_pguard_error]."] val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error +[@@ocaml.deprecated "Use [Type_errors.map_ptype_error]."] val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index d29f66f81f..caafd6ac2f 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -103,7 +103,7 @@ let () = let define ~poly id internal sigma c t = let f = declare_constant ~internal in - let univs = Evd.const_univ_entry ~poly sigma in + let univs = Evd.univ_entry ~poly sigma in let kn = f id (DefinitionEntry { const_entry_body = c; diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 0dfbba0e83..83dd1aa8e4 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -230,10 +230,10 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, | Discharge -> let impl = false in (* copy values from Vernacentries *) let univs = match univs with - | Polymorphic_const_entry (_, univs) -> + | Polymorphic_entry (_, univs) -> (* What is going on here? *) Univ.ContextSet.of_context univs - | Monomorphic_const_entry univs -> univs + | Monomorphic_entry univs -> univs in let c = SectionLocalAssum ((t_i, univs),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in @@ -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 @@ -476,12 +476,19 @@ let save_proof ?proof = function if const_entry_type = None then user_err Pp.(str "Admitted requires an explicit statement"); let typ = Option.get const_entry_type in - let ctx = UState.const_univ_entry ~poly:(pi2 k) universes in + let ctx = UState.univ_entry ~poly:(pi2 k) universes in let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in Admitted(id, k, (sec_vars, (typ, ctx), None), universes) | None -> let pftree = Proof_global.give_me_the_proof () in - let 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 6642d04c98..ba78c73131 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -557,7 +557,7 @@ let declare_mutual_definition l = mk_proof (mkCoFix (i,fixdecls))) 0 l in (* Declare the recursive definitions *) - let univs = UState.const_univ_entry ~poly first.prg_ctx in + let univs = UState.univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) fixnames fixdecls fixtypes fiximps in @@ -656,9 +656,9 @@ let declare_obligation prg obl body ty uctx = if not opaque then add_hint (Locality.make_section_locality None) prg constant; definition_message obl.obl_name; let body = match uctx with - | Polymorphic_const_entry (_, uctx) -> + | Polymorphic_entry (_, uctx) -> Some (DefinedObl (constant, Univ.UContext.instance uctx)) - | Monomorphic_const_entry _ -> + | Monomorphic_entry _ -> Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) in true, { obl with obl_body = body } @@ -879,7 +879,7 @@ let obligation_terminator ?univ_hook name num guard auto pf = if pi2 prg.prg_kind then ctx else UState.union prg.prg_ctx ctx in - let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in + let uctx = UState.univ_entry ~poly:(pi2 prg.prg_kind) ctx in let (defined, obl) = declare_obligation prg obl body ty uctx in let obls = Array.copy obls in let () = obls.(num) <- obl in @@ -921,15 +921,15 @@ let obligation_hook prg obl num auto ctx' _ gr = | (true, Evar_kinds.Define true) -> if not transparent then err_not_transp () | _ -> () -in + in let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in let inst, ctx' = if not (pi2 prg.prg_kind) (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) - let evd = Evd.from_env (Global.env ()) in - let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in - Univ.Instance.empty, Evd.evar_universe_context ctx' + let ctx = UState.make (Global.universes ()) in + let ctx' = UState.merge_subst ctx (UState.subst ctx') in + Univ.Instance.empty, ctx' else (* We get the right order somehow, but surely it could be enforced in a clearer way. *) let uctx = UState.context ctx' in @@ -1010,7 +1010,7 @@ and solve_obligation_by_tac prg obls i tac = (pi2 prg.prg_kind) (Evd.evar_universe_context evd) with | None -> None | Some (t, ty, ctx) -> - let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in + let uctx = UState.univ_entry ~poly:(pi2 prg.prg_kind) ctx in let prg = {prg with prg_ctx = ctx} in let def, obl' = declare_obligation prg obl t ty uctx in obls.(i) <- obl'; @@ -1159,7 +1159,7 @@ let admit_prog prg = match x.obl_body with | None -> let x = subst_deps_obl obls x in - let ctx = Monomorphic_const_entry (UState.context_set prg.prg_ctx) in + let ctx = UState.univ_entry ~poly:false prg.prg_ctx in let kn = Declare.declare_constant x.obl_name ~local:true (ParameterEntry (None,(x.obl_type,ctx),None), IsAssumption Conjectural) in @@ -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/ppvernac.ml b/vernac/ppvernac.ml index 5eeeaada2d..d22e52e960 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1182,6 +1182,12 @@ open Pputils hov 2 (keyword "Register Inline" ++ spc() ++ pr_qualid qid) ) + | VernacPrimitive(id,r,typopt) -> + hov 2 + (keyword "Primitive" ++ spc() ++ pr_lident id ++ + (Option.cata (fun ty -> spc() ++ str":" ++ pr_spc_lconstr ty) (mt()) typopt) ++ spc() ++ + str ":=" ++ spc() ++ + str (CPrimitives.op_or_type_to_string r)) | VernacComments l -> return ( hov 2 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 2867ad1437..0bd15e203b 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' -> @@ -176,19 +176,20 @@ let typecheck_params_and_fields finite def poly pl ps records = else sigma, typ in let (sigma, typs) = List.fold_left2_map fold sigma typs data in - let sigma = Evd.minimize_universes sigma in - let newps = List.map (EConstr.to_rel_decl sigma) newps in + let sigma, (newps, ans) = Evarutil.finalize sigma (fun nf -> + let newps = List.map (RelDecl.map_constr_het nf) newps in + let map (impls, newfs) typ = + let newfs = List.map (RelDecl.map_constr_het nf) newfs in + let typ = nf typ in + (typ, impls, newfs) + in + let ans = List.map2 map data typs in + newps, ans) + in let univs = Evd.check_univ_decl ~poly sigma decl in let ubinders = Evd.universe_binders sigma in let ce t = Pretyping.check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr t) in let () = List.iter (iter_constr ce) (List.rev newps) in - let map (impls, newfs) typ = - let newfs = List.map (EConstr.to_rel_decl sigma) newfs in - let typ = EConstr.to_constr sigma typ in - List.iter (iter_constr ce) (List.rev newfs); - (typ, impls, newfs) - in - let ans = List.map2 map data typs in ubinders, univs, template, newps, imps, ans type record_error = @@ -270,20 +271,14 @@ let instantiate_possibly_recursive_type ind u ntypes paramdecls fields = let subst' = List.init ntypes (fun i -> mkIndU ((ind, ntypes - i - 1), u)) in Termops.substl_rel_context (subst @ subst') fields -let warn_non_primitive_record = - CWarnings.create ~name:"non-primitive-record" ~category:"record" - (fun (env,indsp) -> - (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ - strbrk" could not be defined as a primitive record"))) - (* We build projections *) let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in let u = match ctx with - | Polymorphic_const_entry (_, ctx) -> Univ.UContext.instance ctx - | Monomorphic_const_entry ctx -> Univ.Instance.empty + | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx + | Monomorphic_entry ctx -> Univ.Instance.empty in let paramdecls = Inductive.inductive_paramdecls (mib, u) in let r = mkIndU (indsp,u) in @@ -293,16 +288,9 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f let fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in let primitive = - if !primitive_flag then - let is_primitive = - match mib.mind_record with - | PrimRecord _ -> true - | FakeRecord | NotRecord -> false - in - if not is_primitive then - warn_non_primitive_record (env,indsp); - is_primitive - else false + match mib.mind_record with + | PrimRecord _ -> true + | FakeRecord | NotRecord -> false in let (_,_,kinds,sp_projs,_) = List.fold_left3 @@ -381,17 +369,16 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f open Typeclasses -let declare_structure finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data = +let declare_structure ~cum finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data = let nparams = List.length params in let poly, ctx = match univs with - | Monomorphic_ind_entry ctx -> - false, Monomorphic_const_entry Univ.ContextSet.empty - | Polymorphic_ind_entry (nas, ctx) -> - true, Polymorphic_const_entry (nas, ctx) - | Cumulative_ind_entry (nas, cumi) -> - true, Polymorphic_const_entry (nas, Univ.CumulativityInfo.univ_context cumi) + | Monomorphic_entry ctx -> + false, Monomorphic_entry Univ.ContextSet.empty + | Polymorphic_entry (nas, ctx) -> + true, Polymorphic_entry (nas, ctx) in + let variance = if poly && cum then Some (InferCumulativity.dummy_variance ctx) else None in let binder_name = match name with | None -> @@ -426,13 +413,20 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St mind_entry_lc = [type_constructor] } in let blocks = List.mapi mk_block record_data in + let primitive = + !primitive_flag && + List.for_all (fun (_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data + (* will warn_non_primitive_record in declare_projections if we try + to declare a 0-field record *) + in let mie = { mind_entry_params = params; - mind_entry_record = Some (if !primitive_flag then Some binder_name else None); + mind_entry_record = Some (if primitive then Some binder_name else None); mind_entry_finite = finite; mind_entry_inds = blocks; mind_entry_private = None; mind_entry_universes = univs; + mind_entry_variance = variance; } in let mie = InferCumulativity.infer_inductive (Global.env ()) mie in @@ -478,8 +472,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity (DefinitionEntry class_entry, IsDefinition Definition) in let inst, univs = match univs with - | Polymorphic_const_entry (_, uctx) -> Univ.UContext.instance uctx, univs - | Monomorphic_const_entry _ -> Univ.Instance.empty, Monomorphic_const_entry Univ.ContextSet.empty + | Polymorphic_entry (_, uctx) -> Univ.UContext.instance uctx, univs + | Monomorphic_entry _ -> Univ.Instance.empty, Monomorphic_entry Univ.ContextSet.empty in let cstu = (cst, inst) in let inst_type = appvectc (mkConstU cstu) @@ -502,18 +496,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity in [cref, [Name proj_name, sub, Some proj_cst]] | _ -> - let univs = - match univs with - | Polymorphic_const_entry (nas, univs) -> - if cum then - Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context univs) - else - Polymorphic_ind_entry (nas, univs) - | Monomorphic_const_entry univs -> - Monomorphic_ind_entry univs - in let record_data = [id, idbuild, arity, fieldimpls, fields, false, List.map (fun _ -> false) fields] in - let inds = declare_structure Declarations.BiFinite ubinders univs paramimpls + let inds = declare_structure ~cum Declarations.BiFinite ubinders univs paramimpls params template ~kind:Method ~name:[|binder_name|] record_data in let coers = List.map2 (fun coe pri -> @@ -537,14 +521,14 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity in let univs, ctx_context, fields = match univs with - | Polymorphic_const_entry (nas, univs) -> + | Polymorphic_entry (nas, univs) -> let usubst, auctx = Univ.abstract_universes nas univs in let usubst = Univ.make_instance_subst usubst in let map c = Vars.subst_univs_level_constr usubst c in let fields = Context.Rel.map map fields in let ctx_context = on_snd (fun d -> Context.Rel.map map d) ctx_context in auctx, ctx_context, fields - | Monomorphic_const_entry _ -> + | Monomorphic_entry _ -> Univ.AUContext.empty, ctx_context, fields in let map (impl, projs) = @@ -676,21 +660,11 @@ let definition_structure udecl kind ~template cum poly finite records = | _ -> let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in - let univs = - match univs with - | Polymorphic_const_entry (nas, univs) -> - if cum then - Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context univs) - else - Polymorphic_ind_entry (nas, univs) - | Monomorphic_const_entry univs -> - Monomorphic_ind_entry univs - in let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in let coe = List.map (fun coe -> not (Option.is_empty coe)) coers in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in - let inds = declare_structure finite ubinders univs implpars params template data in + let inds = declare_structure ~cum finite ubinders univs implpars params template data in List.map (fun ind -> IndRef ind) inds diff --git a/vernac/record.mli b/vernac/record.mli index 04984030f7..9852840d12 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -16,7 +16,7 @@ val primitive_flag : bool ref val declare_projections : inductive -> - Entries.constant_universes_entry -> + Entries.universes_entry -> ?kind:Decl_kinds.definition_object_kind -> Id.t -> bool list -> diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index b4b893a3fd..ed93267665 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -335,6 +335,7 @@ type execution_phase = | LoadingPrelude | LoadingRcFile | InteractiveLoop + | CompilationPhase let default_phase = ref InteractiveLoop @@ -373,7 +374,9 @@ let pr_phase ?loc () = Some (str "While loading initial state:" ++ Option.cata (fun loc -> fnl () ++ pr_loc loc) (mt ()) loc) | _, Some loc -> Some (pr_loc loc) | ParsingCommandLine, _ - | Initialization, _ -> None + | Initialization, _ + | CompilationPhase, _ -> + None | InteractiveLoop, _ -> (* Note: interactive messages such as "foo is defined" are not located *) None diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 5f84c5edee..b0e3b3772c 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -60,6 +60,7 @@ type execution_phase = | LoadingPrelude | LoadingRcFile | InteractiveLoop + | CompilationPhase val in_phase : phase:execution_phase -> ('a -> 'b) -> 'a -> 'b diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 996fe320f9..d511bcd4fd 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,9 +606,14 @@ 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 is_polymorphic_inductive_cumulativity = + declare_bool_option_and_ref ~depr:false ~value:false + ~name:"Polymorphic inductive cumulativity" + ~key:["Polymorphic"; "Inductive"; "Cumulativity"] + let should_treat_as_cumulative cum poly = match cum with | Some VernacCumulative -> @@ -620,7 +622,7 @@ let should_treat_as_cumulative cum poly = | Some VernacNonCumulative -> if poly then false else user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.") - | None -> poly && Flags.is_polymorphic_inductive_cumulativity () + | None -> poly && is_polymorphic_inductive_cumulativity () let get_uniform_inductive_parameters = Goptions.declare_bool_option_and_ref @@ -675,9 +677,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 +708,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 +731,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 +755,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 +773,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 +786,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 +1027,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 @@ -1573,22 +1569,6 @@ let () = optwrite = (fun b -> Flags.raw_print := b) } 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; - optwrite = Flags.make_polymorphic_inductive_cumulativity } - -let () = declare_int_option { optdepr = false; optname = "the level of inlining during functor application"; @@ -1802,7 +1782,7 @@ let vernac_check_may_eval ~atts redexp glopt rc = else let c = EConstr.to_constr sigma c in (* OK to call kernel which does not support evars *) - Termops.on_judgment EConstr.of_constr (Arguments_renaming.rename_typing env c) + Environ.on_judgment EConstr.of_constr (Arguments_renaming.rename_typing env c) in let pp = match redexp with | None -> @@ -2032,21 +2012,31 @@ let vernac_locate = function let vernac_register qid r = let gr = Smartlocate.global_with_alias qid in - if Proof_global.there_are_pending_proofs () then + if Proof_global.there_are_pending_proofs () then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); match r with | RegisterInline -> - if not (isConstRef gr) then - user_err Pp.(str "Register inline: a constant is expected"); - Global.register_inline (destConstRef gr) + begin match gr with + | ConstRef c -> Global.register_inline c + | _ -> CErrors.user_err (Pp.str "Register Inline: expecting a constant") + end | RegisterCoqlib n -> - let path, id = Libnames.repr_qualid n in - if DirPath.equal path Retroknowledge.int31_path - then - let f = Retroknowledge.(KInt31 (int31_field_of_string (Id.to_string id))) in - Global.register f gr - else - Coqlib.register_ref (Libnames.string_of_qualid n) gr + let ns, id = Libnames.repr_qualid n in + if DirPath.equal (dirpath_of_string "kernel") ns then begin + if Lib.sections_are_opened () then + user_err Pp.(str "Registering a kernel type is not allowed in sections"); + let pind = match Id.to_string id with + | "ind_bool" -> CPrimitives.PIT_bool + | "ind_carry" -> CPrimitives.PIT_carry + | "ind_pair" -> CPrimitives.PIT_pair + | "ind_cmp" -> CPrimitives.PIT_cmp + | k -> CErrors.user_err Pp.(str "Register: unknown identifier “" ++ str k ++ str "” in the “kernel” namespace") + in + match gr with + | IndRef ind -> Global.register_inductive ind pind + | _ -> CErrors.user_err (Pp.str "Register in kernel: expecting an inductive type") + end + else Coqlib.register_ref (Libnames.string_of_qualid n) gr (********************) (* Proof management *) @@ -2157,7 +2147,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; @@ -2179,6 +2169,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. @@ -2222,15 +2217,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 @@ -2261,9 +2256,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 @@ -2316,6 +2311,7 @@ let interp ?proof ~atts ~st c = | VernacLocate l -> unsupported_attributes atts; Feedback.msg_notice @@ vernac_locate l | VernacRegister (qid, r) -> unsupported_attributes atts; vernac_register qid r + | VernacPrimitive (id, prim, typopt) -> unsupported_attributes atts; ComAssumption.do_primitive id prim typopt | VernacComments l -> unsupported_attributes atts; Flags.if_verbose Feedback.msg_info (str "Comments ok\n") @@ -2412,7 +2408,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 @@ -2434,21 +2429,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 @@ -2459,7 +2446,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 diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 68a17e316e..2eb901890b 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -378,6 +378,7 @@ type nonrec vernac_expr = | VernacSearch of searchable * Goal_select.t option * search_restriction | VernacLocate of locatable | VernacRegister of qualid * register_kind + | VernacPrimitive of lident * CPrimitives.op_or_type * constr_expr option | VernacComments of comment list (* Proof management *) |