diff options
179 files changed, 2026 insertions, 1295 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9e96d3602b..536bd0af76 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -121,7 +121,7 @@ before_script: OPAM_VARIANT: "+flambda" artifacts: name: "$CI_JOB_NAME" - expire_in: 1 month + expire_in: 2 months # every non build job must set dependencies otherwise all build # artifacts are used together and we may get some random Coq. To that @@ -140,6 +140,7 @@ before_script: name: "$CI_JOB_NAME" paths: - _install_ci/share/doc/coq/ + expire_in: 2 months # set dependencies when using .test-suite-template: @@ -159,6 +160,8 @@ before_script: when: on_failure paths: - test-suite/logs + # Gitlab doesn't support yet "expire_in: never" so we use the instance default + # expire_in: never variables: timeout: "" @@ -177,7 +180,7 @@ before_script: name: "$CI_JOB_NAME.logs" paths: - coqchk.log - expire_in: 1 month + expire_in: 2 months .ci-template: stage: test @@ -341,6 +344,8 @@ pkg:opam: when: on_failure paths: - nix-build-coq.drv-0/*/test-suite/logs + # Gitlab doesn't support yet "expire_in: never" so we use the instance default + # expire_in: never pkg:nix:deploy: extends: .nix-template @@ -465,6 +470,8 @@ test-suite:egde:dune:dev: when: on_failure paths: - _build/default/test-suite/logs + # Gitlab doesn't support yet "expire_in: never" so we use the instance default + # expire_in: never test-suite:edge+trunk+make: stage: test @@ -6,7 +6,7 @@ ## To avoid spam issues, we use by default a pseudo-email <login@gforge> ## for all persons that haven't made commits with real emails ## -## If you're mentionned here and want to update your information, +## If you're mentioned here and want to update your information, ## either amend this file and commit it, or contact the coqdev list Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 31fa3d2c4a..e811c116b6 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -31,7 +31,7 @@ account). You can file a bug for any of the following: It would help if you search the existing issues before reporting a bug. This can be difficult, so consider it extra credit. We don't mind duplicate bug reports. If unsure, you are always very welcome to ask on our [Discourse forum][] -or [Gitter chat][] before, after, or while writting a bug report +or [Gitter chat][] before, after, or while writing a bug report When it applies, it's extremely helpful for bug reports to include sample code, and much better if the code is self-contained and complete. It's not diff --git a/Makefile.build b/Makefile.build index 034c9ea03c..147668187f 100644 --- a/Makefile.build +++ b/Makefile.build @@ -150,7 +150,7 @@ endif ########################################################################### -# This include below will lauch the build of all .d. +# This include below will launch the build of all .d. # The - at front is for disabling warnings about currently missing ones. # For creating the missing .d, make will recursively build things like # coqdep_boot (for the .v.d files) or coqpp (for .mlg -> .ml -> .ml.d). diff --git a/Makefile.dev b/Makefile.dev index 13b85dfad4..6057696375 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -8,7 +8,7 @@ ## # (see LICENSE file for the text of the license) ## ########################################################################## -# Extra targets for developpers : +# Extra targets for developers : # debug printers, revision, partial targets ... ######################### diff --git a/Makefile.doc b/Makefile.doc index 25d146000b..94642e702f 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -167,7 +167,7 @@ doc/stdlib/Library.pdf: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Li $(PDFLATEX) -interaction=batchmode Library;\ ../tools/show_latex_messages -no-overfull Library.log) -### Standard library (full version if you're crazy enouth to try) +### Standard library (full version if you're crazy enough to try) doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex sed -e 's/Library.coqdoc/FullLibrary.coqdoc/g;s/\\begin{document}/\\newcommand{\\textlambda}{\\ensuremath{\\lambda}}\\newcommand{\\textPi}{\\ensuremath{\\Pi}}\\begin{document}/' $< > $@ diff --git a/Makefile.dune b/Makefile.dune index ebf74978a9..88055d62dc 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -5,7 +5,7 @@ .PHONY: coq coqide coqide-server # Package targets .PHONY: quickbyte quickopt quickide # Partial / quick developer targets .PHONY: refman-html stdlib-html apidoc # Documentation targets -.PHONY: test-suite release # Accesory targets +.PHONY: test-suite release # Accessory targets .PHONY: ocheck trunk ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build diff --git a/Makefile.ide b/Makefile.ide index 4cec7aa443..89c1f246db 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -77,7 +77,7 @@ ADWAITASHARE=$(shell ls -d /usr/local/Cellar/adwaita-icon-theme/*)/share .PHONY: coqide coqide-opt coqide-byte coqide-bindings coqide-files coqide-binaries .PHONY: ide-toploop ide-byteloop ide-optloop -# target to build CoqIde (native version) and the stuff needed to lauch it +# target to build CoqIde (native version) and the stuff needed to launch it coqide: coqide-files coqide-opt theories/Init/Prelude.$(VO) $(TOPBIN) # target to build CoqIde (in native and byte versions), and no more diff --git a/azure-pipelines.yml b/azure-pipelines.yml index f2cec1eb19..c93920a884 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -43,7 +43,7 @@ jobs: vmImage: 'macOS-10.13' variables: - MACOSX_DEPLOYMENT_TARGET: '10.12' + MACOSX_DEPLOYMENT_TARGET: '10.11' steps: - checkout: self diff --git a/checker/include b/checker/include index 3ffc301724..411321cb3e 100644 --- a/checker/include +++ b/checker/include @@ -3,7 +3,7 @@ (* Caml script to include for debugging the checker. Usage: from the checker/ directory launch ocaml toplevel and then type #use"include";; - This command loads the relevent modules, defines some pretty + This command loads the relevant modules, defines some pretty printers, and provides functions to interactively check modules (mainly run_l and norec). *) diff --git a/clib/iStream.mli b/clib/iStream.mli index 40d579be60..e56f066c5e 100644 --- a/clib/iStream.mli +++ b/clib/iStream.mli @@ -31,7 +31,7 @@ val cons : 'a -> 'a t -> 'a t (** Append an element in front of a stream. *) val thunk : (unit -> ('a,'a t) u) -> 'a t -(** Internalize the lazyness of a stream. *) +(** Internalize the laziness of a stream. *) val make : ('a -> ('b, 'a) u) -> 'a -> 'b t (** Coiteration constructor. *) diff --git a/configure.ml b/configure.ml index 57f31fec4c..3ced82718e 100644 --- a/configure.ml +++ b/configure.ml @@ -451,7 +451,7 @@ let coq_profile_flag = if !prefs.profile then "-p" else "" let coq_annot_flag = if !prefs.annot then "-annot" else "" let coq_bin_annot_flag = if !prefs.bin_annot then "-bin-annot" else "" -(* This variable can be overriden only for debug purposes, use with +(* This variable can be overridden only for debug purposes, use with care. *) let coq_safe_string = "-safe-string" let coq_strict_sequence = "-strict-sequence" diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 26e1e25fb9..42fe13e4eb 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -499,7 +499,7 @@ let print_rules fmt (name, rules) = let pr fmt l = print_list fmt (fun fmt r -> fprintf fmt "(%a)" GramExt.print_extrule r) l in match rules with | [([SymbEntry (e, None)], [Some s], { code = c } )] when String.trim c = s -> - (* This is a horrible hack to work aroud limitations of camlp5 regarding + (* This is a horrible hack to work around limitations of camlp5 regarding factorization of parsing rules. It allows to recognize rules of the form [ entry(x) ] -> [ x ] so as not to generate a proxy entry and reuse the same entry directly. *) diff --git a/default.nix b/default.nix index 1e2cb3625d..d5c6cdb8ad 100644 --- a/default.nix +++ b/default.nix @@ -74,7 +74,7 @@ stdenv.mkDerivation rec { else with builtins; filterSource (path: _: - !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci"]) ./.; + !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci" "nix"]) ./.; preConfigure = '' patchShebangs dev/tools/ diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index c3f3a97ff5..7c8f73c7e4 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -285,9 +285,9 @@ SET RESULT_INSTALLDIR_WFMT=%DESTCOQ% SET TARGET_ARCH=%ARCH%-w64-mingw32
SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
-REM Convert pathes to various formats
+REM Convert paths to various formats
REM WFMT = windows format (C:\..) Used in this batch file.
-REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work.
+REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH variable, which is : separated, so C: doesn't work.
REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
@@ -429,13 +429,13 @@ ECHO ========== BATCH FUNCTIONS ========== REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
- ECHO ^<absoloute = install coq in -destcoq absulute path^>
+ ECHO ^<absolute = install coq in -destcoq absolute path^>
ECHO ^<relocatable = install relocatable coq in -destcoq path^>
ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
ECHO -destcyg ^<path to cygwin destination folder^>
- ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^>
+ ECHO -destcoq ^<path to coq destination folder (mode=absolute/relocatable)^>
ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
ECHO -proxy ^<internet proxy^>
ECHO -cygrepo ^<cygwin download repository^>
diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt index a392115ea4..55b46c616c 100644 --- a/dev/build/windows/ReadMe.txt +++ b/dev/build/windows/ReadMe.txt @@ -43,7 +43,7 @@ paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The missing piece is a posix shell running on plain Windows (without msys or -Cygwin DLL) and not beeing a binary from obscure sources. I am working on it ... +Cygwin DLL) and not being a binary from obscure sources. I am working on it ... Since compiling gcc and binutils takes a while and it is not of much use without a shell, the building of these components is currently disabled. OCaml is built @@ -274,11 +274,11 @@ Default value: N ===== -cygquiet ===== -Control if the Cygwin setup runs quitely or interactive. +Control if the Cygwin setup runs quietly or interactive. Possible values: -Y: Install Cygwin quitely without user interaction. +Y: Install Cygwin quietly without user interaction. N: Install Cygwin interactively (allows to select additional packages). @@ -344,12 +344,12 @@ selecting more packages) ==================== TODO ==================== - Check for spaces in destination paths -- Check for = signs in all paths (DOS commands don't work with pathes with = in it, possibly even when quoted) +- Check for = signs in all paths (DOS commands don't work with paths with = in it, possibly even when quoted) - Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) - CoqIDE doesn't find theme files - Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) -- Possibly create/login as specific user to bash (not sure if it makes sense - nead to create additional bash login link then) -- maybe move share/doc/menhir somehwere else (reduces coqc startup time) +- Possibly create/login as specific user to bash (not sure if it makes sense - need to create additional bash login link then) +- maybe move share/doc/menhir somewhere else (reduces coqc startup time) - Use original installed file list for removing files in uninstaller ==================== Issues with relocation ==================== diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh index 3bba451ec6..543ca972cd 100644 --- a/dev/build/windows/difftar-folder.sh +++ b/dev/build/windows/difftar-folder.sh @@ -40,7 +40,7 @@ fi # Get path prefix if --strip is used if [ "$strip" -gt 0 ] ; then - # Get the path/name of the first file from teh tar and extract the first $strip path components + # Get the path/name of the first file from the tar and extract the first $strip path components # This assumes that the first file in the tar file has at least $strip many path components prefix=$(tar -t -f "$tarfile" | head -1 | cut -d / -f -$strip)/ else diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index d737632638..549f70e8fe 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -765,7 +765,7 @@ function make_ncurses { # gettext make/make install work anyway # # CONFIGURE PARAMETERS - # --enable-term-driver --enable-sp-funcs is rewuired for mingw (see README.MinGW) + # --enable-term-driver --enable-sp-funcs is required for mingw (see README.MinGW) # additional changes # ADD --with-pkg-config # ADD --enable-pc-files @@ -1281,7 +1281,7 @@ function copy_coq_objects { done } -# Copy required GTK config and suport files +# Copy required GTK config and support files function copy_coq_gtk { echo 'gtk-theme-name = "Default"' > "$PREFIX/etc/gtk-3.0/gtkrc" diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c index e4fdcd4d7d..c4c7ec2bff 100755 --- a/dev/build/windows/patches_coq/pkg-config.c +++ b/dev/build/windows/patches_coq/pkg-config.c @@ -1,5 +1,5 @@ // MinGW personality wrapper for pkgconf -// This is an excutable replacement for the shell scripts /bin/ARCH-pkg-config +// This is an executable replacement for the shell scripts /bin/ARCH-pkg-config // Compile with e.g. // gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe // gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 98ea594366..408d36df7f 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -31,7 +31,7 @@ PR by running GitLab CI on your private branches. To do so follow these steps: 6. You are encouraged to go to the CI / CD general settings and increase the timeout from 1h to 2h for better reliability. -Now everytime you push (including force-push unless you changed the default +Now every time you push (including force-push unless you changed the default GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and CI will be run. You will receive an e-mail with a report of the failures if there are some. diff --git a/dev/ci/nix/bignums.nix b/dev/ci/nix/bignums.nix index 1d931c858e..d813ddd8d7 100644 --- a/dev/ci/nix/bignums.nix +++ b/dev/ci/nix/bignums.nix @@ -1,5 +1,5 @@ { ocamlPackages }: { - buildInputs = with ocamlPackages; [ ocaml findlib camlp5 ]; + buildInputs = [ ocamlPackages.ocaml ]; } diff --git a/dev/ci/nix/unicoq/unicoq-num.patch b/dev/ci/nix/unicoq/unicoq-num.patch index 6d96d94dfc..6d2f6470b1 100644 --- a/dev/ci/nix/unicoq/unicoq-num.patch +++ b/dev/ci/nix/unicoq/unicoq-num.patch @@ -4,19 +4,6 @@ Date: Thu Nov 29 08:59:22 2018 +0000 Make explicit dependency to num -diff --git a/Make b/Make -index 550dc6a..8aa1309 100644 ---- a/Make -+++ b/Make -@@ -9,7 +9,7 @@ src/logger.ml - src/munify.mli - src/munify.ml - src/unitactics.mlg --src/unicoq.mllib -+src/unicoq.mlpack - theories/Unicoq.v - test-suite/munifytest.v - test-suite/microtests.v diff --git a/Makefile.local b/Makefile.local new file mode 100644 index 0000000..88be365 @@ -24,21 +11,3 @@ index 0000000..88be365 +++ b/Makefile.local @@ -0,0 +1 @@ +CAMLPKGS += -package num -diff --git a/src/unicoq.mllib b/src/unicoq.mllib -deleted file mode 100644 -index 2b84e2d..0000000 ---- a/src/unicoq.mllib -+++ /dev/null -@@ -1,3 +0,0 @@ --Logger --Munify --Unitactics -diff --git a/src/unicoq.mlpack b/src/unicoq.mlpack -new file mode 100644 -index 0000000..2b84e2d ---- /dev/null -+++ b/src/unicoq.mlpack -@@ -0,0 +1,3 @@ -+Logger -+Munify -+Unitactics diff --git a/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh b/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh new file mode 100644 index 0000000000..fcbeb32a58 --- /dev/null +++ b/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10188" ] || [ "$CI_BRANCH" = "def-not-visible-remove-warning" ]; then + + elpi_CI_REF=def-not-visible-generic-warning + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh b/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh new file mode 100644 index 0000000000..a89f6aca1b --- /dev/null +++ b/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10177" ] || [ "$CI_BRANCH" = "generalize" ]; then + + quickchick_CI_REF=generalize + quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index c9eceb1270..66f5a96802 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -92,7 +92,7 @@ When fixes are ready, there are two cases to consider: Once all reviewers approved the PR, the assignee is expected to check that CI completed without relevant failures, and that the PR comes with appropriate documentation and test cases. If not, they should leave a comment on the PR and -put the approriate label. Otherwise, they are expected to merge the PR using the +put the appropriate label. Otherwise, they are expected to merge the PR using the [merge script](../tools/merge-pr.sh). When CI has a few failures which look spurious, restarting the corresponding diff --git a/dev/doc/archive/naming-conventions.tex b/dev/doc/archive/naming-conventions.tex index 0b0811d81b..8b0b14efb8 100644 --- a/dev/doc/archive/naming-conventions.tex +++ b/dev/doc/archive/naming-conventions.tex @@ -570,11 +570,11 @@ Example: \formula{eq\_true\_neg: \~{} eq\_true b <-> eq\_true (negb b)}. Zero on domain {\D} & D0 & (notation \verb=0=)\\ One on domain {\D} & D1 (if explicitly defined) & (notation \verb=1=)\\ Successor on domain {\D} & Dsucc\\ -Predessor on domain {\D} & Dpred\\ -Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existng libraries that already use \texttt{plus} and \texttt{mult}} +Predecessor on domain {\D} & Dpred\\ +Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existing libraries that already use \texttt{plus} and \texttt{mult}} & (infix notation \verb=+= [50,L])\\ Multiplication on domain {\D} & Dmul/Dmult\footnotemark[\value{footnote}] & (infix notation \verb=*= [40,L]))\\ -Soustraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\ +Subtraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\ Opposite on domain {\D} & Dopp (if any) & (prefix notation \verb=-= [35,R]))\\ Inverse on domain {\D} & Dinv (if any) & (prefix notation \verb=/= [35,R]))\\ Power on domain {\D} & Dpower & (infix notation \verb=^= [30,R])\\ diff --git a/dev/doc/archive/versions-history.tex b/dev/doc/archive/versions-history.tex index 25dabad497..46516dd4e4 100644 --- a/dev/doc/archive/versions-history.tex +++ b/dev/doc/archive/versions-history.tex @@ -372,7 +372,7 @@ Coq V8.4pl5& released 22 October 2014 & \\ Coq V8.4pl6& released 9 April 2015 & \\ Coq V8.5 beta1 & released 21 January 2015 & \feature{computation via compilation to OCaml} [22-1-2013]\\ -&& \feature{asynchonous evaluation} [8-8-2013]\\ +&& \feature{asynchronous evaluation} [8-8-2013]\\ && \feature{new proof engine deployed} [2-11-2013]\\ && \feature{universe polymorphism} [6-5-2014]\\ && \feature{primitive projections} [6-5-2014]\\ diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt index b0a2b04121..6efc8ec1fe 100644 --- a/dev/doc/build-system.dev.txt +++ b/dev/doc/build-system.dev.txt @@ -9,13 +9,13 @@ HISTORY: * March 2010 (Pierre Letouzey). Revised build system. In particular, no more stage1,2,3 : - - Stage3 was removed some time ago when coqdep was splitted into + - Stage3 was removed some time ago when coqdep was split into coqdep_boot and full coqdep. - Stage1,2 were replaced by brutal inclusion of all .d at the start of Makefile.build, without trying to guess what could be done at what time. Some initial inclusions hence _fail_, but "make" tries again later and succeed. - - Btw, .ml4 are explicitely turned into .ml files, which stay after build. + - Btw, .ml4 are explicitly turned into .ml files, which stay after build. By default, they are in binary ast format, see READABLE_ML4 option. * February 2014 (Pierre Letouzey). @@ -87,7 +87,7 @@ Cons: clear-text generated .ml. -Makefiles hierachy +Makefiles hierarchy ------------------ The Makefile is separated in several files : diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt index 8cefe699cc..a14781a058 100644 --- a/dev/doc/build-system.txt +++ b/dev/doc/build-system.txt @@ -18,8 +18,8 @@ See http://www.gnu.org/software/make/manual/make.htmlPrerequisite-Types * Annotation before commands: +/-/@ a command starting by - is always successful (errors are ignored) -a command starting by + is runned even if option -n is given to make -a command starting by @ is not echoed before being runned +a command starting by + is run even if option -n is given to make +a command starting by @ is not echoed before being run * Custom functions @@ -36,7 +36,7 @@ If the file given to -include doesn't exist, make tries to build it, and even retries again if necessary, but doesn't care if this build finally fails. We used to rely on this "feature", but this should not be the case anymore. We kept "-include" instead of "include" for -avoiding warnings about initially non-existant files. +avoiding warnings about initially non-existent files. Changes (for old-timers) ------------------------ diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 7221c3de56..339ac2d9b7 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1278,7 +1278,7 @@ next_global_ident_away true -> next_ident_away_in_goal next_global_ident_away false -> next_global_ident_away ``` -### Cleaning in commmand.ml +### Cleaning in command.ml Functions about starting/ending a lemma are in lemmas.ml Functions about inductive schemes are in indschemes.ml @@ -1593,7 +1593,7 @@ Other kinds of objects: #### Writing subst_thing functions -The subst_thing shoud not copy the thing if it hasn't actually +The subst_thing should not copy the thing if it hasn't actually changed. There are some cool emacs macros in dev/objects.el to help writing subst functions this way quickly and without errors. Also there are *_smartmap functions in Util. diff --git a/dev/doc/econstr.md b/dev/doc/econstr.md index bb17e8fb62..16abf3f519 100644 --- a/dev/doc/econstr.md +++ b/dev/doc/econstr.md @@ -25,7 +25,7 @@ val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_ter Essentially, each time it sees an evar which happens to be defined in the provided evar-map, it replaces it with the corresponding body and carries on. -Due to universe unification occuring at the tactic level, the same goes for +Due to universe unification occurring at the tactic level, the same goes for universe instances and sorts. See the `ESort` and `EInstance` modules in `EConstr`. diff --git a/dev/doc/proof-engine.md b/dev/doc/proof-engine.md index 774552237a..a2c8d2f5ac 100644 --- a/dev/doc/proof-engine.md +++ b/dev/doc/proof-engine.md @@ -121,7 +121,7 @@ a limited set of derivation rules), it is recommended to generate proofs as much as possible by refining in ML tactics when it is possible and easy enough. Indeed, this prevents dependence on fragile constructions such as unification. -Obviously, it does not forbid the use of tacticals to mimick what one would do +Obviously, it does not forbid the use of tacticals to mimic what one would do in Ltac. Each Ltac primitive has a corresponding ML counterpart with simple semantics. A list of such tacticals can be found in the `Tacticals` module. Most of them are a porting of the tacticals from the old engine to the new one, so diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 189d6f9fa5..452160ea5a 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -113,7 +113,7 @@ - [ ] Upload the new version of the reference manual to the website. *TODO: setup some continuous deployment for this.* - [ ] Merge the website update, publish the release - and send annoucement e-mails. + and send announcement e-mails. - [ ] Ping **@Zimmi48** to publish a new version on Zenodo. *TODO: automate this.* - [ ] Close the milestone diff --git a/dev/doc/universes.md b/dev/doc/universes.md index c276603ed2..026c3830a2 100644 --- a/dev/doc/universes.md +++ b/dev/doc/universes.md @@ -163,9 +163,9 @@ only, it's just a matter of using `Evd.fresh_global` / The universe graph ------------------ -To accomodate universe polymorphic definitions, the graph structure in +To accommodate universe polymorphic definitions, the graph structure in kernel/univ.ml was modified. The new API forces every universe to be -declared before it is mentionned in any constraint. This forces to +declared before it is mentioned in any constraint. This forces to declare every universe to be >= Set or > Set. Every universe variable introduced during elaboration is >= Set. Every _global_ universe is now declared explicitly > Set, _after_ typechecking the definition. In diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 48671c03b6..e23d1234f7 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -437,7 +437,7 @@ Searches for objects that satisfy a list of constraints. If `${positiveConstrain * Type pattern: `${constraintType} = "type_pattern"`; `${constraintValue}` is a pattern (???: an open gallina term) string. * SubType pattern: `${constraintType} = "subtype_pattern"`; `${constraintValue}` is a pattern (???: an open gallina term) string. * In module: `${constraintType} = "in_module"`; `${constraintValue}` is a list of strings specifying the module/directory structure. -* Include blacklist: `${constraintType} = "include_blacklist"`; `${constraintValue}` *is ommitted*. +* Include blacklist: `${constraintType} = "include_blacklist"`; `${constraintValue}` *is omitted*. ------------------------------- diff --git a/dev/lint-commits.sh b/dev/lint-commits.sh index d8043558eb..96c92e3162 100755 --- a/dev/lint-commits.sh +++ b/dev/lint-commits.sh @@ -34,6 +34,6 @@ if [ "${#bad[@]}" != 0 ] then >&2 echo "Whitespace errors!" >&2 echo "In commits ${bad[*]}" - >&2 echo "If you use emacs, you can prevent this kind of error from reocurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." + >&2 echo "If you use emacs, you can prevent this kind of error from reoccurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." exit 1 fi diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index f4786d9431..8dfe1e7833 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/8471ab76242987b11afd4486b82888e1588f8307.tar.gz"; - sha256 = "06pp6b6x78jlinxifnphkbp79dx58jr990fkm4qziq0ay5klpxd7"; + url = "https://github.com/NixOS/nixpkgs/archive/bc9df0f66110039e495b6debe3a6cda4a1bb0fed.tar.gz"; + sha256 = "0y2w259j0vqiwjhjvlbsaqnp1nl2zwz6sbwwhkrqn7k7fmhmxnq1"; }) diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index f48013cf2e..b4c5d3d528 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -6,7 +6,7 @@ ;SetCompress off SetCompressor lzma -; Comment out after debuging. +; Comment out after debugging. ; The VERSION should be passed as an argument at compile time using : ; diff --git a/dev/v8-syntax/memo-v8.tex b/dev/v8-syntax/memo-v8.tex index ae4b569b36..84894b6f7c 100644 --- a/dev/v8-syntax/memo-v8.tex +++ b/dev/v8-syntax/memo-v8.tex @@ -55,7 +55,7 @@ _ are allowed after the first character. Quoted strings are used typically to give a filename (which may not be a regular identifier). As before they are written between double quotes ("). Unlike for V7, there is no escape character: characters -are written normaly but the double quote which is doubled. +are written normally but the double quote which is doubled. \section{Main changes in terms w.r.t. V7} @@ -252,7 +252,7 @@ became \TERM{context}. Syntax is unified with subterm matching. \subsection{Occurrences} -To avoid ambiguity between a numeric literal and the optionnal +To avoid ambiguity between a numeric literal and the optional occurrence numbers of this term, the occurrence numbers are put after the term itself. This applies to tactic \TERM{pattern} and also \TERM{unfold} diff --git a/doc/changelog/07-commands-and-options/09530-rm-unknown.rst b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst new file mode 100644 index 0000000000..78874cadb1 --- /dev/null +++ b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst @@ -0,0 +1,6 @@ +- Deprecated flag `Refine Instance Mode` has been removed. + (`#09530 <https://github.com/coq/coq/pull/09530>`_, fixes + `#3632 <https://github.com/coq/coq/issues/3632>`_, `#3890 + <https://github.com/coq/coq/issues/3890>`_ and `#4638 + <https://github.com/coq/coq/issues/4638>`_ + by Maxime Dénès, review by Gaëtan Gilbert). diff --git a/doc/common/styles/html/coqremote/modules/system/system.css b/doc/common/styles/html/coqremote/modules/system/system.css index 9371bb479e..9556c7882a 100644 --- a/doc/common/styles/html/coqremote/modules/system/system.css +++ b/doc/common/styles/html/coqremote/modules/system/system.css @@ -327,7 +327,7 @@ html.js fieldset.collapsed legend a { * html.js fieldset.collapsed table * { display: inline; } -/* For Safari 2 to prevent collapsible fieldsets containing tables from dissapearing due to tableheader.js. */ +/* For Safari 2 to prevent collapsible fieldsets containing tables from disappearing due to tableheader.js. */ html.js fieldset.collapsible { position: relative; } diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 3c0355c92d..e9b91d5a7e 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,16 +1,16 @@ -let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = +let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false ~opaque ~poly sigma udecl ~types:tyopt ~body in let uctx = Evd.evar_universe_context sigma in let ubinders = Evd.universe_binders sigma in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data + DeclareDef.declare_definition ident k ce ubinders imps ?hook_data let packed_declare_definition ~poly ident value_with_constraints = let body, ctx = value_with_constraints in let sigma = Evd.from_ctx ctx in let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ~ontop:None ident k ~opaque:false sigma udecl body None []) + ignore (edeclare ident k ~opaque:false sigma udecl body None []) (* But this definition cannot be undone by Reset ident *) diff --git a/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg index 82ba45726e..f4d9e7fd5b 100644 --- a/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg +++ b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg @@ -33,7 +33,7 @@ TACTIC EXTEND collapse_hyps END (* More advanced examples, where automatic proof happens but - no tactic is being called explicitely. The first one uses + no tactic is being called explicitly. The first one uses type classes. *) VERNAC COMMAND EXTEND TriggerClasses CLASSIFIED AS QUERY | [ "Tuto3_3" int(n) ] -> { example_classes n } diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 881f7a310d..b20669c7f1 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -60,8 +60,11 @@ The signatures of most objects can be written using a succinct DSL for Coq notat ``{*, …}``, ``{+, …}`` an optional or mandatory repeatable block, with repetitions separated by commas -``%|``, ``%{``, … - an escaped character (rendered without the leading ``%``) +``{| … | … | … }`` + an alternative, indicating than one of multiple constructs can be used + +``%{``, ``%}``, ``%|`` + an escaped character (rendered without the leading ``%``). In most cases, escaping is not necessary. In particular, the following expressions are all parsed as plain text, and do not need escaping: ``{ xyz }``, ``x |- y``. But the following escapes *are* needed: ``{| a b %| c | d }``, ``all: %{``. (We use ``%`` instead of the usual ``\`` because you'd have to type ``\`` twice in your reStructuredText file.) .. FIXME document the new subscript support @@ -148,7 +151,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica Example:: .. prodn:: term += let: @pattern := @term in @term - .. prodn:: occ_switch ::= { {? + %| - } {* @num } } + .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } ``.. table::`` :black_nib: A Coq table, i.e. a setting that is a set of values. Example:: diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index 78803a927f..2093765608 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -60,8 +60,11 @@ The signatures of most objects can be written using a succinct DSL for Coq notat ``{*, …}``, ``{+, …}`` an optional or mandatory repeatable block, with repetitions separated by commas -``%|``, ``%{``, … - an escaped character (rendered without the leading ``%``) +``{| … | … | … }`` + an alternative, indicating than one of multiple constructs can be used + +``%{``, ``%}``, ``%|`` + an escaped character (rendered without the leading ``%``). In most cases, escaping is not necessary. In particular, the following expressions are all parsed as plain text, and do not need escaping: ``{ xyz }``, ``x |- y``. But the following escapes *are* needed: ``{| a b %| c | d }``, ``all: %{``. (We use ``%`` instead of the usual ``\`` because you'd have to type ``\`` twice in your reStructuredText file.) .. FIXME document the new subscript support diff --git a/doc/sphinx/_static/coqnotations.sty b/doc/sphinx/_static/coqnotations.sty index 75eac1f724..3548b8754c 100644 --- a/doc/sphinx/_static/coqnotations.sty +++ b/doc/sphinx/_static/coqnotations.sty @@ -18,6 +18,9 @@ \newlength{\nscriptsize} \setlength{\nscriptsize}{0.8em} +\newlength{\nboxsep} +\setlength{\nboxsep}{2pt} + \newcommand*{\scriptsmallsquarebox}[1]{% % Force width \makebox[\nscriptsize]{% @@ -31,7 +34,8 @@ \newcommand*{\nsup}[1]{^{\nscript{0.15}{#1}}} \newcommand*{\nsub}[1]{_{\nscript{0.35}{#1}}} \newcommand*{\nnotation}[1]{#1} -\newcommand*{\nrepeat}[1]{\text{\adjustbox{cfbox=nbordercolor 0.5pt 2pt,bgcolor=nbgcolor}{#1\hspace{.5\nscriptsize}}}} +\newcommand*{\nbox}[1]{\adjustbox{cfbox=nbordercolor 0.5pt \nboxsep,bgcolor=nbgcolor}{#1}} +\newcommand*{\nrepeat}[1]{\text{\nbox{#1\hspace{.5\nscriptsize}}}} \newcommand*{\nwrapper}[1]{\ensuremath{\displaystyle#1}} % https://tex.stackexchange.com/questions/310877/ \newcommand*{\nhole}[1]{\textit{\color{nholecolor}#1}} @@ -42,9 +46,32 @@ } % </magic> +% https://tex.stackexchange.com/questions/490262/ +\def\naltsep{} +\newsavebox{\nsavedalt} +\newlength{\naltvruleht} +\newlength{\naltvruledp} +\def\naltvrule{\smash{\vrule height\naltvruleht depth\naltvruledp}} +\newcommand{\nalternative}[2]{% + % First measure the contents of the box without the bar + \bgroup% + \def\naltsep{}% + \savebox{\nsavedalt}{#1}% + \setlength{\naltvruleht}{\ht\nsavedalt}% + \setlength{\naltvruledp}{\dp\nsavedalt}% + \addtolength{\naltvruleht}{#2}% + \addtolength{\naltvruledp}{#2}% + % Then redraw it with the bar + \def\naltsep{\naltvrule}% + #1\egroup} + \newcssclass{notation-sup}{\nsup{#1}} \newcssclass{notation-sub}{\nsub{#1}} \newcssclass{notation}{\nnotation{#1}} \newcssclass{repeat}{\nrepeat{#1}} \newcssclass{repeat-wrapper}{\nwrapper{#1}} \newcssclass{hole}{\nhole{#1}} +\newcssclass{alternative}{\nalternative{\nbox{#1}}{0pt}} +\newcssclass{alternative-block}{#1} +\newcssclass{repeated-alternative}{\nalternative{#1}{\nboxsep}} +\newcssclass{alternative-separator}{\quad\naltsep{}\quad} diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index dcb47d1786..8322ab0137 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -45,15 +45,46 @@ width: 2.2em; } -.notation .repeat { +.notation .repeat, .notation .alternative { background: #EAEAEA; border: 1px solid #AAA; display: inline-block; - padding-right: 0.6em; /* Space for the left half of the sub- and sup-scripts */ - padding-left: 0.2em; + padding: 0 0.2em 0 0.3em; margin: 0.25em 0; } +.notation .repeated-alternative { + display: inline-table; +} + +.notation .alternative { + display: inline-table; + padding: 0 0.2em; +} + +.notation .alternative-block { + display: table-cell; + padding: 0 0.5em; +} + +.notation .alternative-separator { + border-left: 1px solid black; /* Display a thin bar */ + display: table-cell; + width: 0; +} + +.alternative-block:first-child { + padding-left: 0; +} + +.alternative-block:last-child { + padding-right: 0; +} + +.notation .repeat { + padding-right: 0.6em; /* Space for the left half of the sub- and sup-scripts */ +} + .notation .repeat-wrapper { display: inline-block; position: relative; diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index e93b01f14d..3dc8707a34 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -99,7 +99,7 @@ Extraction Options Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Extraction Language ( OCaml | Haskell | Scheme ) +.. cmd:: Extraction Language {| OCaml | Haskell | Scheme } :name: Extraction Language The ability to fix target language is the first and more important @@ -168,7 +168,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: .. cmd:: Extraction NoInline {+ @qualid } - Conversely, the constants mentionned by this command will + Conversely, the constants mentioned by this command will never be inlined during extraction. .. cmd:: Print Extraction Inline diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index b474c51f17..68f6d4008a 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -170,12 +170,12 @@ compatibility constraints. Adding new relations and morphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Add Parametric Relation (x1 : T1) ... (xn : Tk) : (A t1 ... tn) (Aeq t′1 ... t′m) {? reflexivity proved by refl} {? symmetry proved by sym} {? transitivity proved by trans} as @ident +.. cmd:: Add Parametric Relation @binders : (A t1 ... tn) (Aeq t′1 ... t′m) {? reflexivity proved by @term} {? symmetry proved by @term} {? transitivity proved by @term} as @ident This command declares a parametric relation :g:`Aeq: forall (y1 : β1 ... ym : βm)`, :g:`relation (A t1 ... tn)` over :g:`(A : αi -> ... αn -> Type)`. - The :token:`ident` gives a unique name to the morphism and it is used + The final :token:`ident` gives a unique name to the morphism and it is used by the command to generate fresh names for automatically provided lemmas used internally. @@ -219,15 +219,16 @@ replace terms with related ones only in contexts that are syntactic compositions of parametric morphism instances declared with the following command. -.. cmd:: Add Parametric Morphism (x1 : T1) ... (xk : Tk) : (f t1 ... tn) with signature sig as @ident +.. cmd:: Add Parametric Morphism @binders : (@ident {+ @term__1}) with signature @term__2 as @ident - This command declares ``f`` as a parametric morphism of signature ``sig``. The - identifier :token:`ident` gives a unique name to the morphism and it is used as - the base name of the typeclass instance definition and as the name of - the lemma that proves the well-definedness of the morphism. The - parameters of the morphism as well as the signature may refer to the - context of variables. The command asks the user to prove interactively - that ``f`` respects the relations identified from the signature. + This command declares a parametric morphism :n:`@ident {+ @term__1}` of + signature :n:`@term__2`. The final identifier :token:`ident` gives a unique + name to the morphism and it is used as the base name of the typeclass + instance definition and as the name of the lemma that proves the + well-definedness of the morphism. The parameters of the morphism as well as + the signature may refer to the context of variables. The command asks the + user to prove interactively that the function denoted by the first + :token:`ident` respects the relations identified from the signature. .. example:: @@ -440,7 +441,7 @@ First class setoids and morphisms The implementation is based on a first-class representation of properties of relations and morphisms as typeclasses. That is, the various combinations of properties on relations and morphisms are -represented as records and instances of theses classes are put in a +represented as records and instances of these classes are put in a hint database. For example, the declaration: .. coqdoc:: @@ -577,7 +578,7 @@ Deprecated syntax and backward incompatibilities Notice that the syntax is not completely backward compatible since the identifier was not required. -.. cmd:: Add Morphism f : @ident +.. cmd:: Add Morphism @ident : @ident :name: Add Morphism This command is restricted to the declaration of morphisms @@ -809,7 +810,7 @@ Usage ~~~~~ -.. tacn:: rewrite_strat @s [in @ident] +.. tacn:: rewrite_strat @s {? in @ident } :name: rewrite_strat Rewrite using the strategy s in hypothesis ident or the conclusion. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index b410833d25..22ddcae584 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -283,7 +283,7 @@ optional identifier is used when multiple functions have unsolved obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. -.. cmd:: {? Local|Global} Obligation Tactic := @tactic +.. cmd:: {? {| Local | Global } } Obligation Tactic := @tactic :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 77a6ee79cc..2ba13db042 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -311,24 +311,24 @@ Summary of the commands This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {? @binders} : @class t1 … tn [| priority] := { field1 := b1 ; …; fieldi := bi } +.. cmd:: Instance @ident {? @binders} : @term__0 {+ @term} {? | @num} := { {*; @field_def} } This command is used to declare a typeclass instance named - :token:`ident` of the class :token:`class` with parameters ``t1`` to ``tn`` and - fields ``b1`` to ``bi``, where each field must be a declared field of - the class. Missing fields must be filled in interactive proof mode. + :token:`ident` of the class :n:`@term__0` with parameters :token:`term` and + fields defined by :token:`field_def`, where each field must be a declared field of + the class. An arbitrary context of :token:`binders` can be put after the name of the instance and before the colon to declare a parameterized instance. An optional priority can be declared, 0 being the highest priority as for - :tacn:`auto` hints. If the priority is not specified, it defaults to the number + :tacn:`auto` hints. If the priority :token:`num` is not specified, it defaults to the number of non-dependent binders of the instance. - .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n [| priority] := @term + .. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @term__0 {+ @term} {? | @num } := @term This syntax is used for declaration of singleton class instances or - for directly giving an explicit term of type :n:`forall @binders, @class - @term__1 … @term__n`. One need not even mention the unique field name for + for directly giving an explicit term of type :n:`forall @binders, @term__0 + {+ @term}`. One need not even mention the unique field name for singleton classes. .. cmdv:: Global Instance @@ -356,11 +356,11 @@ Summary of the commands Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a few other commands related to typeclasses. -.. cmd:: Existing Instance {+ @ident} [| priority] +.. cmd:: Existing Instance {+ @ident} {? | @num} This command adds an arbitrary list of constants whose type ends with an applied typeclass to the instance database with an optional - priority. It can be used for redeclaring instances at the end of + priority :token:`num`. It can be used for redeclaring instances at the end of sections, or declaring structure projections as instances. This is equivalent to ``Hint Resolve ident : typeclass_instances``, except it registers instances for :cmd:`Print Instances`. @@ -385,7 +385,7 @@ few other commands related to typeclasses. .. note:: As of Coq 8.6, ``all:once (typeclasses eauto)`` faithfully - mimicks what happens during typeclass resolution when it is called + mimics what happens during typeclass resolution when it is called during refinement/type inference, except that *only* declared class subgoals are considered at the start of resolution during type inference, while ``all`` can select non-class subgoals as well. It might @@ -408,7 +408,7 @@ few other commands related to typeclasses. + When considering local hypotheses, we use the union of all the modes declared in the given databases. - .. cmdv:: typeclasses eauto @num + .. tacv:: typeclasses eauto @num .. warning:: The semantics for the limit :n:`@num` @@ -417,7 +417,7 @@ few other commands related to typeclasses. counted, which might result in larger limits being necessary when searching with ``typeclasses eauto`` than with :tacn:`auto`. - .. cmdv:: typeclasses eauto with {+ @ident} + .. tacv:: typeclasses eauto with {+ @ident} This variant runs resolution with the given hint databases. It treats typeclass subgoals the same as other subgoals (no shelving of @@ -563,23 +563,10 @@ Settings of goals. Setting this option to 1 or 2 turns on :flag:`Typeclasses Debug`; setting this option to 0 turns that option off. -.. flag:: Refine Instance Mode - - .. deprecated:: 8.10 - - This flag allows to switch the behavior of instance declarations made through - the Instance command. - - + 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. - Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? (dfs) | (bfs) } @num +.. cmd:: Typeclasses eauto := {? debug} {? {| (dfs) | (bfs) } } @num :name: Typeclasses eauto This command allows more global customization of the typeclass diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 6b10b7c0b3..1aa2111816 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -449,7 +449,7 @@ underscore or by omitting the annotation to a polymorphic definition. This option, on by default, removes universes which appear only in the body of an opaque polymorphic definition from the definition's universe arguments. As such, no value needs to be provided for - these universes when instanciating the definition. Universe + these universes when instantiating the definition. Universe constraints are automatically adjusted. Consider the following definition: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index cca3b2e06b..701c62cdce 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -186,7 +186,7 @@ Coq is now continuously tested against OCaml trunk, in addition to the oldest supported and latest OCaml releases. Coq's documentation for the development branch is now deployed -continously at https://coq.github.io/doc/master/api (documentation of +continuously at https://coq.github.io/doc/master/api (documentation of the ML API), https://coq.github.io/doc/master/refman (reference manual), and https://coq.github.io/doc/master/stdlib (documentation of the standard library). Similar links exist for the `v8.10` branch. @@ -486,10 +486,9 @@ Other changes in 8.10+beta1 - :cmd:`Declare Instance` now requires an instance name. - The flag :flag:`Refine Instance Mode` has been turned off by default, - meaning that :cmd:`Instance` no longer opens a proof when a body is - provided. The flag has been deprecated and will be removed in the next - version. + The flag `Refine Instance Mode` has been turned off by default, meaning that + :cmd:`Instance` no longer opens a proof when a body is provided. The flag + has been deprecated and will be removed in the next version. (`#9270 <https://github.com/coq/coq/pull/9270>`_, and `#9825 <https://github.com/coq/coq/pull/9825>`_, @@ -498,7 +497,7 @@ Other changes in 8.10+beta1 - Command :cmd:`Instance`, when no body is provided, now always opens a proof. This is a breaking change, as instance of :n:`Instance @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will - have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` + have to be changed into :n:`Instance @ident__1 : @ident__2 := %{%}.` or :n:`Instance @ident__1 : @ident__2. Proof. Qed.` (`#9274 <https://github.com/coq/coq/pull/9274>`_, by Maxime Dénès). @@ -666,7 +665,7 @@ changes: - New commands :cmd:`Hint Variables` and :cmd:`Hint Constants`, by Matthieu Sozeau, for controlling the opacity status of variables and constants in hint databases. It is recommended to always use these - commands after creating a hint databse with :cmd:`Create HintDb`. + commands after creating a hint database with :cmd:`Create HintDb`. - Multiple sections with the same name are now allowed, by Jasper Hugunin. @@ -893,7 +892,7 @@ Vernacular Commands `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` - New `Set Hint Variables/Constants Opaque/Transparent` commands for setting globally the opacity flag of variables and constants in hint databases, - overwritting the opacity set of the hint database. + overwriting the opacity set of the hint database. - Added generic syntax for "attributes", as in: `#[local] Lemma foo : bar.` - Added the `Numeral Notation` command for registering decimal numeral @@ -1130,7 +1129,7 @@ Tactics few rare incompatibilities (it was unintendedly recursively rewriting in the side conditions generated by H). - Added tactics "assert_succeeds tac" and "assert_fails tac" to ensure - properties of the executation of a tactic without keeping the effect + properties of the execution of a tactic without keeping the effect of the execution. - `vm_compute` now supports existential variables. - Calls to `shelve` and `give_up` within calls to tactic `refine` now working. @@ -1263,7 +1262,7 @@ Tools Tactic language - The undocumented "nameless" forms `fix N`, `cofix` have been - deprecated; please use `fix ident N /cofix ident` to explicitely + deprecated; please use `fix ident N /cofix ident` to explicitly name the (co)fixpoint hypothesis to be introduced. Documentation @@ -2954,7 +2953,7 @@ Other bugfixes - Fix incorrect behavior of CS resolution - #4591: Uncaught exception in directory browsing. - CoqIDE is more resilient to initialization errors. -- #4614: "Fully check the document" is uninterruptable. +- #4614: "Fully check the document" is uninterruptible. - Try eta-expansion of records only on non-recursive ones - Fix bug when a sort is ascribed to a Record - Primitive projections: protect kernel from erroneous definitions. @@ -3443,7 +3442,7 @@ Libraries * all functions over type Z : Z.add, Z.mul, ... * the minimal proofs of specifications for these functions : Z.add_0_l, ... - * an instantation of all derived properties proved generically in Numbers : + * an instantiation of all derived properties proved generically in Numbers : Z.add_comm, Z.add_assoc, ... A large part of ZArith is now simply compatibility notations, for instance @@ -3940,7 +3939,7 @@ Vernacular commands Equality Schemes", this replaces deprecated option "Equality Scheme"). - Made support for automatic generation of case analysis schemes available to user (governed by option "Set Case Analysis Schemes"). -- New command :n:`{? Global } Generalizable [All|No] [Variable|Variables] {* @ident}` to +- New command :n:`{? Global } Generalizable {| All | No } {| Variable | Variables } {* @ident}` to declare which identifiers are generalizable in `` `{} `` and `` `() `` binders. - New command "Print Opaque Dependencies" to display opaque constants in addition to all variables, parameters or axioms a theorem or @@ -4624,7 +4623,7 @@ Setoid rewriting + Setoid_Theory is now an alias to Equivalence, scripts building objects of type Setoid_Theory need to unfold (or "red") the definitions of Reflexive, Symmetric and Transitive in order to get the same goals - as before. Scripts which introduced variables explicitely will not break. + as before. Scripts which introduced variables explicitly will not break. + The order of subgoals when doing [setoid_rewrite] with side-conditions is always the same: first the new goal, then the conditions. @@ -5023,7 +5022,7 @@ Syntax Language and commands -- Added sort-polymorphism for definitions in Type (but finally abandonned). +- Added sort-polymorphism for definitions in Type (but finally abandoned). - Support for implicit arguments in the types of parameters in (co-)fixpoints and (co-)inductive declarations. - Improved type inference: use as much of possible general information. @@ -5252,7 +5251,7 @@ Library - New file about the factorial function in Arith -- An additional elimination Acc_iter for Acc, simplier than Acc_rect. +- An additional elimination Acc_iter for Acc, simpler than Acc_rect. This new elimination principle is used for definition well_founded_induction. - New library NArith on binary natural numbers @@ -5337,7 +5336,7 @@ Bugs Miscellaneous - Implicit parameters of inductive types definition now taken into - account for infering other implicit arguments + account for inferring other implicit arguments Incompatibilities @@ -5418,7 +5417,7 @@ Gallina Known problems of the automatic translation - iso-latin-1 characters are no longer supported: move your files to - 7-bits ASCII or unicode before translation (swith to unicode is + 7-bits ASCII or unicode before translation (switch to unicode is automatically done if a file is loaded and saved again by coqide) - Renaming in ZArith: incompatibilities in Coq user contribs due to merging names INZ, from Reals, and inject_nat. @@ -5443,7 +5442,7 @@ Vernacular commands - "Functional Scheme" and "Functional Induction" extended to polymorphic types and dependent types - Notation now allows recursive patterns, hence recovering parts of the - fonctionalities of pre-V8 Grammar/Syntax commands + functionalities of pre-V8 Grammar/Syntax commands - Command "Print." discontinued. - Redundant syntax "Implicit Arguments On/Off" discontinued diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index 0f5b991ba4..c4a48d6985 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -110,7 +110,7 @@ advantage of special hardware, debuggers, and the like. We hope that |Coq| can be of use to researchers interested in experimenting with this new methodology. -.. [#years] At the time of writting, i.e. 1995. +.. [#years] At the time of writing, i.e. 1995. Versions 1 to 5 --------------- @@ -305,7 +305,7 @@ Michel Mauny, Ascander Suarez and Pierre Weis. V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November 1986. V3.4 was developed in the first half of 1987. -Thierry Coquand held a post-doctoral position in Cambrige University +Thierry Coquand held a post-doctoral position in Cambridge University in 1986-87, where he developed a variant implementation in SML, with which he wrote some developments on fixpoints in Scott's domains. @@ -345,7 +345,7 @@ lemmas when local hypotheses of proofs were discharged. This gave a notion of global mathematical environment with local sections. Another significant practical change was that the system, originally -developped on the VAX central computer of our lab, was transferred on +developed on the VAX central computer of our lab, was transferred on SUN personal workstations, allowing a level of distributed development. The extraction algorithm was modified, with three annotations ``Pos``, ``Null`` and ``Typ`` decorating the sorts ``Prop`` @@ -503,7 +503,7 @@ of CNRS-ENS Lyon. Chetan Murthy joined the team in 1991 and became the main software architect of Version 5. He completely rehauled the implementation for efficiency. Versions 5.6 and 5.8 were major distributed versions, -with complete documentation and a library of users' developements. The +with complete documentation and a library of users' developments. The use of the RCS revision control system, and systematic ChangeLog files, allow a more precise tracking of the software developments. @@ -1330,7 +1330,7 @@ Language - Inductive definitions now accept ">" in constructor types to declare the corresponding constructor as a coercion. -- Idem for assumptions declarations and constants when the type is mentionned. +- Idem for assumptions declarations and constants when the type is mentioned. - The "Coercion" and "Canonical Structure" keywords now accept the same syntax as "Definition", i.e. "hyps :=c (:t)?" or "hyps :t". - Theorem-like declaration now accepts the syntax "Theorem thm [x:t;...] : u". @@ -1383,7 +1383,7 @@ Tactics it can also recognize 'False' in the hypothesis and use it to solve the goal. - Coercions now handled in "with" bindings -- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses +- "Subst x" replaces all occurrences of x by t in the goal and hypotheses when an hypothesis x=t or x:=t or t=x exists - Fresh names for Assert and Pose now based on collision-avoiding Intro naming strategy (exceptional source of incompatibilities) diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index ba766c8c3d..c48964d66c 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -85,7 +85,7 @@ To build an object of type :token:`ident`, one should provide the constructor .. productionlist:: record_term : {| [`field_def` ; … ; `field_def`] |} - field_def : name [binders] := `record_term` + field_def : `ident` [`binders`] := `term` Alternatively, the following syntax allows creating objects by using named fields, as shown in this grammar. The fields do not have to be in any particular order, nor do they have @@ -831,16 +831,16 @@ Sections create local contexts which can be shared across multiple definitions. Links :token:`type` to each :token:`ident`. - .. cmdv:: Variable {+ ( {+ @ident } : @type ) } + .. cmdv:: Variable {+ ( {+ @ident } : @type ) } Declare one or more variables with various types. - .. cmdv:: Variables {+ ( {+ @ident } : @type) } - Hypothesis {+ ( {+ @ident } : @type) } - Hypotheses {+ ( {+ @ident } : @type) } + .. cmdv:: Variables {+ ( {+ @ident } : @type) } + Hypothesis {+ ( {+ @ident } : @type) } + Hypotheses {+ ( {+ @ident } : @type) } :name: Variables; Hypothesis; Hypotheses - These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @type) }`. + These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @type) }`. .. cmd:: Let @ident := @term @@ -931,7 +931,7 @@ In the syntax of module application, the ! prefix indicates that any :token:`module_binding`. The output module type is verified against each :token:`module_type`. -.. cmdv:: Module [ Import | Export ] +.. cmdv:: Module {| Import | Export } Behaves like :cmd:`Module`, but automatically imports or exports the module. @@ -1648,7 +1648,7 @@ Declaring Implicit Arguments -.. cmd:: Arguments @qualid {* [ @ident ] | { @ident } | @ident } +.. cmd:: Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } :name: Arguments (implicits) This command is used to set implicit arguments *a posteriori*, @@ -1665,20 +1665,20 @@ Declaring Implicit Arguments This command clears implicit arguments. -.. cmdv:: Global Arguments @qualid {* [ @ident ] | { @ident } | @ident } +.. cmdv:: Global Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } This command is used to recompute the implicit arguments of :token:`qualid` after ending of the current section if any, enforcing the implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* [ @ident ] | { @ident } | @ident } +.. cmdv:: Local Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } When in a module, tell not to activate the implicit arguments of :token:`qualid` declared by this command to contexts that require the module. -.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | { @ident } | @ident } } +.. cmdv:: {? {| Global | Local } } Arguments @qualid {*, {+ {| [ @ident ] | { @ident } | @ident } } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -2131,24 +2131,71 @@ Implicit generalization .. index:: `{ } .. index:: `( ) +.. index:: `{! } +.. index:: `(! ) Implicit generalization is an automatic elaboration of a statement with free variables into a closed statement where these variables are -quantified explicitly. Implicit generalization is done inside binders -starting with a \` and terms delimited by \`{ } and \`( ), always -introducing maximally inserted implicit arguments for the generalized -variables. Inside implicit generalization delimiters, free variables -in the current context are automatically quantified using a product or -a lambda abstraction to generate a closed term. In the following -statement for example, the variables n and m are automatically -generalized and become explicit arguments of the lemma as we are using -\`( ): +quantified explicitly. -.. coqtop:: all +It is activated for a binder by prefixing a \`, and for terms by +surrounding it with \`{ } or \`( ). + +Terms surrounded by \`{ } introduce their free variables as maximally +inserted implicit arguments, and terms surrounded by \`( ) introduce +them as explicit arguments. + +Generalizing binders always introduce their free variables as +maximally inserted implicit arguments. The binder itself introduces +its argument as usual. + +In the following statement, ``A`` and ``y`` are automatically +generalized, ``A`` is implicit and ``x``, ``y`` and the anonymous +equality argument are explicit. + +.. coqtop:: all reset Generalizable All Variables. - Lemma nat_comm : `(n = n + 0). + Definition sym `(x:A) : `(x = y -> y = x) := fun _ p => eq_sym p. + + Print sym. + +Dually to normal binders, the name is optional but the type is required: + +.. coqtop:: all + + Check (forall `{x = y :> A}, y = x). + +When generalizing a binder whose type is a typeclass, its own class +arguments are omitted from the syntax and are generalized using +automatic names, without instance search. Other arguments are also +generalized unless provided. This produces a fully general statement. +this behaviour may be disabled by prefixing the type with a ``!`` or +by forcing the typeclass name to be an explicit application using +``@`` (however the later ignores implicit argument information). + +.. coqtop:: all + + Class Op (A:Type) := op : A -> A -> A. + + Class Commutative (A:Type) `(Op A) := commutative : forall x y, op x y = op y x. + Instance nat_op : Op nat := plus. + + Set Printing Implicit. + Check (forall `{Commutative }, True). + Check (forall `{Commutative nat}, True). + Fail Check (forall `{Commutative nat _}, True). + Fail Check (forall `{!Commutative nat}, True). + Arguments Commutative _ {_}. + Check (forall `{!Commutative nat}, True). + Check (forall `{@Commutative nat plus}, True). + +Multiple binders can be merged using ``,`` as a separator: + +.. coqtop:: all + + Check (forall `{Commutative A, Hnat : !Commutative nat}, True). One can control the set of generalizable identifiers with the ``Generalizable`` vernacular command to avoid unexpected @@ -2167,7 +2214,7 @@ that specify which variables should be generalizable. Disable implicit generalization entirely. This is the default behavior. -.. cmd:: Generalizable (Variable | Variables) {+ @ident } +.. cmd:: Generalizable {| Variable | Variables } {+ @ident } Allow generalization of the given identifiers only. Calling this command multiple times adds to the allowed identifiers. @@ -2176,22 +2223,6 @@ that specify which variables should be generalizable. Allows exporting the choice of generalizable variables. -One can also use implicit generalization for binders, in which case -the generalized variables are added as binders and set maximally -implicit. - -.. coqtop:: all - - Definition id `(x : A) : A := x. - - Print id. - -The generalizing binders \`{ } and \`( ) work similarly to their -explicit counterparts, only binding the generalized variables -implicitly, as maximally-inserted arguments. In these binders, the -binding name for the bound object is optional, whereas the type is -mandatory, dually to regular binders. - .. _Coercions: Coercions diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 5a1af9f9fa..8acbcbec8f 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -616,34 +616,34 @@ has type :token:`type`. Adds several parameters with specification :token:`type`. - .. cmdv:: Parameter {+ ( {+ @ident } : @type ) } + .. cmdv:: Parameter {+ ( {+ @ident } : @type ) } Adds blocks of parameters with different specifications. - .. cmdv:: Local Parameter {+ ( {+ @ident } : @type ) } + .. cmdv:: Local Parameter {+ ( {+ @ident } : @type ) } :name: Local Parameter Such parameters are never made accessible through their unqualified name by :cmd:`Import` and its variants. You have to explicitly give their fully qualified name to refer to them. - .. cmdv:: {? Local } Parameters {+ ( {+ @ident } : @type ) } - {? Local } Axiom {+ ( {+ @ident } : @type ) } - {? Local } Axioms {+ ( {+ @ident } : @type ) } - {? Local } Conjecture {+ ( {+ @ident } : @type ) } - {? Local } Conjectures {+ ( {+ @ident } : @type ) } + .. cmdv:: {? Local } Parameters {+ ( {+ @ident } : @type ) } + {? Local } Axiom {+ ( {+ @ident } : @type ) } + {? Local } Axioms {+ ( {+ @ident } : @type ) } + {? Local } Conjecture {+ ( {+ @ident } : @type ) } + {? Local } Conjectures {+ ( {+ @ident } : @type ) } :name: Parameters; Axiom; Axioms; Conjecture; Conjectures - These variants are synonyms of :n:`{? Local } Parameter {+ ( {+ @ident } : @type ) }`. + These variants are synonyms of :n:`{? Local } Parameter {+ ( {+ @ident } : @type ) }`. - .. cmdv:: Variable {+ ( {+ @ident } : @type ) } - Variables {+ ( {+ @ident } : @type ) } - Hypothesis {+ ( {+ @ident } : @type ) } - Hypotheses {+ ( {+ @ident } : @type ) } + .. cmdv:: Variable {+ ( {+ @ident } : @type ) } + Variables {+ ( {+ @ident } : @type ) } + Hypothesis {+ ( {+ @ident } : @type ) } + Hypotheses {+ ( {+ @ident } : @type ) } :name: Variable (outside a section); Variables (outside a section); Hypothesis (outside a section); Hypotheses (outside a section) Outside of any section, these variants are synonyms of - :n:`Local Parameter {+ ( {+ @ident } : @type ) }`. + :n:`Local Parameter {+ ( {+ @ident } : @type ) }`. For their meaning inside a section, see :cmd:`Variable` in :ref:`section-mechanism`. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index a7eb7c2319..fed7111628 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -360,7 +360,7 @@ Detecting progress We can check if a tactic made progress with: -.. tacn:: progress expr +.. tacn:: progress @expr :name: progress :n:`@expr` is evaluated to v which must be a tactic value. The tactic value ``v`` @@ -555,7 +555,7 @@ Identity The constant :n:`idtac` is the identity tactic: it leaves any goal unchanged but it appears in the proof script. -.. tacn:: idtac {* message_token} +.. tacn:: idtac {* @message_token} :name: idtac This prints the given tokens. Strings and integers are printed @@ -684,7 +684,7 @@ Timing a tactic that evaluates to a term Tactic expressions that produce terms can be timed with the experimental tactic -.. tacn:: time_constr expr +.. tacn:: time_constr @expr :name: time_constr which evaluates :n:`@expr ()` and displays the time the tactic expression @@ -708,7 +708,7 @@ tactic for printing. By copying the definition of :tacn:`time_constr` from the standard library, - users can achive support for a fixed pattern of nesting by passing + users can achieve support for a fixed pattern of nesting by passing different :token:`string` parameters to :tacn:`restart_timer` and :tacn:`finish_timing` at each level of nesting. @@ -880,7 +880,7 @@ We can perform pattern matching on goals using the following expression: .. we should provide the full grammar here -.. tacn:: match goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end +.. tacn:: match goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end :name: match goal If each hypothesis pattern :n:`hyp`\ :sub:`1,i`, with i = 1, ..., m\ :sub:`1` is @@ -918,7 +918,7 @@ We can perform pattern matching on goals using the following expression: first), but it possible to reverse this order (oldest first) with the :n:`match reverse goal with` variant. - .. tacv:: multimatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + .. tacv:: multimatch goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end Using :n:`multimatch` instead of :n:`match` will allow subsequent tactics to backtrack into a right-hand side tactic which has backtracking points @@ -929,7 +929,7 @@ We can perform pattern matching on goals using the following expression: The syntax :n:`match [reverse] goal …` is, in fact, a shorthand for :n:`once multimatch [reverse] goal …`. - .. tacv:: lazymatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + .. tacv:: lazymatch goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end Using lazymatch instead of match will perform the same pattern matching procedure but will commit to the first matching branch with the first @@ -1135,33 +1135,33 @@ Defining |Ltac| functions Basically, |Ltac| toplevel definitions are made as follows: -.. cmd:: Ltac @ident {* @ident} := @expr +.. cmd:: {? Local} Ltac @ident {* @ident} := @expr + :name: Ltac This defines a new |Ltac| function that can be used in any tactic script or new |Ltac| toplevel definition. + If preceded by the keyword ``Local``, the tactic definition will not be + exported outside the current module. + .. note:: The preceding definition can equivalently be written: :n:`Ltac @ident := fun {+ @ident} => @expr` - Recursive and mutual recursive function definitions are also possible - with the syntax: - .. cmdv:: Ltac @ident {* @ident} {* with @ident {* @ident}} := @expr - It is also possible to *redefine* an existing user-defined tactic using the syntax: + This syntax allows recursive and mutual recursive function definitions. .. cmdv:: Ltac @qualid {* @ident} ::= @expr + This syntax *redefines* an existing user-defined tactic. + A previous definition of qualid must exist in the environment. The new definition will always be used instead of the old one and it goes across module boundaries. - If preceded by the keyword Local the tactic definition will not be - exported outside the current module. - Printing |Ltac| tactics ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1676,7 +1676,7 @@ It is possible to measure the time spent in invocations of primitive tactics as well as tactics defined in |Ltac| and their inner invocations. The primary use is the development of complex tactics, which can sometimes be so slow as to impede interactive usage. The -reasons for the performence degradation can be intricate, like a slowly +reasons for the performance degradation can be intricate, like a slowly performing |Ltac| match or a sub-tactic whose performance only degrades in certain situations. The profiler generates a call tree and indicates the time spent in a tactic depending on its calling context. Thus diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 6e33862b39..aa603fc966 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -668,7 +668,7 @@ A scope is a name given to a grammar entry used to produce some Ltac2 expression at parsing time. Scopes are described using a form of S-expression. .. prodn:: - ltac2_scope ::= @string %| @integer %| @lident ({+, @ltac2_scope}) + ltac2_scope ::= {| @string | @integer | @lident ({+, @ltac2_scope}) } A few scopes contain antiquotation features. For sake of uniformity, all antiquotations are introduced by the syntax :n:`$@lident`. @@ -751,7 +751,7 @@ Notations The Ltac2 parser can be extended by syntactic notations. -.. cmd:: Ltac2 Notation {+ @lident (@ltac2_scope) %| @string } {? : @integer} := @ltac2_term +.. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @integer} := @ltac2_term :name: Ltac2 Notation A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded @@ -823,9 +823,9 @@ Ltac2 features a toplevel loop that can be used to evaluate expressions. Debug ----- -.. opt:: Ltac2 Backtrace +.. flag:: Ltac2 Backtrace - When this option is set, toplevel failures will be printed with a backtrace. + When this flag is set, toplevel failures will be printed with a backtrace. Compatibility layer with Ltac1 ------------------------------ @@ -966,7 +966,7 @@ errors produced by the typechecker. In Ltac expressions +++++++++++++++++++ -.. exn:: Unbound ( value | constructor ) X +.. exn:: Unbound {| value | constructor } X * if `X` is meant to be a term from the current stactic environment, replace the problematic use by `'X`. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 16b158c397..4a2f9c0db3 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -322,7 +322,7 @@ Navigation in the proof tree .. index:: { } -.. cmd:: %{ %| %} +.. cmd:: {| %{ | %} } The command ``{`` (without a terminating period) focuses on the first goal, much like :cmd:`Focus` does, however, the subproof can only be @@ -430,7 +430,7 @@ not go beyond enclosing ``{`` and ``}``, so bullets can be reused as further nesting levels provided they are delimited by these. Bullets are made of repeated ``-``, ``+`` or ``*`` symbols: -.. prodn:: bullet ::= {+ - } %| {+ + } %| {+ * } +.. prodn:: bullet ::= {| {+ - } | {+ + } | {+ * } } Note again that when a focused goal is proved a message is displayed together with a suggestion about the right bullet or ``}`` to unfocus it @@ -492,7 +492,7 @@ The following example script illustrates all these features: Set Bullet Behavior ``````````````````` -.. opt:: Bullet Behavior %( "None" %| "Strict Subproofs" %) +.. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } :name: Bullet Behavior This option controls the bullet behavior and can take two possible values: @@ -544,9 +544,9 @@ Requesting information ``<Your Tactic Text here>``. - .. deprecated:: 8.10 + .. deprecated:: 8.10 - Please use a text editor. + Please use a text editor. .. cmdv:: Show Proof :name: Show Proof @@ -680,7 +680,7 @@ This image shows an error message with diff highlighting in CoqIDE: How to enable diffs ``````````````````` -.. opt:: Diffs %( "on" %| "off" %| "removed" %) +.. opt:: Diffs {| "on" | "off" | "removed" } :name: Diffs The “on” setting highlights added tokens in green, while the “removed” setting diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 4e40df6f94..b19b0742c1 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -617,7 +617,7 @@ Abbreviations selected occurrences of a term. .. prodn:: - occ_switch ::= { {? + %| - } {* @num } } + occ_switch ::= { {? {| + | - } } {* @num } } where: @@ -853,7 +853,7 @@ An *occurrence switch* can be: algorithm in a local definition, instead of copying large terms by hand. -It is important to remember that matching *preceeds* occurrence +It is important to remember that matching *precedes* occurrence selection. .. example:: @@ -2273,7 +2273,7 @@ to the others. Iteration ~~~~~~~~~ -.. tacn:: do {? @num } ( @tactic | [ {+| @tactic } ] ) +.. tacn:: do {? @num } {| @tactic | [ {+| @tactic } ] } :name: do (ssreflect) This tactical offers an accurate control on the repetition of tactics. @@ -2300,7 +2300,7 @@ tactic should be repeated on the current subgoal. There are four kinds of multipliers: .. prodn:: - mult ::= @num ! %| ! %| @num ? %| ? + mult ::= {| @num ! | ! | @num ? | ? } Their meaning is: @@ -2455,7 +2455,7 @@ the holes are abstracted in term. Lemma test : True. have: _ * 0 = 0. - The invokation of ``have`` is equivalent to: + The invocation of ``have`` is equivalent to: .. coqtop:: reset none @@ -2571,7 +2571,7 @@ destruction of existential assumptions like in the tactic: An alternative use of the ``have`` tactic is to provide the explicit proof term for the intermediate lemma, using tactics of the form: -.. tacv:: have {? @ident } := term +.. tacv:: have {? @ident } := @term This tactic creates a new assumption of type the type of :token:`term`. If the @@ -4927,7 +4927,7 @@ bookkeeping steps. apply/PQequiv. thus in this case, the tactic ``apply/PQequiv`` is equivalent to - ``apply: (iffRL (PQequiv _ _))``, where ``iffRL`` is tha analogue of + ``apply: (iffRL (PQequiv _ _))``, where ``iffRL`` is the analogue of ``iffRL`` for the converse implication. Any |SSR| term whose type coerces to a double implication can be @@ -5444,7 +5444,7 @@ equivalences are indeed taken into account, otherwise only single |SSR| searching tool -------------------- -.. cmd:: Search {? @pattern } {* {? - } %( @string %| @pattern %) {? % @ident} } {? in {+ {? - } @qualid } } +.. cmd:: Search {? @pattern } {* {? - } {| @string | @pattern } {? % @ident} } {? in {+ {? - } @qualid } } :name: Search (ssreflect) This is the |SSR| extension of the Search command. :token:`qualid` is the @@ -5686,7 +5686,7 @@ respectively. local cofix definition -.. tacn:: set @ident {? : @term } := {? @occ_switch } %( @term %| ( @c_pattern) %) +.. tacn:: set @ident {? : @term } := {? @occ_switch } {| @term | ( @c_pattern) } abbreviation (see :ref:`abbreviations_ssr`) @@ -5714,26 +5714,26 @@ introduction see :ref:`introduction_ssr` localization see :ref:`localization_ssr` -.. prodn:: tactic += do {? @mult } %( @tactic %| [ {+| @tactic } ] %) +.. prodn:: tactic += do {? @mult } {| @tactic | [ {+| @tactic } ] } iteration see :ref:`iteration_ssr` -.. prodn:: tactic += @tactic ; %( first %| last %) {? @num } %( @tactic %| [ {+| @tactic } ] %) +.. prodn:: tactic += @tactic ; {| first | last } {? @num } {| @tactic | [ {+| @tactic } ] } selector see :ref:`selectors_ssr` -.. prodn:: tactic += @tactic ; %( first %| last %) {? @num } +.. prodn:: tactic += @tactic ; {| first | last } {? @num } rotation see :ref:`selectors_ssr` -.. prodn:: tactic += by %( @tactic %| [ {*| @tactic } ] %) +.. prodn:: tactic += by {| @tactic | [ {*| @tactic } ] } closing see :ref:`terminators_ssr` Commands ~~~~~~~~ -.. cmd:: Hint View for %( move %| apply %) / @ident {? | @num } +.. cmd:: Hint View for {| move | apply } / @ident {? | @num } view hint declaration (see :ref:`declaring_new_hints_ssr`) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index c728b925ac..2ee23df019 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -1749,7 +1749,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) They combine the effects of the ``with``, ``as``, ``eqn:``, ``using``, and ``in`` clauses. -.. tacn:: case term +.. tacn:: case @term :name: case The tactic :n:`case` is a more basic tactic to perform case analysis without @@ -1982,7 +1982,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) :n:`induction @ident; induction @ident` (or :n:`induction @ident ; destruct @ident` depending on the exact needs). -.. tacv:: double induction num1 num2 +.. tacv:: double induction @num__1 @num__2 This tactic is deprecated and should be replaced by :n:`induction num1; induction num3` where :n:`num3` is the result @@ -2271,11 +2271,11 @@ and an explanation of the underlying technique. :undocumented: .. tacv:: injection @term {? with @bindings_list} as {+ @simple_intropattern} - injection @num as {+ simple_intropattern} - injection as {+ simple_intropattern} - einjection @term {? with @bindings_list} as {+ simple_intropattern} - einjection @num as {+ simple_intropattern} - einjection as {+ simple_intropattern} + injection @num as {+ @simple_intropattern} + injection as {+ @simple_intropattern} + einjection @term {? with @bindings_list} as {+ @simple_intropattern} + einjection @num as {+ @simple_intropattern} + einjection as {+ @simple_intropattern} These variants apply :n:`intros {+ @simple_intropattern}` after the call to :tacn:`injection` or :tacn:`einjection` so that all equalities generated are moved in @@ -2637,7 +2637,7 @@ and an explanation of the underlying technique. is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). -.. tacv:: fix @ident @num with {+ (ident {+ @binder} [{struct @ident}] : @type)} +.. tacv:: fix @ident @num with {+ (@ident {+ @binder} [{struct @ident}] : @type)} This starts a proof by mutual induction. The statements to be simultaneously proved are respectively :g:`forall binder ... binder, type`. @@ -3714,7 +3714,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. cmdv:: Hint Resolve -> @term : @ident Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @term`, although as mentionned + the hint will be used as :n:`apply <- @term`, although as mentioned before, the tactic actually used is a restricted version of :tacn:`apply`). @@ -3777,13 +3777,13 @@ The general command to add a hint to some databases :n:`{+ @ident}` is discrimination network to relax or constrain it in the case of discriminated databases. - .. cmdv:: Hint Variables %( Transparent %| Opaque %) : @ident - Hint Constants %( Transparent %| Opaque %) : @ident + .. cmdv:: Hint Variables {| Transparent | Opaque } : @ident + Hint Constants {| Transparent | Opaque } : @ident :name: Hint Variables; Hint Constants This sets the transparency flag used during unification of hints in the database for all constants or all variables, - overwritting the existing settings of opacity. It is advised + overwriting the existing settings of opacity. It is advised to use this just after a :cmd:`Create HintDb` command. .. cmdv:: Hint Extern @num {? @pattern} => @tactic : @ident @@ -3850,7 +3850,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is semantics of :n:`Hint Cut @regexp` is to set the cut expression to :n:`c | regexp`, the initial cut expression being `emp`. - .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} : @ident + .. cmdv:: Hint Mode @qualid {* {| + | ! | - } } : @ident :name: Hint Mode This sets an optional mode of use of the identifier :n:`@qualid`. When @@ -4016,7 +4016,7 @@ We propose a smooth transitional path by providing the :opt:`Loose Hint Behavior option which accepts three flags allowing for a fine-grained handling of non-imported hints. -.. opt:: Loose Hint Behavior %( "Lax" %| "Warn" %| "Strict" %) +.. opt:: Loose Hint Behavior {| "Lax" | "Warn" | "Strict" } :name: Loose Hint Behavior This option accepts three values, which control the behavior of hints w.r.t. @@ -4048,7 +4048,7 @@ Setting implicit automation tactics .. seealso:: :cmd:`Proof` in :ref:`proof-editing-mode`. - .. cmdv:: Proof with tactic using {+ @ident} + .. cmdv:: Proof with @tactic using {+ @ident} Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` @@ -4400,6 +4400,11 @@ Equality This tactic applies to a goal that has the form :g:`t=u` and transforms it into the two subgoals :n:`t=@term` and :n:`@term=u`. + .. tacv:: etransitivity + + This tactic behaves like :tacn:`transitivity`, using a fresh evar instead of + a concrete :token:`term`. + Equality and inductive sets --------------------------- diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index e207a072cc..26dc4e02cf 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -91,13 +91,13 @@ and tables: Flags, options and tables are identified by a series of identifiers, each with an initial capital letter. -.. cmd:: {? Local | Global | Export } Set @flag +.. cmd:: {? {| Local | Global | Export } } Set @flag :name: Set Sets :token:`flag` on. Scoping qualifiers are described :ref:`here <set_unset_scope_qualifiers>`. -.. cmd:: {? Local | Global | Export } Unset @flag +.. cmd:: {? {| Local | Global | Export } } Unset @flag :name: Unset Sets :token:`flag` off. Scoping qualifiers are @@ -108,13 +108,13 @@ capital letter. Prints the current value of :token:`flag`. -.. cmd:: {? Local | Global | Export } Set @option ( @num | @string ) +.. cmd:: {? {| Local | Global | Export } } Set @option {| @num | @string } :name: Set @option Sets :token:`option` to the specified value. Scoping qualifiers are described :ref:`here <set_unset_scope_qualifiers>`. -.. cmd:: {? Local | Global | Export } Unset @option +.. cmd:: {? {| Local | Global | Export } } Unset @option :name: Unset @option Sets :token:`option` to its default value. Scoping qualifiers are @@ -129,17 +129,17 @@ capital letter. Prints the current value of all flags and options, and the names of all tables. -.. cmd:: Add @table ( @string | @qualid ) +.. cmd:: Add @table {| @string | @qualid } :name: Add @table Adds the specified value to :token:`table`. -.. cmd:: Remove @table ( @string | @qualid ) +.. cmd:: Remove @table {| @string | @qualid } :name: Remove @table Removes the specified value from :token:`table`. -.. cmd:: Test @table for ( @string | @qualid ) +.. cmd:: Test @table for {| @string | @qualid } :name: Test @table for Reports whether :token:`table` contains the specified value. @@ -162,7 +162,7 @@ capital letter. Scope qualifiers for :cmd:`Set` and :cmd:`Unset` ````````````````````````````````````````````````` -:n:`{? Local | Global | Export }` +:n:`{? {| Local | Global | Export } }` Flag and option settings can be global in scope or local to nested scopes created by :cmd:`Module` and :cmd:`Section` commands. There are four alternatives: @@ -277,7 +277,7 @@ Requests to the environment :token:`term_pattern` (holes of the pattern are either denoted by `_` or by :n:`?@ident` when non linear patterns are expected). - .. cmdv:: Search { + [-]@term_pattern_string } + .. cmdv:: Search {+ {? -}@term_pattern_string} where :n:`@term_pattern_string` is a term_pattern, a string, or a string followed @@ -289,17 +289,17 @@ Requests to the environment prefixed by `-`, the search excludes the objects that mention that term_pattern or that string. - .. cmdv:: Search @term_pattern_string … @term_pattern_string inside {+ @qualid } + .. cmdv:: Search {+ {? -}@term_pattern_string} inside {+ @qualid } This restricts the search to constructions defined in the modules named by the given :n:`qualid` sequence. - .. cmdv:: Search @term_pattern_string … @term_pattern_string outside {+ @qualid } + .. cmdv:: Search {+ {? -}@term_pattern_string} outside {+ @qualid } This restricts the search to constructions not defined in the modules named by the given :n:`qualid` sequence. - .. cmdv:: @selector: Search [-]@term_pattern_string … [-]@term_pattern_string + .. cmdv:: @selector: Search {+ {? -}@term_pattern_string} This specifies the goal on which to search hypothesis (see Section :ref:`invocation-of-tactics`). @@ -353,7 +353,7 @@ Requests to the environment This restricts the search to constructions defined in the modules named by the given :n:`qualid` sequence. - .. cmdv:: SearchHead term outside {+ @qualid } + .. cmdv:: SearchHead @term outside {+ @qualid } This restricts the search to constructions not defined in the modules named by the given :n:`qualid` sequence. @@ -443,7 +443,7 @@ Requests to the environment SearchRewrite (_ + _ + _). - .. cmdv:: SearchRewrite term inside {+ @qualid } + .. cmdv:: SearchRewrite @term inside {+ @qualid } This restricts the search to constructions defined in the modules named by the given :n:`qualid` sequence. @@ -622,7 +622,7 @@ file is a particular case of module called *library file*. but if a further module, say `A`, contains a command :cmd:`Require Export` `B`, then the command :cmd:`Require Import` `A` also imports the module `B.` - .. cmdv:: Require [Import | Export] {+ @qualid } + .. cmdv:: Require {| Import | Export } {+ @qualid } This loads the modules named by the :token:`qualid` sequence and their recursive @@ -988,7 +988,7 @@ Controlling display This option controls the normal displaying. -.. opt:: Warnings "{+, {? %( - %| + %) } @ident }" +.. opt:: Warnings "{+, {? {| - | + } } @ident }" :name: Warnings This option configures the display of warnings. It is experimental, and diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 418922e9b3..3a12ee288a 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -336,29 +336,32 @@ Generation of induction principles with ``Functional`` ``Scheme`` Generation of inversion principles with ``Derive`` ``Inversion`` ----------------------------------------------------------------- -.. cmd:: Derive Inversion @ident with forall (x : T), I t Sort sort +.. cmd:: Derive Inversion @ident with @ident Sort @sort + Derive Inversion @ident with (forall @binders, @ident @term) Sort @sort This command generates an inversion principle for the - :tacn:`inversion ... using ...` tactic. Let :g:`I` be an inductive - predicate and :g:`x` the variables occurring in t. This command - generates and stocks the inversion lemma for the sort :g:`sort` - corresponding to the instance :g:`∀ (x:T), I t` with the name - :n:`@ident` in the global environment. When applied, it is - equivalent to having inverted the instance with the tactic - :g:`inversion`. - + :tacn:`inversion ... using ...` tactic. The first :token:`ident` is the name + of the generated principle. The second :token:`ident` should be an inductive + predicate, and :token:`binders` the variables occurring in the term + :token:`term`. This command generates the inversion lemma for the sort + :token:`sort` corresponding to the instance :n:`forall @binders, @ident @term`. + When applied, it is equivalent to having inverted the instance with the + tactic :g:`inversion`. -.. cmdv:: Derive Inversion_clear @ident with forall (x:T), I t Sort @sort +.. cmdv:: Derive Inversion_clear @ident with @ident Sort @sort + Derive Inversion_clear @ident with (forall @binders, @ident @term) Sort @sort When applied, it is equivalent to having inverted the instance with the tactic inversion replaced by the tactic `inversion_clear`. -.. cmdv:: Derive Dependent Inversion @ident with forall (x:T), I t Sort @sort +.. cmdv:: Derive Dependent Inversion @ident with @ident Sort @sort + Derive Dependent Inversion @ident with (forall @binders, @ident @term) Sort @sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion`. -.. cmdv:: Derive Dependent Inversion_clear @ident with forall(x:T), I t Sort @sort +.. cmdv:: Derive Dependent Inversion_clear @ident with @ident Sort @sort + Derive Dependent Inversion_clear @ident with (forall @binders, @ident @term) Sort @sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion_clear`. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index edec13f681..6da42f4a48 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -327,22 +327,29 @@ symbols. Reserving notations ~~~~~~~~~~~~~~~~~~~ -A given notation may be used in different contexts. Coq expects all -uses of the notation to be defined at the same precedence and with the -same associativity. To avoid giving the precedence and associativity -every time, it is possible to declare a parsing rule in advance -without giving its interpretation. Here is an example from the initial -state of Coq. +.. cmd:: Reserved Notation @string {? (@modifiers) } -.. coqtop:: in + A given notation may be used in different contexts. Coq expects all + uses of the notation to be defined at the same precedence and with the + same associativity. To avoid giving the precedence and associativity + every time, this command declares a parsing rule (:token:`string`) in advance + without giving its interpretation. Here is an example from the initial + state of Coq. + + .. coqtop:: in + + Reserved Notation "x = y" (at level 70, no associativity). + + Reserving a notation is also useful for simultaneously defining an + inductive type or a recursive constant and a notation for it. - Reserved Notation "x = y" (at level 70, no associativity). + .. note:: The notations mentioned in the module :ref:`init-notations` are reserved. Hence + their precedence and associativity cannot be changed. -Reserving a notation is also useful for simultaneously defining an -inductive type or a recursive constant and a notation for it. + .. cmdv:: Reserved Infix "@symbol" {* @modifiers} -.. note:: The notations mentioned in the module :ref:`init-notations` are reserved. Hence - their precedence and associativity cannot be changed. + This command declares an infix parsing rule without giving its + interpretation. Simultaneous definition of terms and notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1191,7 +1198,7 @@ The ``function_scope`` interpretation scope The scope ``function_scope`` also has a special status. It is temporarily activated each time the argument of a global reference is -recognized to be a ``Funclass`` istance, i.e., of type :g:`forall x:A, B` or +recognized to be a ``Funclass`` instance, i.e., of type :g:`forall x:A, B` or :g:`A -> B`. diff --git a/doc/tools/Translator.tex b/doc/tools/Translator.tex index d8ac640f2a..dde8a7b838 100644 --- a/doc/tools/Translator.tex +++ b/doc/tools/Translator.tex @@ -412,7 +412,7 @@ but its behaviour is not to fold the abbreviation at all.}. {\tt LetTac} could be followed by a specification (called a clause) of the places where the abbreviation had to be folded (hypothese and/or conclusion). Clauses are the syntactic notion to denote in which parts -of a goal a given transformation shold occur. Its basic notation is +of a goal a given transformation should occur. Its basic notation is either \TERM{*} (meaning everywhere), or {\tt\textrm{\em hyps} |- \textrm{\em concl}} where {\em hyps} is either \TERM{*} (to denote all the hypotheses), or a comma-separated list of either hypothesis name, @@ -620,7 +620,7 @@ These constraints are met by the makefiles produced by {\tt coq\_makefile} Otherwise, modify your build program so as to pass option {\tt -translate} to program {\tt coqc}. The effect of this option is to -ouptut the translated source of any {\tt .v} file in a file with +output the translated source of any {\tt .v} file in a file with extension {\tt .v8} located in the same directory than the original file. @@ -675,7 +675,7 @@ solve all occurrences of the problem. The definition of identifiers changed. Most of those changes are handled by the translator. They include: \begin{itemize} -\item {\tt \_} is not an identifier anymore: it is tranlated to {\tt +\item {\tt \_} is not an identifier anymore: it is translated to {\tt x\_} \item avoid clash with new keywords by adding a trailing {\tt \_} \end{itemize} diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index 1de9890992..ba58ff0084 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -52,7 +52,7 @@ def is_whitespace_string(elem): return isinstance(elem, NavigableString) and elem.strip() == "" def strip_soup(soup, pred): - """Strip elements maching pred from front and tail of soup.""" + """Strip elements matching pred from front and tail of soup.""" while soup.contents and pred(soup.contents[-1]): soup.contents.pop() diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 0ade9fdbf5..4bdfac7c42 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -39,14 +39,29 @@ from sphinx.ext import mathbase from . import coqdoc from .repl import ansicolors from .repl.coqtop import CoqTop, CoqTopError +from .notations.parsing import ParseError from .notations.sphinx import sphinxify from .notations.plain import stringify_with_ellipses -def parse_notation(notation, source, line, rawtext=None): +PARSE_ERROR = """Parse error in notation! +Offending notation: {} +Error message: {}""" + +def notation_to_sphinx(notation, source, line, rawtext=None): """Parse notation and wrap it in an inline node""" - node = nodes.inline(rawtext or notation, '', *sphinxify(notation), classes=['notation']) - node.source, node.line = source, line - return node + try: + node = nodes.inline(rawtext or notation, '', *sphinxify(notation), classes=['notation']) + node.source, node.line = source, line + return node + except ParseError as e: + raise ExtensionError(PARSE_ERROR.format(notation, e.msg)) from e + +def notation_to_string(notation): + """Parse notation and format it as a string with ellipses.""" + try: + return stringify_with_ellipses(notation) + except ParseError as e: + raise ExtensionError(PARSE_ERROR.format(notation, e.msg)) from e def highlight_using_coqdoc(sentence): """Lex sentence using coqdoc, and yield inline nodes for each token""" @@ -136,7 +151,7 @@ class CoqObject(ObjectDescription): self._render_signature(signature, signode) name = self._names.get(signature) if name is None: - name = self._name_from_signature(signature) + name = self._name_from_signature(signature) # pylint: disable=assignment-from-none # remove trailing ‘.’ found in commands, but not ‘...’ (ellipsis) if name is not None and name.endswith(".") and not name.endswith("..."): name = name[:-1] @@ -241,7 +256,7 @@ class NotationObject(DocumentableObject): """ def _render_signature(self, signature, signode): position = self.state_machine.get_source_and_line(self.lineno) - tacn_node = parse_notation(signature, *position) + tacn_node = notation_to_sphinx(signature, *position) signode += addnodes.desc_name(signature, '', tacn_node) class GallinaObject(PlainObject): @@ -346,7 +361,7 @@ class OptionObject(NotationObject): annotation = "Option" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class FlagObject(NotationObject): @@ -365,7 +380,7 @@ class FlagObject(NotationObject): annotation = "Flag" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class TableObject(NotationObject): @@ -383,7 +398,7 @@ class TableObject(NotationObject): annotation = "Table" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class ProductionObject(CoqObject): r"""A grammar production. @@ -403,7 +418,7 @@ class ProductionObject(CoqObject): Example:: .. prodn:: term += let: @pattern := @term in @term - .. prodn:: occ_switch ::= { {? + %| - } {* @num } } + .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } """ subdomain = "prodn" @@ -432,7 +447,7 @@ class ProductionObject(CoqObject): lhs_node = nodes.literal(lhs_op, lhs_op) position = self.state_machine.get_source_and_line(self.lineno) - rhs_node = parse_notation(rhs, *position) + rhs_node = notation_to_sphinx(rhs, *position) signode += addnodes.desc_name(signature, '', lhs_node, rhs_node) return ('token', lhs) if op == '::=' else None @@ -475,7 +490,7 @@ class ExceptionObject(NotationObject): # Generate names automatically def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) class WarningObject(NotationObject): """An warning raised by a Coq command or tactic.. @@ -497,7 +512,7 @@ class WarningObject(NotationObject): # Generate names automatically def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + return notation_to_string(signature) def NotationRole(role, rawtext, text, lineno, inliner, options={}, content=[]): #pylint: disable=unused-argument, dangerous-default-value @@ -516,7 +531,7 @@ def NotationRole(role, rawtext, text, lineno, inliner, options={}, content=[]): """ notation = utils.unescape(text, 1) position = inliner.reporter.get_source_and_line(lineno) - return [nodes.literal(rawtext, '', parse_notation(notation, *position, rawtext=rawtext))], [] + return [nodes.literal(rawtext, '', notation_to_sphinx(notation, *position, rawtext=rawtext))], [] def coq_code_role(role, rawtext, text, lineno, inliner, options={}, content=[]): #pylint: disable=dangerous-default-value diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index a889ebda7b..01c656eb23 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -13,21 +13,38 @@ grammar TacticNotations; // needs rendering (in particular whitespace (kept in output) vs. WHITESPACE // (discarded)). +// The distinction between nopipeblock and block is needed because we only want +// to require escaping within alternative blocks, so that e.g. `first [ x | y ]` +// can be written without escaping the `|`. + top: blocks EOF; blocks: block ((whitespace)? block)*; -block: atomic | meta | hole | repeat | curlies; -repeat: LGROUP (ATOM)? WHITESPACE blocks (WHITESPACE)? RBRACE; + +block: pipe | nopipeblock; +nopipeblock: atomic | escaped | hole | alternative | repeat | curlies; + +alternative: LALT (WHITESPACE)? altblocks (WHITESPACE)? RBRACE; +altblocks: altblock ((WHITESPACE)? altsep (WHITESPACE)? altblock)+; +altblock: nopipeblock ((whitespace)? nopipeblock)*; + +repeat: LGROUP (ATOM | PIPE)? WHITESPACE blocks (WHITESPACE)? RBRACE; curlies: LBRACE (whitespace)? blocks (whitespace)? RBRACE; + +pipe: PIPE; +altsep: PIPE; whitespace: WHITESPACE; -meta: METACHAR; +escaped: ESCAPED; atomic: ATOM (SUB)?; hole: ID (SUB)?; -LGROUP: '{' [+*?]; + +LALT: '{|'; +LGROUP: '{+' | '{*' | '{?'; LBRACE: '{'; RBRACE: '}'; -METACHAR: '%' [|(){}]; -ATOM: '@' | '_' | ~[@_{} ]+; +ESCAPED: '%{' | '%}' | '%|'; +PIPE: '|'; +ATOM: '@' | '_' | ~[@_{}| ]+; ID: '@' ('_'? [a-zA-Z0-9])+; SUB: '_' '_' [a-zA-Z0-9]+; WHITESPACE: ' '+; diff --git a/doc/tools/coqrst/notations/TacticNotations.tokens b/doc/tools/coqrst/notations/TacticNotations.tokens index 88b38f97a6..2670e20aa6 100644 --- a/doc/tools/coqrst/notations/TacticNotations.tokens +++ b/doc/tools/coqrst/notations/TacticNotations.tokens @@ -1,10 +1,14 @@ -LGROUP=1 -LBRACE=2 -RBRACE=3 -METACHAR=4 -ATOM=5 -ID=6 -SUB=7 -WHITESPACE=8 -'{'=2 -'}'=3 +LALT=1 +LGROUP=2 +LBRACE=3 +RBRACE=4 +ESCAPED=5 +PIPE=6 +ATOM=7 +ID=8 +SUB=9 +WHITESPACE=10 +'{|'=1 +'{'=3 +'}'=4 +'|'=6 diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index 27293e7e09..e3a115e32a 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -1,4 +1,4 @@ -# Generated from TacticNotations.g by ANTLR 4.7 +# Generated from TacticNotations.g by ANTLR 4.7.2 from antlr4 import * from io import StringIO from typing.io import TextIO @@ -7,28 +7,34 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\n") - buf.write(":\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") - buf.write("\4\b\t\b\4\t\t\t\3\2\3\2\3\2\3\3\3\3\3\4\3\4\3\5\3\5\3") - buf.write("\5\3\6\3\6\6\6 \n\6\r\6\16\6!\5\6$\n\6\3\7\3\7\5\7(\n") - buf.write("\7\3\7\6\7+\n\7\r\7\16\7,\3\b\3\b\3\b\6\b\62\n\b\r\b\16") - buf.write("\b\63\3\t\6\t\67\n\t\r\t\16\t8\2\2\n\3\3\5\4\7\5\t\6\13") - buf.write("\7\r\b\17\t\21\n\3\2\7\4\2,-AA\4\2*+}\177\4\2BBaa\7\2") - buf.write("\"\"BBaa}}\177\177\5\2\62;C\\c|\2?\2\3\3\2\2\2\2\5\3\2") - buf.write("\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2") - buf.write("\2\17\3\2\2\2\2\21\3\2\2\2\3\23\3\2\2\2\5\26\3\2\2\2\7") - buf.write("\30\3\2\2\2\t\32\3\2\2\2\13#\3\2\2\2\r%\3\2\2\2\17.\3") - buf.write("\2\2\2\21\66\3\2\2\2\23\24\7}\2\2\24\25\t\2\2\2\25\4\3") - buf.write("\2\2\2\26\27\7}\2\2\27\6\3\2\2\2\30\31\7\177\2\2\31\b") - buf.write("\3\2\2\2\32\33\7\'\2\2\33\34\t\3\2\2\34\n\3\2\2\2\35$") - buf.write("\t\4\2\2\36 \n\5\2\2\37\36\3\2\2\2 !\3\2\2\2!\37\3\2\2") - buf.write("\2!\"\3\2\2\2\"$\3\2\2\2#\35\3\2\2\2#\37\3\2\2\2$\f\3") - buf.write("\2\2\2%*\7B\2\2&(\7a\2\2\'&\3\2\2\2\'(\3\2\2\2()\3\2\2") - buf.write("\2)+\t\6\2\2*\'\3\2\2\2+,\3\2\2\2,*\3\2\2\2,-\3\2\2\2") - buf.write("-\16\3\2\2\2./\7a\2\2/\61\7a\2\2\60\62\t\6\2\2\61\60\3") - buf.write("\2\2\2\62\63\3\2\2\2\63\61\3\2\2\2\63\64\3\2\2\2\64\20") - buf.write("\3\2\2\2\65\67\7\"\2\2\66\65\3\2\2\2\678\3\2\2\28\66\3") - buf.write("\2\2\289\3\2\2\29\22\3\2\2\2\t\2!#\',\638\2") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\f") + buf.write("M\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\3\2\3\2\3\2\3\3\3\3") + buf.write("\3\3\3\3\3\3\3\3\5\3!\n\3\3\4\3\4\3\5\3\5\3\6\3\6\3\6") + buf.write("\3\6\3\6\3\6\5\6-\n\6\3\7\3\7\3\b\3\b\6\b\63\n\b\r\b\16") + buf.write("\b\64\5\b\67\n\b\3\t\3\t\5\t;\n\t\3\t\6\t>\n\t\r\t\16") + buf.write("\t?\3\n\3\n\3\n\6\nE\n\n\r\n\16\nF\3\13\6\13J\n\13\r\13") + buf.write("\16\13K\2\2\f\3\3\5\4\7\5\t\6\13\7\r\b\17\t\21\n\23\13") + buf.write("\25\f\3\2\5\4\2BBaa\6\2\"\"BBaa}\177\5\2\62;C\\c|\2V\2") + buf.write("\3\3\2\2\2\2\5\3\2\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3") + buf.write("\2\2\2\2\r\3\2\2\2\2\17\3\2\2\2\2\21\3\2\2\2\2\23\3\2") + buf.write("\2\2\2\25\3\2\2\2\3\27\3\2\2\2\5 \3\2\2\2\7\"\3\2\2\2") + buf.write("\t$\3\2\2\2\13,\3\2\2\2\r.\3\2\2\2\17\66\3\2\2\2\218\3") + buf.write("\2\2\2\23A\3\2\2\2\25I\3\2\2\2\27\30\7}\2\2\30\31\7~\2") + buf.write("\2\31\4\3\2\2\2\32\33\7}\2\2\33!\7-\2\2\34\35\7}\2\2\35") + buf.write("!\7,\2\2\36\37\7}\2\2\37!\7A\2\2 \32\3\2\2\2 \34\3\2\2") + buf.write("\2 \36\3\2\2\2!\6\3\2\2\2\"#\7}\2\2#\b\3\2\2\2$%\7\177") + buf.write("\2\2%\n\3\2\2\2&\'\7\'\2\2\'-\7}\2\2()\7\'\2\2)-\7\177") + buf.write("\2\2*+\7\'\2\2+-\7~\2\2,&\3\2\2\2,(\3\2\2\2,*\3\2\2\2") + buf.write("-\f\3\2\2\2./\7~\2\2/\16\3\2\2\2\60\67\t\2\2\2\61\63\n") + buf.write("\3\2\2\62\61\3\2\2\2\63\64\3\2\2\2\64\62\3\2\2\2\64\65") + buf.write("\3\2\2\2\65\67\3\2\2\2\66\60\3\2\2\2\66\62\3\2\2\2\67") + buf.write("\20\3\2\2\28=\7B\2\29;\7a\2\2:9\3\2\2\2:;\3\2\2\2;<\3") + buf.write("\2\2\2<>\t\4\2\2=:\3\2\2\2>?\3\2\2\2?=\3\2\2\2?@\3\2\2") + buf.write("\2@\22\3\2\2\2AB\7a\2\2BD\7a\2\2CE\t\4\2\2DC\3\2\2\2E") + buf.write("F\3\2\2\2FD\3\2\2\2FG\3\2\2\2G\24\3\2\2\2HJ\7\"\2\2IH") + buf.write("\3\2\2\2JK\3\2\2\2KI\3\2\2\2KL\3\2\2\2L\26\3\2\2\2\13") + buf.write("\2 ,\64\66:?FK\2") return buf.getvalue() @@ -38,34 +44,36 @@ class TacticNotationsLexer(Lexer): decisionsToDFA = [ DFA(ds, i) for i, ds in enumerate(atn.decisionToState) ] - LGROUP = 1 - LBRACE = 2 - RBRACE = 3 - METACHAR = 4 - ATOM = 5 - ID = 6 - SUB = 7 - WHITESPACE = 8 + LALT = 1 + LGROUP = 2 + LBRACE = 3 + RBRACE = 4 + ESCAPED = 5 + PIPE = 6 + ATOM = 7 + ID = 8 + SUB = 9 + WHITESPACE = 10 channelNames = [ u"DEFAULT_TOKEN_CHANNEL", u"HIDDEN" ] modeNames = [ "DEFAULT_MODE" ] literalNames = [ "<INVALID>", - "'{'", "'}'" ] + "'{|'", "'{'", "'}'", "'|'" ] symbolicNames = [ "<INVALID>", - "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", "SUB", - "WHITESPACE" ] + "LALT", "LGROUP", "LBRACE", "RBRACE", "ESCAPED", "PIPE", "ATOM", + "ID", "SUB", "WHITESPACE" ] - ruleNames = [ "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", - "SUB", "WHITESPACE" ] + ruleNames = [ "LALT", "LGROUP", "LBRACE", "RBRACE", "ESCAPED", "PIPE", + "ATOM", "ID", "SUB", "WHITESPACE" ] grammarFileName = "TacticNotations.g" def __init__(self, input=None, output:TextIO = sys.stdout): super().__init__(input, output) - self.checkVersion("4.7") + self.checkVersion("4.7.2") self._interp = LexerATNSimulator(self, self.atn, self.decisionsToDFA, PredictionContextCache()) self._actions = None self._predicates = None diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens index 88b38f97a6..2670e20aa6 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens @@ -1,10 +1,14 @@ -LGROUP=1 -LBRACE=2 -RBRACE=3 -METACHAR=4 -ATOM=5 -ID=6 -SUB=7 -WHITESPACE=8 -'{'=2 -'}'=3 +LALT=1 +LGROUP=2 +LBRACE=3 +RBRACE=4 +ESCAPED=5 +PIPE=6 +ATOM=7 +ID=8 +SUB=9 +WHITESPACE=10 +'{|'=1 +'{'=3 +'}'=4 +'|'=6 diff --git a/doc/tools/coqrst/notations/TacticNotationsParser.py b/doc/tools/coqrst/notations/TacticNotationsParser.py index 645f078979..4a2a73672a 100644 --- a/doc/tools/coqrst/notations/TacticNotationsParser.py +++ b/doc/tools/coqrst/notations/TacticNotationsParser.py @@ -1,4 +1,4 @@ -# Generated from TacticNotations.g by ANTLR 4.7 +# Generated from TacticNotations.g by ANTLR 4.7.2 # encoding: utf-8 from antlr4 import * from io import StringIO @@ -7,31 +7,47 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\n") - buf.write("J\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7\4\b") - buf.write("\t\b\4\t\t\t\4\n\t\n\3\2\3\2\3\2\3\3\3\3\5\3\32\n\3\3") - buf.write("\3\7\3\35\n\3\f\3\16\3 \13\3\3\4\3\4\3\4\3\4\3\4\5\4\'") - buf.write("\n\4\3\5\3\5\5\5+\n\5\3\5\3\5\3\5\5\5\60\n\5\3\5\3\5\3") - buf.write("\6\3\6\5\6\66\n\6\3\6\3\6\5\6:\n\6\3\6\3\6\3\7\3\7\3\b") - buf.write("\3\b\3\t\3\t\5\tD\n\t\3\n\3\n\5\nH\n\n\3\n\2\2\13\2\4") - buf.write("\6\b\n\f\16\20\22\2\2\2L\2\24\3\2\2\2\4\27\3\2\2\2\6&") - buf.write("\3\2\2\2\b(\3\2\2\2\n\63\3\2\2\2\f=\3\2\2\2\16?\3\2\2") - buf.write("\2\20A\3\2\2\2\22E\3\2\2\2\24\25\5\4\3\2\25\26\7\2\2\3") - buf.write("\26\3\3\2\2\2\27\36\5\6\4\2\30\32\5\f\7\2\31\30\3\2\2") - buf.write("\2\31\32\3\2\2\2\32\33\3\2\2\2\33\35\5\6\4\2\34\31\3\2") - buf.write("\2\2\35 \3\2\2\2\36\34\3\2\2\2\36\37\3\2\2\2\37\5\3\2") - buf.write("\2\2 \36\3\2\2\2!\'\5\20\t\2\"\'\5\16\b\2#\'\5\22\n\2") - buf.write("$\'\5\b\5\2%\'\5\n\6\2&!\3\2\2\2&\"\3\2\2\2&#\3\2\2\2") - buf.write("&$\3\2\2\2&%\3\2\2\2\'\7\3\2\2\2(*\7\3\2\2)+\7\7\2\2*") - buf.write(")\3\2\2\2*+\3\2\2\2+,\3\2\2\2,-\7\n\2\2-/\5\4\3\2.\60") - buf.write("\7\n\2\2/.\3\2\2\2/\60\3\2\2\2\60\61\3\2\2\2\61\62\7\5") - buf.write("\2\2\62\t\3\2\2\2\63\65\7\4\2\2\64\66\5\f\7\2\65\64\3") - buf.write("\2\2\2\65\66\3\2\2\2\66\67\3\2\2\2\679\5\4\3\28:\5\f\7") - buf.write("\298\3\2\2\29:\3\2\2\2:;\3\2\2\2;<\7\5\2\2<\13\3\2\2\2") - buf.write("=>\7\n\2\2>\r\3\2\2\2?@\7\6\2\2@\17\3\2\2\2AC\7\7\2\2") - buf.write("BD\7\t\2\2CB\3\2\2\2CD\3\2\2\2D\21\3\2\2\2EG\7\b\2\2F") - buf.write("H\7\t\2\2GF\3\2\2\2GH\3\2\2\2H\23\3\2\2\2\13\31\36&*/") - buf.write("\659CG") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\f") + buf.write("\u0081\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\4\f\t\f\4\r\t\r\4\16") + buf.write("\t\16\4\17\t\17\4\20\t\20\3\2\3\2\3\2\3\3\3\3\5\3&\n\3") + buf.write("\3\3\7\3)\n\3\f\3\16\3,\13\3\3\4\3\4\5\4\60\n\4\3\5\3") + buf.write("\5\3\5\3\5\3\5\3\5\5\58\n\5\3\6\3\6\5\6<\n\6\3\6\3\6\5") + buf.write("\6@\n\6\3\6\3\6\3\7\3\7\5\7F\n\7\3\7\3\7\5\7J\n\7\3\7") + buf.write("\3\7\6\7N\n\7\r\7\16\7O\3\b\3\b\5\bT\n\b\3\b\7\bW\n\b") + buf.write("\f\b\16\bZ\13\b\3\t\3\t\5\t^\n\t\3\t\3\t\3\t\5\tc\n\t") + buf.write("\3\t\3\t\3\n\3\n\5\ni\n\n\3\n\3\n\5\nm\n\n\3\n\3\n\3\13") + buf.write("\3\13\3\f\3\f\3\r\3\r\3\16\3\16\3\17\3\17\5\17{\n\17\3") + buf.write("\20\3\20\5\20\177\n\20\3\20\2\2\21\2\4\6\b\n\f\16\20\22") + buf.write("\24\26\30\32\34\36\2\3\3\2\b\t\2\u0086\2 \3\2\2\2\4#\3") + buf.write("\2\2\2\6/\3\2\2\2\b\67\3\2\2\2\n9\3\2\2\2\fC\3\2\2\2\16") + buf.write("Q\3\2\2\2\20[\3\2\2\2\22f\3\2\2\2\24p\3\2\2\2\26r\3\2") + buf.write("\2\2\30t\3\2\2\2\32v\3\2\2\2\34x\3\2\2\2\36|\3\2\2\2 ") + buf.write("!\5\4\3\2!\"\7\2\2\3\"\3\3\2\2\2#*\5\6\4\2$&\5\30\r\2") + buf.write("%$\3\2\2\2%&\3\2\2\2&\'\3\2\2\2\')\5\6\4\2(%\3\2\2\2)") + buf.write(",\3\2\2\2*(\3\2\2\2*+\3\2\2\2+\5\3\2\2\2,*\3\2\2\2-\60") + buf.write("\5\24\13\2.\60\5\b\5\2/-\3\2\2\2/.\3\2\2\2\60\7\3\2\2") + buf.write("\2\618\5\34\17\2\628\5\32\16\2\638\5\36\20\2\648\5\n\6") + buf.write("\2\658\5\20\t\2\668\5\22\n\2\67\61\3\2\2\2\67\62\3\2\2") + buf.write("\2\67\63\3\2\2\2\67\64\3\2\2\2\67\65\3\2\2\2\67\66\3\2") + buf.write("\2\28\t\3\2\2\29;\7\3\2\2:<\7\f\2\2;:\3\2\2\2;<\3\2\2") + buf.write("\2<=\3\2\2\2=?\5\f\7\2>@\7\f\2\2?>\3\2\2\2?@\3\2\2\2@") + buf.write("A\3\2\2\2AB\7\6\2\2B\13\3\2\2\2CM\5\16\b\2DF\7\f\2\2E") + buf.write("D\3\2\2\2EF\3\2\2\2FG\3\2\2\2GI\5\26\f\2HJ\7\f\2\2IH\3") + buf.write("\2\2\2IJ\3\2\2\2JK\3\2\2\2KL\5\16\b\2LN\3\2\2\2ME\3\2") + buf.write("\2\2NO\3\2\2\2OM\3\2\2\2OP\3\2\2\2P\r\3\2\2\2QX\5\b\5") + buf.write("\2RT\5\30\r\2SR\3\2\2\2ST\3\2\2\2TU\3\2\2\2UW\5\b\5\2") + buf.write("VS\3\2\2\2WZ\3\2\2\2XV\3\2\2\2XY\3\2\2\2Y\17\3\2\2\2Z") + buf.write("X\3\2\2\2[]\7\4\2\2\\^\t\2\2\2]\\\3\2\2\2]^\3\2\2\2^_") + buf.write("\3\2\2\2_`\7\f\2\2`b\5\4\3\2ac\7\f\2\2ba\3\2\2\2bc\3\2") + buf.write("\2\2cd\3\2\2\2de\7\6\2\2e\21\3\2\2\2fh\7\5\2\2gi\5\30") + buf.write("\r\2hg\3\2\2\2hi\3\2\2\2ij\3\2\2\2jl\5\4\3\2km\5\30\r") + buf.write("\2lk\3\2\2\2lm\3\2\2\2mn\3\2\2\2no\7\6\2\2o\23\3\2\2\2") + buf.write("pq\7\b\2\2q\25\3\2\2\2rs\7\b\2\2s\27\3\2\2\2tu\7\f\2\2") + buf.write("u\31\3\2\2\2vw\7\7\2\2w\33\3\2\2\2xz\7\t\2\2y{\7\13\2") + buf.write("\2zy\3\2\2\2z{\3\2\2\2{\35\3\2\2\2|~\7\n\2\2}\177\7\13") + buf.write("\2\2~}\3\2\2\2~\177\3\2\2\2\177\37\3\2\2\2\23%*/\67;?") + buf.write("EIOSX]bhlz~") return buf.getvalue() @@ -45,37 +61,47 @@ class TacticNotationsParser ( Parser ): sharedContextCache = PredictionContextCache() - literalNames = [ "<INVALID>", "<INVALID>", "'{'", "'}'" ] + literalNames = [ "<INVALID>", "'{|'", "<INVALID>", "'{'", "'}'", "<INVALID>", + "'|'" ] - symbolicNames = [ "<INVALID>", "LGROUP", "LBRACE", "RBRACE", "METACHAR", - "ATOM", "ID", "SUB", "WHITESPACE" ] + symbolicNames = [ "<INVALID>", "LALT", "LGROUP", "LBRACE", "RBRACE", + "ESCAPED", "PIPE", "ATOM", "ID", "SUB", "WHITESPACE" ] RULE_top = 0 RULE_blocks = 1 RULE_block = 2 - RULE_repeat = 3 - RULE_curlies = 4 - RULE_whitespace = 5 - RULE_meta = 6 - RULE_atomic = 7 - RULE_hole = 8 - - ruleNames = [ "top", "blocks", "block", "repeat", "curlies", "whitespace", - "meta", "atomic", "hole" ] + RULE_nopipeblock = 3 + RULE_alternative = 4 + RULE_altblocks = 5 + RULE_altblock = 6 + RULE_repeat = 7 + RULE_curlies = 8 + RULE_pipe = 9 + RULE_altsep = 10 + RULE_whitespace = 11 + RULE_escaped = 12 + RULE_atomic = 13 + RULE_hole = 14 + + ruleNames = [ "top", "blocks", "block", "nopipeblock", "alternative", + "altblocks", "altblock", "repeat", "curlies", "pipe", + "altsep", "whitespace", "escaped", "atomic", "hole" ] EOF = Token.EOF - LGROUP=1 - LBRACE=2 - RBRACE=3 - METACHAR=4 - ATOM=5 - ID=6 - SUB=7 - WHITESPACE=8 + LALT=1 + LGROUP=2 + LBRACE=3 + RBRACE=4 + ESCAPED=5 + PIPE=6 + ATOM=7 + ID=8 + SUB=9 + WHITESPACE=10 def __init__(self, input:TokenStream, output:TextIO = sys.stdout): super().__init__(input, output) - self.checkVersion("4.7") + self.checkVersion("4.7.2") self._interp = ParserATNSimulator(self, self.atn, self.decisionsToDFA, self.sharedContextCache) self._predicates = None @@ -112,9 +138,9 @@ class TacticNotationsParser ( Parser ): self.enterRule(localctx, 0, self.RULE_top) try: self.enterOuterAlt(localctx, 1) - self.state = 18 + self.state = 30 self.blocks() - self.state = 19 + self.state = 31 self.match(TacticNotationsParser.EOF) except RecognitionException as re: localctx.exception = re @@ -163,24 +189,24 @@ class TacticNotationsParser ( Parser ): self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 21 + self.state = 33 self.block() - self.state = 28 + self.state = 40 self._errHandler.sync(self) _alt = self._interp.adaptivePredict(self._input,1,self._ctx) while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: if _alt==1: - self.state = 23 + self.state = 35 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 22 + self.state = 34 self.whitespace() - self.state = 25 + self.state = 37 self.block() - self.state = 30 + self.state = 42 self._errHandler.sync(self) _alt = self._interp.adaptivePredict(self._input,1,self._ctx) @@ -198,18 +224,77 @@ class TacticNotationsParser ( Parser ): super().__init__(parent, invokingState) self.parser = parser + def pipe(self): + return self.getTypedRuleContext(TacticNotationsParser.PipeContext,0) + + + def nopipeblock(self): + return self.getTypedRuleContext(TacticNotationsParser.NopipeblockContext,0) + + + def getRuleIndex(self): + return TacticNotationsParser.RULE_block + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitBlock" ): + return visitor.visitBlock(self) + else: + return visitor.visitChildren(self) + + + + + def block(self): + + localctx = TacticNotationsParser.BlockContext(self, self._ctx, self.state) + self.enterRule(localctx, 4, self.RULE_block) + try: + self.state = 45 + self._errHandler.sync(self) + token = self._input.LA(1) + if token in [TacticNotationsParser.PIPE]: + self.enterOuterAlt(localctx, 1) + self.state = 43 + self.pipe() + pass + elif token in [TacticNotationsParser.LALT, TacticNotationsParser.LGROUP, TacticNotationsParser.LBRACE, TacticNotationsParser.ESCAPED, TacticNotationsParser.ATOM, TacticNotationsParser.ID]: + self.enterOuterAlt(localctx, 2) + self.state = 44 + self.nopipeblock() + pass + else: + raise NoViableAltException(self) + + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class NopipeblockContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + def atomic(self): return self.getTypedRuleContext(TacticNotationsParser.AtomicContext,0) - def meta(self): - return self.getTypedRuleContext(TacticNotationsParser.MetaContext,0) + def escaped(self): + return self.getTypedRuleContext(TacticNotationsParser.EscapedContext,0) def hole(self): return self.getTypedRuleContext(TacticNotationsParser.HoleContext,0) + def alternative(self): + return self.getTypedRuleContext(TacticNotationsParser.AlternativeContext,0) + + def repeat(self): return self.getTypedRuleContext(TacticNotationsParser.RepeatContext,0) @@ -219,48 +304,53 @@ class TacticNotationsParser ( Parser ): def getRuleIndex(self): - return TacticNotationsParser.RULE_block + return TacticNotationsParser.RULE_nopipeblock def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitBlock" ): - return visitor.visitBlock(self) + if hasattr( visitor, "visitNopipeblock" ): + return visitor.visitNopipeblock(self) else: return visitor.visitChildren(self) - def block(self): + def nopipeblock(self): - localctx = TacticNotationsParser.BlockContext(self, self._ctx, self.state) - self.enterRule(localctx, 4, self.RULE_block) + localctx = TacticNotationsParser.NopipeblockContext(self, self._ctx, self.state) + self.enterRule(localctx, 6, self.RULE_nopipeblock) try: - self.state = 36 + self.state = 53 self._errHandler.sync(self) token = self._input.LA(1) if token in [TacticNotationsParser.ATOM]: self.enterOuterAlt(localctx, 1) - self.state = 31 + self.state = 47 self.atomic() pass - elif token in [TacticNotationsParser.METACHAR]: + elif token in [TacticNotationsParser.ESCAPED]: self.enterOuterAlt(localctx, 2) - self.state = 32 - self.meta() + self.state = 48 + self.escaped() pass elif token in [TacticNotationsParser.ID]: self.enterOuterAlt(localctx, 3) - self.state = 33 + self.state = 49 self.hole() pass - elif token in [TacticNotationsParser.LGROUP]: + elif token in [TacticNotationsParser.LALT]: self.enterOuterAlt(localctx, 4) - self.state = 34 + self.state = 50 + self.alternative() + pass + elif token in [TacticNotationsParser.LGROUP]: + self.enterOuterAlt(localctx, 5) + self.state = 51 self.repeat() pass elif token in [TacticNotationsParser.LBRACE]: - self.enterOuterAlt(localctx, 5) - self.state = 35 + self.enterOuterAlt(localctx, 6) + self.state = 52 self.curlies() pass else: @@ -274,6 +364,232 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx + class AlternativeContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def LALT(self): + return self.getToken(TacticNotationsParser.LALT, 0) + + def altblocks(self): + return self.getTypedRuleContext(TacticNotationsParser.AltblocksContext,0) + + + def RBRACE(self): + return self.getToken(TacticNotationsParser.RBRACE, 0) + + def WHITESPACE(self, i:int=None): + if i is None: + return self.getTokens(TacticNotationsParser.WHITESPACE) + else: + return self.getToken(TacticNotationsParser.WHITESPACE, i) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_alternative + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAlternative" ): + return visitor.visitAlternative(self) + else: + return visitor.visitChildren(self) + + + + + def alternative(self): + + localctx = TacticNotationsParser.AlternativeContext(self, self._ctx, self.state) + self.enterRule(localctx, 8, self.RULE_alternative) + self._la = 0 # Token type + try: + self.enterOuterAlt(localctx, 1) + self.state = 55 + self.match(TacticNotationsParser.LALT) + self.state = 57 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 56 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 59 + self.altblocks() + self.state = 61 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 60 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 63 + self.match(TacticNotationsParser.RBRACE) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class AltblocksContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def altblock(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.AltblockContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.AltblockContext,i) + + + def altsep(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.AltsepContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.AltsepContext,i) + + + def WHITESPACE(self, i:int=None): + if i is None: + return self.getTokens(TacticNotationsParser.WHITESPACE) + else: + return self.getToken(TacticNotationsParser.WHITESPACE, i) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_altblocks + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAltblocks" ): + return visitor.visitAltblocks(self) + else: + return visitor.visitChildren(self) + + + + + def altblocks(self): + + localctx = TacticNotationsParser.AltblocksContext(self, self._ctx, self.state) + self.enterRule(localctx, 10, self.RULE_altblocks) + self._la = 0 # Token type + try: + self.enterOuterAlt(localctx, 1) + self.state = 65 + self.altblock() + self.state = 75 + self._errHandler.sync(self) + _alt = 1 + while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: + if _alt == 1: + self.state = 67 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 66 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 69 + self.altsep() + self.state = 71 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 70 + self.match(TacticNotationsParser.WHITESPACE) + + + self.state = 73 + self.altblock() + + else: + raise NoViableAltException(self) + self.state = 77 + self._errHandler.sync(self) + _alt = self._interp.adaptivePredict(self._input,8,self._ctx) + + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class AltblockContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def nopipeblock(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.NopipeblockContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.NopipeblockContext,i) + + + def whitespace(self, i:int=None): + if i is None: + return self.getTypedRuleContexts(TacticNotationsParser.WhitespaceContext) + else: + return self.getTypedRuleContext(TacticNotationsParser.WhitespaceContext,i) + + + def getRuleIndex(self): + return TacticNotationsParser.RULE_altblock + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAltblock" ): + return visitor.visitAltblock(self) + else: + return visitor.visitChildren(self) + + + + + def altblock(self): + + localctx = TacticNotationsParser.AltblockContext(self, self._ctx, self.state) + self.enterRule(localctx, 12, self.RULE_altblock) + self._la = 0 # Token type + try: + self.enterOuterAlt(localctx, 1) + self.state = 79 + self.nopipeblock() + self.state = 86 + self._errHandler.sync(self) + _alt = self._interp.adaptivePredict(self._input,10,self._ctx) + while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: + if _alt==1: + self.state = 81 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.WHITESPACE: + self.state = 80 + self.whitespace() + + + self.state = 83 + self.nopipeblock() + self.state = 88 + self._errHandler.sync(self) + _alt = self._interp.adaptivePredict(self._input,10,self._ctx) + + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + class RepeatContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): @@ -299,6 +615,9 @@ class TacticNotationsParser ( Parser ): def ATOM(self): return self.getToken(TacticNotationsParser.ATOM, 0) + def PIPE(self): + return self.getToken(TacticNotationsParser.PIPE, 0) + def getRuleIndex(self): return TacticNotationsParser.RULE_repeat @@ -314,33 +633,38 @@ class TacticNotationsParser ( Parser ): def repeat(self): localctx = TacticNotationsParser.RepeatContext(self, self._ctx, self.state) - self.enterRule(localctx, 6, self.RULE_repeat) + self.enterRule(localctx, 14, self.RULE_repeat) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 38 + self.state = 89 self.match(TacticNotationsParser.LGROUP) - self.state = 40 + self.state = 91 self._errHandler.sync(self) _la = self._input.LA(1) - if _la==TacticNotationsParser.ATOM: - self.state = 39 - self.match(TacticNotationsParser.ATOM) + if _la==TacticNotationsParser.PIPE or _la==TacticNotationsParser.ATOM: + self.state = 90 + _la = self._input.LA(1) + if not(_la==TacticNotationsParser.PIPE or _la==TacticNotationsParser.ATOM): + self._errHandler.recoverInline(self) + else: + self._errHandler.reportMatch(self) + self.consume() - self.state = 42 + self.state = 93 self.match(TacticNotationsParser.WHITESPACE) - self.state = 43 + self.state = 94 self.blocks() - self.state = 45 + self.state = 96 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 44 + self.state = 95 self.match(TacticNotationsParser.WHITESPACE) - self.state = 47 + self.state = 98 self.match(TacticNotationsParser.RBRACE) except RecognitionException as re: localctx.exception = re @@ -388,31 +712,31 @@ class TacticNotationsParser ( Parser ): def curlies(self): localctx = TacticNotationsParser.CurliesContext(self, self._ctx, self.state) - self.enterRule(localctx, 8, self.RULE_curlies) + self.enterRule(localctx, 16, self.RULE_curlies) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 49 + self.state = 100 self.match(TacticNotationsParser.LBRACE) - self.state = 51 + self.state = 102 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 50 + self.state = 101 self.whitespace() - self.state = 53 + self.state = 104 self.blocks() - self.state = 55 + self.state = 106 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 54 + self.state = 105 self.whitespace() - self.state = 57 + self.state = 108 self.match(TacticNotationsParser.RBRACE) except RecognitionException as re: localctx.exception = re @@ -422,6 +746,80 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx + class PipeContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def PIPE(self): + return self.getToken(TacticNotationsParser.PIPE, 0) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_pipe + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitPipe" ): + return visitor.visitPipe(self) + else: + return visitor.visitChildren(self) + + + + + def pipe(self): + + localctx = TacticNotationsParser.PipeContext(self, self._ctx, self.state) + self.enterRule(localctx, 18, self.RULE_pipe) + try: + self.enterOuterAlt(localctx, 1) + self.state = 110 + self.match(TacticNotationsParser.PIPE) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + + class AltsepContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def PIPE(self): + return self.getToken(TacticNotationsParser.PIPE, 0) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_altsep + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitAltsep" ): + return visitor.visitAltsep(self) + else: + return visitor.visitChildren(self) + + + + + def altsep(self): + + localctx = TacticNotationsParser.AltsepContext(self, self._ctx, self.state) + self.enterRule(localctx, 20, self.RULE_altsep) + try: + self.enterOuterAlt(localctx, 1) + self.state = 112 + self.match(TacticNotationsParser.PIPE) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + class WhitespaceContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): @@ -446,10 +844,10 @@ class TacticNotationsParser ( Parser ): def whitespace(self): localctx = TacticNotationsParser.WhitespaceContext(self, self._ctx, self.state) - self.enterRule(localctx, 10, self.RULE_whitespace) + self.enterRule(localctx, 22, self.RULE_whitespace) try: self.enterOuterAlt(localctx, 1) - self.state = 59 + self.state = 114 self.match(TacticNotationsParser.WHITESPACE) except RecognitionException as re: localctx.exception = re @@ -459,35 +857,35 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx - class MetaContext(ParserRuleContext): + class EscapedContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): super().__init__(parent, invokingState) self.parser = parser - def METACHAR(self): - return self.getToken(TacticNotationsParser.METACHAR, 0) + def ESCAPED(self): + return self.getToken(TacticNotationsParser.ESCAPED, 0) def getRuleIndex(self): - return TacticNotationsParser.RULE_meta + return TacticNotationsParser.RULE_escaped def accept(self, visitor:ParseTreeVisitor): - if hasattr( visitor, "visitMeta" ): - return visitor.visitMeta(self) + if hasattr( visitor, "visitEscaped" ): + return visitor.visitEscaped(self) else: return visitor.visitChildren(self) - def meta(self): + def escaped(self): - localctx = TacticNotationsParser.MetaContext(self, self._ctx, self.state) - self.enterRule(localctx, 12, self.RULE_meta) + localctx = TacticNotationsParser.EscapedContext(self, self._ctx, self.state) + self.enterRule(localctx, 24, self.RULE_escaped) try: self.enterOuterAlt(localctx, 1) - self.state = 61 - self.match(TacticNotationsParser.METACHAR) + self.state = 116 + self.match(TacticNotationsParser.ESCAPED) except RecognitionException as re: localctx.exception = re self._errHandler.reportError(self, re) @@ -523,17 +921,17 @@ class TacticNotationsParser ( Parser ): def atomic(self): localctx = TacticNotationsParser.AtomicContext(self, self._ctx, self.state) - self.enterRule(localctx, 14, self.RULE_atomic) + self.enterRule(localctx, 26, self.RULE_atomic) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 63 + self.state = 118 self.match(TacticNotationsParser.ATOM) - self.state = 65 + self.state = 120 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.SUB: - self.state = 64 + self.state = 119 self.match(TacticNotationsParser.SUB) @@ -572,17 +970,17 @@ class TacticNotationsParser ( Parser ): def hole(self): localctx = TacticNotationsParser.HoleContext(self, self._ctx, self.state) - self.enterRule(localctx, 16, self.RULE_hole) + self.enterRule(localctx, 28, self.RULE_hole) self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 67 + self.state = 122 self.match(TacticNotationsParser.ID) - self.state = 69 + self.state = 124 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.SUB: - self.state = 68 + self.state = 123 self.match(TacticNotationsParser.SUB) diff --git a/doc/tools/coqrst/notations/TacticNotationsVisitor.py b/doc/tools/coqrst/notations/TacticNotationsVisitor.py index c0bcc4af37..aba696c89f 100644 --- a/doc/tools/coqrst/notations/TacticNotationsVisitor.py +++ b/doc/tools/coqrst/notations/TacticNotationsVisitor.py @@ -1,4 +1,4 @@ -# Generated from TacticNotations.g by ANTLR 4.7 +# Generated from TacticNotations.g by ANTLR 4.7.2 from antlr4 import * if __name__ is not None and "." in __name__: from .TacticNotationsParser import TacticNotationsParser @@ -24,6 +24,26 @@ class TacticNotationsVisitor(ParseTreeVisitor): return self.visitChildren(ctx) + # Visit a parse tree produced by TacticNotationsParser#nopipeblock. + def visitNopipeblock(self, ctx:TacticNotationsParser.NopipeblockContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#alternative. + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#altblocks. + def visitAltblocks(self, ctx:TacticNotationsParser.AltblocksContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#altblock. + def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): + return self.visitChildren(ctx) + + # Visit a parse tree produced by TacticNotationsParser#repeat. def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): return self.visitChildren(ctx) @@ -34,13 +54,23 @@ class TacticNotationsVisitor(ParseTreeVisitor): return self.visitChildren(ctx) + # Visit a parse tree produced by TacticNotationsParser#pipe. + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + return self.visitChildren(ctx) + + + # Visit a parse tree produced by TacticNotationsParser#altsep. + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + return self.visitChildren(ctx) + + # Visit a parse tree produced by TacticNotationsParser#whitespace. def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return self.visitChildren(ctx) - # Visit a parse tree produced by TacticNotationsParser#meta. - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + # Visit a parse tree produced by TacticNotationsParser#escaped. + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): return self.visitChildren(ctx) diff --git a/doc/tools/coqrst/notations/html.py b/doc/tools/coqrst/notations/html.py index 87a41cf9f3..d2b5d86b37 100644 --- a/doc/tools/coqrst/notations/html.py +++ b/doc/tools/coqrst/notations/html.py @@ -13,12 +13,24 @@ Uses the dominate package. """ from dominate import tags +from dominate.utils import text from .parsing import parse from .TacticNotationsParser import TacticNotationsParser from .TacticNotationsVisitor import TacticNotationsVisitor class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + with tags.span(_class='alternative'): + self.visitChildren(ctx) + + def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): + with tags.span(_class='alternative-block'): + self.visitChildren(ctx) + + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + tags.span('\u200b', _class="alternative-separator") + def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): with tags.span(_class="repeat-wrapper"): with tags.span(_class="repeat"): @@ -39,21 +51,20 @@ class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): tags.span(ctx.ATOM().getText()) + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + text("|") + def visitHole(self, ctx:TacticNotationsParser.HoleContext): tags.span(ctx.ID().getText()[1:], _class="hole") sub = ctx.SUB() if sub: tags.sub(sub.getText()[1:]) - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - txt = ctx.METACHAR().getText()[1:] - if (txt == "{") or (txt == "}"): - tags.span(txt) - else: - tags.span(txt, _class="meta") + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): + tags.span(ctx.ESCAPED().getText()[1:]) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): - tags.span(" ") # TODO: no need for a <span> here + text(" ") def htmlize(notation): """Translate notation to a dominate HTML tree""" diff --git a/doc/tools/coqrst/notations/parsing.py b/doc/tools/coqrst/notations/parsing.py index 506240d907..2312e09090 100644 --- a/doc/tools/coqrst/notations/parsing.py +++ b/doc/tools/coqrst/notations/parsing.py @@ -11,10 +11,22 @@ from .TacticNotationsLexer import TacticNotationsLexer from .TacticNotationsParser import TacticNotationsParser from antlr4 import CommonTokenStream, InputStream +from antlr4.error.ErrorListener import ErrorListener SUBSTITUTIONS = [#("@bindings_list", "{+ (@id := @val) }"), ("@qualid_or_string", "@id|@string")] +class ParseError(Exception): + def __init__(self, msg): + super().__init__() + self.msg = msg + +class ExceptionRaisingErrorListener(ErrorListener): + def syntaxError(self, recognizer, offendingSymbol, line, column, msg, e): + raise ParseError("{}:{}: {}".format(line, column, msg)) + +ERROR_LISTENER = ExceptionRaisingErrorListener() + def substitute(notation): """Perform common substitutions in the notation string. @@ -27,11 +39,13 @@ def substitute(notation): return notation def parse(notation): - """Parse a notation string. + """Parse a notation string, optionally reporting errors to `error_listener`. :return: An ANTLR AST. Use one of the supplied visitors (or write your own) to turn it into useful output. """ substituted = substitute(notation) lexer = TacticNotationsLexer(InputStream(substituted)) - return TacticNotationsParser(CommonTokenStream(lexer)).top() + parser = TacticNotationsParser(CommonTokenStream(lexer)) + parser.addErrorListener(ERROR_LISTENER) + return parser.top() diff --git a/doc/tools/coqrst/notations/plain.py b/doc/tools/coqrst/notations/plain.py index f6e82fc68e..2180c8e6a5 100644 --- a/doc/tools/coqrst/notations/plain.py +++ b/doc/tools/coqrst/notations/plain.py @@ -22,8 +22,16 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): def __init__(self): self.buffer = StringIO() + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + self.buffer.write("[") + self.visitChildren(ctx) + self.buffer.write("]") + + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + self.buffer.write("|") + def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): - separator = ctx.ATOM() + separator = ctx.ATOM() or ctx.PIPE() self.visitChildren(ctx) if ctx.LGROUP().getText()[1] == "+": spacer = (separator.getText() + " " if separator else "") @@ -38,11 +46,14 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): self.buffer.write(ctx.ATOM().getText()) + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + self.buffer.write("|") + def visitHole(self, ctx:TacticNotationsParser.HoleContext): self.buffer.write("‘{}’".format(ctx.ID().getText()[1:])) - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - self.buffer.write(ctx.METACHAR().getText()[1:]) + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): + self.buffer.write(ctx.ESCAPED().getText()[1:]) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): self.buffer.write(" ") diff --git a/doc/tools/coqrst/notations/sphinx.py b/doc/tools/coqrst/notations/sphinx.py index e05b834184..4ed09e04a9 100644 --- a/doc/tools/coqrst/notations/sphinx.py +++ b/doc/tools/coqrst/notations/sphinx.py @@ -20,8 +20,6 @@ from .TacticNotationsVisitor import TacticNotationsVisitor from docutils import nodes from sphinx import addnodes -import sys - class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def defaultResult(self): return [] @@ -31,16 +29,36 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): aggregate.extend(nextResult) return aggregate + def visitAlternative(self, ctx:TacticNotationsParser.AlternativeContext): + return [nodes.inline('', '', *self.visitChildren(ctx), classes=['alternative'])] + + def visitAltblock(self, ctx:TacticNotationsParser.AltblockContext): + return [nodes.inline('', '', *self.visitChildren(ctx), classes=['alternative-block'])] + + def visitAltsep(self, ctx:TacticNotationsParser.AltsepContext): + return [nodes.inline('|', '\u200b', classes=['alternative-separator'])] + + @staticmethod + def is_alternative(node): + return isinstance(node, nodes.inline) and node['classes'] == ['alternative'] + def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): # Uses inline nodes instead of subscript and superscript to ensure that # we get the right customization hooks at the LaTeX level wrapper = nodes.inline('', '', classes=['repeat-wrapper']) - wrapper += nodes.inline('', '', *self.visitChildren(ctx), classes=["repeat"]) + + children = self.visitChildren(ctx) + if len(children) == 1 and self.is_alternative(children[0]): + # Use a custom style if an alternative is nested in a repeat. + # (We could detect this in CSS, but it's much harder in LaTeX.) + + children[0]['classes'] = ['repeated-alternative'] + wrapper += nodes.inline('', '', *children, classes=["repeat"]) repeat_marker = ctx.LGROUP().getText()[1] wrapper += nodes.inline(repeat_marker, repeat_marker, classes=['notation-sup']) - separator = ctx.ATOM() + separator = ctx.ATOM() or ctx.PIPE() if separator: sep = separator.getText() wrapper += nodes.inline(sep, sep, classes=['notation-sub']) @@ -65,6 +83,9 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): return [node] + def visitPipe(self, ctx:TacticNotationsParser.PipeContext): + return [nodes.Text("|")] + def visitHole(self, ctx:TacticNotationsParser.HoleContext): hole = ctx.ID().getText() token_name = hole[1:] @@ -75,23 +96,18 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): sub_index = sub.getText()[2:] node += nodes.subscript(sub_index, sub_index) - return [addnodes.pending_xref(token_name, node, reftype='token', refdomain='std', reftarget=token_name)] + return [addnodes.pending_xref(token_name, node, reftype='token', + refdomain='std', reftarget=token_name)] - def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - meta = ctx.METACHAR().getText() - metachar = meta[1:] # remove escape char - token_name = metachar - if (metachar == "{") or (metachar == "}"): - classes=[] - else: - classes=["meta"] - return [nodes.inline(metachar, token_name, classes=classes)] + def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): + escaped = ctx.ESCAPED().getText() + return [nodes.inline(escaped, escaped[1:])] def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return [nodes.Text(" ")] def sphinxify(notation): - """Translate notation into a Sphinx document tree""" + """Translate a notation into a Sphinx document tree.""" vs = TacticNotationsToSphinxVisitor() return vs.visit(parse(notation)) diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index 26f6255069..2b124ee5c1 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -47,7 +47,7 @@ class CoqTop: :param coqtop_bin: The path to coqtop; uses $COQBIN by default, falling back to "coqtop" :param color: When True, tell coqtop to produce ANSI color codes (see the ansicolors module) - :param args: Additional arugments to coqtop. + :param args: Additional arguments to coqtop. """ self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN', ""), "coqtop") if not pexpect.utils.which(self.coqtop_bin): @@ -68,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 preceding it.""" self.coqtop.expect(CoqTop.COQTOP_PROMPT, timeout = 10) return self.coqtop.before diff --git a/doc/whodidwhat/whodidwhat-8.2update.tex b/doc/whodidwhat/whodidwhat-8.2update.tex index 4f4f0e952e..f45e6564f2 100644 --- a/doc/whodidwhat/whodidwhat-8.2update.tex +++ b/doc/whodidwhat/whodidwhat-8.2update.tex @@ -181,7 +181,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin, Yves Bertot -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/doc/whodidwhat/whodidwhat-8.3update.tex b/doc/whodidwhat/whodidwhat-8.3update.tex index 0a07378169..7cce0083d5 100644 --- a/doc/whodidwhat/whodidwhat-8.3update.tex +++ b/doc/whodidwhat/whodidwhat-8.3update.tex @@ -188,7 +188,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/doc/whodidwhat/whodidwhat-8.4update.tex b/doc/whodidwhat/whodidwhat-8.4update.tex index bb4c5ce469..2d74a653ed 100644 --- a/doc/whodidwhat/whodidwhat-8.4update.tex +++ b/doc/whodidwhat/whodidwhat-8.4update.tex @@ -191,7 +191,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/doc/whodidwhat/whodidwhat-8.5update.tex b/doc/whodidwhat/whodidwhat-8.5update.tex index ce099dc363..600ecf93db 100644 --- a/doc/whodidwhat/whodidwhat-8.5update.tex +++ b/doc/whodidwhat/whodidwhat-8.5update.tex @@ -197,7 +197,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 0a5bba39b9..7c2ecca89e 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -860,7 +860,7 @@ let compare_constructor_instances evd u u' = [u] up to existential variable instantiation and equalisable universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extention of those in [sigma1]. *) + assumed to be an extension of those in [sigma1]. *) let eq_constr_univs_test sigma1 sigma2 t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 8eaff8bd13..907be8eba2 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -208,7 +208,7 @@ val kind_of_term_upto : evar_map -> Constr.constr -> [u] up to existential variable instantiation and equalisable universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extention of those in [sigma1]. *) + assumed to be an extension of those in [sigma1]. *) val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool (** [compare_cumulative_instances cv_pb variance u1 u2 sigma] Returns diff --git a/engine/evd.ml b/engine/evd.ml index 0f10a380d3..15b4c31851 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -222,7 +222,7 @@ let map_evar_body f = function let map_evar_info f evi = {evi with evar_body = map_evar_body f evi.evar_body; - evar_hyps = map_named_val f evi.evar_hyps; + evar_hyps = map_named_val (fun d -> NamedDecl.map_constr f d) evi.evar_hyps; evar_concl = f evi.evar_concl; evar_candidates = Option.map (List.map f) evi.evar_candidates } diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index e0c24f049f..a504ee28e2 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -151,7 +151,7 @@ struct (** Double-continuation backtracking monads are reasonable folklore for "search" implementations (including the Tac interactive prover's tactics). Yet it's quite hard to wrap your head around - these. I recommand reading a few times the "Backtracking, + these. I recommend reading a few times the "Backtracking, Interleaving, and Terminating Monad Transformers" paper by O. Kiselyov, C. Shan, D. Friedman, and A. Sabry. The peculiar shape of the monadic type is reminiscent of that of the diff --git a/engine/proofview.ml b/engine/proofview.ml index 1fd8b5d50e..c00c90e5e9 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -31,7 +31,7 @@ type entry = (EConstr.constr * EConstr.types) list ide-s. *) (* spiwack: the type of [proofview] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: returns the list of focused goals together with the [evar_map] context. *) let proofview p = @@ -46,7 +46,7 @@ let compact el ({ solution } as pv) = let apply_subst_einfo _ ei = Evd.({ ei with evar_concl = nf ei.evar_concl; - evar_hyps = Environ.map_named_val nf0 ei.evar_hyps; + evar_hyps = Environ.map_named_val (fun d -> map_constr nf0 d) ei.evar_hyps; evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in @@ -114,7 +114,7 @@ type focus_context = goal_with_state list * goal_with_state list instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) let focus_context (left,right) = @@ -123,7 +123,7 @@ let focus_context (left,right) = (** This (internal) function extracts a sublist between two indices, and returns this sublist together with its context: if it returns [(a,(b,c))] then [a] is the sublist and [(rev b) @ a @ c] is the - original list. The focused list has lenght [j-i-1] and contains + original list. The focused list has length [j-i-1] and contains the goals from number [i] to number [j] (both included) the first goal of the list being numbered [1]. [focus_sublist i j l] raises [IndexOutOfRange] if [i > length l], or [j > length l] or [j < @@ -245,7 +245,7 @@ let tclUNIT = Proof.return (** Bind operation of the tactic monad. *) let tclBIND = Proof.(>>=) -(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, +(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, it's a specialized "bind". *) let tclTHEN = Proof.(>>) diff --git a/engine/proofview.mli b/engine/proofview.mli index b7ff3ac432..60697c1611 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -24,7 +24,7 @@ type proofview ide-s. *) (* spiwack: the type of [proofview] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: returns the list of focused goals together with the [evar_map] context. *) val proofview : proofview -> Evar.t list * Evd.evar_map @@ -95,7 +95,7 @@ type focus_context instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) val focus_context : focus_context -> Evar.t list * Evar.t list diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 80eb9d0124..8ed75a8d00 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -252,7 +252,7 @@ module Giveup : Writer with type t = goal list = struct let put gs = Logical.put (true, gs) end -(** Lens and utilies pertaining to the info trace *) +(** Lens and utilities pertaining to the info trace *) module InfoL = struct let recording = Logical.(map (fun {P.trace} -> trace) current) let if_recording t = diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 3437b6ce77..f0c9fdb589 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -145,7 +145,7 @@ module Shelf : State with type t = goal list of the tactic. *) module Giveup : Writer with type t = goal list -(** Lens and utilies pertaining to the info trace *) +(** Lens and utilities pertaining to the info trace *) module InfoL : sig (** [record_trace t] behaves like [t] and compute its [info] trace. *) val record_trace : 'a Logical.t -> 'a Logical.t diff --git a/engine/univMinim.ml b/engine/univMinim.ml index fcbf305f9d..4f9f9ce6a5 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -353,7 +353,7 @@ let normalize_context_set g ctx us algs weak = noneqs Constraint.empty in (* Compute the left and right set of flexible variables, constraints - mentionning other variables remain in noneqs. *) + mentioning other variables remain in noneqs. *) let noneqs, ucstrsl, ucstrsr = Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> let lus = LMap.mem l us and rus = LMap.mem r us in diff --git a/ide/idetop.ml b/ide/idetop.ml index ce00ba6d8c..970d7cf650 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -537,7 +537,11 @@ let rec parse = function Xmlprotocol.document Xml_printer.to_string_fmt; exit 0 | "--xml_format=Ppcmds" :: rest -> msg_format := (fun () -> Xmlprotocol.Ppcmds); parse rest - | x :: rest -> x :: parse rest + | x :: rest -> + if String.length x > 0 && x.[0] = '-' then + (prerr_endline ("Unknown option " ^ x); exit 1) + else + x :: parse rest | [] -> [] let () = Usage.add_to_usage "coqidetop" diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 9f778d99e9..3ebbbdfb88 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -40,8 +40,8 @@ type explicitation = type binder_kind = | Default of binding_kind - | Generalized of binding_kind * binding_kind * bool - (** Inner binding, outer bindings, typeclass-specific flag + | Generalized of binding_kind * bool + (** (Inner binding always Implicit) Outer bindings, typeclass-specific flag for implicit generalization of superclasses *) type abstraction_kind = AbsLambda | AbsPi diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 443473d5b6..bcb2f34377 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -34,8 +34,8 @@ let abstraction_kind_eq ak1 ak2 = match ak1, ak2 with let binder_kind_eq b1 b2 = match b1, b2 with | Default bk1, Default bk2 -> binding_kind_eq bk1 bk2 -| Generalized (bk1, ck1, b1), Generalized (bk2, ck2, b2) -> - binding_kind_eq bk1 bk2 && binding_kind_eq ck1 ck2 && +| Generalized (ck1, b1), Generalized (ck2, b2) -> + binding_kind_eq ck1 ck2 && (if b1 then b2 else not b2) | _ -> false diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f06493b374..753065b7dd 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -389,7 +389,7 @@ let push_name_env ?(global_level=false) ntnvars implargs env = {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} let intern_generalized_binder ?(global_level=false) intern_type ntnvars - env {loc;v=na} b b' t ty = + env {loc;v=na} b' t ty = let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in let ty, ids' = if t then ty, ids else @@ -403,7 +403,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars env fvs in let bl = List.map CAst.(map (fun id -> - (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) + (Name id, Implicit, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) fvs in let na = match na with @@ -433,8 +433,8 @@ let intern_assumption intern ntnvars env nal bk ty = (push_name_env ntnvars impls env locna, (make ?loc (na,k,locate_if_hole ?loc na ty))::bl)) (env, []) nal - | Generalized (b,b',t) -> - let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b b' t ty in + | Generalized (b',t) -> + let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b' t ty in env, b let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function diff --git a/interp/declare.ml b/interp/declare.ml index 76b4bab2ce..7ee7ecb5e8 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -36,9 +36,8 @@ type internal_flag = (** Declaration of constants and parameters *) type constant_obj = { - cst_decl : global_declaration option; - (** [None] when the declaration is a side-effect and has already been defined - in the global environment. *) + cst_decl : Cooking.recipe option; + (** Non-empty only when rebuilding a constant after a section *) cst_kind : logical_kind; cst_locl : bool; } @@ -65,21 +64,21 @@ let open_constant i ((sp,kn), obj) = let exists_name id = variable_exists id || Global.exists_objlabel (Label.of_id id) -let check_exists sp = - let id = basename sp in +let check_exists id = if exists_name id then alreadydeclared (Id.print id ++ str " already exists") let cache_constant ((sp,kn), obj) = + (* Invariant: the constant must exist in the logical environment, except when + redefining it when exiting a section. See [discharge_constant]. *) let id = basename sp in let kn' = match obj.cst_decl with | None -> if Global.exists_objlabel (Label.of_id (basename sp)) then Constant.make1 kn - else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") - | Some decl -> - let () = check_exists sp in - Global.add_constant ~in_section:(Lib.sections_are_opened ()) id decl + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") + | Some r -> + Global.add_recipe ~in_section:(Lib.sections_are_opened ()) id r in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); @@ -93,7 +92,9 @@ let discharge_constant ((sp, kn), obj) = let modlist = replacement_context () in let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in let abstract = (named_of_variable_context hyps, subst, uctx) in - let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in + let new_decl = { from; info = { Opaqueproof.modlist; abstract } } in + (* This is a hack: when leaving a section, we lose the constant definition, so + we have to store it in the libobject to be able to retrieve it after. *) Some { obj with cst_decl = Some new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) @@ -121,27 +122,22 @@ let update_tables c = declare_constant_implicits c; Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) -let register_side_effect (c, role) = +let register_constant kn kind local = let o = inConstant { cst_decl = None; - cst_kind = IsProof Theorem; - cst_locl = false; + cst_kind = kind; + cst_locl = local; } in - let id = Label.to_id (Constant.label c) in - ignore(add_leaf id o); - update_tables c; + let id = Label.to_id (Constant.label kn) in + let _ = add_leaf id o in + update_tables kn + +let register_side_effect (c, role) = + let () = register_constant c (IsProof Theorem) false in match role with | Subproof -> () | Schema (ind, kind) -> !declare_scheme kind [|ind,c|] -let declare_constant_common id cst = - let o = inConstant cst in - let _, kn as oname = add_leaf id o in - pull_to_head oname; - let c = Global.constant_of_delta_kn kn in - update_tables c; - c - 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 = @@ -153,7 +149,8 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = +let define_constant ?role ?(export_seff=false) id cd = + (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false | Polymorphic_entry _ -> true @@ -165,20 +162,27 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e export_seff || not de.const_entry_opaque || is_poly de -> - (* This globally defines the side-effects in the environment. We mark - exported constants as being side-effect not to redeclare them at - caching time. *) + (* This globally defines the side-effects in the environment. *) let de, export = Global.export_private_constants ~in_section de in export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in + let kn, eff = Global.add_constant ?role ~in_section id decl in + kn, eff, export + +let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = + let () = check_exists id in + let kn, _eff, export = define_constant ~export_seff id cd in + (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in - let cst = { - cst_decl = Some decl; - cst_kind = kind; - cst_locl = local; - } in - declare_constant_common id cst + let () = register_constant kn kind local in + kn + +let declare_private_constant ~role ?(internal=UserIndividualRequest) ?(local = false) id (cd, kind) = + let kn, eff, export = define_constant ~role id cd in + let () = assert (List.is_empty export) in + let () = register_constant kn kind local in + kn, eff let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) @@ -297,7 +301,7 @@ let open_inductive i ((sp,kn),mie) = let cache_inductive ((sp,kn),mie) = let names = inductive_names sp kn mie in - List.iter check_exists (List.map fst names); + List.iter check_exists (List.map (fun p -> basename (fst p)) names); let id = basename sp in let kn' = Global.add_mind id mie in assert (MutInd.equal kn' (MutInd.make1 kn)); diff --git a/interp/declare.mli b/interp/declare.mli index 8f1e73c88c..2ffde31fc0 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -55,6 +55,9 @@ val definition_entry : ?fix_exn:Future.fix_exn -> val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t +val declare_private_constant : + role:side_effect_role -> ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> Constant.t * Safe_typing.private_constants + val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> ?local:bool -> Id.t -> ?types:constr -> diff --git a/interp/impargs.ml b/interp/impargs.ml index 90fb5a2036..806fe93297 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -497,9 +497,9 @@ type implicit_interactive_request = type implicit_discharge_request = | ImplLocal - | ImplConstant of Constant.t * implicits_flags + | ImplConstant of implicits_flags | ImplMutualInductive of MutInd.t * implicits_flags - | ImplInteractive of GlobRef.t * implicits_flags * + | ImplInteractive of implicits_flags * implicit_interactive_request let implicits_table = Summary.ref GlobRef.Map.empty ~name:"implicits" @@ -552,39 +552,24 @@ let add_section_impls vars extra_impls (cond,impls) = let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None - | ImplInteractive (ref,flags,exp) -> - (try - let vars = variable_section_segment_of_reference ref in - let extra_impls = impls_of_context vars in - let l' = [ref, List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in - Some (ImplInteractive (ref,flags,exp),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) - | ImplConstant (con,flags) -> - (try - let vars = variable_section_segment_of_reference (ConstRef con) in - let extra_impls = impls_of_context vars in - let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in - let l' = [ConstRef con,newimpls] in - Some (ImplConstant (con,flags),l') - with Not_found -> (* con not defined in this section *) Some (req,l)) - | ImplMutualInductive (kn,flags) -> - (try - let l' = List.map (fun (gr, l) -> - let vars = variable_section_segment_of_reference gr in - let extra_impls = impls_of_context vars in - (gr, - List.map (add_section_impls vars extra_impls) l)) l - in - Some (ImplMutualInductive (kn,flags),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) + | ImplMutualInductive _ | ImplInteractive _ | ImplConstant _ -> + let l' = + try + List.map (fun (gr, l) -> + let vars = variable_section_segment_of_reference gr in + let extra_impls = impls_of_context vars in + let newimpls = List.map (add_section_impls vars extra_impls) l in + (gr, newimpls)) l + with Not_found -> l in + Some (req,l') let rebuild_implicits (req,l) = match req with | ImplLocal -> assert false - | ImplConstant (con,flags) -> - let oldimpls = snd (List.hd l) in - let newimpls = compute_constant_implicits flags con in - req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] + | ImplConstant flags -> + let ref,oldimpls = List.hd l in + let newimpls = compute_global_implicits flags ref in + req, [ref, List.map2 merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags kn in let rec aux olds news = @@ -595,15 +580,14 @@ let rebuild_implicits (req,l) = | _, _ -> assert false in req, aux l newimpls - | ImplInteractive (ref,flags,o) -> + | ImplInteractive (flags,o) -> + let ref,oldimpls = List.hd l in (if isVarRef ref && is_in_section ref then ImplLocal else req), match o with | ImplAuto -> - let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags ref in [ref,List.map2 merge_impls oldimpls newimpls] | ImplManual userimplsize -> - let oldimpls = snd (List.hd l) in if flags.auto then let newimpls = List.hd (compute_global_implicits flags ref) in let p = List.length (snd newimpls) - userimplsize in @@ -638,7 +622,7 @@ let declare_implicits_gen req flags ref = let declare_implicits local ref = let flags = { !implicit_args with auto = true } in let req = - if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in + if is_local local ref then ImplLocal else ImplInteractive(flags,ImplAuto) in declare_implicits_gen req flags ref let declare_var_implicits id = @@ -647,7 +631,7 @@ let declare_var_implicits id = let declare_constant_implicits con = let flags = !implicit_args in - declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) + declare_implicits_gen (ImplConstant flags) flags (ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in @@ -697,7 +681,7 @@ let declare_manual_implicits local ref ?enriching l = let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l])) let maybe_declare_manual_implicits local ref ?enriching l = @@ -756,7 +740,7 @@ let set_implicits local ref l = compute_implicit_statuses autoimpls imps)) l in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) let extract_impargs_data impls = diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index dffccf02fc..bac46c2d2f 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -196,10 +196,9 @@ let combine_params avoid fn applied needed = user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed -let combine_params_freevar = - fun avoid (_, decl) -> - let id' = next_name_away_from (RelDecl.get_name decl) avoid in - (CAst.make @@ CRef (qualid_of_ident id',None), Id.Set.add id' avoid) +let combine_params_freevar avoid (_, decl) = + let id' = next_name_away_from (RelDecl.get_name decl) avoid in + (CAst.make @@ CRef (qualid_of_ident id',None), Id.Set.add id' avoid) let destClassApp cl = let open CAst in @@ -222,34 +221,34 @@ let implicit_application env ?(allow_partial=true) f ty = let is_class = try let ({CAst.v=(qid, _, _)} as clapp) = destClassAppExpl ty in - let gr = Nametab.locate qid in - if Typeclasses.is_class gr then Some (clapp, gr) else None + if Libnames.idset_mem_qualid qid env then None + else + let gr = Nametab.locate qid in + if Typeclasses.is_class gr then Some (clapp, gr) else None with Not_found -> None in - match is_class with - | None -> ty, env - | Some ({CAst.loc;v=(id, par, inst)}, gr) -> - let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in - let c, avoid = - let env = Global.env () in - let sigma = Evd.from_env env in - let c = class_info env sigma gr in - let (ci, rd) = c.cl_context in - if not allow_partial then - begin - let opt_succ x n = match x with - | None -> succ n - | Some _ -> n - in - let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in - let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in - if not (Int.equal needlen applen) then - mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd - end; - let pars = List.rev (List.combine ci rd) in - let args, avoid = combine_params avoid f par pars in - CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid - in c, avoid + match is_class with + | None -> ty, env + | Some ({CAst.loc;v=(id, par, inst)}, gr) -> + let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in + let env = Global.env () in + let sigma = Evd.from_env env in + let c = class_info env sigma gr in + let (ci, rd) = c.cl_context in + if not allow_partial then + begin + let opt_succ x n = match x with + | None -> succ n + | Some _ -> n + in + let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in + let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in + if not (Int.equal needlen applen) then + mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd + end; + let pars = List.rev (List.combine ci rd) in + let args, avoid = combine_params avoid f par pars in + CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid let warn_ignoring_implicit_status = CWarnings.create ~name:"ignoring_implicit_status" ~category:"implicits" @@ -281,7 +280,7 @@ let implicits_of_glob_constr ?(with_products=true) l = | _ -> () in [] | GLambda (na, bk, t, b) -> abs na bk b - | GLetIn (na, b, t, c) -> aux i b + | GLetIn (na, b, t, c) -> aux i c | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 412637c4b6..95f88c0306 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -389,7 +389,7 @@ type clos_infos = { i_flags : reds; i_cache : infos_cache } -type clos_tab = fconstr constant_def KeyTable.t +type clos_tab = (fconstr, Empty.t) constant_def KeyTable.t let info_flags info = info.i_flags let info_env info = info.i_cache.i_env diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index b1b69dded8..1a790eaed6 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -215,7 +215,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 constant_def +val unfold_reference : clos_infos -> clos_tab -> table_key -> (fconstr, Util.Empty.t) constant_def (*********************************************************************** i This is for lazy debug *) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 6a9550342c..bdaf5fe422 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -20,7 +20,7 @@ val compile : fail_on_error:bool -> (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> - env -> universes -> Constr.t Mod_subst.substituted constant_def -> + env -> universes -> (Constr.t Mod_subst.substituted, 'opaque) constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 9b974c4ecc..9b6e37251f 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -152,11 +152,11 @@ let abstract_constant_body c (hyps, subst) = let c = Vars.subst_vars subst c in it_mkLambda_or_LetIn c hyps -type recipe = { from : constant_body; info : Opaqueproof.cooking_info } +type recipe = { from : Opaqueproof.opaque constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = { - cook_body : constr Mod_subst.substituted constant_def; +type 'opaque result = { + cook_body : (constr Mod_subst.substituted, 'opaque) constant_def; cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; diff --git a/kernel/cooking.mli b/kernel/cooking.mli index b0f143c47d..b022e2ac09 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -13,12 +13,12 @@ open Declarations (** {6 Cooking the constants. } *) -type recipe = { from : constant_body; info : Opaqueproof.cooking_info } +type recipe = { from : Opaqueproof.opaque constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = { - cook_body : constr Mod_subst.substituted constant_def; +type 'opaque result = { + cook_body : (constr Mod_subst.substituted, 'opaque) constant_def; cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; @@ -27,7 +27,7 @@ type result = { cook_context : Constr.named_context option; } -val cook_constant : hcons:bool -> recipe -> result +val cook_constant : hcons:bool -> recipe -> Opaqueproof.opaque result val cook_constr : Opaqueproof.cooking_info -> constr -> constr (** {6 Utility functions used in module [Discharge]. } *) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 5551742c02..36ee952099 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -47,10 +47,10 @@ type inline = int option transparent body, or an opaque one *) (* Global declarations (i.e. constants) can be either: *) -type 'a constant_def = +type ('a, 'opaque) constant_def = | Undef of inline (** a global assumption *) | Def of 'a (** or a transparent global definition *) - | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) + | OpaqueDef of 'opaque (** or an opaque global definition *) | Primitive of CPrimitives.t (** or a primitive operation *) type universes = @@ -87,9 +87,9 @@ type typing_flags = { (* some contraints are in constant_constraints, some other may be in * the OpaqueDef *) -type constant_body = { +type 'opaque constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) - const_body : Constr.t Mod_subst.substituted constant_def; + const_body : (Constr.t Mod_subst.substituted, 'opaque) constant_def; const_type : types; const_relevance : Sorts.relevance; const_body_code : Cemitcodes.to_patch_substituted option; @@ -246,7 +246,7 @@ type module_alg_expr = (** A component of a module structure *) type structure_field_body = - | SFBconst of constant_body + | SFBconst of Opaqueproof.opaque constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 54a853fc81..fb02c6a029 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -26,21 +26,21 @@ val map_decl_arity : ('a -> 'c) -> ('b -> 'd) -> (** {6 Constants} *) -val subst_const_body : substitution -> constant_body -> constant_body +val subst_const_body : substitution -> Opaqueproof.opaque constant_body -> Opaqueproof.opaque constant_body (** Is there a actual body in const_body ? *) -val constant_has_body : constant_body -> bool +val constant_has_body : 'a constant_body -> bool -val constant_polymorphic_context : constant_body -> AUContext.t +val constant_polymorphic_context : 'a constant_body -> AUContext.t (** Is the constant polymorphic? *) -val constant_is_polymorphic : constant_body -> bool +val constant_is_polymorphic : 'a constant_body -> bool (** Return the universe context, in case the definition is polymorphic, otherwise the context is empty. *) -val is_opaque : constant_body -> bool +val is_opaque : 'a constant_body -> bool (** {6 Inductive types} *) @@ -83,7 +83,7 @@ val safe_flags : Conv_oracle.oracle -> typing_flags of the structure, but simply hash-cons all inner constr and other known elements *) -val hcons_const_body : constant_body -> constant_body +val hcons_const_body : 'a constant_body -> 'a constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body val hcons_module_body : module_body -> module_body val hcons_module_type : module_type_body -> module_type_body diff --git a/kernel/environ.ml b/kernel/environ.ml index 97c9f8654a..05f342a82a 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -46,7 +46,7 @@ type link_info = | LinkedInteractive of string | NotLinked -type constant_key = constant_body * (link_info ref * key) +type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref @@ -187,7 +187,7 @@ let match_named_context_val c = match c.env_named_ctx with let map_named_val f ctxt = let open Context.Named.Declaration in let fold accu d = - let d' = map_constr f d in + let d' = f d in let accu = if d == d' then accu else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu diff --git a/kernel/environ.mli b/kernel/environ.mli index 8c6bc105c7..f6cd41861e 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -42,7 +42,7 @@ type link_info = type key = int CEphemeron.key option ref -type constant_key = constant_body * (link_info ref * key) +type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref @@ -134,9 +134,9 @@ val ids_of_named_context_val : named_context_val -> Id.Set.t (** [map_named_val f ctxt] apply [f] to the body and the type of each declarations. - *** /!\ *** [f t] should be convertible with t *) + *** /!\ *** [f t] should be convertible with t, and preserve the name *) val map_named_val : - (constr -> constr) -> named_context_val -> named_context_val + (named_declaration -> named_declaration) -> named_context_val -> named_context_val val push_named : Constr.named_declaration -> env -> env val push_named_context : Constr.named_context -> env -> env @@ -174,19 +174,19 @@ val reset_with_named_context : named_context_val -> env -> env val pop_rel_context : int -> env -> env (** Useful for printing *) -val fold_constants : (Constant.t -> constant_body -> 'a -> 'a) -> env -> 'a -> 'a +val fold_constants : (Constant.t -> Opaqueproof.opaque constant_body -> 'a -> 'a) -> env -> 'a -> 'a (** {5 Global constants } {6 Add entries to global environment } *) -val add_constant : Constant.t -> constant_body -> env -> env -val add_constant_key : Constant.t -> constant_body -> link_info -> +val add_constant : Constant.t -> Opaqueproof.opaque constant_body -> env -> env +val add_constant_key : Constant.t -> Opaqueproof.opaque constant_body -> link_info -> env -> env val lookup_constant_key : Constant.t -> env -> constant_key (** Looks up in the context of global constant names raises [Not_found] if the required path is not found *) -val lookup_constant : Constant.t -> env -> constant_body +val lookup_constant : Constant.t -> env -> Opaqueproof.opaque constant_body val evaluable_constant : Constant.t -> env -> bool (** New-style polymorphism *) @@ -219,7 +219,7 @@ val constant_context : env -> Constant.t -> Univ.AUContext.t it lives in. For monomorphic constant, the latter is empty, and for polymorphic constants, the term contains De Bruijn universe variables that need to be instantiated. *) -val body_of_constant_body : env -> constant_body -> (Constr.constr * Univ.AUContext.t) option +val body_of_constant_body : env -> Opaqueproof.opaque constant_body -> (Constr.constr * Univ.AUContext.t) option (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 96efa7faa5..b5c03b6ca3 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -65,7 +65,7 @@ val empty_updates : code_location_updates val register_native_file : string -> unit val compile_constant_field : env -> string -> Constant.t -> - global list -> constant_body -> global list + global list -> 'a constant_body -> global list val compile_mind_field : ModPath.t -> Label.t -> global list -> mutual_inductive_body -> global list diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 57059300b8..18c1bcc0f8 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -77,11 +77,6 @@ let subst_opaque sub = function | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque.") -let iter_direct_opaque f = function - | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") - | Direct (d,cu) -> - Direct (d,Future.chain cu (fun (c, u) -> f c; c, u)) - let discharge_direct_opaque ~cook_constr ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index d47c0bbb3c..4e8956af06 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -43,7 +43,6 @@ val get_constraints : opaquetab -> opaque -> Univ.ContextSet.t Future.computation option val subst_opaque : substitution -> opaque -> opaque -val iter_direct_opaque : (constr -> unit) -> opaque -> opaque type work_list = (Univ.Instance.t * Id.t array) Cmap.t * (Univ.Instance.t * Id.t array) Mindmap.t diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 75375812c0..a5d8a480ee 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -228,27 +228,10 @@ let check_engagement env expected_impredicative_set = (** {6 Stm machinery } *) -type seff_env = - [ `Nothing - (* The proof term and its universes. - Same as the constant_body's but not in an ephemeron *) - | `Opaque of Constr.t * Univ.ContextSet.t ] - -let get_opaque_body env cbo = - match cbo.const_body with - | Undef _ -> assert false - | Primitive _ -> assert false - | Def _ -> `Nothing - | OpaqueDef opaque -> - `Opaque - (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, - Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) - type side_effect = { from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; - seff_body : Declarations.constant_body; - seff_env : seff_env; + seff_body : (Constr.t * Univ.ContextSet.t) Declarations.constant_body; seff_role : Entries.side_effect_role; } @@ -288,39 +271,38 @@ type private_constants = SideEffects.t let side_effects_of_private_constants l = List.rev (SideEffects.repr l) +(* Only used to push in an Environ.env. *) +let lift_constant c = + let body = match c.const_body with + | OpaqueDef _ -> Undef None + | Def _ | Undef _ | Primitive _ as body -> body + in + { c with const_body = body } + +let map_constant f c = + let body = match c.const_body with + | OpaqueDef o -> OpaqueDef (f o) + | Def _ | Undef _ | Primitive _ as body -> body + in + { c with const_body = body } + let push_private_constants env eff = let eff = side_effects_of_private_constants eff in let add_if_undefined env eff = try ignore(Environ.lookup_constant eff.seff_constant env); env - with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env + with Not_found -> Environ.add_constant eff.seff_constant (lift_constant eff.seff_body) env in List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty let concat_private = SideEffects.concat -let private_constant env role cst = - (** The constant must be the last entry of the safe environment *) - let () = match env.revstruct with - | (lbl, SFBconst _) :: _ -> assert (Label.equal lbl (Constant.label cst)) - | _ -> assert false - in - let from_env = CEphemeron.create env.revstruct in - let cbo = Environ.lookup_constant cst env.env in - let eff = { - from_env = from_env; - seff_constant = cst; - seff_body = cbo; - seff_env = get_opaque_body env.env cbo; - seff_role = role; - } in - SideEffects.add eff empty_private_constants - let universes_of_private eff = let fold acc eff = - let acc = match eff.seff_env with - | `Nothing -> acc - | `Opaque (_, ctx) -> ctx :: acc + let acc = match eff.seff_body.const_body with + | Def _ -> acc + | OpaqueDef (_, ctx) -> ctx :: acc + | Primitive _ | Undef _ -> assert false in match eff.seff_body.const_universes with | Monomorphic ctx -> ctx :: acc @@ -565,7 +547,6 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration - | GlobalRecipe of Cooking.recipe type exported_private_constant = Constant.t * Entries.side_effect_role @@ -598,7 +579,7 @@ let inline_side_effects env body side_eff = let open Constr in (** First step: remove the constants that are still in the environment *) let filter e = - let cb = (e.seff_constant, e.seff_body, e.seff_env) in + let cb = (e.seff_constant, e.seff_body) in try ignore (Environ.lookup_constant e.seff_constant env); None with Not_found -> Some (cb, e.from_env) in @@ -612,10 +593,10 @@ let inline_side_effects env body side_eff = else (** Second step: compute the lifts and substitutions to apply *) let cname c r = Context.make_annot (Name (Label.to_id (Constant.label c))) r in - let fold (subst, var, ctx, args) (c, cb, b) = - let (b, opaque) = match cb.const_body, b with - | Def b, _ -> (Mod_subst.force_constr b, false) - | OpaqueDef _, `Opaque (b,_) -> (b, true) + let fold (subst, var, ctx, args) (c, cb) = + let (b, opaque) = match cb.const_body with + | Def b -> (Mod_subst.force_constr b, false) + | OpaqueDef (b, _) -> (b, true) | _ -> assert false in match cb.const_universes with @@ -701,7 +682,8 @@ let check_signatures curmb sl = | Some (n, _) -> n -let constant_entry_of_side_effect cb u = +let constant_entry_of_side_effect eff = + let cb = eff.seff_body in let open Entries in let univs = match cb.const_universes with @@ -711,9 +693,9 @@ let constant_entry_of_side_effect cb u = Polymorphic_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) in let pt = - match cb.const_body, u with - | OpaqueDef _, `Opaque (b, c) -> b, c - | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty + match cb.const_body with + | OpaqueDef (b, c) -> b, c + | Def b -> Mod_subst.force_constr b, Univ.ContextSet.empty | _ -> assert false in DefinitionEntry { const_entry_body = Future.from_val (pt, ()); @@ -724,18 +706,6 @@ let constant_entry_of_side_effect cb u = const_entry_opaque = Declareops.is_opaque cb; const_entry_inline_code = cb.const_inline_code } -let turn_direct orig = - let cb = orig.seff_body in - if Declareops.is_opaque cb then - let p = match orig.seff_env with - | `Opaque (b, c) -> (b, c) - | _ -> assert false - in - let const_body = OpaqueDef (Opaqueproof.create (Future.from_val p)) in - let cb = { cb with const_body } in - { orig with seff_body = cb } - else orig - let export_eff eff = (eff.seff_constant, eff.seff_body, eff.seff_role) @@ -756,13 +726,14 @@ let export_side_effects mb env c = let trusted = check_signatures mb signatures in let push_seff env eff = let { seff_constant = kn; seff_body = cb ; _ } = eff in - let env = Environ.add_constant kn cb env in + let env = Environ.add_constant kn (lift_constant cb) env in match cb.const_universes with | Polymorphic _ -> env | Monomorphic ctx -> - let ctx = match eff.seff_env with - | `Nothing -> ctx - | `Opaque(_, ctx') -> Univ.ContextSet.union ctx' ctx + let ctx = match eff.seff_body.const_body with + | Def _ -> ctx + | OpaqueDef (_, ctx') -> Univ.ContextSet.union ctx' ctx + | Undef _ | Primitive _ -> assert false in Environ.push_context_set ~strict:true ctx env in @@ -771,35 +742,39 @@ let export_side_effects mb env c = | [] -> List.rev acc, ce | eff :: rest -> if Int.equal sl 0 then - let env, cb = - let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in - let ce = constant_entry_of_side_effect ocb u in + let env, cb = + let kn = eff.seff_constant in + let ce = constant_entry_of_side_effect eff in let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in - let eff = { eff with - seff_body = cb; - seff_env = `Nothing; - } in + let cb = map_constant Future.force cb in + let eff = { eff with seff_body = cb } in (push_seff env eff, export_eff eff) in translate_seff 0 rest (cb :: acc) env else - let cb = turn_direct eff in - let env = push_seff env cb in - let ecb = export_eff cb in + let env = push_seff env eff in + let ecb = export_eff eff in translate_seff (sl - 1) rest (ecb :: acc) env in translate_seff trusted seff [] env let export_private_constants ~in_section ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in - let bodies = List.map (fun (kn, cb, _) -> (kn, cb)) exported in + let map (kn, cb, _) = (kn, map_constant (fun p -> Opaqueproof.create (Future.from_val p)) cb) in + let bodies = List.map map exported in let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv -let add_constant ~in_section l decl senv = +let add_recipe ~in_section l r senv = + let kn = Constant.make2 senv.modpath l in + let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in + let cb = if in_section then cb else Declareops.hcons_const_body cb in + let senv = add_constant_aux ~in_section senv (kn, cb) in + kn, senv + +let add_constant ?role ~in_section l decl senv = let kn = Constant.make2 senv.modpath l in - let senv = let cb = match decl with | ConstantEntry (EffectEntry, ce) -> @@ -811,9 +786,9 @@ let add_constant ~in_section l decl senv = Term_typing.translate_constant (Term_typing.SideEffects handle) senv.env kn ce | ConstantEntry (PureEntry, ce) -> Term_typing.translate_constant Term_typing.Pure senv.env kn ce - | GlobalRecipe r -> - 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 + in + let senv = + let cb = map_constant Opaqueproof.create cb in add_constant_aux ~in_section senv (kn, cb) in let senv = match decl with @@ -822,7 +797,20 @@ let add_constant ~in_section l decl senv = add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv | _ -> senv in - kn, senv + let eff = match role with + | None -> empty_private_constants + | Some role -> + let cb = map_constant Future.force cb in + let from_env = CEphemeron.create senv.revstruct in + let eff = { + from_env = from_env; + seff_constant = kn; + seff_body = cb; + seff_role = role; + } in + SideEffects.add eff empty_private_constants + in + (kn, eff), senv (** Insertion of inductive types *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d6c7022cf5..36ca3d8c47 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -48,9 +48,6 @@ val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) -val private_constant : safe_environment -> Entries.side_effect_role -> Constant.t -> private_constants -(** Constant must be the last definition of the safe_environment. *) - val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : Environ.env -> Constr.constr -> private_constants -> Constr.constr @@ -91,7 +88,6 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration - | GlobalRecipe of Cooking.recipe type exported_private_constant = Constant.t * Entries.side_effect_role @@ -103,8 +99,11 @@ val export_private_constants : in_section:bool -> (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) val add_constant : - in_section:bool -> Label.t -> global_declaration -> - Constant.t safe_transformer + ?role:Entries.side_effect_role -> in_section:bool -> Label.t -> global_declaration -> + (Constant.t * private_constants) safe_transformer + +val add_recipe : + in_section:bool -> Label.t -> Cooking.recipe -> Constant.t safe_transformer (** Adding an inductive type *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 1857ea3329..24845ce459 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -31,7 +31,7 @@ open Mod_subst an inductive type. It can also be useful to allow reorderings in inductive types *) type namedobject = - | Constant of constant_body + | Constant of Opaqueproof.opaque constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index faa4411e92..74c6189a65 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -154,7 +154,7 @@ the polymorphic case let c = Constr.hcons j.uj_val in feedback_completion_typecheck feedback_id; c, uctx) in - let def = OpaqueDef (Opaqueproof.create proofterm) in + let def = OpaqueDef proofterm in { Cooking.cook_body = def; cook_type = tyj.utj_val; @@ -207,7 +207,7 @@ the polymorphic case in let def = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in let def = - if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty))) + if opaque then OpaqueDef (Future.from_val (def, Univ.ContextSet.empty)) else Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; @@ -232,7 +232,7 @@ let record_aux env s_ty s_bo = (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" v -let build_constant_declaration _kn env result = +let build_constant_declaration env result = let open Cooking in let typ = result.cook_type in let check declared inferred = @@ -271,11 +271,8 @@ let build_constant_declaration _kn env result = | Undef _ | Primitive _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> - let vars = - global_vars_set env - (Opaqueproof.force_proof (opaque_tables env) lc) in - (* we force so that cst are added to the env immediately after *) - ignore(Opaqueproof.force_constraints (opaque_tables env) lc); + let (lc, _) = Future.force lc in + let vars = global_vars_set env lc in if !Flags.record_aux_file then record_aux env ids_typ vars; vars in @@ -296,11 +293,15 @@ let build_constant_declaration _kn env result = check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) - OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env c in - let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in - check declared inferred) lc) in + let iter k cu = Future.chain cu (fun (c, _ as p) -> k c; p) in + let kont c = + let ids_typ = global_vars_set env typ in + let ids_def = global_vars_set env c in + let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in + check declared inferred + in + OpaqueDef (iter kont lc) + in let univs = result.cook_universes in let tps = let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in @@ -318,8 +319,8 @@ let build_constant_declaration _kn env result = (*s Global and local constant declaration. *) -let translate_constant mb env kn ce = - build_constant_declaration kn env +let translate_constant mb env _kn ce = + build_constant_declaration env (infer_declaration ~trust:mb env ce) let translate_local_assum env t = @@ -327,8 +328,21 @@ let translate_local_assum env t = let t = Typeops.assumption_of_judgment env j in j.uj_val, t -let translate_recipe ~hcons env kn r = - build_constant_declaration kn env (Cooking.cook_constant ~hcons r) +let translate_recipe ~hcons env _kn r = + let open Cooking in + let result = Cooking.cook_constant ~hcons r in + let univs = result.cook_universes in + let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in + let tps = Option.map Cemitcodes.from_val res in + { const_hyps = Option.get result.cook_context; + const_body = result.cook_body; + const_type = result.cook_type; + const_body_code = tps; + const_universes = univs; + const_private_poly_univs = result.cook_private_univs; + const_relevance = result.cook_relevance; + const_inline_code = result.cook_inline; + const_typing_flags = Environ.typing_flags env } let translate_local_def env _id centry = let open Cooking in @@ -351,8 +365,7 @@ let translate_local_def env _id centry = | Def _ -> () | OpaqueDef lc -> let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env - (Opaqueproof.force_proof (opaque_tables env) lc) in + let ids_def = global_vars_set env (fst (Future.force lc)) in record_aux env ids_typ ids_def end; let () = match decl.cook_universes with @@ -362,8 +375,7 @@ let translate_local_def env _id centry = let c = match decl.cook_body with | Def c -> Mod_subst.force_constr c | OpaqueDef o -> - let p = Opaqueproof.force_proof (Environ.opaque_tables env) o in - let cst = Opaqueproof.force_constraints (Environ.opaque_tables env) o in + let (p, cst) = Future.force o in (** Let definitions are ensured to have no extra constraints coming from the body by virtue of the typing of [Entries.section_def_entry]. *) let () = assert (Univ.ContextSet.is_empty cst) in diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 1fa5eca2e3..592a97e132 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -33,14 +33,14 @@ val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> - constant_body + Opaqueproof.proofterm constant_body -val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> constant_body +val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body (** Internal functions, mentioned here for debug purpose only *) val infer_declaration : trust:'a trust -> env -> - 'a constant_entry -> Cooking.result + 'a constant_entry -> Opaqueproof.proofterm Cooking.result val build_constant_declaration : - Constant.t -> env -> Cooking.result -> constant_body + env -> Opaqueproof.proofterm Cooking.result -> Opaqueproof.proofterm constant_body diff --git a/library/global.ml b/library/global.ml index 06e06a8cf2..58e2380440 100644 --- a/library/global.ml +++ b/library/global.ml @@ -94,7 +94,8 @@ let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) -let add_constant ~in_section id d = globalize (Safe_typing.add_constant ~in_section (i2l id) d) +let add_constant ?role ~in_section id d = globalize (Safe_typing.add_constant ?role ~in_section (i2l id) d) +let add_recipe ~in_section id d = globalize (Safe_typing.add_recipe ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) diff --git a/library/global.mli b/library/global.mli index a60de48897..984d8c666c 100644 --- a/library/global.mli +++ b/library/global.mli @@ -46,7 +46,8 @@ val export_private_constants : in_section:bool -> unit Entries.definition_entry * Safe_typing.exported_private_constant list val add_constant : - in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t + ?role:Entries.side_effect_role -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * Safe_typing.private_constants +val add_recipe : in_section:bool -> Id.t -> Cooking.recipe -> Constant.t val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t @@ -84,7 +85,7 @@ val add_module_parameter : (** {6 Queries in the global environment } *) val lookup_named : variable -> Constr.named_declaration -val lookup_constant : Constant.t -> Declarations.constant_body +val lookup_constant : Constant.t -> Opaqueproof.opaque Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_pinductive : Constr.pinductive -> @@ -105,7 +106,7 @@ val body_of_constant : Constant.t -> (Constr.constr * Univ.AUContext.t) option polymorphic constants, the term contains De Bruijn universe variables that need to be instantiated. *) -val body_of_constant_body : Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option +val body_of_constant_body : Opaqueproof.opaque Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option (** Same as {!body_of_constant} but on {!Declarations.constant_body}. *) (** {6 Compiled libraries } *) diff --git a/library/lib.ml b/library/lib.ml index a046360822..4be288ed20 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -211,9 +211,6 @@ let split_lib_at_opening sp = let add_entry sp node = lib_state := { !lib_state with lib_stk = (sp,node) :: !lib_state.lib_stk } -let pull_to_head oname = - lib_state := { !lib_state with lib_stk = (oname,List.assoc oname !lib_state.lib_stk) :: List.remove_assoc oname !lib_state.lib_stk } - let anonymous_id = let n = ref 0 in fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) diff --git a/library/lib.mli b/library/lib.mli index 30569197bc..5da76961a6 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -57,7 +57,6 @@ val segment_of_objects : val add_leaf : Id.t -> Libobject.obj -> Libobject.object_name val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit -val pull_to_head : Libobject.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) diff --git a/library/libnames.ml b/library/libnames.ml index 87c4de42e8..41b38e0378 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -162,6 +162,9 @@ let qualid_basename qid = let qualid_path qid = qid.CAst.v.dirpath +let idset_mem_qualid qid s = + qualid_is_ident qid && Id.Set.mem (qualid_basename qid) s + (* Default paths *) let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/libnames.mli b/library/libnames.mli index bbb4d2a058..7d77d95991 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -88,6 +88,9 @@ val qualid_is_ident : qualid -> bool val qualid_path : qualid -> DirPath.t val qualid_basename : qualid -> Id.t +val idset_mem_qualid : qualid -> Id.Set.t -> bool +(** false when the qualid is not an ident *) + (** {6 ... } *) (** some preset paths *) diff --git a/library/library.ml b/library/library.ml index 04e38296d9..500e77f89b 100644 --- a/library/library.ml +++ b/library/library.ml @@ -612,8 +612,6 @@ let import_module export modl = (*s Initializing the compilation of a library. *) let load_library_todo f = - let longf = Loadpath.locate_file (f^".v") in - let f = longf^"io" in let ch = raw_intern_library f in let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in @@ -626,7 +624,7 @@ let load_library_todo f = if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); if pi3 (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); - longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 + s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) @@ -727,14 +725,13 @@ let save_library_to ?todo ~output_native_objects dir f otab = iraise reraise let save_library_raw f sum lib univs proofs = - let f' = f^"o" in - let ch = raw_extern_library f' in - System.marshal_out_segment f' ch (sum : seg_sum); - System.marshal_out_segment f' ch (lib : seg_lib); - System.marshal_out_segment f' ch (Some univs : seg_univ option); - System.marshal_out_segment f' ch (None : seg_discharge option); - System.marshal_out_segment f' ch (None : 'tasks option); - System.marshal_out_segment f' ch (proofs : seg_proofs); + let ch = raw_extern_library f in + System.marshal_out_segment f ch (sum : seg_sum); + System.marshal_out_segment f ch (lib : seg_lib); + System.marshal_out_segment f ch (Some univs : seg_univ option); + System.marshal_out_segment f ch (None : seg_discharge option); + System.marshal_out_segment f ch (None : 'tasks option); + System.marshal_out_segment f ch (proofs : seg_proofs); close_out ch module StringOrd = struct type t = string let compare = String.compare end diff --git a/library/library.mli b/library/library.mli index a976be0184..390299bf56 100644 --- a/library/library.mli +++ b/library/library.mli @@ -46,7 +46,7 @@ val save_library_to : DirPath.t -> string -> Opaqueproof.opaquetab -> unit val load_library_todo : - string -> string * seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs + string -> seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit (** {6 Interrogate the status of libraries } *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 4a9190c10a..6df97609f5 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -500,9 +500,9 @@ GRAMMAR EXTEND Gram | "{"; id=name; idl=LIST1 name; "}" -> { List.map (fun id -> CLocalAssum ([id],Default Implicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) (id::idl) } | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> - { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, Explicit, b), t)) tc } + { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Explicit, b), t)) tc } | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> - { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, Implicit, b), t)) tc } + { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, b), t)) tc } | "'"; p = pattern LEVEL "0" -> { let (p, ty) = match p.CAst.v with diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index d27c79cb62..bf98f8cd70 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -16,9 +16,9 @@ open Environ open Evd open Miniml -val extract_constant : env -> Constant.t -> constant_body -> ml_decl +val extract_constant : env -> Constant.t -> Opaqueproof.opaque constant_body -> ml_decl -val extract_constant_spec : env -> Constant.t -> constant_body -> ml_spec +val extract_constant_spec : env -> Constant.t -> 'a constant_body -> ml_spec (** For extracting "module ... with ..." declaration *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 399a77c596..4e229a94b6 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -109,7 +109,7 @@ let labels_of_ref r = (*s Constants tables. *) -let typedefs = ref (Cmap_env.empty : (constant_body * ml_type) Cmap_env.t) +let typedefs = ref (Cmap_env.empty : (Opaqueproof.opaque constant_body * ml_type) Cmap_env.t) let init_typedefs () = typedefs := Cmap_env.empty let add_typedef kn cb t = typedefs := Cmap_env.add kn (cb,t) !typedefs @@ -120,7 +120,7 @@ let lookup_typedef kn cb = with Not_found -> None let cst_types = - ref (Cmap_env.empty : (constant_body * ml_schema) Cmap_env.t) + ref (Cmap_env.empty : (Opaqueproof.opaque constant_body * ml_schema) Cmap_env.t) let init_cst_types () = cst_types := Cmap_env.empty let add_cst_type kn cb s = cst_types := Cmap_env.add kn (cb,s) !cst_types let lookup_cst_type kn cb = diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index acc1bfee8a..7e53964642 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -72,11 +72,11 @@ val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list [mutual_inductive_body] as checksum. In both case, we should ideally also check the env *) -val add_typedef : Constant.t -> constant_body -> ml_type -> unit -val lookup_typedef : Constant.t -> constant_body -> ml_type option +val add_typedef : Constant.t -> Opaqueproof.opaque constant_body -> ml_type -> unit +val lookup_typedef : Constant.t -> Opaqueproof.opaque constant_body -> ml_type option -val add_cst_type : Constant.t -> constant_body -> ml_schema -> unit -val lookup_cst_type : Constant.t -> constant_body -> ml_schema option +val add_cst_type : Constant.t -> Opaqueproof.opaque constant_body -> ml_schema -> unit +val lookup_cst_type : Constant.t -> Opaqueproof.opaque constant_body -> ml_schema option val add_ind : MutInd.t -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : MutInd.t -> mutual_inductive_body -> ml_ind option diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 6494e90a03..ce7d149ae1 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -414,7 +414,7 @@ let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * V match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition ~ontop:pstate + ComDefinition.do_definition ~program_mode:false fname (Decl_kinds.Global,false,Decl_kinds.Definition) pl diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 469551809c..12b12bc7b0 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -278,7 +278,7 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF } | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) - => { VtUnknown, VtNow } + => { (if Lib.is_modtype() then VtSideff([n]) else VtStartProof(GuaranteesOpacity, [n])), VtLater } -> { add_morphism_infer atts m n } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index a68efa4713..963b7189f9 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1800,7 +1800,7 @@ let anew_instance ~pstate atts binders instance fields = let program_mode = atts.program in new_instance ~pstate ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) - ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info + ~global:atts.global ~generalize:false Hints.empty_hint_info let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v index 47fcac6481..4e8fe5a8ff 100644 --- a/plugins/micromega/DeclConstant.v +++ b/plugins/micromega/DeclConstant.v @@ -62,6 +62,7 @@ Instance DZO: DeclaredConstant Z0 := {}. Instance DZpos: DeclaredConstant Zpos := {}. Instance DZneg: DeclaredConstant Zneg := {}. Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. +Instance DZpow : DeclaredConstant Z.pow := {}. Require Import QArith. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 6112eda200..830cbdf7f6 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -55,7 +55,7 @@ Extract Constant Rinv => "fun x -> 1 / x". extraction is only performed as a test in the test suite. *) (*Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index ab218a1778..953690c510 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -75,6 +75,21 @@ Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). +Fixpoint Zeval_const (e: PExpr Z) : option Z := + match e with + | PEc c => Some c + | PEX _ x => None + | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) + (Zeval_const e1) (Zeval_const e2) + | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) + (Zeval_const e1) (Zeval_const e2) + | PEpow e1 n => map_option (fun x => Some (Z.pow x (Z.of_N n))) + (Zeval_const e1) + | PEsub e1 e2 => map_option2 (fun x y => Some (x - y)) + (Zeval_const e1) (Zeval_const e2) + | PEopp e => map_option (fun x => Some (Z.opp x)) (Zeval_const e) + end. + Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. Proof. destruct n. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index de9dec0f74..bed9e55ac0 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -346,7 +346,9 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") - let coq_GT = lazy (m_constant "GT") + (* let coq_GT = lazy (m_constant "GT")*) + + let coq_DeclaredConstant = lazy (m_constant "DeclaredConstant") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" @@ -462,13 +464,24 @@ struct what to consider as a constant (see [parse_constant]) *) - let is_ground_term env sigma term = - let typ = Retyping.get_type_of env sigma term in - try - ignore (Typeclasses.resolve_one_typeclass env sigma (EConstr.mkApp(Lazy.force coq_GT,[| typ;term|]))) ; - true - with - | Not_found -> false + let is_declared_term env evd t = + match EConstr.kind evd t with + | Const _ | Construct _ -> (* Restrict typeclass resolution to trivial cases *) + begin + let typ = Retyping.get_type_of env evd t in + try + ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true + with Not_found -> false + end + | _ -> false + + let rec is_ground_term env evd term = + match EConstr.kind evd term with + | App(c,args) -> + is_declared_term env evd c && + Array.for_all (is_ground_term env evd) args + | Const _ | Construct _ -> is_declared_term env evd term + | _ -> false let parse_z sigma term = @@ -674,26 +687,28 @@ struct let parse_zop gl (op,args) = let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" + match args with + | [| a1 ; a2|] -> assoc_const sigma op zop_table, a1, a2 + | [| ty ; a1 ; a2|] -> + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_Z) + then (Mc.OpEq, args.(1), args.(2)) + else raise ParseError + | _ -> raise ParseError let parse_rop gl (op,args) = let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" + match args with + | [| a1 ; a2|] -> assoc_const sigma op rop_table, a1 , a2 + | [| ty ; a1 ; a2|] -> + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_R) + then (Mc.OpEq, a1, a2) + else raise ParseError + | _ -> raise ParseError let parse_qop gl (op,args) = - (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) + if Array.length args = 2 + then (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) + else raise ParseError type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) @@ -804,7 +819,7 @@ struct (op expr1 expr2,env) in try (Mc.PEc (parse_constant gl term) , env) - with ParseError -> + with ParseError -> match EConstr.kind gl.sigma term with | App(t,args) -> ( @@ -820,7 +835,7 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with e when CErrors.noncritical e -> + with ParseError -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end @@ -858,19 +873,48 @@ struct coq_Ropp , Opp ; coq_Rpower , Power] - (** [parse_constant parse gl t] returns the reification of term [t]. + let parse_constant parse gl t = parse gl.sigma t + + (** [parse_more_constant parse gl t] returns the reification of term [t]. If [t] is a ground term, then it is first reduced to normal form before using a 'syntactic' parser *) - let parse_constant parse gl t = - if is_ground_term gl.env gl.sigma t - then - parse gl.sigma (Redexpr.cbv_vm gl.env gl.sigma t) - else raise ParseError + let parse_more_constant parse gl t = + try + parse gl t + with ParseError -> + begin + if debug then Feedback.msg_debug Pp.(str "try harder"); + if is_ground_term gl.env gl.sigma t + then parse gl (Redexpr.cbv_vm gl.env gl.sigma t) + else raise ParseError + end let zconstant = parse_constant parse_z let qconstant = parse_constant parse_q let nconstant = parse_constant parse_nat + (** [parse_more_zexpr parse_constant gl] improves the parsing of exponent + which can be arithmetic expressions (without variables). + [parse_constant_expr] returns a constant if the argument is an expression without variables. *) + + let rec parse_zexpr gl = + parse_expr gl + zconstant + (fun expr (x:EConstr.t) -> + let z = parse_zconstant gl x in + match z with + | Mc.Zneg _ -> Mc.PEc Mc.Z0 + | _ -> Mc.PEpow(expr, Mc.Z.to_N z) + ) + zop_spec + and parse_zconstant gl e = + let (e,_) = parse_zexpr gl (Env.empty gl) e in + match Mc.zeval_const e with + | None -> raise ParseError + | Some z -> z + + + (* NB: R is a different story. Because it is axiomatised, reducing would not be effective. Therefore, there is a specific parser for constant over R @@ -905,7 +949,7 @@ struct let b = rconstant args.(1) in f a b with - ParseError -> + ParseError -> match op with | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> let arg = rconstant args.(0) in @@ -913,12 +957,12 @@ struct then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> - Mc.CPow(rconstant args.(0) , Mc.Inr (nconstant gl args.(1))) + Mc.CPow(rconstant args.(0) , Mc.Inr (parse_more_constant nconstant gl args.(1))) | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (qconstant gl args.(0)) | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> - Mc.CZ (zconstant gl args.(0)) - | _ -> raise ParseError + Mc.CZ (parse_more_constant zconstant gl args.(0)) + | _ -> raise ParseError end | _ -> raise ParseError in @@ -934,14 +978,6 @@ struct res - let parse_zexpr gl = parse_expr gl - zconstant - (fun expr x -> - let exp = (zconstant gl x) in - match exp with - | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) - zop_spec let parse_qexpr gl = parse_expr gl qconstant @@ -952,7 +988,7 @@ struct begin match expr with | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) - | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError + | _ -> raise ParseError end | _ -> let exp = Mc.Z.to_N exp in Mc.PEpow(expr,exp)) @@ -1031,14 +1067,16 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> + | Prod(typ,a,b) when typ.binder_name = Anonymous || EConstr.Vars.noccurn sigma 1 b -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (Mc.TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> Mc.(FF,env,tg) - | _ when is_prop term -> Mc.X(term),env,tg - | _ -> raise ParseError + | _ -> if EConstr.eq_constr sigma term (Lazy.force coq_True) + then (Mc.TT,env,tg) + else if EConstr.eq_constr sigma term (Lazy.force coq_False) + then Mc.(FF,env,tg) + else if is_prop term then Mc.X(term),env,tg + else raise ParseError in xparse_formula env tg ((*Reductionops.whd_zeta*) term) @@ -1358,19 +1396,11 @@ let rec parse_hyps gl parse_arith env tg hyps = let (c,env,tg) = parse_formula gl parse_arith env tg t in ((i,c)::lhyps, env,tg) with e when CErrors.noncritical e -> (lhyps,env,tg) - (*(if debug then Printf.printf "parse_arith : %s\n" x);*) - - -(*exception ParseError*) - - let parse_goal gl parse_arith (env:Env.t) hyps term = - (* try*) let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in (lhyps,f,env) - (* with Failure x -> raise ParseError*) (** * The datastructures that aggregate theory-dependent proof values. @@ -1886,7 +1916,7 @@ let micromega_genr prover tac = ] with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") + | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index b34c3b2b7d..a64a5a84b3 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -230,6 +230,13 @@ module Coq_Pos = | XO p -> XO (mul p y) | XH -> y + (** val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) + + let rec iter f x = function + | XI n' -> f (iter f (iter f x n') n') + | XO n' -> iter f (iter f x n') n' + | XH -> f x + (** val size_nat : positive -> nat **) let rec size_nat = function @@ -398,6 +405,18 @@ module Z = | Zpos y' -> Zneg (Coq_Pos.mul x' y') | Zneg y' -> Zpos (Coq_Pos.mul x' y')) + (** val pow_pos : z -> positive -> z **) + + let pow_pos z0 = + Coq_Pos.iter (mul z0) (Zpos XH) + + (** val pow : z -> z -> z **) + + let pow x = function + | Z0 -> Zpos XH + | Zpos p -> pow_pos x p + | Zneg _ -> Z0 + (** val compare : z -> z -> comparison **) let compare x y = @@ -460,6 +479,12 @@ module Z = | O -> Z0 | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + (** val of_N : n -> z **) + + let of_N = function + | N0 -> Z0 + | Npos p -> Zpos p + (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = @@ -1642,6 +1667,21 @@ let rec vm_add default x v = function | XO p -> Branch ((vm_add default p v l), o, r) | XH -> Branch (l, v, r)) +(** val zeval_const : z pExpr -> z option **) + +let rec zeval_const = function +| PEc c -> Some c +| PEX _ -> None +| PEadd (e1, e2) -> + map_option2 (fun x y -> Some (Z.add x y)) (zeval_const e1) (zeval_const e2) +| PEsub (e1, e2) -> + map_option2 (fun x y -> Some (Z.sub x y)) (zeval_const e1) (zeval_const e2) +| PEmul (e1, e2) -> + map_option2 (fun x y -> Some (Z.mul x y)) (zeval_const e1) (zeval_const e2) +| PEopp e0 -> map_option (fun x -> Some (Z.opp x)) (zeval_const e0) +| PEpow (e1, n0) -> + map_option (fun x -> Some (Z.pow x (Z.of_N n0))) (zeval_const e1) + type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 5de6caac0b..64cb3a8355 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -86,6 +86,8 @@ module Coq_Pos : val mul : positive -> positive -> positive + val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 + val size_nat : positive -> nat val compare_cont : comparison -> positive -> positive -> comparison @@ -124,6 +126,10 @@ module Z : val mul : z -> z -> z + val pow_pos : z -> positive -> z + + val pow : z -> z -> z + val compare : z -> z -> comparison val leb : z -> z -> bool @@ -140,6 +146,8 @@ module Z : val of_nat : nat -> z + val of_N : n -> z + val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z @@ -179,20 +187,20 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 - pol -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol + -> 'a1 pol val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> + 'a1 pol -> 'a1 pol val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 + pol -> positive -> 'a1 pol -> 'a1 pol val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol @@ -205,20 +213,19 @@ val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 - pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> - 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol -> 'a1 pol val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -232,16 +239,16 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type ('tA, 'tX, 'aA, 'aF) gFormula = | TT @@ -253,8 +260,7 @@ type ('tA, 'tX, 'aA, 'aF) gFormula = | N of ('tA, 'tX, 'aA, 'aF) gFormula | I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula -val mapX : - ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula +val mapX : ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 @@ -278,37 +284,36 @@ val cnf_tt : ('a1, 'a2) cnf val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> - ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, + 'a2) clause option val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) - clause -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> + ('a1, 'a2) clause option val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> + ('a1, 'a2) cnf val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> - ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> - ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> + 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum val ror_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> + (('a1, 'a2) clause, 'a2 list) sum val ror_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause @@ -319,17 +324,16 @@ val ror_cnf : clause list -> ('a1, 'a2) cnf * 'a2 list val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> - ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> + 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 + list -val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool +val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> - ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, - 'a3, unit0) gFormula -> 'a4 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> + 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) + gFormula -> 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -363,27 +367,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> + 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -396,8 +400,8 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> @@ -407,20 +411,20 @@ val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -475,6 +479,8 @@ val singleton : 'a1 -> positive -> 'a1 -> 'a1 t val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t +val zeval_const : z pExpr -> z option + type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool @@ -563,12 +569,12 @@ val bound_var : positive -> z formula val mk_eq_pos : positive -> positive -> positive -> z formula val bound_vars : - (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, - 'a1, 'a2, 'a3) gFormula + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, + 'a2, 'a3) gFormula val bound_problem_fr : - (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, - 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, 'a3) + gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula val zChecker : z nFormula list -> zArithProof -> bool diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 695f000cb1..23d7b141a4 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -359,7 +359,10 @@ Ltac zify_positive_rel := Ltac zify_positive_op := match goal with - (* Zneg -> -Zpos (except for numbers) *) + (* Z.pow_pos -> Z.pow *) + | H : context [ Z.pow_pos ?a ?b ] |- _ => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) in H + | |- context [ Z.pow_pos ?a ?b ] => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) + (* Zneg -> -Zpos (except for numbers) *) | H : context [ Zneg ?a ] |- _ => let isp := isPcst a in match isp with @@ -377,6 +380,10 @@ Ltac zify_positive_op := | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + (* Z.power_pos *) + | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H + | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + (* Pos.add -> Z.add *) | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index c9f18d89be..5ea9b79336 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -145,7 +145,7 @@ let mkSTACK = function type cbv_infos = { env : Environ.env; - tab : cbv_value Declarations.constant_def KeyTable.t; + tab : (cbv_value, Empty.t) Declarations.constant_def KeyTable.t; reds : RedFlags.reds; sigma : Evd.evar_map } diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 78733784a7..9d3ed40f6c 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -339,8 +339,7 @@ let tag_var = tag Tag.variable let pr_binder many pr (nal,k,t) = match k with - | Generalized (b, b', t') -> - assert (match b with Implicit -> true | _ -> false); + | Generalized (b', t') -> begin match nal with |[{loc; v=Anonymous}] -> hov 1 (str"`" ++ (surround_impl b' diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 2493b1fac4..8b455821af 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -125,7 +125,7 @@ module Make(T : Task) () = struct "-async-proofs-worker-priority"; CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] (* Options to discard: 0 arguments *) - | ("-emacs"|"-emacs-U"|"-batch")::tl -> + | ("-emacs"|"-batch")::tl -> set_slave_opt tl (* Options to discard: 1 argument *) | ( "-async-proofs" | "-vio2vo" | "-o" diff --git a/stm/stm.ml b/stm/stm.ml index 21618bc044..6f7cefb582 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -364,7 +364,6 @@ module VCS : sig val set_parsing_state : id -> Vernacstate.Parser.state -> unit val get_parsing_state : id -> Vernacstate.Parser.state option val get_proof_mode : id -> Pvernac.proof_mode option - val set_proof_mode : id -> Pvernac.proof_mode option -> unit (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs @@ -572,6 +571,7 @@ end = struct (* {{{ *) (match Vernacprop.under_control x with | VernacDefinition (_,({CAst.v=Name i},_),_) -> Id.to_string i | VernacStartTheoremProof (_,[({CAst.v=i},_),_]) -> Id.to_string i + | VernacInstance (_,(({CAst.v=Name i},_),_,_),_,_) -> Id.to_string i | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind @@ -611,7 +611,6 @@ end = struct (* {{{ *) info.state <- new_state let get_proof_mode id = (get_info id).proof_mode - let set_proof_mode id pm = (get_info id).proof_mode <- pm let reached id = let info = get_info id in @@ -3050,53 +3049,6 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.set_parsing_state id parsing_state) new_ids; `Ok - (* Unknown: we execute it, check for open goals and propagate sideeff *) - | VtUnknown, VtNow -> - let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in - if not (get_allow_nested_proofs ()) && in_proof then - "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." - |> Pp.str - |> (fun s -> (UserError (None, s), Exninfo.null)) - |> State.exn_on ~valid:Stateid.dummy newtip - |> Exninfo.iraise - else - let id = VCS.new_node ~id:newtip proof_mode () in - let head_id = VCS.get_branch_pos head in - let _st : unit = Reach.known_state ~doc ~cache:true head_id in (* ensure it is ok *) - let step () = - VCS.checkout VCS.Branch.master; - let mid = VCS.get_branch_pos VCS.Branch.master in - let _st' : unit = Reach.known_state ~doc ~cache:(VCS.is_interactive ()) mid in - let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_vernac_interp id st x); - (* Vernac x may or may not start a proof *) - if not in_proof && PG_compat.there_are_pending_proofs () then - begin - let bname = VCS.mk_branch_name x in - let opacity_of_produced_term = function - (* This AST is ambiguous, hence we check it dynamically *) - | VernacInstance (_,_ , None, _) -> GuaranteesOpacity - | _ -> Doesn'tGuaranteeOpacity in - VCS.commit id (Fork (x,bname,opacity_of_produced_term (Vernacprop.under_control x.expr),[])); - VCS.set_proof_mode id (Some (Vernacentries.get_default_proof_mode ())); - VCS.branch bname (`Proof (VCS.proof_nesting () + 1)); - end else begin - begin match (VCS.get_branch head).VCS.kind with - | `Edit _ -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); - | `Master -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); - | `Proof _ -> - VCS.commit id (mkTransCmd x [] in_proof `MainQueue); - (* We hope it can be replayed, but we can't really know *) - ignore(VCS.propagate_sideff ~action:(ReplayCommand x)); - end; - VCS.checkout_shallowest_proof_branch (); - end in - State.define ~doc ~safe_id:head_id ~cache:true step id; - Backtrack.record (); `Ok - - | VtUnknown, VtLater -> - anomaly(str"classifier: VtUnknown must imply VtNow.") - | VtProofMode pm, VtNow -> let proof_mode = Pvernac.lookup_proof_mode pm in let id = VCS.new_node ~id:newtip proof_mode () in @@ -3106,7 +3058,6 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtProofMode _, VtLater -> anomaly(str"classifier: VtProofMode must imply VtNow.") - end in let pr_rc rc = match rc with | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 4a4c5c94e9..7cecd801e4 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -21,7 +21,6 @@ let string_of_parallel = function | `No -> "" let string_of_vernac_type = function - | VtUnknown -> "Unknown" | VtStartProof _ -> "StartProof" | VtSideff _ -> "Sideff" | VtQed (VtKeep VtKeepAxiom) -> "Qed(admitted)" @@ -61,7 +60,7 @@ let options_affecting_stm_scheduling = ] let classify_vernac e = - let static_classifier ~poly e = match e with + let static_classifier ~atts e = match e with (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) @@ -97,15 +96,18 @@ let classify_vernac e = VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater | VernacDefinition (_,({v=i},_),ProveBody _) -> - let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof(guarantee, idents_of_name i), VtLater + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in + let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof(guarantee, idents_of_name i), VtLater | VernacStartTheoremProof (_,l) -> - let ids = List.map (fun (({v=i}, _), _) -> i) l in - let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof (guarantee,ids), VtLater + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in + let ids = List.map (fun (({v=i}, _), _) -> i) l in + let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof (guarantee,ids), VtLater | VernacFixpoint (discharge,l) -> + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = - if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity + if discharge = Decl_kinds.DoDischarge || polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in let ids, open_proof = @@ -115,8 +117,9 @@ let classify_vernac e = then VtStartProof (guarantee,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (discharge,l) -> + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = - if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity + if discharge = Decl_kinds.DoDischarge || polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in let ids, open_proof = @@ -185,8 +188,12 @@ let classify_vernac e = | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) -> VtSideff [], VtNow | VernacProofMode pm -> VtProofMode pm, VtNow - (* These are ambiguous *) - | VernacInstance _ -> VtUnknown, VtNow + | VernacInstance (_,((name,_),_,_),None,_) when not (Attributes.parse_drop_extra Attributes.program atts) -> + let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in + let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in + VtStartProof (guarantee, idents_of_name name.CAst.v), VtLater + | VernacInstance (_,((name,_),_,_),_,_) -> + VtSideff (idents_of_name name.CAst.v), VtLater (* Stm will install a new classifier to handle these *) | VernacBack _ | VernacAbortAll | VernacUndoTo _ | VernacUndo _ @@ -201,9 +208,8 @@ let classify_vernac e = with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier v = v |> CAst.with_val (function - | VernacExpr (f, e) -> - let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in - static_classifier ~poly e + | VernacExpr (atts, e) -> + static_classifier ~atts e | VernacTimeout (_,e) -> static_control_classifier e | VernacTime (_,e) | VernacRedirect (_, e) -> static_control_classifier e @@ -214,6 +220,6 @@ let classify_vernac e = | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtLater - | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater)) + | (VtStartProof _ | VtProofMode _), _ -> VtQuery, VtLater)) in static_control_classifier e diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 69c1d9bd23..0f78e0acf6 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -10,11 +10,11 @@ open Util -let check_vio (ts,f) = +let check_vio (ts,f_in) = Dumpglob.noglob (); - let long_f_dot_v, _, _, _, _, tasks, _ = Library.load_library_todo f in - Stm.set_compilation_hints long_f_dot_v; - List.fold_left (fun acc ids -> Stm.check_task f tasks ids && acc) true ts + let _, _, _, _, tasks, _ = Library.load_library_todo f_in in + Stm.set_compilation_hints f_in; + List.fold_left (fun acc ids -> Stm.check_task f_in tasks ids && acc) true ts module Worker = Spawn.Sync () @@ -28,15 +28,12 @@ module Pool = Map.Make(IntOT) let schedule_vio_checking j fs = if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in - List.iter (fun f -> - let f = - if Filename.check_suffix f ".vio" then Filename.chop_extension f - else f in - let long_f_dot_v, _,_,_,_, tasks, _ = Library.load_library_todo f in - Stm.set_compilation_hints long_f_dot_v; + List.iter (fun long_f_dot_vio -> + let _,_,_,_, tasks, _ = Library.load_library_todo long_f_dot_vio in + Stm.set_compilation_hints long_f_dot_vio; let infos = Stm.info_tasks tasks in let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in - if infos <> [] then jobs := (f, eta, infos) :: !jobs) + if infos <> [] then jobs := (long_f_dot_vio, eta, infos) :: !jobs) fs; let cmp_job (_,t1,_) (_,t2,_) = compare t2 t1 in jobs := List.sort cmp_job !jobs; @@ -103,16 +100,12 @@ let schedule_vio_checking j fs = let schedule_vio_compilation j fs = if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in - List.iter (fun f -> - let f = - if Filename.check_suffix f ".vio" then Filename.chop_extension f - else f in - let long_f_dot_v = Loadpath.locate_file (f^".v") in - let aux = Aux_file.load_aux_file_for long_f_dot_v in + List.iter (fun long_f_dot_vio -> + let aux = Aux_file.load_aux_file_for long_f_dot_vio in let eta = try float_of_string (Aux_file.get aux "vo_compile_time") with Not_found -> 0.0 in - jobs := (f, eta) :: !jobs) + jobs := (long_f_dot_vio, eta) :: !jobs) fs; let cmp_job (_,t1) (_,t2) = compare t2 t1 in jobs := List.sort cmp_job !jobs; @@ -146,7 +139,7 @@ let schedule_vio_compilation j fs = (* set the access and last modification time of all files to the same t * not to confuse make into thinking that some of them are outdated *) let t = Unix.gettimeofday () in - List.iter (fun (f,_) -> Unix.utimes (f^".vo") t t) all_jobs; + List.iter (fun (f,_) -> Unix.utimes (Filename.chop_extension f^".vo") t t) all_jobs; end; exit !rc diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 499152f39a..6dd9a976f9 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -158,9 +158,9 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl + Declare.declare_private_constant ~role:Entries.Subproof ~internal:Declare.InternalTacticRequest ~local:true id decl in - let cst = Impargs.with_implicit_protection cst () in + let cst, eff = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with | Entries.Monomorphic_entry _ -> EInstance.empty | Entries.Polymorphic_entry (_, ctx) -> @@ -174,7 +174,6 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in - let eff = private_constant (Global.safe_env ()) Entries.Subproof cst in let effs = concat_private eff Entries.(snd (Future.force const.const_entry_body)) in let solve = diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e95778a90d..b9485b8823 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -116,8 +116,7 @@ let compute_name internal id = | InternalTacticRequest -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name -let define internal id c poly univs = - let fd = declare_constant ~internal in +let define internal role 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 @@ -133,12 +132,12 @@ let define internal id c poly univs = const_entry_inline_code = false; const_entry_feedback = None; } in - let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in + let kn, eff = declare_private_constant ~role ~internal id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in let () = match internal with | InternalTacticRequest -> () | _-> definition_message id in - kn + kn, eff let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let (c, ctx), eff = f mode ind in @@ -146,9 +145,8 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define mode id c (Declareops.inductive_is_polymorphic mib) ctx in let role = Entries.Schema (ind, kind) in - let neff = Safe_typing.private_constant (Global.safe_env ()) role const in + let const, neff = define mode role id c (Declareops.inductive_is_polymorphic mib) ctx in declare_scheme kind [|ind,const|]; const, Safe_typing.concat_private neff eff @@ -165,9 +163,8 @@ let define_mutual_scheme_base kind suff f mode names mind = try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let fold i effs id cl = - let cst = define mode id cl (Declareops.inductive_is_polymorphic mib) ctx in let role = Entries.Schema ((mind, i), kind)in - let neff = Safe_typing.private_constant (Global.safe_env ()) role cst in + let cst, neff = define mode role id cl (Declareops.inductive_is_polymorphic mib) ctx in (Safe_typing.concat_private neff effs, cst) in let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2bdfc85d6d..9dafa8bad9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -614,7 +614,7 @@ let cofix id = mutual_cofix id [] 0 type tactic_reduction = Reductionops.reduction_function type e_tactic_reduction = Reductionops.e_reduction_function -let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = +let e_pf_change_decl (redfun : bool -> e_reduction_function) where env sigma decl = let open Context.Named.Declaration in match decl with | LocalAssum (id,ty) -> @@ -713,28 +713,61 @@ let e_change_in_hyp ~check ~reorder redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id gl in - let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + let (sigma, c) = e_pf_change_decl redfun where (Proofview.Goal.env gl) sigma hyp in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (convert_hyp ~check ~reorder c) end +type hyp_conversion = +| AnyHypConv (** Arbitrary conversion *) +| StableHypConv (** Does not introduce new dependencies on variables *) +| LocalHypConv (** Same as above plus no dependence on the named environment *) + let e_change_in_hyps ~check ~reorder f args = Proofview.Goal.enter begin fun gl -> - let fold (env, sigma) arg = - let (redfun, id, where) = f arg in - let hyp = - try lookup_named id env - with Not_found -> - raise (RefinerError (env, sigma, NoSuchHyp id)) + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (env, sigma) = match reorder with + | LocalHypConv -> + (* If the reduction function is known not to depend on the named + context, then we can perform it in parallel. *) + let fold accu arg = + let (id, redfun) = f arg in + let old = try Id.Map.find id accu with Not_found -> [] in + Id.Map.add id (redfun :: old) accu + in + let reds = List.fold_left fold Id.Map.empty args in + let evdref = ref sigma in + let map d = + let id = NamedDecl.get_id d in + match Id.Map.find id reds with + | reds -> + let d = EConstr.of_named_decl d in + let fold redfun (sigma, d) = redfun env sigma d in + let (sigma, d) = List.fold_right fold reds (sigma, d) in + let () = evdref := sigma in + EConstr.Unsafe.to_named_decl d + | exception Not_found -> d in - let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in - let sign = Logic.convert_hyp ~check ~reorder env sigma d in + let sign = Environ.map_named_val map (Environ.named_context_val env) in let env = reset_with_named_context sign env in - (env, sigma) + (env, !evdref) + | StableHypConv | AnyHypConv -> + let reorder = reorder == AnyHypConv in + let fold (env, sigma) arg = + let (id, redfun) = f arg in + let hyp = + try lookup_named id env + with Not_found -> + raise (RefinerError (env, sigma, NoSuchHyp id)) + in + let (sigma, d) = redfun env sigma hyp in + let sign = Logic.convert_hyp ~check ~reorder env sigma d in + let env = reset_with_named_context sign env in + (env, sigma) + in + List.fold_left fold (env, sigma) args in - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let (env, sigma) = List.fold_left fold (env, sigma) args in let ty = Proofview.Goal.concl gl in Proofview.Unsafe.tclEVARS sigma <*> @@ -851,10 +884,12 @@ let change ~check chg c cls = let f (id, occs, where) = let occl = bind_change_occurrences occs chg in let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in - (redfun, id, where) + let redfun env sigma d = e_pf_change_decl redfun where env sigma d in + (id, redfun) in + let reorder = if check then AnyHypConv else StableHypConv in (* Don't check, we do it already in [change_on_subterm] *) - e_change_in_hyps ~check:false ~reorder:check f hyps + e_change_in_hyps ~check:false ~reorder f hyps end let change_concl t = @@ -881,6 +916,22 @@ let pattern_option l = e_reduct_option ~check:false (pattern_occs l,DEFAULTcast) (* The main reduction function *) +let is_local_flag env flags = + if flags.rDelta then false + else + let check = function + | EvalVarRef _ -> false + | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (ConstRef c)) + in + List.for_all check flags.rConst + +let is_local_unfold env flags = + let check (_, c) = match c with + | EvalVarRef _ -> false + | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (ConstRef c)) + in + List.for_all check flags + let reduce redexp cl = let trace env sigma = let open Printer in @@ -889,23 +940,33 @@ let reduce redexp cl = in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in - let reorder = match redexp with Fold _ | Pattern _ -> true | _ -> false in + let reorder = match redexp with + | Fold _ | Pattern _ -> AnyHypConv + | Simpl (flags, _) | Cbv flags | Cbn flags | Lazy flags -> + if is_local_flag env flags then LocalHypConv else StableHypConv + | Unfold flags -> + if is_local_unfold env flags then LocalHypConv else StableHypConv + | Red _ | Hnf | CbvVm _ | CbvNative _ -> StableHypConv + | ExtraRedExpr _ -> StableHypConv (* Should we be that lenient ?*) + in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> let redexp = bind_red_expr_occurrences occs nbcl redexp in - let redfun = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + let redfun = Redexpr.reduction_of_red_expr env redexp in e_change_in_concl ~check (revert_cast redfun) end <*> let f (id, occs, where) = let redexp = bind_red_expr_occurrences occs nbcl redexp in - let (redfun, _) = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in let redfun _ env sigma c = redfun env sigma c in - (redfun, id, where) + let redfun env sigma d = e_pf_change_decl redfun where env sigma d in + (id, redfun) in e_change_in_hyps ~check ~reorder f hyps end diff --git a/test-suite/bugs/closed/bug_10176.v b/test-suite/bugs/closed/bug_10176.v new file mode 100644 index 0000000000..fdb0eb87a4 --- /dev/null +++ b/test-suite/bugs/closed/bug_10176.v @@ -0,0 +1,7 @@ +Class Foo (xxx:nat) := foo : nat. + +Lemma aa `{Foo} : nat. Abort. + +Fail Lemma xy (Foo:bool->Type) `{Foo} : nat. + +Fail Lemma yx (Fooo:bool->Type) `{Fooo} : nat. diff --git a/test-suite/bugs/closed/bug_10189.v b/test-suite/bugs/closed/bug_10189.v new file mode 100644 index 0000000000..d603bff386 --- /dev/null +++ b/test-suite/bugs/closed/bug_10189.v @@ -0,0 +1,9 @@ +Definition foo : forall (x := unit) {y : nat}, nat := fun y => y. +Check foo (y := 3). (*We fail to get implicits in the type past a let-in*) +Definition foo' : forall (x : Set) {y : nat}, nat := fun _ y => y. +Check foo' unit (y := 3). (* It works with a function binder *) + +Definition bar := let f {x} : nat -> nat := fun y => x in f (x := 3). +(* Adding bar : nat -> nat gives implicits-in-term warning *) +Fail Check bar (x := 3). +(* The implicits from the type of the local definition leak to the outer term *) diff --git a/test-suite/bugs/closed/bug_3890.v b/test-suite/bugs/closed/bug_3890.v new file mode 100644 index 0000000000..e1823ac54c --- /dev/null +++ b/test-suite/bugs/closed/bug_3890.v @@ -0,0 +1,12 @@ +Set Nested Proofs Allowed. + +Class Foo. +Class Bar := b : Type. + +Instance foo : Foo. + +Instance bar : Bar. +exact Type. +Defined. + +Defined. diff --git a/test-suite/bugs/closed/bug_4429.v b/test-suite/bugs/closed/bug_4429.v deleted file mode 100644 index bf0e570ab8..0000000000 --- a/test-suite/bugs/closed/bug_4429.v +++ /dev/null @@ -1,31 +0,0 @@ -Require Import Arith.Compare_dec. -Require Import Unicode.Utf8. - -Fixpoint my_nat_iter (n : nat) {A} (f : A → A) (x : A) : A := - match n with - | O => x - | S n' => f (my_nat_iter n' f x) - end. - -Definition gcd_IT_F (f : nat * nat → nat) (mn : nat * nat) : nat := - match mn with - | (0, 0) => 0 - | (0, S n') => S n' - | (S m', 0) => S m' - | (S m', S n') => - match le_gt_dec (S m') (S n') with - | left _ => f (S m', S n' - S m') - | right _ => f (S m' - S n', S n') - end - end. - -Axiom max_correct_l : ∀ m n : nat, m <= max m n. -Axiom max_correct_r : ∀ m n : nat, n <= max m n. - -Hint Resolve max_correct_l max_correct_r : arith. - -Theorem foo : ∀ p p' p'' : nat, p'' < S (max p (max p' p'')). -Proof. - intros. - Timeout 3 eauto with arith. -Qed. diff --git a/test-suite/bugs/closed/bug_4580.v b/test-suite/bugs/closed/bug_4580.v index a8a446cc9b..3f40569d61 100644 --- a/test-suite/bugs/closed/bug_4580.v +++ b/test-suite/bugs/closed/bug_4580.v @@ -2,6 +2,5 @@ Require Import Program. Class Foo (A : Type) := foo : A. -Unset Refine Instance Mode. Program Instance f1 : Foo nat := S _. Next Obligation. exact 0. Defined. diff --git a/test-suite/bugs/closed/bug_4638.v b/test-suite/bugs/closed/bug_4638.v new file mode 100644 index 0000000000..951fe5302b --- /dev/null +++ b/test-suite/bugs/closed/bug_4638.v @@ -0,0 +1,12 @@ +Set Nested Proofs Allowed. + +Class Foo. + +Goal True. + +Instance foo: Foo. +Qed. + +trivial. + +Qed. diff --git a/test-suite/bugs/opened/bug_3890.v b/test-suite/bugs/opened/bug_3890.v deleted file mode 100644 index 9d83743b2a..0000000000 --- a/test-suite/bugs/opened/bug_3890.v +++ /dev/null @@ -1,22 +0,0 @@ -Set Nested Proofs Allowed. - -Class Foo. -Class Bar := b : Type. - -Set Refine Instance Mode. -Instance foo : Foo := _. -Unset Refine Instance Mode. -(* 1 subgoals, subgoal 1 (ID 4) - - ============================ - Foo *) - -Instance bar : Bar. -exact Type. -Defined. -(* bar is defined *) - -About foo. -(* foo not a defined object. *) - -Fail Defined. diff --git a/test-suite/micromega/bug_10158.v b/test-suite/micromega/bug_10158.v new file mode 100644 index 0000000000..2c8f798f12 --- /dev/null +++ b/test-suite/micromega/bug_10158.v @@ -0,0 +1,48 @@ +Require Import ZArith_base. +Require Import Coq.micromega.Lia. + +Open Scope Z_scope. + +Fixpoint fib (n: nat) : Z := + match n with + | O => 1 + | S O => 1 + | S (S n as p) => fib p + fib n + end. + +Axiom fib_47_computed: fib 47 = 2971215073. + +Lemma fib_bound: + fib 47 < 2 ^ 32. +Proof. + pose proof fib_47_computed. + lia. +Qed. + +Require Import Reals. +Require Import Coq.micromega.Lra. + +Open Scope R_scope. + +Fixpoint fibr (n: nat) : R := + match n with + | O => 1 + | S O => 1 + | S (S n as p) => fibr p + fibr n + end. + +Axiom fibr_47_computed: fibr 47 = 2971215073. + +Lemma fibr_bound: + fibr 47 < 2 ^ 32. +Proof. + pose proof fibr_47_computed. + lra. +Qed. + +Lemma fibr_bound': + fibr 47 < IZR (Z.pow_pos 2 32). +Proof. + pose proof fibr_47_computed. + lra. +Qed. diff --git a/test-suite/micromega/rsyntax.v b/test-suite/micromega/rsyntax.v index 02b98b562f..f02d93f911 100644 --- a/test-suite/micromega/rsyntax.v +++ b/test-suite/micromega/rsyntax.v @@ -57,15 +57,7 @@ Require Import Lia. Goal ( 1 ^ (2 + 2) = 1)%Z. Proof. - Fail lia. - reflexivity. -Qed. - -Instance DZplus : DeclaredConstant Z.add := {}. - -Goal ( 1 ^ (2 + 2) = 1)%Z. -Proof. - lia. + lia. (* exponent is a constant expr *) Qed. diff --git a/test-suite/misc/changelog.sh b/test-suite/misc/changelog.sh index 8b4a49e577..ed473e5874 100755 --- a/test-suite/misc/changelog.sh +++ b/test-suite/misc/changelog.sh @@ -1,11 +1,9 @@ #!/bin/sh -while read line; do - if [ "$line" = "is_a_released_version = False" ]; then +if grep -q -F "is_a_released_version = False" ../config/coq_config.py; then echo "This is not a released version: nothing to test." exit 0 - fi -done < ../config/coq_config.py +fi for d in ../doc/changelog/*; do if [ -d "$d" ]; then diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index 7429a521b3..c0ef9b392d 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -7,8 +7,8 @@ Require Import QMicromega. Require Import RMicromega. Recursive Extraction - Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ +Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 3888cafed3..736d05fefc 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -198,9 +198,7 @@ Module UniqueInstances. for it. *) Set Typeclasses Unique Instances. Class Eq (A : Type) : Set. - Set Refine Instance Mode. - Instance eqa : Eq nat := _. constructor. Qed. - Unset Refine Instance Mode. + Instance eqa : Eq nat. Qed. Instance eqb : Eq nat := {}. Class Foo (A : Type) (e : Eq A) : Set. Instance fooa : Foo _ eqa := {}. diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index 05d63d9a47..49e0af9b2c 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -14,4 +14,3 @@ Local Set Warnings "-deprecated". Require Export Coq.Compat.Coq810. Unset Private Polymorphic Universes. -Set Refine Instance Mode. diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 8934385091..2f63410761 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -73,14 +73,18 @@ let ensure_bname src tgt = let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt -let ensure_v v = ensure ".v" v v -let ensure_vo v vo = ensure ".vo" v vo -let ensure_vio v vio = ensure ".vio" v vio - let ensure_exists f = if not (Sys.file_exists f) then fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) +let ensure_exists_with_prefix f_in f_out src_suffix tgt_suffix = + let long_f_dot_src = ensure src_suffix f_in f_in in + ensure_exists long_f_dot_src; + let long_f_dot_tgt = match f_out with + | None -> chop_extension long_f_dot_src ^ tgt_suffix + | Some f -> ensure tgt_suffix long_f_dot_src f in + long_f_dot_src, long_f_dot_tgt + (* Compile a vernac file *) let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in @@ -102,12 +106,9 @@ let compile opts copts ~echo ~f_in ~f_out = match copts.compilation_mode with | BuildVo -> Flags.record_aux_file := true; - let long_f_dot_v = ensure_v f_in in - ensure_exists long_f_dot_v; - let long_f_dot_vo = - match f_out with - | None -> long_f_dot_v ^ "o" - | Some f -> ensure_vo long_f_dot_v f in + + let long_f_dot_v, long_f_dot_vo = + ensure_exists_with_prefix f_in f_out ".v" ".vo" in let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc @@ -138,13 +139,8 @@ let compile opts copts ~echo ~f_in ~f_out = Flags.record_aux_file := false; Dumpglob.noglob (); - let long_f_dot_v = ensure_v f_in in - ensure_exists long_f_dot_v; - - let long_f_dot_vio = - match f_out with - | None -> long_f_dot_v ^ "io" - | Some f -> ensure_vio long_f_dot_v f in + let long_f_dot_v, long_f_dot_vio = + ensure_exists_with_prefix f_in f_out ".v" ".vio" in (* We need to disable error resiliency, otherwise some errors will be ignored in batch mode. c.f. #6707 @@ -175,13 +171,15 @@ let compile opts copts ~echo ~f_in ~f_out = Stm.reset_task_queue () | Vio2Vo -> - let open Filename in + Flags.record_aux_file := false; Dumpglob.noglob (); - let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in - let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in - let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in - Library.save_library_raw lfdv sum lib univs proofs + let long_f_dot_vio, long_f_dot_vo = + ensure_exists_with_prefix f_in f_out ".vio" ".vo" in + let sum, lib, univs, disch, tasks, proofs = + Library.load_library_todo long_f_dot_vio in + let univs, proofs = Stm.finish_tasks long_f_dot_vo univs disch proofs tasks in + Library.save_library_raw long_f_dot_vo sum lib univs proofs let compile opts copts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); @@ -205,16 +203,22 @@ let compile_files opts copts = (******************************************************************************) let check_vio_tasks copts = let rc = - List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) + List.fold_left (fun acc (n,f) -> + let f_in = ensure ".vio" f f in + ensure_exists f_in; + Vio_checking.check_vio (n,f_in) && acc) true (List.rev copts.vio_tasks) in if not rc then fatal_error Pp.(str "VIO Task Check failed") (* vio files *) let schedule_vio copts = + let l = + List.map (fun f -> let f_in = ensure ".vio" f f in ensure_exists f_in; f_in) + copts.vio_files in if copts.vio_checking then - Vio_checking.schedule_vio_checking copts.vio_files_j copts.vio_files + Vio_checking.schedule_vio_checking copts.vio_files_j l else - Vio_checking.schedule_vio_compilation copts.vio_files_j copts.vio_files + Vio_checking.schedule_vio_compilation copts.vio_files_j l let do_vio opts copts = (* We must initialize the loadpath here as the vio scheduling diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 7445619d26..2279ce5505 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -56,6 +56,13 @@ let error_missing_arg s = prerr_endline "See -help for the syntax of supported options"; exit 1 +let check_compilation_output_name_consistency args = + match args.compilation_output_name, args.compile_list with + | Some _, _::_::_ -> + prerr_endline ("Error: option -o is not valid when more than one"); + prerr_endline ("file have to be compiled") + | _ -> () + 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 @@ -82,7 +89,22 @@ let set_vio_checking_j opts opt j = 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 set_compilation_mode opts mode = + match opts.compilation_mode with + | BuildVo -> { opts with compilation_mode = mode } + | mode' when mode <> mode' -> + prerr_endline "Options -quick and -vio2vo are exclusive"; + exit 1 + | _ -> opts + +let get_task_list s = + List.map (fun s -> + try int_of_string s + with Failure _ -> + prerr_endline "Option -check-vio-tasks expects a comma-separated list"; + prerr_endline "of integers followed by a list of files"; + exit 1) + (Str.split (Str.regexp ",") s) let is_not_dash_option = function | Some f when String.length f > 0 && f.[0] <> '-' -> true @@ -138,7 +160,7 @@ let parse arglist : t = | "-o" -> { oval with compilation_output_name = Some (next ()) } | "-quick" -> - { oval with compilation_mode = BuildVio } + set_compilation_mode oval BuildVio | "-check-vio-tasks" -> let tno = get_task_list (next ()) in let tfile = next () in @@ -157,7 +179,7 @@ let parse arglist : t = | "-vio2vo" -> let oval = add_compile ~echo:false oval (next ()) in - { oval with compilation_mode = Vio2Vo } + set_compilation_mode oval Vio2Vo | "-outputstate" -> set_outputstate oval (next ()) @@ -170,5 +192,7 @@ let parse arglist : t = in try let opts, extra = parse default in - List.fold_left add_compile opts extra + let args = List.fold_left add_compile opts extra in + check_compilation_output_name_consistency args; + args with any -> fatal_error any diff --git a/toplevel/usage.ml b/toplevel/usage.ml index da2094653b..29948d50b2 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -42,12 +42,12 @@ let print_usage_common co command = \n\ \n -load-ml-object f load ML object file f\ \n -load-ml-source f load ML file f\ -\n -load-vernac-source f load Coq file f.v (Load f.)\ +\n -load-vernac-source f load Coq file f.v (Load \"f\".)\ \n -l f (idem)\ -\n -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.)\ -\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 -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ +\n -lv f (idem)\ +\n -load-vernac-object path load Coq library path (Require path)\ \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ @@ -74,9 +74,9 @@ let print_usage_common co command = \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ -\n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ -\n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ -\n -unset \"Foo Bar\" disable Foo Bar (as Unset Foo Bar. in a file)\ +\n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ +\n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ +\n -unset \"Foo Bar\" disable Foo Bar (as Unset Foo Bar. in a file)\ \n -time display the time taken by each command\ \n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ @@ -107,7 +107,7 @@ coqtop specific options:\ exit 1 let print_usage_coqc () = - print_usage_common stderr "Usage: coqc <options> <Coq options> file..."; + print_usage_common stderr "Usage: coqc <options> <Coq options> file...\n\n"; output_string stderr "\n\ coqc specific options:\ \n\ diff --git a/user-contrib/Ltac2/tac2expr.mli b/user-contrib/Ltac2/tac2expr.mli index 1069d0bfa3..2e7dfc42db 100644 --- a/user-contrib/Ltac2/tac2expr.mli +++ b/user-contrib/Ltac2/tac2expr.mli @@ -173,7 +173,7 @@ type strexpr = (** {5 Dynamic semantics} *) -(** Values are represented in a way similar to OCaml, i.e. they constrast +(** Values are represented in a way similar to OCaml, i.e. they contrast immediate integers (integers, constructors without arguments) and structured blocks (tuples, arrays, constructors with arguments), as well as a few other base cases, namely closures, strings, named constructors, and dynamic type diff --git a/user-contrib/Ltac2/tac2intern.mli b/user-contrib/Ltac2/tac2intern.mli index d646b5cda5..829570a354 100644 --- a/user-contrib/Ltac2/tac2intern.mli +++ b/user-contrib/Ltac2/tac2intern.mli @@ -20,7 +20,7 @@ val is_value : glb_tacexpr -> bool val check_unit : ?loc:Loc.t -> type_scheme -> unit val check_subtype : type_scheme -> type_scheme -> bool -(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] +(** [check_subtype t1 t2] returns [true] iff all values of instances of type [t1] also have type [t2]. *) val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr diff --git a/user-contrib/Ltac2/tac2match.ml b/user-contrib/Ltac2/tac2match.ml index 058d02adde..354a578cb3 100644 --- a/user-contrib/Ltac2/tac2match.ml +++ b/user-contrib/Ltac2/tac2match.ml @@ -88,7 +88,7 @@ module PatternMatching (E:StaticEnvironment) = struct (** To focus on the algorithmic portion of pattern-matching, the bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) + backtracking monad of {!IStream.t} with a "writer" effect. *) (* spiwack: as we don't benefit from the various stream optimisations of Haskell, it may be costly to give the monad in direct style such as here. We may want to use some continuation passing style. *) diff --git a/vernac/classes.ml b/vernac/classes.ml index ece9fc8937..5a7f60584a 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -31,16 +31,6 @@ module NamedDecl = Context.Named.Declaration open Decl_kinds open Entries -let refine_instance = ref false - -let () = Goptions.(declare_bool_option { - optdepr = true; - optname = "definition of instances by refining"; - optkey = ["Refine";"Instance";"Mode"]; - optread = (fun () -> !refine_instance); - optwrite = (fun b -> refine_instance := b) -}) - let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) @@ -328,6 +318,7 @@ let instance_hook k info global imps ?hook cst = (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k info global imps ?hook id decl poly sigma term termtype = + (* XXX: Duplication of the declare_constant path *) let kind = IsDefinition Instance in let sigma = let levels = Univ.LSet.union (CVars.universes_of_constr termtype) @@ -349,14 +340,9 @@ let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma = Evd.minimize_universes sigma in - Pretyping.check_evars env (Evd.from_env env) sigma termtype; - let univs = Evd.check_univ_decl ~poly sigma decl in - let termtype = to_constr sigma termtype in + let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma decl termtype in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id - (ParameterEntry - (None,(termtype,univs),None), Decl_kinds.IsAssumption Decl_kinds.Logical) - in + (ParameterEntry entry, Decl_kinds.IsAssumption Decl_kinds.Logical) in Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps (ConstRef cst) @@ -419,7 +405,7 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po | None -> pstate) ()) -let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -503,7 +489,7 @@ let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program let term = to_constr sigma (Option.get term) in (declare_instance_constant k pri global imps ?hook id decl poly sigma term termtype; None) - else if program_mode || refine || Option.is_empty props then + else if program_mode || Option.is_empty props then declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in id, pstate @@ -550,7 +536,7 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mode +let new_instance ~pstate ?(global=false) ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -566,7 +552,7 @@ let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mo Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode + do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) pri = diff --git a/vernac/classes.mli b/vernac/classes.mli index e7f90ff306..57bb9ce312 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -48,7 +48,6 @@ val declare_instance_constant : val new_instance : pstate:Proof_global.t option -> ?global:bool (** Not global by default. *) -> - ?refine:bool (** Allow refinement *) -> program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 3406b6276f..635751bb24 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -43,7 +43,7 @@ let should_axiom_into_instance = function true | Global | Local -> !axiom_into_instance -let declare_assumption ~pstate is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = +let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with @@ -53,11 +53,6 @@ match local with let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in let () = assumption_message ident in - let () = - if not !Flags.quiet && Option.has_some pstate then - Feedback.msg_info Pp.(str"Variable" ++ spc () ++ Id.print ident ++ - strbrk " is not visible from current goals") - in let r = VarRef ident in let () = maybe_declare_manual_implicits true r imps in let env = Global.env () in @@ -101,11 +96,11 @@ let next_uctx = | Polymorphic_entry _ as uctx -> uctx | Monomorphic_entry _ -> empty_uctx -let declare_assumptions ~pstate idl is_coe k (c,uctx) pl imps nl = +let declare_assumptions idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = List.fold_left (fun (refs,status,uctx) id -> let ref',u',status' = - declare_assumption ~pstate is_coe k (c,uctx) pl imps false nl id in + declare_assumption is_coe k (c,uctx) pl imps false nl id in (ref',u')::refs, status' && status, next_uctx uctx) ([],true,uctx) idl in @@ -137,7 +132,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 ~pstate ~program_mode 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 @@ -173,12 +168,17 @@ let do_assumptions ~pstate ~program_mode kind nl l = uvars, (coe,t,imps)) Univ.LSet.empty l in + (* XXX: Using `DeclareDef.prepare_parameter` here directly is not + possible as we indeed declare several parameters; however, + restrict_universe_context should be called in a centralized place + IMO, thus I think we should adapt `prepare_parameter` to handle + this case too. *) let sigma = Evd.restrict_universe_context sigma uvars in let uctx = Evd.check_univ_decl ~poly:(pi2 kind) sigma udecl in let ubinders = Evd.universe_binders sigma in pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in - let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in + let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs @@ -226,7 +226,7 @@ let named_of_rel_context l = l ([], []) in ctx -let context ~pstate poly 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 ~program_mode:false env sigma l in @@ -291,12 +291,12 @@ let context ~pstate poly l = let decl = (Discharge, poly, Definitional) in let nstatus = match b with | None -> - pi3 (declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl + pi3 (declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl Declaremods.NoInline (CAst.make id)) | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in - let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in + let _gr = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 7c64317b70..8f37bc0ba4 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -16,8 +16,7 @@ open Decl_kinds (** {6 Parameters/Assumptions} *) val do_assumptions - : pstate:Proof_global.t option - -> program_mode:bool + : program_mode:bool -> locality * polymorphic * assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list @@ -26,8 +25,7 @@ val do_assumptions (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) val declare_assumption - : pstate:Proof_global.t option - -> coercion_flag + : coercion_flag -> assumption_kind -> Constr.types Entries.in_universes_entry -> UnivNames.universe_binders @@ -42,8 +40,7 @@ val declare_assumption (** returns [false] if, for lack of section, it declares an assumption (unless in a module type). *) val context - : pstate:Proof_global.t option - -> Decl_kinds.polymorphic + : Decl_kinds.polymorphic -> local_binder_expr list -> bool diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index d2c986fe5c..4cae4b8a74 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -79,7 +79,7 @@ let check_definition ~program_mode (ce, evd, _, imps) = check_evars_are_solved ~program_mode env evd; ce -let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ctypopt = +let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = interp_definition ~program_mode univdecl bl (pi2 k) red_option c ctypopt in @@ -104,4 +104,4 @@ let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ct let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - ignore(DeclareDef.declare_definition ~ontop ident k ?hook_data ce (Evd.universe_binders evd) imps) + ignore(DeclareDef.declare_definition ident k ?hook_data ce (Evd.universe_binders evd) imps) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 12853d83e0..fa4860b079 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -17,8 +17,7 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : ontop:Proof_global.t option - -> program_mode:bool + : program_mode:bool -> ?hook:Lemmas.declaration_hook -> Id.t -> definition_kind diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 1912646ffd..00f19f545c 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -284,7 +284,7 @@ let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, Fixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; @@ -319,7 +319,7 @@ let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,c let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, CoFixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames; diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 052832244b..bdda3314ca 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -14,12 +14,6 @@ open Entries open Globnames open Impargs -let warn_definition_not_visible = - CWarnings.create ~name:"definition-not-visible" ~category:"implicits" - Pp.(fun ident -> - strbrk "Section definition " ++ - Names.Id.print ident ++ strbrk " is not visible from current goals") - let warn_local_declaration = CWarnings.create ~name:"local-declaration" ~category:"scope" Pp.(fun (id,kind) -> @@ -33,12 +27,11 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = +let declare_definition ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with | Discharge when Lib.sections_are_opened () -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in - let () = if Option.has_some ontop then warn_definition_not_visible ident in VarRef ident | Discharge | Local | Global -> let local = get_locality ident ~kind:"definition" local in @@ -57,9 +50,9 @@ let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = end; gr -let declare_fix ~ontop ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = +let declare_fix ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - declare_definition ~ontop f kind ?hook_data ce pl imps + declare_definition f kind ?hook_data ce pl imps let check_definition_evars ~allow_evars sigma = let env = Global.env () in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 8e4f4bf7fb..c4500d0a6b 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -14,8 +14,7 @@ open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition - : ontop:Proof_global.t option - -> Id.t + : Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> Safe_typing.private_constants Entries.definition_entry @@ -24,8 +23,7 @@ val declare_definition -> GlobRef.t val declare_fix - : ontop:Proof_global.t option - -> ?opaque:bool + : ?opaque:bool -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> definition_kind -> UnivNames.universe_binders diff --git a/vernac/obligations.ml b/vernac/obligations.ml index f768278dd7..46c4422d17 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -454,7 +454,7 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let declare_definition ~ontop prg = +let declare_definition prg = let varsubst = obligation_substitution true prg in let body, typ = subst_prog varsubst prg in let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) @@ -473,7 +473,7 @@ let declare_definition ~ontop prg = let () = progmap_remove prg in let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition ~ontop prg.prg_name + DeclareDef.declare_definition prg.prg_name prg.prg_kind ce ubinders prg.prg_implicits ?hook_data let rec lam_index n t acc = @@ -552,7 +552,7 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) 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 ~ontop:None ~opaque (local, poly, kind) UnivNames.empty_binders univs) + let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; @@ -759,7 +759,7 @@ let update_obls prg obls rem = else ( match prg'.prg_deps with | [] -> - let kn = declare_definition ~ontop:None prg' in + let kn = declare_definition prg' in progmap_remove prg'; Defined kn | l -> @@ -1110,7 +1110,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); - let cst = declare_definition ~ontop:None prg in + let cst = declare_definition prg in Defined cst) else ( let len = Array.length obls in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 7bb4f71014..697bb788ac 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -605,7 +605,7 @@ let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = | Some r -> let sigma, env = get_current_or_global_context ~pstate in Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~ontop:pstate ~program_mode name + ComDefinition.do_definition ~program_mode name (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; pstate ) @@ -632,7 +632,7 @@ let vernac_exact_proof ~pstate c = if not status then Feedback.feedback Feedback.AddedAxiom; pstate -let vernac_assumption ~atts ~pstate discharge kind l nl = +let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in @@ -642,7 +642,7 @@ let vernac_assumption ~atts ~pstate 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 ~pstate ~program_mode:atts.program 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 = @@ -1075,8 +1075,8 @@ let vernac_declare_instance ~atts sup inst pri = Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri -let vernac_context ~pstate ~poly l = - if not (ComAssumption.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~poly l = + if not (ComAssumption.context poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_existing_instance ~section_local insts = let glob = not section_local in @@ -2300,7 +2300,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = unsupported_attributes atts; vernac_require_open_proof ~pstate (vernac_exact_proof c) | VernacAssumption ((discharge,kind),nl,l) -> - with_def_attributes ~atts vernac_assumption ~pstate discharge kind l nl; + with_def_attributes ~atts vernac_assumption discharge kind l nl; pstate | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l; @@ -2383,7 +2383,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = with_def_attributes ~atts vernac_declare_instance sup inst info; pstate | VernacContext sup -> - let () = vernac_context ~pstate ~poly:(only_polymorphism atts) sup in + let () = vernac_context ~poly:(only_polymorphism atts) sup in pstate | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts; diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index ef06e59316..730f5fd6da 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -36,7 +36,6 @@ type vernac_type = | VtProofMode of string (* To be removed *) | VtMeta - | VtUnknown and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 4d89eaffd9..54e08d0e95 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -52,7 +52,6 @@ type vernac_type = | VtProofMode of string (* To be removed *) | VtMeta - | VtUnknown and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = |