diff options
205 files changed, 2540 insertions, 5318 deletions
diff --git a/.gitignore b/.gitignore index 582a8f43c7..0ab6e25852 100644 --- a/.gitignore +++ b/.gitignore @@ -101,7 +101,7 @@ doc/faq/axioms.pdf_t doc/faq/axioms.png doc/sphinx/index.rst doc/sphinx/zebibliography.rst -doc/sphinx/credits-wrapper.rst +doc/sphinx/credits.rst doc/stdlib/Library.out doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 039c02c4b9..a6b17fd148 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2018-09-21-V2" + CACHEKEY: "bionic_coq-V2018-09-24-V01" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -40,8 +40,8 @@ before_script: - printenv -0 | sort -z | tr '\0' '\n' - declare -A switch_table - switch_table=( ["base"]="$COMPILER" ["edge"]="$COMPILER_EDGE" ) - - opam switch -y "${switch_table[$OPAM_SWITCH]}$OPAM_VARIANT" - - eval $(opam config env) + - opam switch set -y "${switch_table[$OPAM_SWITCH]}$OPAM_VARIANT" + - eval $(opam env) - opam list - opam config list @@ -112,7 +112,7 @@ after_script: - not-a-real-job script: - SPHINXENV='COQBIN="'"$PWD"'/_install_ci/bin/" COQBOOT=no' - - make -j "$NJOBS" SPHINXENV="$SPHINXENV" SPHINX_DEPS= sphinx + - make -j "$NJOBS" SPHINXENV="$SPHINXENV" SPHINX_DEPS= refman - make install-doc-sphinx artifacts: name: "$CI_JOB_NAME" @@ -175,8 +175,8 @@ after_script: artifacts: name: "%CI_JOB_NAME%" paths: - - dev\nsis\*.exe - - coq-opensource-archive-windows-*.zip + - artifacts + when: always expire_in: 1 week dependencies: [] tags: @@ -288,13 +288,12 @@ doc:ml-api:ocamldoc: - dev/ocamldoc doc:ml-api:odoc: - <<: *dune-template stage: test dependencies: - build:egde:dune:dev + script: make -f Makefile.dune apidoc variables: OPAM_SWITCH: edge - DUNE_TARGET: apidoc artifacts: name: "$CI_JOB_NAME" paths: @@ -8,6 +8,10 @@ Plugins externally, the Coq development team can provide assistance for extracting the plugin and setting up a new repository. +Tactics + +- Removed the deprecated `romega` tactics. + Changes from 8.8.2 to 8.9+beta1 =============================== @@ -69,18 +73,32 @@ Tactics - The `romega` tactics have been deprecated; please use `lia` instead. +- Names of existential variables occurring in Ltac functions + (e.g. "?[n]" or "?n" in terms - not in patterns) are now interpreted + the same way as other variable names occurring in Ltac functions. + Focusing - Focusing bracket `{` now supports named goal selectors, e.g. `[x]: {` will focus on a goal (existential variable) named `x`. As usual, unfocus with `}` once the sub-goal is fully solved. -Specification language +Specification language, type inference - A fix to unification (which was sensitive to the ascii name of variables) may occasionally change type inference in incompatible ways, especially regarding the inference of the return clause of "match". +- Fixing a missing check in interpreting instances of existential + variables which are bound to local definitions might exceptionally + induce an overhead if the cost of checking the conversion of the + corresponding definitions is additionally high (PR #8215). + +- A few improvements in inference of the return clause of "match" can + exceptionally introduce incompatibilities (PR #262). This can be + solved by writing an explicit "return" clause, sometimes even simply + an explicit "return _" clause. + Standard Library - Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, @@ -91,6 +109,7 @@ Standard Library want). - Added `Ndigits.N2Bv_sized`, and proved some lemmas about it. + Deprecated `Ndigits.N2Bv_gen`. - The scopes `int_scope` and `uint_scope` have been renamed to `dec_int_scope` and `dec_uint_scope`, to clash less with ssreflect @@ -119,6 +138,9 @@ Standard Library impacts users running Coq without the init library (`-nois` or `-noinit`) and also issuing `Require Import Coq.Init.Datatypes`. +- Added `Bvector.BVeq` that decides whether two `Bvector`s are equal. +- Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. + Tools - Coq_makefile lets one override or extend the following variables from diff --git a/META.coq.in b/META.coq.in index a7bf08ec49..1ccde1338f 100644 --- a/META.coq.in +++ b/META.coq.in @@ -301,18 +301,6 @@ package "plugins" ( archive(native) = "omega_plugin.cmx" ) - package "romega" ( - - description = "Coq romega plugin" - version = "8.10" - - requires = "coq.plugins.omega" - directory = "romega" - - archive(byte) = "romega_plugin.cmo" - archive(native) = "romega_plugin.cmx" - ) - package "micromega" ( description = "Coq micromega plugin" @@ -268,7 +268,7 @@ distclean: clean cleanconfig cacheclean timingclean voclean: find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" \ -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + - find theories plugins test-suite -name .coq-native -empty -exec rm -f {} + + find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} + timingclean: find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ diff --git a/Makefile.common b/Makefile.common index 69dea1d284..f90919a4bc 100644 --- a/Makefile.common +++ b/Makefile.common @@ -95,7 +95,7 @@ CORESRCDIRS:=\ tactics vernac stm toplevel PLUGINDIRS:=\ - omega romega micromega \ + omega micromega \ setoid_ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ @@ -129,7 +129,6 @@ GRAMMARCMA:=grammar/grammar.cma ########################################################################### OMEGACMO:=plugins/omega/omega_plugin.cmo -ROMEGACMO:=plugins/romega/romega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo RINGCMO:=plugins/setoid_ring/newring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo @@ -150,7 +149,7 @@ LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo -PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) \ +PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ diff --git a/Makefile.dev b/Makefile.dev index 2a7e61126a..82b81908ac 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -169,7 +169,6 @@ noreal: unicode logic arith bool zarith qarith lists sets fsets \ ################ OMEGAVO:=$(filter plugins/omega/%, $(PLUGINSVO)) -ROMEGAVO:=$(filter plugins/romega/%, $(PLUGINSVO)) MICROMEGAVO:=$(filter plugins/micromega/%, $(PLUGINSVO)) RINGVO:=$(filter plugins/setoid_ring/%, $(PLUGINSVO)) NSATZVO:=$(filter plugins/nsatz/%, $(PLUGINSVO)) @@ -181,7 +180,7 @@ CCVO:= DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO)) LTACVO:=$(filter plugins/ltac/%, $(PLUGINSVO)) -omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO) +omega: $(OMEGAVO) $(OMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) setoid_ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) diff --git a/Makefile.doc b/Makefile.doc index 788e4e61e7..db52607612 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -50,32 +50,35 @@ DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps -.PHONY: stdlib full-stdlib +.PHONY: stdlib full-stdlib sphinx -doc: sphinx stdlib +doc: refman stdlib ifndef QUICK SPHINX_DEPS := coq endif -# sphinx-html and sphinx-latex -sphinx-%: $(SPHINX_DEPS) +# refman-html and refman-latex +refman-%: $(SPHINX_DEPS) $(SHOW)'SPHINXBUILD doc/sphinx ($*)' $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \ $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$* -sphinx-pdf: sphinx-latex +refman-pdf: refman-latex +$(MAKE) -C $(SPHINXBUILDDIR)/latex -sphinx: $(SPHINX_DEPS) - +$(MAKE) sphinx-html - +$(MAKE) sphinx-pdf +refman: $(SPHINX_DEPS) + +$(MAKE) refman-html + +$(MAKE) refman-pdf + +# compatibility alias +sphinx: refman-html doc-html:\ - doc/stdlib/html/index.html sphinx-html + doc/stdlib/html/index.html refman-html doc-pdf:\ - doc/stdlib/Library.pdf sphinx-pdf + doc/stdlib/Library.pdf refman-pdf doc-ps:\ doc/stdlib/Library.ps @@ -188,7 +191,7 @@ install-doc-meta: $(MKDIR) $(FULLDOCDIR) $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc -install-doc-html: install-doc-stdlib-html install-doc-sphinx-html +install-doc-html: install-doc-stdlib-html install-doc-sphinx install-doc-stdlib-html: $(MKDIR) $(FULLDOCDIR)/html/stdlib @@ -199,7 +202,7 @@ install-doc-printable: $(INSTALLLIB) doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/stdlib/Library.ps $(FULLDOCDIR)/ps -install-doc-sphinx-html: +install-doc-sphinx: $(MKDIR) $(FULLDOCDIR)/sphinx (for f in `cd doc/sphinx/_build; find . -type f`; do \ $(MKDIR) $$(dirname $(FULLDOCDIR)/sphinx/$$f);\ diff --git a/Makefile.dune b/Makefile.dune index cac1bdd6a1..1e401a57b9 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -7,9 +7,6 @@ # DUNEOPT=--display=short BUILD_CONTEXT=_build/default -COQ_CONFIGURE_PREFIX?=_build/install/default - -export COQ_CONFIGURE_PREFIX help: @echo "Welcome to Coq's Dune-based build system. Targets are:" @@ -37,11 +34,8 @@ watch: voboot release: voboot dune build $(DUNEOPT) -p coq -apidoc: - # Ugly workaround for https://github.com/ocaml/odoc/issues/148 - mv checker/dune checker/dune.disabled || true +apidoc: voboot dune build $(DUNEOPT) @doc - mv checker/dune.disabled checker/dune || true clean: dune clean diff --git a/checker/dune b/checker/dune index d918f853dd..d520171f98 100644 --- a/checker/dune +++ b/checker/dune @@ -3,24 +3,30 @@ (rule (copy %{project_root}/kernel/esubst.ml esubst.ml)) (rule (copy %{project_root}/kernel/esubst.mli esubst.mli)) +; Careful with bug https://github.com/ocaml/odoc/issues/148 +; +; If we don't pack checker we will have a problem here due to +; duplicate module names in the whole build. (library - (name checker) - (public_name coq.checker) + (name checklib) + (public_name coq.checklib) (synopsis "Coq's Standalone Proof Checker") - (modules values analyze names esubst) - (wrapped false) + (modules :standard \ main votour) + (modules_without_implementation cic) + (wrapped true) (libraries coq.lib)) (executable (name main) (public_name coqchk) - (modules :standard \ votour values analyze names esubst) - (modules_without_implementation cic) - (libraries coq.checker)) + (modules main) + (flags :standard -open Checklib) + (libraries coq.checklib)) (executable (name votour) (public_name votour) (modules votour) - (libraries coq.checker)) + (flags :standard -open Checklib) + (libraries coq.checklib)) diff --git a/checker/environ.ml b/checker/environ.ml index 74cf237763..b172acb126 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -183,7 +183,7 @@ let lookup_mind kn env = let add_mind kn mib env = if Mindmap_env.mem kn env.env_globals.env_inductives then - Printf.ksprintf anomaly ("Inductive %s is already defined.") + Printf.ksprintf anomaly ("Mutual inductive block %s is already defined.") (MutInd.to_string kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 8f11e01c33..1fd86bc368 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -595,8 +595,12 @@ let check_subtyping cumi paramsctxt env inds = (************************************************************************) (************************************************************************) +let print_mutind ind = + let kn = MutInd.user ind in + str (ModPath.to_string (KerName.modpath kn) ^ "." ^ Label.to_string (KerName.label kn)) + let check_inductive env kn mib = - Flags.if_verbose Feedback.msg_notice (str " checking ind: " ++ MutInd.print kn); + Flags.if_verbose Feedback.msg_notice (str " checking mutind block: " ++ print_mutind kn); (* check mind_constraints: should be consistent with env *) let env0 = match mib.mind_universes with diff --git a/checker/typeops.ml b/checker/typeops.ml index 138fe8bc95..e4c3f4ae4b 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -158,7 +158,7 @@ let judge_of_inductive_knowing_parameters env (ind,u) (paramstyp:constr array) = let specif = try lookup_mind_specif env ind with Not_found -> - failwith ("Cannot find inductive: "^MutInd.to_string (fst ind)) + failwith ("Cannot find mutual inductive block: "^MutInd.to_string (fst ind)) in type_of_inductive_knowing_parameters env (specif,u) paramstyp @@ -172,7 +172,7 @@ let judge_of_constructor env (c,u) = let specif = try lookup_mind_specif env ind with Not_found -> - failwith ("Cannot find inductive: "^MutInd.to_string (fst ind)) + failwith ("Cannot find mutual inductive block: "^MutInd.to_string (fst ind)) in type_of_constructor (c,u) specif diff --git a/checker/validate.ml b/checker/validate.ml index f831875dd4..c214409a2c 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -85,6 +85,7 @@ let rec val_gen v ctx o = match v with | Fail s -> fail ctx o ("unexpected object " ^ s) | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o | Dyn -> val_dyn ctx o + | Proxy { contents = v } -> val_gen v ctx o (* Check that an object is a tuple (or a record). vs is an array of value representation for each field. Its size corresponds to the diff --git a/checker/values.ml b/checker/values.ml index 801874773a..35027d5bfb 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -45,6 +45,13 @@ type value = | String | Annot of string * value | Dyn + | Proxy of value ref + +let fix (f : value -> value) : value = + let self = ref Any in + let ans = f (Proxy self) in + let () = self := ans in + ans (** Some pseudo-constructors *) @@ -347,18 +354,16 @@ let v_states = v_pair Any v_frozen let v_state = Tuple ("state", [|v_states; Any; v_bool|]) let v_vcs = - let data = Opt Any in - let vcs = + let vcs self = Tuple ("vcs", [|Any; Any; Tuple ("dag", [|Any; Any; v_map Any (Tuple ("state_info", - [|Any; Any; Opt v_state; v_pair data Any|])) + [|Any; Any; Opt v_state; v_pair (Opt self) Any|])) |]) |]) in - let () = Obj.set_field (Obj.magic data) 0 (Obj.magic vcs) in - vcs + fix vcs let v_uuid = Any let v_request id doc = diff --git a/checker/values.mli b/checker/values.mli index 20b9d54a68..1b1437a469 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -20,6 +20,7 @@ type value = | String | Annot of string * value | Dyn + | Proxy of value ref val v_univopaques : value val v_libsum : value diff --git a/checker/votour.ml b/checker/votour.ml index bc820e23dd..1ea0de456e 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -152,6 +152,7 @@ let rec get_name ?(extra=false) = function |String -> "string" |Annot (s,v) -> s^"/"^get_name ~extra v |Dyn -> "<dynamic>" + | Proxy v -> get_name ~extra !v (** For tuples, its quite handy to display the inner 1st string (if any). Cf. [structure_body] for instance *) @@ -255,6 +256,7 @@ let rec get_children v o pos = match v with | _ -> raise Exit end |Fail s -> raise Forbidden + | Proxy v -> get_children !v o pos let get_children v o pos = try get_children v o pos diff --git a/config/dune b/config/dune index cf2bc71363..ce87a7816d 100644 --- a/config/dune +++ b/config/dune @@ -10,4 +10,4 @@ (targets coq_config.ml) (mode fallback) (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) - (action (chdir %{project_root} (run %{ocaml} configure.ml -native-compiler no)))) + (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/configure.ml b/configure.ml index 1c2edefc5c..da6a6f8cbf 100644 --- a/configure.ml +++ b/configure.ml @@ -242,6 +242,7 @@ type ide = Opt | Byte | No type preferences = { prefix : string option; local : bool; + interactive : bool; vmbyteflags : string option; custom : bool option; bindir : string option; @@ -279,6 +280,7 @@ module Profiles = struct let default = { prefix = None; local = false; + interactive = true; vmbyteflags = None; custom = None; bindir = None; @@ -331,6 +333,11 @@ end let prefs = ref Profiles.default +(* Support don't ask *) +let cprintf x = + if !prefs.interactive + then cprintf x + else Printf.ifprintf stdout x let get_bool = function | "true" | "yes" | "y" | "all" -> true @@ -366,6 +373,8 @@ let args_options = Arg.align [ "<dir> Set installation directory to <dir>"; "-local", arg_set (fun p local -> { p with local }), " Set installation directory to the current source tree"; + "-no-ask", arg_clear (fun p interactive -> { p with interactive }), + " Don't ask questions / print variables during configure [questions will be filled with defaults]"; "-vmbyteflags", arg_string_option (fun p vmbyteflags -> { p with vmbyteflags }), "<flags> Comma-separated link flags for the VM of coqtop.byte"; "-custom", arg_set_option (fun p custom -> { p with custom }), @@ -649,9 +658,8 @@ let camltag = match caml_version_list with 50: unexpected documentation comment: too common and annoying to avoid 56: unreachable match case: the [_ -> .] syntax doesn't exist in 4.02.3 58: "no cmx file was found in path": See https://github.com/ocaml/num/issues/9 - 59: "potential assignment to a non-mutable value": See Coq's issue #8043 *) -let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50-58-59" +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50-58" let coq_warn_error = if !prefs.warn_error then "-warn-error +a" @@ -1044,7 +1052,9 @@ let do_one_instdir (var,msg,uservalue,selfcontainedlayout,unixlayout,locallayout | None -> begin try Some (Sys.getenv "COQ_CONFIGURE_PREFIX") - with Not_found -> None + with + | Not_found when !prefs.interactive -> None + | Not_found -> Some "_build/default/install" end | p -> p in match uservalue, env_prefix with @@ -1145,8 +1155,8 @@ let print_summary () = pr "*Warning* To compile the system for a new architecture\n"; pr " don't forget to do a 'make clean' before './configure'.\n" -let _ = print_summary () - +let _ = + if !prefs.interactive then print_summary () (** * Build the dev/ocamldebug-coq file *) @@ -1240,7 +1250,10 @@ let write_configml f = pr "\nlet core_src_dirs = [\n%s]\n" core_src_dirs; pr "\nlet plugins_dirs = [\n"; - let plugins = Sys.readdir "plugins" in + let plugins = + try Sys.readdir "plugins" + with _ -> [||] + in Array.sort compare plugins; Array.iter (fun f -> diff --git a/default.nix b/default.nix index 88992a30a3..29c0c68174 100644 --- a/default.nix +++ b/default.nix @@ -23,8 +23,8 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/947ae71dcec680b5075ece14e38eae64831b9819.tar.gz"; - sha256 = "15nryymfch4fzxk6nacli4gw4cyicpdjwzai5v3bc0azaslww2x5"; + url = "https://github.com/NixOS/nixpkgs/archive/52a1179b6c20e923beddde1dd1e0034aa19176d2.tar.gz"; + sha256 = "040xrsgnip6gqljfyy1ad0l7q41h659h5hqbcn96bzhdiakcr4yc"; }) {}) , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 5af0fcff3a..61cf6bc4cc 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -247,7 +247,7 @@ IF "%~0" == "-addon" ( IF NOT "%~0" == "" ( ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW ECHO !!! Illegal parameter %~0 - ECHO Usage: + ECHO Usage: ECHO MakeCoq_MinGW CALL :PrintPars GOTO :EOF @@ -267,7 +267,6 @@ IF "%INSTALLMODE%" == "mingwincygwin" ( IF "%MAKEINSTALLER%" == "Y" ( SET INSTALLMODE=relocatable - SET INSTALLOCAML=Y ) REM ========== CONFIRM PARAMETERS ========== @@ -275,7 +274,7 @@ REM ========== CONFIRM PARAMETERS ========== CALL :PrintPars REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block IF "%COQREGTESTING%"=="Y" (GOTO DontAsk) - SET /p ANSWER=Is this correct? y/n + SET /p ANSWER="Is this correct? y/n " IF NOT "%ANSWER%"=="y" (GOTO :EOF) :DontAsk @@ -315,12 +314,13 @@ ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset -SET MAKE_OPT=-j %MAKE_THREADS% +SET MAKE_OPT=-j %MAKE_THREADS% REM ========== DERIVED CYGWIN SETUP OPTIONS ========== -REM WARNING: Add a space after the = otherwise the variable will be unset -SET CYGWIN_OPT= +REM One can't set a variable to empty in DOS, but you can set it to a space this way. +REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". +SET "CYGWIN_OPT= " IF "%CYGWIN_FROM_CACHE%" == "Y" ( SET CYGWIN_OPT= %CYGWIN_OPT% -L @@ -334,8 +334,6 @@ IF "%GTK_FROM_SOURCES%"=="N" ( SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 ) -ECHO ========== INSTALL CYGWIN ========== - REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. REM Otherwise chmod won't work and e.g. the ocaml build will fail. REM Cygwin setup does not touch the ACLs of existing folders. @@ -349,7 +347,10 @@ IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( IF NOT "%CYGWIN_QUIET%" == "Y" ( SET RUNSETUP=Y ) + IF "%COQREGTESTING%" == "Y" ( + ECHO "========== REMOVE EXISTING CYGWIN ==========" + DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL SET RUNSETUP=Y ) @@ -359,6 +360,8 @@ IF NOT "%APPVEYOR%" == "True" ( SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 ) +ECHO "========== INSTALL CYGWIN ==========" + IF "%RUNSETUP%"=="Y" ( %SETUP% ^ --proxy "%PROXY%" ^ @@ -436,10 +439,10 @@ ECHO ========== BATCH FUNCTIONS ========== ECHO -proxy ^<internet proxy^> ECHO -cygrepo ^<cygwin download repository^> ECHO -cygcache ^<local cygwin repository/cache^> - ECHO -cyglocal ^<Y or N^> install cygwin from cache + ECHO -cyglocal ^<Y or N^> install cygwin from cache ECHO -cygquiet ^<Y or N^> install cygwin without user interaction ECHO -srccache ^<local source code repository/cache^> - ECHO -coqver ^<Coq version to install^> + ECHO -coqver ^<Coq version to install^> ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version ECHO -threads ^<1..N^> Number of make threads ECHO -addon ^<name^> Enable building selected addon (can be repeated) @@ -452,9 +455,9 @@ ECHO ========== BATCH FUNCTIONS ========== ECHO -ocaml = %INSTALLOCAML% ECHO -installer= %MAKEINSTALLER% ECHO -make = %INSTALLMAKE% - ECHO -destcyg = %DESTCYG% - ECHO -destcoq = %DESTCOQ% - ECHO -setup = %SETUP% + ECHO -destcyg = %DESTCYG% + ECHO -destcoq = %DESTCOQ% + ECHO -setup = %SETUP% ECHO -proxy = %PROXY% ECHO -cygrepo = %CYGWIN_REPOSITORY% ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 2a29b0d3b6..23eb6fbc63 100644..100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -18,6 +18,8 @@ set -o nounset set -o errexit set -x +# Print current wall time as part of the xtrace +export PS4='+\t ' # Set this to 1 if all module directories shall be removed before build (no incremental make) RMDIR_BEFORE_BUILD=1 @@ -119,7 +121,11 @@ mkdir -p "$PREFIXCOQ/bin" mkdir -p "$PREFIXOCAML/bin" # This is required for building addons and plugins +# This must be CFMT (/cygdrive/c/...) otherwise coquelicot 3.0.2 configure fails. +# coquelicot uses which ${COQBIN}/coqc to check if coqc exists. This does not work with COQBIN in MFMT. export COQBIN=$RESULT_INSTALLDIR_CFMT/bin/ +# This must be MFMT (C:/) otherwise bignums 68a7a3d7e0b21985913a6c3ee12067f4c5ac4e20 fails +export COQLIB=$RESULT_INSTALLDIR_MFMT/lib/coq/ ###################### Copy Cygwin Setup Info ##################### @@ -145,27 +151,64 @@ LOGS=$(pwd)/buildlogs # The current log target (first part of the log file name) LOGTARGET=other -# Log command output - take log target name from command name (like log1 make => log target is "<module>-make") -log1() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) -} - -# Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") -log2() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) -} - -# Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") -log_1_3() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) -} - -# Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") -logn() { - LOGTARGETEX=$1 - shift - "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) -} +# For an explanation of ${COQREGTESTING:-N} search for ${parameter:-word} in +# http://pubs.opengroup.org/onlinepubs/009695399/utilities/xcu_chap02.html + +if [ "${COQREGTESTING:-N}" == "Y" ] ; then + # If COQREGTESTING, log to log files only + # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") + log1() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1.log" 2>"$LOGS/$LOGTARGET-$1.err" + } + + # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") + log2() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1-$2.log" 2>"$LOGS/$LOGTARGET-$1-$2.err" + } + + # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") + log_1_3() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1-$3.log" 2>"$LOGS/$LOGTARGET-$1-$3.err" + } + + # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") + logn() { + { local -; set +x; } 2> /dev/null + LOGTARGETEX=$1 + shift + "$@" >"$LOGS/$LOGTARGET-$LOGTARGETEX.log" 2>"$LOGS/$LOGTARGET-$LOGTARGETEX.err" + } +else + # If COQREGTESTING, log to log files and console + # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") + log1() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) + } + + # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") + log2() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) + } + + # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") + log_1_3() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) + } + + # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") + logn() { + { local -; set +x; } 2> /dev/null + LOGTARGETEX=$1 + shift + "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) + } +fi ###################### 'UNFIX' SED ##################### @@ -229,7 +272,7 @@ function get_expand_source_tar { if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" else - wget "$1/$2.$3" + wget --progress=dot:giga "$1/$2.$3" if file -i "$2.$3" | grep text/html; then echo Download failed: "$1/$2.$3" echo The file wget downloaded is an html file: @@ -260,8 +303,8 @@ function get_expand_source_tar { if [ "$3" == "zip" ] ; then log1 unzip "$TARBALLS/$name.$3" if [ "$strip" == "1" ] ; then - # Ok, this is dirty, but it works and it fails if there are name clashes - mv -- */* . + # move subfolders of root folders one level up + find "$(ls)" -mindepth 1 -maxdepth 1 -exec mv -- "{}" . \; else echo "Unzip strip count not supported" return 1 @@ -314,13 +357,13 @@ function build_prep { fi # Check if build is already done - if [ ! -f "flagfiles/$name.finished" ] ; then + if [ ! -f "$FLAGFILES/$name.finished" ] ; then BUILD_PACKAGE_NAME=$name BUILD_OLDPATH=$PATH BUILD_OLDPWD=$(pwd) LOGTARGET=$name - touch "flagfiles/$name.started" + touch "$FLAGFILES/$name.started" get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" @@ -344,9 +387,9 @@ function build_prep { # ------------------------------------------------------------------------------ function build_post { - if [ ! -f "flagfiles/$BUILD_PACKAGE_NAME.finished" ]; then + if [ ! -f "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" ]; then cd "$BUILD_OLDPWD" - touch "flagfiles/$BUILD_PACKAGE_NAME.finished" + touch "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" PATH=$BUILD_OLDPATH LOGTARGET=other fi @@ -384,19 +427,17 @@ function build_conf_make_inst { # Install all files given by a glob pattern to a given folder # # parameters -# $1 glob pattern (in '') -# $2 target folder +# $1 source path +# $2 pattern (in '') +# $3 target folder # ------------------------------------------------------------------------------ function install_glob { - # Check if any files matching the pattern exist - if [ "$(echo $1)" != "$1" ] ; then - # shellcheck disable=SC2086 - install -D -t $2 $1 - fi + SRCDIR=$(realpath -m $1) + DESTDIR=$(realpath -m $3) + ( cd "$SRCDIR" && find . -maxdepth 1 -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) } - # ------------------------------------------------------------------------------ # Recursively Install all files given by a glob pattern to a given folder # @@ -407,12 +448,15 @@ function install_glob { # ------------------------------------------------------------------------------ function install_rec { - ( cd "$1" && find . -type f -name "$2" -exec install -D -T "$1"/{} "$3"/{} \; ) + SRCDIR=$(realpath -m $1) + DESTDIR=$(realpath -m $3) + ( cd "$SRCDIR" && find . -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) } # ------------------------------------------------------------------------------ # Write a file list of the target folder # The file lists are used to create file lists for the windows installer +# Don't overwrite an existing file list # # parameters # $1 name of file list @@ -425,6 +469,19 @@ function list_files { } # ------------------------------------------------------------------------------ +# Write a file list of the target folder +# The file lists are used to create file lists for the windows installer +# Do overwrite an existing file list +# +# parameters +# $1 name of file list +# ------------------------------------------------------------------------------ + +function list_files_always { + ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) +} + +# ------------------------------------------------------------------------------ # Compute the set difference of two file lists # # parameters @@ -777,15 +834,15 @@ function make_flex_dll_link { # For this purpose hard links are better. function make_ln { - if [ ! -f flagfiles/myln.finished ] ; then - touch flagfiles/myln.started + if [ ! -f $FLAGFILES/myln.finished ] ; then + touch $FLAGFILES/myln.started mkdir -p myln ( cd myln cp $PATCHES/ln.c . "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c install -D ln.exe "$PREFIXCOQ/bin/ln.exe" ) - touch flagfiles/myln.finished + touch $FLAGFILES/myln.finished fi } @@ -848,7 +905,6 @@ function make_ocaml { function make_ocaml_tools { make_findlib - # make_menhir make_camlp5 } @@ -865,7 +921,7 @@ function make_ocaml_libs { function make_num { make_ocaml # We need this commit due to windows fixed, IMHO this is better than patching v1.1. - if build_prep https://github.com/ocaml/num/archive/ 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then + if build_prep https://github.com/ocaml/num/archive 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then log2 make all # log2 make test log2 make install @@ -874,10 +930,23 @@ function make_num { fi } +##### OCAMLBUILD ##### + +function make_ocamlbuild { + make_ocaml + if build_prep https://github.com/ocaml/ocamlbuild/archive 0.12.0 tar.gz 1 ocamlbuild-0.12.0; then + log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib + log1 make + log2 make install + build_post + fi +} + ##### FINDLIB Ocaml library manager ##### function make_findlib { make_ocaml + make_ocamlbuild if build_prep https://opam.ocaml.org/1.2.2/archives ocamlfind.1.8.0+opam tar.gz 1 ; then logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT @@ -885,6 +954,10 @@ function make_findlib { log2 make opt log2 make install log2 make clean + # Add Coq install library path to ocamlfind config file + # $(ocamlfind printconf conf | tr -d '\r') is the name of the config file + # printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g' is the coq lib path double escaped for sed + sed -i -e 's|path="\(.*\)"|path="\1;'$(printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g')'"|' $(ocamlfind printconf conf | tr -d '\r') build_post fi } @@ -894,15 +967,11 @@ function make_findlib { function make_menhir { make_ocaml make_findlib - # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151112 tar.gz 1 ; then - # For Ocaml 4.02 - # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151012 tar.gz 1 ; then - # For Ocaml 4.01 - if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20140422 tar.gz 1 ; then + make_ocamlbuild + if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20180530 tar.gz 1 ; then # Note: menhir doesn't support -j 8, so don't pass MAKE_OPT log2 make all PREFIX="$PREFIXOCAML" log2 make install PREFIX="$PREFIXOCAML" - mv "$PREFIXOCAML/bin/menhir" "$PREFIXOCAML/bin/menhir.exe" build_post fi } @@ -1085,13 +1154,13 @@ function copy_coq_dlls { function copy_coq_objects { # copy objects only from folders which exist in the target lib directory find . -type d | while read -r FOLDER ; do - if [ -e "$PREFIXCOQ/lib/$FOLDER" ] ; then - install_glob "$FOLDER"/'*.cmxa' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cmi' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cma' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cmo' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.a' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.o' "$PREFIXCOQ/lib/$FOLDER" + if [ -e "$PREFIXCOQ/lib/coq/$FOLDER" ] ; then + install_glob "$FOLDER" '*.cmxa' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cmi' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cma' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cmo' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.a' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.o' "$PREFIXCOQ/lib/coq/$FOLDER" fi done } @@ -1103,10 +1172,10 @@ function copq_coq_gtk { echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-2.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-2.0/"'*' "$PREFIXCOQ/gtk-2.0" - install_glob "$PREFIX/share/gtksourceview-2.0/language-specs/"'*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-2.0/styles/"'*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" - install_rec "$PREFIX/share/themes/" '*' "$PREFIXCOQ/share/themes" + install_glob "$PREFIX/etc/gtk-2.0" '*' "$PREFIXCOQ/gtk-2.0" + install_glob "$PREFIX/share/gtksourceview-2.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" + install_glob "$PREFIX/share/gtksourceview-2.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" + install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install if [ -d "$PREFIXCOQ/share/coq/" ] ; then @@ -1136,7 +1205,7 @@ function copy_coq_license { install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" install -D CHANGES "$PREFIXCOQ/license_readme/coq/Changes.txt" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" - install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" + install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi } @@ -1175,11 +1244,11 @@ function make_coq { then if [ "$INSTALLMODE" == "relocatable" ]; then # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - ./configure -with-doc no -prefix ./ -libdir ./lib -mandir ./man + logn configure ./configure -with-doc no -prefix ./ -libdir ./lib/coq -mandir ./man elif [ "$INSTALLMODE" == "absolute" ]; then - ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" else - ./configure -with-doc no -prefix "$PREFIXCOQ" + logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" fi # The windows resource compiler binary name is hard coded @@ -1191,21 +1260,21 @@ function make_coq { log1 make else # shellcheck disable=SC2086 - make $MAKE_OPT + log1 make $MAKE_OPT fi if [ "$INSTALLMODE" == "relocatable" ]; then - ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + logn reconfigure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" fi - make install - copy_coq_dlls + log2 make install + log1 copy_coq_dlls if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - copq_coq_gtk - copy_coq_license + log1 copq_coq_gtk + log1 copy_coq_license # make clean seems to be broken for 8.5pl2 # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile @@ -1213,8 +1282,8 @@ function make_coq { # make clean # Copy these files somewhere the plugin builds can find them - cp dev/ci/ci-basic-overlay.sh /build/ - cp -r dev/ci/user-overlays /build/ + logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ + logn copy-user-overlays cp -r dev/ci/user-overlays /build/ build_post fi @@ -1283,8 +1352,8 @@ function make_gcc { ##### Get sources for Cygwin MinGW packages ##### function get_cygwin_mingw_sources { - if [ ! -f flagfiles/cygwin_mingw_sources.finished ] ; then - touch flagfiles/cygwin_mingw_sources.started + if [ ! -f $FLAGFILES/cygwin_mingw_sources.finished ] ; then + touch $FLAGFILES/cygwin_mingw_sources.started # Find all installed files with mingw in the name and download the corresponding source code file from cygwin # Steps: @@ -1311,7 +1380,7 @@ function get_cygwin_mingw_sources { if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS else - wget "$CYGWIN_REPOSITORY/$SOURCE" + wget --progress=dot:giga "$CYGWIN_REPOSITORY/$SOURCE" mv "$SOURCEFILE" "$TARBALLS" # Save the source archive in the source cache if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then @@ -1322,7 +1391,7 @@ function get_cygwin_mingw_sources { done - touch flagfiles/cygwin_mingw_sources.finished + touch $FLAGFILES/cygwin_mingw_sources.finished fi } @@ -1344,7 +1413,7 @@ function make_coq_installer { filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' # Filter out plugin object files - filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' + filter_files coq_objects_plugins coq_objects '/lib/coq/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' # Coq objects objects required for plugin development = coq objects except those for pre installed plugins diff_files coq_plugindev coq_objects coq_objects_plugins @@ -1460,6 +1529,8 @@ function make_addons { ###################### TOP LEVEL BUILD ##################### +ocamlfind list || true + make_sed make_ocaml make_ocaml_tools @@ -1477,7 +1548,7 @@ list_files ocaml_coq make_addons -list_files ocaml_coq_addons +list_files_always ocaml_coq_addons if [ "$MAKEINSTALLER" == "Y" ] ; then make_coq_installer diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 7af648f0a6..4acc0e86cf 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -8,6 +8,7 @@ export NJOBS if [ -n "${GITLAB_CI}" ]; then + # Gitlab build, Coq installed into `_install_ci` export OCAMLPATH="$PWD/_install_ci/lib:$OCAMLPATH" export COQBIN="$PWD/_install_ci/bin" export CI_BRANCH="$CI_COMMIT_REF_NAME" @@ -15,18 +16,29 @@ then then export CI_PULL_REQUEST="${CI_BRANCH#pr-}" fi +elif [ -n "${TRAVIS}" ]; +then + # Travis build, `-local` passed to `configure` + export OCAMLPATH="$PWD:$OCAMLPATH" + export COQBIN="$PWD/bin" + export CI_PULL_REQUEST="$TRAVIS_PULL_REQUEST" + export CI_BRANCH="$TRAVIS_BRANCH" +elif [ -d "$PWD/_build/install/default/" ]; +then + # Dune build + export OCAMLPATH="$PWD/_build/install/default/lib/" + export COQBIN="$PWD/_build/install/default/bin" + export COQLIB="$PWD/_build/install/default/lib/coq" + CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" + export CI_BRANCH else - if [ -n "${TRAVIS}" ]; - then - export CI_PULL_REQUEST="$TRAVIS_PULL_REQUEST" - export CI_BRANCH="$TRAVIS_BRANCH" - else # assume local - CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" - export CI_BRANCH - fi + # We assume we are in `-profile devel` build, thus `-local` is set export OCAMLPATH="$PWD:$OCAMLPATH" export COQBIN="$PWD/bin" + CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" + export CI_BRANCH fi + export PATH="$COQBIN:$PATH" # Coq's tools need an ending slash :S, we should fix them. diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index d943795258..8d0f69626e 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-09-21-V2" +# CACHEKEY: "bionic_coq-V2018-09-24-V01" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -8,7 +8,7 @@ ENV DEBIAN_FRONTEND="noninteractive" RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects - m4 automake autoconf time wget rsync git gcc-multilib opam \ + m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \ # Dependencies of lablgtk (for CoqIDE) libgtk2.0-dev libgtksourceview2.0-dev \ # Dependencies of stdlib and sphinx doc @@ -21,32 +21,38 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 +# We need to install OPAM 2.0 manually for now. +RUN wget https://github.com/ocaml/opam/releases/download/2.0.0/opam-2.0.0-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam + # Basic OPAM setup ENV NJOBS="2" \ + OPAMJOBS="2" \ OPAMROOT=/root/.opamcache \ - OPAMROOTISOK="true" + OPAMROOTISOK="true" \ + OPAMYES="true" # Base opam is the set of base packages required by Coq ENV COMPILER="4.02.3" -RUN opam init -a -y -j $NJOBS --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam config env) && opam update - # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.2.1 ounit.2.0.8" \ - CI_OPAM="menhir.20180530 elpi.1.0.5 ocamlgraph.1.8.8" + CI_OPAM="menhir.20180530 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV CAMLP5_VER="6.14" \ COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" -RUN opam switch -y -j $NJOBS "$COMPILER" && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER $COQIDE_OPAM $CI_OPAM +# The separate `opam install ocamlfind` workarounds an OPAM repository bug in 4.02.3 +RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ + opam install ocamlfind.1.8.0 && \ + opam install $BASE_OPAM camlp5.$CAMLP5_VER $COQIDE_OPAM $CI_OPAM # base+32bit switch -RUN opam switch -y -j $NJOBS "${COMPILER}+32bit" && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER +RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ + opam install ocamlfind.1.8.0 && \ + opam install $BASE_OPAM camlp5.$CAMLP5_VER # EDGE switch ENV COMPILER_EDGE="4.07.0" \ @@ -54,10 +60,12 @@ ENV COMPILER_EDGE="4.07.0" \ COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ BASE_OPAM_EDGE="odoc.1.2.0 dune-release.0.3.0" -RUN opam switch -y -j $NJOBS $COMPILER_EDGE && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE +RUN opam switch create $COMPILER_EDGE && eval $(opam env) && \ + opam install $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. -RUN opam switch -y -j $NJOBS "${COMPILER_EDGE}+flambda" && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE $CI_OPAM +RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ + opam install $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE $CI_OPAM + +RUN opam clean -a -c diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 973319de68..a848c49d75 100644..100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -2,23 +2,38 @@ REM This script builds and signs the Windows packages on Gitlab +ECHO "Start Time" +TIME /T + +REM List currently used cygwin and target folders for debugging / maintenance purposes + +ECHO "Currently used cygwin folders" +DIR C:\ci\cygwin* +ECHO "Currently used target folders" +DIR C:\ci\coq* +ECHO "Root folders" +DIR C:\ + if %ARCH% == 32 ( SET ARCHLONG=i686 - SET CYGROOT=C:\cygwin SET SETUP=setup-x86.exe ) if %ARCH% == 64 ( SET ARCHLONG=x86_64 - SET CYGROOT=C:\cygwin64 SET SETUP=setup-x86_64.exe ) +SET CYGROOT=C:\ci\cygwin%ARCH% +SET DESTCOQ=C:\ci\coq%ARCH% + +CALL :MakeUniqueFolder %CYGROOT% CYGROOT +CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')" SET CYGCACHE=%CYGROOT%\var\cache\setup SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/% SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/% -SET DESTCOQ=C:\coq%ARCH%_inst SET COQREGTESTING=Y SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin @@ -29,10 +44,24 @@ call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ -arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^ -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ -addon="bignums ltac2 equations" -make=N ^ - -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorExit + -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit + + +ECHO "Start Artifact Creation" +TIME /T + +mkdir artifacts + +CALL :CopyLogFiles -copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit -7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit +copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" artifacts || GOTO ErrorExit +REM The open source archive is only required for release builds +IF DEFINED WIN_CERTIFICATE_PATH ( + 7z a artifacts\coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit +) ELSE ( + REM In non release builds, create a dummy file + ECHO "This is not a release build - open source archive not created / uploaded" > artifacts\coq-opensource-info.txt +) REM DO NOT echo the signing command below, as this would leak secrets in the logs IF DEFINED WIN_CERTIFICATE_PATH ( @@ -43,8 +72,49 @@ IF DEFINED WIN_CERTIFICATE_PATH ( ) ) +ECHO "Finished Artifact Creation" +TIME /T + +CALL :CleanupFolders + +ECHO "Finished Cleanup" +TIME /T + GOTO :EOF +:CopyLogFiles + ECHO Copy log files for artifact upload + MKDIR artifacts\buildlogs + COPY %CYGROOT%\build\buildlogs\* artifacts\buildlogs + MKDIR artifacts\filelists + COPY %CYGROOT%\build\filelists\* artifacts\filelists + MKDIR artifacts\flagfiles + COPY %CYGROOT%\build\flagfiles\* artifacts\flagfiles + GOTO :EOF + +:CleanupFolders + ECHO "Cleaning %CYGROOT%" + RMDIR /S /Q "%CYGROOT%" + ECHO "Cleaning %DESTCOQ%" + RMDIR /S /Q "%DESTCOQ%" + GOTO :EOF + +:MakeUniqueFolder + REM Create a uniquely named folder + REM This script is safe because folder creation is atomic - either we create it or fail + REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this) + REM %2 = name of the variable which receives the unique folder name + SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%" + MKDIR "%UNIQUENAME%" + IF ERRORLEVEL 1 GOTO :MakeUniqueFolder + SET "%2=%UNIQUENAME%" + GOTO :EOF + +:ErrorCopyLogFilesAndExit + CALL :CopyLogFiles + REM fall through + :ErrorExit + CALL :CleanupFolders ECHO ERROR %0 failed EXIT /b 1 diff --git a/dev/ci/user-overlays/08552-gares-elpi-11.sh b/dev/ci/user-overlays/08552-gares-elpi-11.sh new file mode 100644 index 0000000000..c08f44fc50 --- /dev/null +++ b/dev/ci/user-overlays/08552-gares-elpi-11.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8552" ] || [ "$CI_BRANCH" = "elpi-1.1" ]; then + Elpi_CI_REF=coq-master-elpi-1.1 +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 1eea2443fe..fdeb0abed4 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,3 +1,12 @@ +## Changes between Coq 8.9 and Coq 8.10 + +### ML API + +Termops: + +- Internal printing functions have been placed under the + `Termops.Internal` namespace. + ## Changes between Coq 8.8 and Coq 8.9 ### ML API @@ -219,7 +228,7 @@ General deprecation Proof engine - Due to the introduction of `EConstr` in 8.7, it is not necessary to +- Due to the introduction of `EConstr` in 8.7, it is not necessary to track "goal evar normal form status" anymore, thus the type `'a Proofview.Goal.t` loses its ghost argument. This may introduce some minor incompatibilities at the typing level. Code-wise, things diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt index b5dd8445db..45766293c7 100644 --- a/dev/doc/profiling.txt +++ b/dev/doc/profiling.txt @@ -21,6 +21,58 @@ and plug into the process perf record -g -p PID +### Per-component [flame graphs](https://github.com/brendangregg/FlameGraph) + +I (Andres Erbsen) have found it useful to look at library-wide flame graphs of +coq time consumption. As the Ltac interpreter stack is reflected in the OCaml +stack, calls to the same primitive can appear on top of multiple essentially +equivalent stacks. To make the profiles more readable, one could either try to +edit the stack trace to merge "equivalent" frames, or simply look at the +aggregate profile on a component-by-component basis. Here is how to do the +second for the standard library ([example output](https://cdn.rawgit.com/andres-erbsen/b29b29cb6480dfc6a662062e4fcd0ae3/raw/304fc3fea9630c8e453929aa7920ca8a2a570d0b/stdlib_categorized_outermost.svg)). + +~~~~~ +#!/bin/bash +make -f Makefile.dune clean +make -f Makefile.dune states +perf record -F99 `# ~1GB of data` --call-graph=dwarf -- make -f Makefile.dune world +perf script --time '0%-100%' | + stackcollapse-perf.pl | + grep Coqtop__compile | + sed -rf <(cat <<'EOF' + s/;caml/;/g + s/_[0-9]*;/;/g + s/Logic_monad__fun;//g + s/_apply[0-9];//g + s/;System/@&@/ + s/;Hashcons/@&@/ + s/;Grammar/@&@/ + s/;Declaremods/@&@/ + s/;Tactics/@&@/ + s/;Pretyping/@&@/ + s/;Typeops/@&@/ + s/;Reduction/@&@/ + s/;Unification/@&@/ + s/;Evarutil/@&@/ + s/;Evd/@&@/ + s/;EConstr/@&@/ + s/;Constr/@&@/ + s/;Univ/@&@/ + s/;Ugraph/@&@/ + s/;UState/@&@/ + s/;Micromega/@&@/ + s/;Omega/@&@/ + s/;Auto/@&@/ + s/;Ltac_plugin__Tacinterp/@&@/ + s/;Ltac_plugin__Rewrite/@&@/ + s/[^@]*@;([^@]*)@/\1;\1/ + s/@//g + :a; s/;([^;]+);\1;/;\1;/g;ta +EOF + ) | + flamegraph.pl +~~~~~ + ## Memory You first need a few commits atop trunk for this to work. diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index bccd3fefb4..85bb04efe0 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -37,7 +37,7 @@ if [ -z "$GUESS_CHECKER" ]; then -I $COQTOP/plugins/funind -I $COQTOP/plugins/groebner \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ - -I $COQTOP/plugins/ring -I $COQTOP/plugins/romega \ + -I $COQTOP/plugins/ring \ -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ab679a71ce..e15fd776b2 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -64,8 +64,14 @@ let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma let rawdebug = ref false let ppevar evk = pp (Evar.print evk) -let ppconstr x = pp (Termops.print_constr (EConstr.of_constr x)) -let ppeconstr x = pp (Termops.print_constr x) +let pr_constr t = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_constr_env env sigma t +let pr_econstr t = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_econstr_env env sigma t +let ppconstr x = pp (pr_constr x) +let ppeconstr x = pp (pr_econstr x) let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x @@ -95,9 +101,9 @@ let ppidmapgen l = pp (pridmapgen l) let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) -> hov 0 - (Termops.print_constr (EConstr.of_constr c) ++ + (pr_constr c ++ (match copt with None -> mt () | Some c -> spc () ++ str "<expanded: " ++ - Termops.print_constr (EConstr.of_constr c) ++ str">") ++ + pr_constr c ++ str">") ++ (if id = id0 then mt () else spc () ++ str "<canonical: " ++ Id.print id ++ str ">")))) @@ -106,7 +112,7 @@ let ppididmap = ppidmap (fun _ -> Id.print) let prconstrunderbindersidmap = pridmap (fun _ (l,c) -> hov 1 (str"[" ++ prlist_with_sep spc Id.print l ++ str"]") - ++ str "," ++ spc () ++ Termops.print_constr c) + ++ str "," ++ spc () ++ pr_econstr c) let ppconstrunderbindersidmap l = pp (prconstrunderbindersidmap l) @@ -133,7 +139,7 @@ let safe_pr_global = function | ConstRef kn -> pp (str "CONSTREF(" ++ Constant.debug_print kn ++ str ")") | IndRef (kn,i) -> pp (str "INDREF(" ++ MutInd.debug_print kn ++ str "," ++ int i ++ str ")") - | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ MutInd.debug_print kn ++ str "," ++ + | ConstructRef ((kn,i),j) -> pp (str "CONSTRUCTREF(" ++ MutInd.debug_print kn ++ str "," ++ int i ++ str "," ++ int j ++ str ")") | VarRef id -> pp (str "VARREF(" ++ Id.print id ++ str ")") @@ -155,9 +161,9 @@ let ppdelta s = pp (Mod_subst.debug_pr_delta s) let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) let pp_transparent_state s = pp (pr_transparent_state s) -let pp_stack_t n = pp (Reductionops.Stack.pr (EConstr.of_constr %> Termops.print_constr) n) -let pp_cst_stack_t n = pp (Reductionops.Cst_stack.pr n) -let pp_state_t n = pp (Reductionops.pr_state n) +let pp_stack_t n = pp (Reductionops.Stack.pr (EConstr.of_constr %> pr_econstr) n) +let pp_cst_stack_t n = pp (Reductionops.Cst_stack.pr Global.(env()) Evd.empty n) +let pp_state_t n = pp (Reductionops.pr_state Global.(env()) Evd.empty n) (* proof printers *) let pr_evar ev = Pp.int (Evar.repr ev) diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index 6b7960c92f..dd3908c25f 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -765,8 +765,6 @@ Conflicts exists between integers and constrs. %% plugins/ring \nlsep \TERM{quote}~\NT{ident}~\OPTGR{\KWD{[}~\PLUS{\NT{ident}}~\KWD{]}} \nlsep \TERM{ring}~\STAR{\tacconstr} -%% plugins/romega -\nlsep \TERM{romega} \SEPDEF \DEFNT{orient} \KWD{$\rightarrow$}~\mid~\KWD{$\leftarrow$} diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 47cfeb98d7..ea126e2756 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -10,7 +10,7 @@ let ppripos (ri,pos) = | Reloc_annot a -> let sp,i = a.ci.ci_ind in print_string - ("annot : MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^")\n") + ("annot : MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" | Reloc_getglobal kn -> diff --git a/doc/README.md b/doc/README.md index 1461fa2e2c..3db1261656 100644 --- a/doc/README.md +++ b/doc/README.md @@ -88,8 +88,11 @@ Alternatively, you can use some specific targets: - `make doc-html` to produce all HTML documents -- `make sphinx` - to produce the HTML and PDF versions of the reference manual +- `make refman` + to produce the HTML and PDF versions of the reference manual + +- `make refman-{html,pdf}` + to produce only one format of the reference manual - `make stdlib` to produce all formats of the Coq standard library @@ -103,12 +106,12 @@ to avoid treating Sphinx warnings as errors. Otherwise, Sphinx quits upon detecting the first warning. You can set this on the Sphinx `make` command line or as an environment variable: -- `make sphinx SPHINXWARNERROR=0` +- `make refman SPHINXWARNERROR=0` - ~~~ export SPHINXWARNERROR=0 ⋮ - make sphinx + make refman ~~~ Installation diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 062e14d615..01240a062c 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -114,32 +114,23 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica Raised if :n:`@tactic` does not fully solve the goal. -``.. flag::`` :black_nib: A Coq flag (i.e a binary-valued setting). +``.. flag::`` :black_nib: A Coq flag (i.e. a boolean setting). Example:: .. flag:: Nonrecursive Elimination Schemes - This option controls whether types declared with the keywords - :cmd:`Variant` and :cmd:`Record` get an automatic declaration of the + Controls whether types declared with the keywords + :cmd:`Variant` and :cmd:`Record` get an automatic declaration of induction principles. -``.. opt::`` :black_nib: A Coq option (with a string or numeric value; use "flag" for binary options) +``.. opt::`` :black_nib: A Coq option (a setting with non-boolean value, e.g. a string or numeric value). Example:: - .. opt:: Printing Width @num - :name: Printing Width + .. opt:: Hyps Limit @num + :name Hyps Limit - This command sets which left-aligned part of the width of the screen is used - for display. At the time of writing this documentation, the default value - is 78. - -``.. table::`` :black_nib: A Coq table (i.e a setting whose value is a set). - Example:: - - .. table:: Search Blacklist @string - :name: Search Blacklist - - This table controls ... + Controls the maximum number of hypotheses displayed in goals after + application of a tactic. ``.. prodn::`` A grammar production. This is useful if you intend to document individual grammar productions. @@ -159,6 +150,14 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica .. prodn:: term += let: @pattern := @term in @term .. prodn:: occ_switch ::= { {? + %| - } {* @num } } +``.. table::`` :black_nib: A Coq table, i.e. a setting that is a set of values. + Example:: + + .. table:: Search Blacklist @string + :name: Search Blacklist + + Controls ... + ``.. tacn::`` :black_nib: A tactic, or a tactic notation. Example:: @@ -296,7 +295,9 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo \WTEG{\forall~x:T,U}{\Prop} ``.. preamble::`` A reST directive to include a TeX file. - Mostly useful to let MathJax know about `\def`s and `\newcommand`s. + Mostly useful to let MathJax know about `\def`s and `\newcommand`s. The + contents of the TeX file are wrapped in a math environment, as MathJax + doesn't process LaTeX definitions otherwise. Usage:: diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index d03a31c044..3b9760f586 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -112,11 +112,11 @@ and checked to be :math:`-1`. .. tacn:: lia :name: lia -This tactic offers an alternative to the :tacn:`omega` and :tacn:`romega` -tactics. Roughly speaking, the deductive power of lia is the combined deductive -power of :tacn:`ring_simplify` and :tacn:`omega`. However, it solves linear -goals that :tacn:`omega` and :tacn:`romega` do not solve, such as the following -so-called *omega nightmare* :cite:`TheOmegaPaper`. + This tactic offers an alternative to the :tacn:`omega` tactic. Roughly + speaking, the deductive power of lia is the combined deductive power of + :tacn:`ring_simplify` and :tacn:`omega`. However, it solves linear goals + that :tacn:`omega` does not solve, such as the following so-called *omega + nightmare* :cite:`TheOmegaPaper`. .. coqtop:: in @@ -124,8 +124,7 @@ so-called *omega nightmare* :cite:`TheOmegaPaper`. 27 <= 11 * x + 13 * y <= 45 -> -10 <= 7 * x - 9 * y <= 4 -> False. -The estimation of the relative efficiency of :tacn:`lia` *vs* :tacn:`omega` and -:tacn:`romega` is under evaluation. +The estimation of the relative efficiency of :tacn:`lia` *vs* :tacn:`omega` is under evaluation. High level view of `lia` ~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 828505b850..03d4f148e3 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -23,13 +23,6 @@ Description of ``omega`` If the tactic cannot solve the goal, it fails with an error message. In any case, the computation eventually stops. -.. tacv:: romega - :name: romega - - .. deprecated:: 8.9 - - Use :tacn:`lia` instead. - Arithmetical goals recognized by ``omega`` ------------------------------------------ diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index b43d5fb6f0..71f01cbb17 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -106,7 +106,7 @@ def setup(app): master_doc = "index" # General information about the project. -project = 'The Coq Reference Manual' +project = 'Coq' copyright = '1999-2018, Inria' author = 'The Coq Development Team' @@ -335,7 +335,7 @@ latex_additional_files = [ "_static/coqnotations.sty" ] -latex_documents = [('index', 'CoqRefMan.tex', project, author, 'manual')] +latex_documents = [('index', 'CoqRefMan.tex', 'The Coq Reference Manual', author, 'manual')] # The name of an image file (relative to this directory) to place at the top of # the title page. diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits-contents.rst index 212f0a65b0..212f0a65b0 100644 --- a/doc/sphinx/credits.rst +++ b/doc/sphinx/credits-contents.rst diff --git a/doc/sphinx/credits-wrapper.latex.rst b/doc/sphinx/credits-wrapper.latex.rst deleted file mode 100644 index 9f7dd49af8..0000000000 --- a/doc/sphinx/credits-wrapper.latex.rst +++ /dev/null @@ -1,3 +0,0 @@ -.. _credits: - -.. include:: credits.rst diff --git a/doc/sphinx/credits-wrapper.html.rst b/doc/sphinx/credits.html.rst index 2d35a12dc2..0b2b1c6ad1 100644 --- a/doc/sphinx/credits-wrapper.html.rst +++ b/doc/sphinx/credits.html.rst @@ -4,4 +4,4 @@ Credits ------- -.. include:: credits.rst +.. include:: credits-contents.rst diff --git a/doc/sphinx/credits.latex.rst b/doc/sphinx/credits.latex.rst new file mode 100644 index 0000000000..39101f9d52 --- /dev/null +++ b/doc/sphinx/credits.latex.rst @@ -0,0 +1,3 @@ +.. _credits: + +.. include:: credits-contents.rst diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index 9d90857061..cf12b57414 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -1,11 +1,8 @@ -========================== - The Coq Reference Manual -========================== - .. _introduction: +========================== Introduction ------------- +========================== .. include:: introduction.rst @@ -28,7 +25,7 @@ Table of contents :caption: Preamble self - credits-wrapper + credits .. toctree:: :caption: The language @@ -89,3 +86,8 @@ License ------- .. include:: license.rst + +.. [#PG] Proof-General is available at https://proofgeneral.github.io/. + Optionally, you can enhance it with the minor mode + Company-Coq :cite:`Pit16` + (see https://github.com/cpitclaudel/company-coq). diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index 0f2f7b4897..af757f8746 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -7,10 +7,15 @@ Introduction .. include:: introduction.rst +.. [#PG] Proof-General is available at https://proofgeneral.github.io/. + Optionally, you can enhance it with the minor mode + Company-Coq :cite:`Pit16` + (see https://github.com/cpitclaudel/company-coq). + Credits ------- -.. include:: credits-wrapper.rst +.. include:: credits.rst License ------- diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index b8d2f6b6dc..5bb7bf542c 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -35,11 +35,6 @@ are processed from a file. The `coqtop` read-eval-print-loop can also be used directly, for debugging purposes. - .. [#PG] Proof-General is available at https://proofgeneral.github.io/. - Optionally, you can enhance it with the minor mode - Company-Coq :cite:`Pit16` - (see https://github.com/cpitclaudel/company-coq). - - The compiled mode acts as a proof checker taking a file containing a whole development in order to ensure its correctness. Moreover, |Coq|’s compiler provides an output file containing a compact diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index daf34500bf..593afa8f20 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -522,7 +522,7 @@ The Vernacular ============== .. productionlist:: coq - decorated-sentence : [`decoration`] `sentence` + decorated-sentence : [ `decoration` … `decoration` ] `sentence` sentence : `assumption` : | `definition` : | `inductive` @@ -1438,7 +1438,7 @@ Attributes Any vernacular command can be decorated with a list of attributes, enclosed between ``#[`` (hash and opening square bracket) and ``]`` (closing square bracket) -and separated by commas ``,``. +and separated by commas ``,``. Multiple space-separated blocks may be provided. Each attribute has a name (an identifier) and may have a value. A value is either a :token:`string` (in which case it is specified with an equal ``=`` sign), diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 837d3f10a2..be65ff7570 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -35,7 +35,7 @@ Displaying .. cmdv:: Print {? Term } @qualid\@@name This locally renames the polymorphic universes of :n:`@qualid`. - An underscore means the raw universe is printed. + An underscore means the usual name is printed. .. cmd:: About @qualid @@ -49,7 +49,7 @@ Displaying .. cmdv:: About @qualid\@@name This locally renames the polymorphic universes of :n:`@qualid`. - An underscore means the raw universe is printed. + An underscore means the usual name is printed. .. cmd:: Print All diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 029e100800..2c69dcfe08 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -333,14 +333,15 @@ class TacticNotationVariantObject(TacticNotationObject): annotation = "Variant" class OptionObject(NotationObject): - """A Coq option. + """A Coq option (a setting with non-boolean value, e.g. a string or numeric value). Example:: .. opt:: Hyps Limit @num + :name Hyps Limit - This option controls the maximum number of hypotheses displayed in goals after - the application of a tactic. + Controls the maximum number of hypotheses displayed in goals after + application of a tactic. """ subdomain = "opt" index_suffix = "(opt)" @@ -351,14 +352,14 @@ class OptionObject(NotationObject): class FlagObject(NotationObject): - """A Coq flag, i.e. a boolean Option. + """A Coq flag (i.e. a boolean setting). Example:: .. flag:: Nonrecursive Elimination Schemes - This flag controls whether types declared with the keywords - :cmd:`Variant` and :cmd:`Record` get an automatic declaration of the + Controls whether types declared with the keywords + :cmd:`Variant` and :cmd:`Record` get an automatic declaration of induction principles. """ subdomain = "flag" @@ -374,9 +375,10 @@ class TableObject(NotationObject): Example:: - .. table:: Search Blacklist + .. table:: Search Blacklist @string + :name: Search Blacklist - This table controls ... + Controls ... """ subdomain = "table" index_suffix = "(table)" @@ -667,7 +669,9 @@ class ExampleDirective(BaseAdmonition): class PreambleDirective(Directive): r"""A reST directive to include a TeX file. - Mostly useful to let MathJax know about `\def`s and `\newcommand`s. + Mostly useful to let MathJax know about `\def`s and `\newcommand`s. The + contents of the TeX file are wrapped in a math environment, as MathJax + doesn't process LaTeX definitions otherwise. Usage:: @@ -694,7 +698,7 @@ class PreambleDirective(Directive): with open(abs_fname, encoding="utf-8") as ltx: latex = ltx.read() - node = make_math_node(latex, env.docname, nowrap=True) + node = make_math_node(latex, env.docname, nowrap=False) node['classes'] = ["math-preamble"] set_source_info(self, node) return [node] @@ -1195,6 +1199,6 @@ def setup(app): # contents of ``env.domaindata['coq']`` change. See # `https://github.com/sphinx-doc/sphinx/issues/4460`. meta = { "version": "0.1", - "env_version": 1, + "env_version": 2, "parallel_read_safe": True } return meta diff --git a/dune-workspace b/dune-workspace index 682631e7dc..ee206e8e17 100644 --- a/dune-workspace +++ b/dune-workspace @@ -2,5 +2,5 @@ ; Add custom flags here. Default developer profile is `dev` (env - (dev (flags :standard -rectypes -w -9-27-50)) + (dev (flags :standard -rectypes -w -9-27-50+60)) (release (flags :standard -rectypes))) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 2913645c1c..678f7c6ce6 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -445,10 +445,22 @@ let fold sigma f acc c = match kind sigma c with let compare_gen k eq_inst eq_sort eq_constr nargs c1 c2 = (c1 == c2) || Constr.compare_head_gen_with k k eq_inst eq_sort eq_constr nargs c1 c2 +let eq_einstance sigma i1 i2 = + let i1 = EInstance.kind sigma (EInstance.make i1) in + let i2 = EInstance.kind sigma (EInstance.make i2) in + Univ.Instance.equal i1 i2 + +let eq_esorts sigma s1 s2 = + let s1 = ESorts.kind sigma (ESorts.make s1) in + let s2 = ESorts.kind sigma (ESorts.make s2) in + Sorts.equal s1 s2 + let eq_constr sigma c1 c2 = let kind c = kind_upto sigma c in + let eq_inst _ _ i1 i2 = eq_einstance sigma i1 i2 in + let eq_sorts s1 s2 = eq_esorts sigma s1 s2 in let rec eq_constr nargs c1 c2 = - compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal eq_constr nargs c1 c2 + compare_gen kind eq_inst eq_sorts eq_constr nargs c1 c2 in eq_constr 0 (unsafe_to_constr c1) (unsafe_to_constr c2) @@ -461,8 +473,10 @@ let eq_constr_nounivs sigma c1 c2 = let compare_constr sigma cmp c1 c2 = let kind c = kind_upto sigma c in + let eq_inst _ _ i1 i2 = eq_einstance sigma i1 i2 in + let eq_sorts s1 s2 = eq_esorts sigma s1 s2 in let cmp nargs c1 c2 = cmp (of_constr c1) (of_constr c2) in - compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) + compare_gen kind eq_inst eq_sorts cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) let compare_cumulative_instances cv_pb nargs_ok variances u u' cstrs = let open UnivProblem in diff --git a/engine/ftactic.ml b/engine/ftactic.ml index e23a03c0c7..b371884ba4 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -61,7 +61,7 @@ let nf_enter f = (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) + Proofview.V82.wrap_exceptions (fun () -> f nfgl)) [@warning "-3"] let enter f = bind goals diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 6c389b2d67..3c4fa6f4e8 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -42,6 +42,8 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) val nf_enter : (Proofview.Goal.t -> 'a t) -> 'a t +[@@ocaml.deprecated "Normalization is enforced by EConstr, please use [enter]"] + (** Enter a goal. The resulting tactic is focussed. *) val enter : (Proofview.Goal.t -> 'a t) -> 'a t diff --git a/engine/proofview.mli b/engine/proofview.mli index a9666e4f90..0bb3229a9b 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -497,6 +497,7 @@ module Goal : sig (** Normalises the argument goal. *) val normalize : t -> t tactic + [@@ocaml.deprecated "Normalization is enforced by EConstr, [normalize] is not needed anymore"] (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the @@ -514,6 +515,7 @@ module Goal : sig the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) val nf_enter : (t -> unit tactic) -> unit tactic + [@@ocaml.deprecated "Normalization is enforced by EConstr, please use [enter]"] (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : (t -> unit tactic) -> unit tactic diff --git a/engine/termops.ml b/engine/termops.ml index 156d1370e3..efe1525c9a 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -22,6 +22,8 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration module CompactedDecl = Context.Compacted.Declaration +module Internal = struct + (* Sorts and sort family *) let print_sort = function @@ -49,6 +51,8 @@ let pr_puniverses p u = if Univ.Instance.is_empty u then p else p ++ str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" +(* Minimalistic constr printer, typically for debugging *) + let rec pr_constr c = match kind c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" @@ -96,12 +100,16 @@ let rec pr_constr c = match kind c with cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") -let term_printer = ref (fun _env _sigma c -> pr_constr (EConstr.Unsafe.to_constr c)) +let debug_print_constr c = pr_constr EConstr.Unsafe.(to_constr c) +let debug_print_constr_env env sigma c = pr_constr EConstr.(to_constr sigma c) +let term_printer = ref debug_print_constr_env + let print_constr_env env sigma t = !term_printer env sigma t let print_constr t = let env = Global.env () in let evd = Evd.from_env env in !term_printer env evd t + let set_print_constr f = term_printer := f module EvMap = Evar.Map @@ -1535,3 +1543,6 @@ let env_rel_context_chop k env = let ctx1,ctx2 = List.chop k rels in push_rel_context ctx2 (reset_with_named_context (named_context_val env) env), ctx1 +end + +include Internal diff --git a/engine/termops.mli b/engine/termops.mli index b967bb6abb..aa0f837938 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -311,12 +311,40 @@ val pr_metaset : Metaset.t -> Pp.t val pr_evar_universe_context : UState.t -> Pp.t val pr_evd_level : evar_map -> Univ.Level.t -> Pp.t -(** debug printer: do not use to display terms to the casual user... *) +module Internal : sig -val set_print_constr : (env -> Evd.evar_map -> constr -> Pp.t) -> unit -val print_constr : constr -> Pp.t +(** NOTE: to print terms you always want to use functions in + Printer, not these ones which are for very special cases. *) + +(** debug printers: print raw form for terms, both with + evar-substitution and without. *) +val debug_print_constr : constr -> Pp.t +val debug_print_constr_env : env -> evar_map -> constr -> Pp.t + +(** Pretty-printer hook: [print_constr_env env sigma c] will pretty + print c if the pretty printing layer has been linked into the Coq + binary. *) val print_constr_env : env -> Evd.evar_map -> constr -> Pp.t + +(** [set_print_constr f] sets f to be the pretty printer *) +val set_print_constr : (env -> Evd.evar_map -> constr -> Pp.t) -> unit + +(** Printers for contexts *) val print_named_context : env -> Pp.t val pr_rel_decl : env -> Constr.rel_declaration -> Pp.t val print_rel_context : env -> Pp.t val print_env : env -> Pp.t + +val print_constr : constr -> Pp.t +[@@deprecated "use print_constr_env"] + +end + +val print_constr : constr -> Pp.t +[@@deprecated "use Internal.print_constr_env"] + +val print_constr_env : env -> Evd.evar_map -> constr -> Pp.t +[@@deprecated "use Internal.print_constr_env"] + +val print_rel_context : env -> Pp.t +[@@deprecated "use Internal.print_rel_context"] diff --git a/engine/univNames.ml b/engine/univNames.ml index e861913de2..70cdd3a2db 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Util open Names open Univ -open Nametab let qualid_of_level l = @@ -30,20 +30,6 @@ let pr_with_global_universes l = Libnames.pr_qualid (qualid_of_level l) (** Global universe information outside the kernel, to handle polymorphic universe names in sections that have to be discharged. *) -let universe_map = (Summary.ref UnivIdMap.empty ~name:"global universe info" : bool Nametab.UnivIdMap.t ref) - -let add_global_universe u p = - match Level.name u with - | Some n -> universe_map := Nametab.UnivIdMap.add n p !universe_map - | None -> () - -let is_polymorphic l = - match Level.name l with - | Some n -> - (try Nametab.UnivIdMap.find n !universe_map - with Not_found -> false) - | None -> false - (** Local universe names of polymorphic references *) type universe_binders = Univ.Level.t Names.Id.Map.t @@ -52,10 +38,10 @@ let empty_binders = Id.Map.empty let universe_binders_table = Summary.ref GlobRef.Map.empty ~name:"universe binders" -let universe_binders_of_global ref : universe_binders = +let universe_binders_of_global ref : Id.t list = try let l = GlobRef.Map.find ref !universe_binders_table in l - with Not_found -> Names.Id.Map.empty + with Not_found -> [] let cache_ubinder (_,(ref,l)) = universe_binders_table := GlobRef.Map.add ref l !universe_binders_table @@ -64,10 +50,28 @@ let subst_ubinder (subst,(ref,l as orig)) = let ref' = fst (Globnames.subst_global subst ref) in if ref == ref' then orig else ref', l +let name_universe lvl = + (** Best-effort naming from the string representation of the level. This is + completely hackish and should be solved in upper layers instead. *) + Id.of_string_soft (Level.to_string lvl) + let discharge_ubinder (_,(ref,l)) = + (** Expand polymorphic binders with the section context *) + let info = Lib.section_segment_of_reference ref in + let sec_inst = Array.to_list (Instance.to_array (info.Lib.abstr_subst)) in + let map lvl = match Level.name lvl with + | None -> (* Having Prop/Set/Var as section universes makes no sense *) + assert false + | Some na -> + try + let qid = Nametab.shortest_qualid_of_universe na in + snd (Libnames.repr_qualid qid) + with Not_found -> name_universe lvl + in + let l = List.map map sec_inst @ l in Some (Lib.discharge_global ref, l) -let ubinder_obj : GlobRef.t * universe_binders -> Libobject.obj = +let ubinder_obj : GlobRef.t * Id.t list -> Libobject.obj = let open Libobject in declare_object { (default_object "universe binder") with cache_function = cache_ubinder; @@ -78,28 +82,35 @@ let ubinder_obj : GlobRef.t * universe_binders -> Libobject.obj = rebuild_function = (fun x -> x); } let register_universe_binders ref ubinders = - (* Add the polymorphic (section) universes *) - let ubinders = UnivIdMap.fold (fun lvl poly ubinders -> - let qid = Nametab.shortest_qualid_of_universe lvl in - let level = Level.make (fst lvl) (snd lvl) in - if poly then Id.Map.add (snd (Libnames.repr_qualid qid)) level ubinders - else ubinders) - !universe_map ubinders + (** TODO: change the API to register a [Name.t list] instead. This is the last + part of the code that depends on the internal representation of names in + abstract contexts, but removing it requires quite a rework of the + callers. *) + let univs = AUContext.instance (Global.universes_of_global ref) in + let revmap = Id.Map.fold (fun id lvl accu -> LMap.add lvl id accu) ubinders LMap.empty in + let map lvl = + try LMap.find lvl revmap + with Not_found -> name_universe lvl in - if not (Id.Map.is_empty ubinders) - then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders)) + let ubinders = Array.map_to_list map (Instance.to_array univs) in + if not (List.is_empty ubinders) then Lib.add_anonymous_leaf (ubinder_obj (ref, ubinders)) type univ_name_list = Names.lname list -let universe_binders_with_opt_names ref levels = function - | None -> universe_binders_of_global ref +let universe_binders_with_opt_names ref names = + let orig = universe_binders_of_global ref in + let udecl = match names with + | None -> orig | Some udecl -> - if Int.equal(List.length levels) (List.length udecl) - then - List.fold_left2 (fun acc { CAst.v = na} lvl -> match na with - | Anonymous -> acc - | Name na -> Names.Id.Map.add na lvl acc) - empty_binders udecl levels - else + try + List.map2 (fun orig {CAst.v = na} -> + match na with + | Anonymous -> orig + | Name id -> id) orig udecl + with Invalid_argument _ -> + let len = List.length orig in CErrors.user_err ~hdr:"universe_binders_with_opt_names" - Pp.(str "Universe instance should have length " ++ int (List.length levels)) + Pp.(str "Universe instance should have length " ++ int len) + in + let fold i acc na = Names.Id.Map.add na (Level.var i) acc in + List.fold_left_i fold 0 empty_binders udecl diff --git a/engine/univNames.mli b/engine/univNames.mli index 837beac267..bd4062ade4 100644 --- a/engine/univNames.mli +++ b/engine/univNames.mli @@ -13,13 +13,6 @@ open Univ val pr_with_global_universes : Level.t -> Pp.t val qualid_of_level : Level.t -> Libnames.qualid -(** Global universe information outside the kernel, to handle - polymorphic universes in sections that have to be discharged. *) -val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit - -(** Is [lvl] a global polymorphic universe? (ie section polymorphic universe) *) -val is_polymorphic : Level.t -> bool - (** Local universe name <-> level mapping *) type universe_binders = Univ.Level.t Names.Id.Map.t @@ -27,15 +20,14 @@ type universe_binders = Univ.Level.t Names.Id.Map.t val empty_binders : universe_binders val register_universe_binders : Names.GlobRef.t -> universe_binders -> unit -val universe_binders_of_global : Names.GlobRef.t -> universe_binders type univ_name_list = Names.lname list -(** [universe_binders_with_opt_names ref u l] +(** [universe_binders_with_opt_names ref l] - If [l] is [Some univs] return the universe binders naming the levels of [u] by [univs] (skipping Anonymous). - May error if the lengths mismatch. + If [l] is [Some univs] return the universe binders naming the bound levels + of [ref] by [univs] (skipping Anonymous). May error if the lengths mismatch. - Otherwise return [universe_binders_of_global ref]. *) + Otherwise return the bound universe names registered for [ref]. *) val universe_binders_with_opt_names : Names.GlobRef.t -> - Univ.Level.t list -> univ_name_list option -> universe_binders + univ_name_list option -> universe_binders diff --git a/engine/universes.ml b/engine/universes.ml index ee9668433c..5d0157b2db 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -19,14 +19,9 @@ type univ_name_list = UnivNames.univ_name_list let pr_with_global_universes = UnivNames.pr_with_global_universes let reference_of_level = UnivNames.qualid_of_level -let add_global_universe = UnivNames.add_global_universe - -let is_polymorphic = UnivNames.is_polymorphic - let empty_binders = UnivNames.empty_binders let register_universe_binders = UnivNames.register_universe_binders -let universe_binders_of_global = UnivNames.universe_binders_of_global let universe_binders_with_opt_names = UnivNames.universe_binders_with_opt_names diff --git a/engine/universes.mli b/engine/universes.mli index ad937471e9..0d3bae4c95 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -25,12 +25,6 @@ val pr_with_global_universes : Level.t -> Pp.t val reference_of_level : Level.t -> Libnames.qualid [@@ocaml.deprecated "Use [UnivNames.qualid_of_level]"] -val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit -[@@ocaml.deprecated "Use [UnivNames.add_global_universe]"] - -val is_polymorphic : Level.t -> bool -[@@ocaml.deprecated "Use [UnivNames.is_polymorphic]"] - type universe_binders = UnivNames.universe_binders [@@ocaml.deprecated "Use [UnivNames.universe_binders]"] @@ -39,14 +33,12 @@ val empty_binders : universe_binders val register_universe_binders : Globnames.global_reference -> universe_binders -> unit [@@ocaml.deprecated "Use [UnivNames.register_universe_binders]"] -val universe_binders_of_global : Globnames.global_reference -> universe_binders -[@@ocaml.deprecated "Use [UnivNames.universe_binders_of_global]"] type univ_name_list = UnivNames.univ_name_list [@@ocaml.deprecated "Use [UnivNames.univ_name_list]"] val universe_binders_with_opt_names : Globnames.global_reference -> - Univ.Level.t list -> univ_name_list option -> universe_binders + univ_name_list option -> universe_binders [@@ocaml.deprecated "Use [UnivNames.universe_binders_with_opt_names]"] (** ****** Deprecated: moved to [UnivGen] *) @@ -1,10 +1,11 @@ -(executable - (name idetop) - (public_name coqidetop.opt) - (package coqide) - (modules idetop) - (libraries coq.toplevel coqide.protocol) - (link_flags -linkall)) +(ocamllex utf8_convert config_lexer coq_lex) + +(library + (name core) + (public_name coqide.core) + (wrapped false) + (modules (:standard \ idetop coqide_main)) + (libraries threads str lablgtk2.sourceview2 coq.lib coqide.protocol)) (rule (targets coqide_main.ml) @@ -15,7 +16,13 @@ (name coqide_main) (public_name coqide) (package coqide) - (modules (:standard \ idetop)) - (libraries threads str lablgtk2.sourceview2 coq.lib coqide.protocol)) + (modules coqide_main) + (libraries coqide.core)) -(ocamllex utf8_convert config_lexer coq_lex) +(executable + (name idetop) + (public_name coqidetop.opt) + (package coqide) + (modules idetop) + (libraries coq.toplevel coqide.protocol) + (link_flags -linkall)) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index ddc0a5c000..3996a1756c 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -102,7 +102,7 @@ let _show_inactive_notations () = (function | NotationRule (scopt, ntn) -> Feedback.msg_notice (pr_notation ntn ++ show_scope scopt) - | SynDefRule kn -> Feedback.msg_notice (str (Names.KerName.to_string kn))) + | SynDefRule kn -> Feedback.msg_notice (str (string_of_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn)))) !inactive_notations_table let deactivate_notation nr = @@ -135,8 +135,9 @@ let reactivate_notation nr = ++ str "is already active" ++ show_scope scopt ++ str ".") | SynDefRule kn -> + let s = string_of_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) in Feedback.msg_warning - (str "Notation" ++ spc () ++ str (Names.KerName.to_string kn) + (str "Notation" ++ spc () ++ str s ++ spc () ++ str "is already active.") diff --git a/interp/declare.ml b/interp/declare.ml index 22e6cf9d1c..23c68b5e18 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -491,7 +491,6 @@ let add_universe src (dp, i) = Option.iter (fun poly -> let ctx = Univ.ContextSet.add_universe level Univ.ContextSet.empty in Global.push_context_set poly ctx; - UnivNames.add_global_universe level poly; if poly then Lib.add_section_context ctx) optpoly @@ -580,7 +579,7 @@ let do_constraint poly l = let open Univ in let u_of_id x = let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in - UnivNames.is_polymorphic level, level + Lib.is_polymorphic_univ level, level in let in_section = Lib.sections_are_opened () in let () = diff --git a/interp/notation.ml b/interp/notation.ml index a6a14efc87..02c7812e21 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -379,23 +379,364 @@ module InnerPrimToken = struct end -(* The following two tables of (un)interpreters will *not* be synchronized. - But their indexes will be checked to be unique *) +(* The following two tables of (un)interpreters will *not* be + synchronized. But their indexes will be checked to be unique. + These tables contain primitive token interpreters which are + registered in plugins, such as string and ascii syntax. It is + essential that only plugins add to these tables, and that + vernacular commands do not. See + https://github.com/coq/coq/issues/8401 for details of what goes + wrong when vernacular commands add to these tables. *) let prim_token_interpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.interpreter) Hashtbl.t) let prim_token_uninterpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.uninterpreter) Hashtbl.t) +(*******************************************************) +(* Numeral notation interpretation *) +type numeral_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error + +type numnot_option = + | Nop + | Warning of raw_natural_number + | Abstract of raw_natural_number + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + +type option_kind = Option | Direct +type conversion_kind = target_kind * option_kind + +type numeral_notation_obj = + { to_kind : conversion_kind; + to_ty : GlobRef.t; + of_kind : conversion_kind; + of_ty : GlobRef.t; + num_ty : Libnames.qualid; (* for warnings / error messages *) + warning : numnot_option } + +module Numeral = struct +(** * Numeral notation *) + +(** Reduction + + The constr [c] below isn't necessarily well-typed, since we + built it via an [mkApp] of a conversion function on a term + that starts with the right constructor but might be partially + applied. + + At least [c] is known to be evar-free, since it comes from + our own ad-hoc [constr_of_glob] or from conversions such + as [coqint_of_rawnum]. +*) + +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let sigma,t = Typing.type_of env sigma c in + let c' = Vnorm.cbv_vm env sigma c t in + EConstr.Unsafe.to_constr c' + +(* For testing with "compute" instead of "vm_compute" : +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let c' = Tacred.compute env sigma c in + EConstr.Unsafe.to_constr c' +*) + +let eval_constr_app env sigma c1 c2 = + eval_constr env sigma (mkApp (c1,[| c2 |])) + +exception NotANumber + +let warn_large_num = + CWarnings.create ~name:"large-number" ~category:"numbers" + (fun ty -> + strbrk "Stack overflow or segmentation fault happens when " ++ + strbrk "working with large numbers in " ++ pr_qualid ty ++ + strbrk " (threshold may vary depending" ++ + strbrk " on your system limits and on the command executed).") + +let warn_abstract_large_num = + CWarnings.create ~name:"abstract-large-number" ~category:"numbers" + (fun (ty,f) -> + strbrk "To avoid stack overflow, large numbers in " ++ + pr_qualid ty ++ strbrk " are interpreted as applications of " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") + +(** Comparing two raw numbers (base 10, big-endian, non-negative). + A bit nasty, but not critical: only used to decide when a + number is considered as large (see warnings above). *) + +exception Comp of int + +let rec rawnum_compare s s' = + let l = String.length s and l' = String.length s' in + if l < l' then - rawnum_compare s' s + else + let d = l-l' in + try + for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; + for i = d to l-1 do + let c = Pervasives.compare s.[i] s'.[i-d] in + if c != 0 then raise (Comp c) + done; + 0 + with Comp c -> c + +(***********************************************************************) + +(** ** Conversion between Coq [Decimal.int] and internal raw string *) + +(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) + +let digit_of_char c = + assert ('0' <= c && c <= '9'); + Char.code c - Char.code '0' + 2 + +let char_of_digit n = + assert (2<=n && n<=11); + Char.chr (n-2 + Char.code '0') + +let coquint_of_rawnum uint str = + let nil = mkConstruct (uint,1) in + let rec do_chars s i acc = + if i < 0 then acc + else + let dg = mkConstruct (uint, digit_of_char s.[i]) in + do_chars s (i-1) (mkApp(dg,[|acc|])) + in + do_chars str (String.length str - 1) nil + +let coqint_of_rawnum inds (str,sign) = + let uint = coquint_of_rawnum inds.uint str in + mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) + +let rawnum_of_coquint c = + let rec of_uint_loop c buf = + match Constr.kind c with + | Construct ((_,1), _) (* Nil *) -> () + | App (c, [|a|]) -> + (match Constr.kind c with + | Construct ((_,n), _) (* D0 to D9 *) -> + let () = Buffer.add_char buf (char_of_digit n) in + of_uint_loop a buf + | _ -> raise NotANumber) + | _ -> raise NotANumber + in + let buf = Buffer.create 64 in + let () = of_uint_loop c buf in + if Int.equal (Buffer.length buf) 0 then + (* To avoid ambiguities between Nil and (D0 Nil), we choose + to not display Nil alone as "0" *) + raise NotANumber + else Buffer.contents buf + +let rawnum_of_coqint c = + match Constr.kind c with + | App (c,[|c'|]) -> + (match Constr.kind c with + | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) + | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) + | _ -> raise NotANumber) + | _ -> raise NotANumber + + +(***********************************************************************) + +(** ** Conversion between Coq [Z] and internal bigint *) + +(** First, [positive] from/to bigint *) + +let rec pos_of_bigint posty n = + match Bigint.div2_with_rest n with + | (q, false) -> + let c = mkConstruct (posty, 2) in (* xO *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) when not (Bigint.equal q Bigint.zero) -> + let c = mkConstruct (posty, 1) in (* xI *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) -> + mkConstruct (posty, 3) (* xH *) + +let rec bigint_of_pos c = match Constr.kind c with + | Construct ((_, 3), _) -> (* xH *) Bigint.one + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) + | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) + | n -> assert false (* no other constructor of type positive *) + end + | x -> raise NotANumber + end + | x -> raise NotANumber + +(** Now, [Z] from/to bigint *) + +let z_of_bigint { z_ty; pos_ty } n = + if Bigint.equal n Bigint.zero then + mkConstruct (z_ty, 1) (* Z0 *) + else + let (s, n) = + if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) + else (3, Bigint.neg n) (* Zneg *) + in + let c = mkConstruct (z_ty, s) in + mkApp (c, [| pos_of_bigint pos_ty n |]) + +let bigint_of_z z = match Constr.kind z with + | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 2 -> (* Zpos *) bigint_of_pos d + | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) + | n -> assert false (* no other constructor of type Z *) + end + | _ -> raise NotANumber + end + | _ -> raise NotANumber + +(** The uninterp function below work at the level of [glob_constr] + which is too low for us here. So here's a crude conversion back + to [constr] for the subset that concerns us. *) + +let rec constr_of_glob env sigma g = match DAst.get g with + | Glob_term.GRef (ConstructRef c, _) -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | Glob_term.GApp (gc, gcl) -> + let sigma,c = constr_of_glob env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | _ -> + raise NotANumber + +let rec glob_of_constr ?loc env sigma c = match Constr.kind c with + | App (c, ca) -> + let c = glob_of_constr ?loc env sigma c in + let cel = List.map (glob_of_constr ?loc env sigma) (Array.to_list ca) in + DAst.make ?loc (Glob_term.GApp (c, cel)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | _ -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedTerm c)) + +let no_such_number ?loc ty = + CErrors.user_err ?loc + (str "Cannot interpret this number as a value of type " ++ + pr_qualid ty) + +let interp_option ty ?loc env sigma c = + match Constr.kind c with + | App (_Some, [| _; c |]) -> glob_of_constr ?loc env sigma c + | App (_None, [| _ |]) -> no_such_number ?loc ty + | x -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedNonOptionTerm c)) + +let uninterp_option c = + match Constr.kind c with + | App (_Some, [| _; x |]) -> x + | _ -> raise NotANumber + +let big2raw n = + if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) + else (Bigint.to_string (Bigint.neg n), false) + +let raw2big (n,s) = + if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) + +let interp o ?loc n = + begin match o.warning with + | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> + warn_large_num o.num_ty + | _ -> () + end; + let c = match fst o.to_kind with + | Int int_ty -> coqint_of_rawnum int_ty n + | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) + | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty + | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) + in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + match o.warning, snd o.to_kind with + | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> + warn_abstract_large_num (o.num_ty,o.to_ty); + glob_of_constr ?loc env sigma (mkApp (to_ty,[|c|])) + | _ -> + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr ?loc env sigma res + | Option -> interp_option o.num_ty ?loc env sigma res + +let uninterp o (Glob_term.AnyGlobConstr n) = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in + let of_ty = EConstr.Unsafe.to_constr of_ty in + try + let sigma,n = constr_of_glob env sigma n in + let c = eval_constr_app env sigma of_ty n in + let c = if snd o.of_kind == Direct then c else uninterp_option c in + match fst o.of_kind with + | Int _ -> Some (rawnum_of_coqint c) + | UInt _ -> Some (rawnum_of_coquint c, true) + | Z _ -> Some (big2raw (bigint_of_z c)) + with + | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) + | NotANumber -> None (* all other functions except big2raw *) +end + +(* A [prim_token_infos], which is synchronized with the document + state, either contains a unique id pointing to an unsynchronized + prim token function, or a numeral notation object describing how to + interpret and uninterpret. We provide [prim_token_infos] because + we expect plugins to provide their own interpretation functions, + rather than going through numeral notations, which are available as + a vernacular. *) + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + +type prim_token_infos = { + pt_local : bool; (** Is this interpretation local? *) + pt_scope : scope_name; (** Concerned scope *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_required : required_module; (** Module that should be loaded first *) + pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) + pt_in_match : bool (** Is this prim token legal in match patterns ? *) +} + (* Table from scope_name to backtrack-able informations about interpreters (in particular interpreter unique id). *) let prim_token_interp_infos = - ref (String.Map.empty : (required_module * prim_token_uid) String.Map.t) + ref (String.Map.empty : (required_module * prim_token_interp_info) String.Map.t) (* Table from global_reference to backtrack-able informations about prim_token uninterpretation (in particular uninterpreter unique id). *) let prim_token_uninterp_infos = - ref (GlobRef.Map.empty : (scope_name * prim_token_uid * bool) GlobRef.Map.t) + ref (GlobRef.Map.empty : (scope_name * prim_token_interp_info * bool) GlobRef.Map.t) let hashtbl_check_and_set allow_overwrite uid f h eq = match Hashtbl.find h uid with @@ -425,23 +766,14 @@ let register_string_interpretation ?(allow_overwrite=false) uid (interp, uninter register_gen_interpretation allow_overwrite uid (InnerPrimToken.StringInterp interp, InnerPrimToken.StringUninterp uninterp) -type prim_token_infos = { - pt_local : bool; (** Is this interpretation local? *) - pt_scope : scope_name; (** Concerned scope *) - pt_uid : prim_token_uid; (** Unique id "pointing" to (un)interp functions *) - pt_required : required_module; (** Module that should be loaded first *) - pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) - pt_in_match : bool (** Is this prim token legal in match patterns ? *) -} - let cache_prim_token_interpretation (_,infos) = + let ptii = infos.pt_interp_info in let sc = infos.pt_scope in - let uid = infos.pt_uid in check_scope ~tolerant:true sc; prim_token_interp_infos := - String.Map.add sc (infos.pt_required,infos.pt_uid) !prim_token_interp_infos; + String.Map.add sc (infos.pt_required,ptii) !prim_token_interp_infos; List.iter (fun r -> prim_token_uninterp_infos := - GlobRef.Map.add r (sc,uid,infos.pt_in_match) + GlobRef.Map.add r (sc,ptii,infos.pt_in_match) !prim_token_uninterp_infos) infos.pt_refs @@ -479,7 +811,7 @@ let declare_numeral_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = enable_prim_token_interpretation { pt_local = local; pt_scope = sc; - pt_uid = uid; + pt_interp_info = Uid uid; pt_required = dir; pt_refs = List.map_filter glob_prim_constr_key patl; pt_in_match = b } @@ -489,7 +821,7 @@ let declare_string_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = enable_prim_token_interpretation { pt_local = local; pt_scope = sc; - pt_uid = uid; + pt_interp_info = Uid uid; pt_required = dir; pt_refs = List.map_filter glob_prim_constr_key patl; pt_in_match = b } @@ -605,9 +937,12 @@ let find_prim_token check_allowed ?loc p sc = pat, df with Not_found -> (* Try for a primitive numerical notation *) - let (spdir,uid) = String.Map.find sc !prim_token_interp_infos in + let (spdir,info) = String.Map.find sc !prim_token_interp_infos in check_required_module ?loc sc spdir; - let interp = Hashtbl.find prim_token_interpreters uid in + let interp = match info with + | Uid uid -> Hashtbl.find prim_token_interpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + in let pat = InnerPrimToken.do_interp ?loc interp p in check_allowed pat; pat, ((dirpath (fst spdir),DirPath.empty),"") @@ -783,8 +1118,11 @@ let uninterp_prim_token c = | None -> raise Notation_ops.No_match | Some r -> try - let (sc,uid,_) = GlobRef.Map.find r !prim_token_uninterp_infos in - let uninterp = Hashtbl.find prim_token_uninterpreters uid in + let (sc,info,_) = GlobRef.Map.find r !prim_token_uninterp_infos in + let uninterp = match info with + | Uid uid -> Hashtbl.find prim_token_uninterpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) @@ -799,12 +1137,16 @@ let availability_of_prim_token n printer_scope local_scopes = let f scope = try let uid = snd (String.Map.find scope !prim_token_interp_infos) in - let interp = Hashtbl.find prim_token_interpreters uid in let open InnerPrimToken in - match n, interp with - | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true - | String _, StringInterp _ -> true - | _ -> false + match n, uid with + | Numeral _, NumeralNotation _ -> true + | _, NumeralNotation _ -> false + | _, Uid uid -> + let interp = Hashtbl.find prim_token_interpreters uid in + match n, interp with + | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true + | String _, StringInterp _ -> true + | _ -> false with Not_found -> false in let scopes = make_current_scopes local_scopes in diff --git a/interp/notation.mli b/interp/notation.mli index 6e59c0fd70..734198bbf6 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -102,10 +102,51 @@ val register_bignumeral_interpretation : val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit +(** * Numeral notation *) + +type numeral_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error + +type numnot_option = + | Nop + | Warning of raw_natural_number + | Abstract of raw_natural_number + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + +type option_kind = Option | Direct +type conversion_kind = target_kind * option_kind + +type numeral_notation_obj = + { to_kind : conversion_kind; + to_ty : GlobRef.t; + of_kind : conversion_kind; + of_ty : GlobRef.t; + num_ty : Libnames.qualid; (* for warnings / error messages *) + warning : numnot_option } + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_uid : prim_token_uid; (** Unique id "pointing" to (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index fd9394025a..c4c96c9b55 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -281,7 +281,7 @@ let assoc_defined id env = match Environ.lookup_named id env with | LocalDef (_, c, _) -> c | _ -> raise Not_found -let ref_value_cache ({i_cache = cache} as infos) tab ref = +let ref_value_cache ({i_cache = cache;_} as infos) tab ref = try Some (KeyTable.find tab ref) with Not_found -> @@ -289,7 +289,7 @@ let ref_value_cache ({i_cache = cache} as infos) tab ref = let body = match ref with | RelKey n -> - let open Context.Rel.Declaration in + let open! Context.Rel.Declaration in let i = n - 1 in let (d, _) = try Range.get cache.i_rels i @@ -837,7 +837,7 @@ let eta_expand_ind_stack env ind m s (f, s') = arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.Declarations.mind_nparams in let right = fapp_stack (f, s') in - let (depth, args, s) = strip_update_shift_app m s in + let (depth, args, _s) = strip_update_shift_app m s in (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in let hstack = Array.map (fun p -> @@ -925,7 +925,7 @@ and knht info e t stk = | Fix _ -> knh info (mk_clos2 e t) stk | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk - | Proj (p,c) -> knh info (mk_clos2 e t) stk + | Proj (_p,_c) -> knh info (mk_clos2 e t) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) @@ -952,7 +952,7 @@ let rec knr info tab m stk = (match ref_value_cache info tab (RelKey k) with Some v -> kni info tab v stk | None -> (set_norm m; (m,stk))) - | FConstruct((ind,c),u) -> + | FConstruct((_ind,c),_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then @@ -1018,7 +1018,7 @@ let rec zip_term zfun m stk = zip_term zfun h s | Zshift(n)::s -> zip_term zfun (lift n m) s - | Zupdate(rf)::s -> + | Zupdate(_rf)::s -> zip_term zfun m s (* Computes the strong normal form of a term. @@ -1038,7 +1038,7 @@ let rec kl info tab m = and norm_head info tab m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with - | FLambda(n,tys,f,e) -> + | FLambda(_n,tys,f,e) -> let (e',rvtys) = List.fold_left (fun (e,ctxt) (na,ty) -> (subs_lift e, (na,kl info tab (mk_clos e ty))::ctxt)) diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index ed3bd866a4..c63795b295 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -126,8 +126,8 @@ let compare e1 e2 = match e1, e2 with | FVrel r1, FVrel r2 -> Int.compare r1 r2 | FVrel _, (FVuniv_var _ | FVevar _) -> -1 | FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 -| FVuniv_var i1, (FVnamed _ | FVrel _) -> 1 -| FVuniv_var i1, FVevar _ -> -1 +| FVuniv_var _i1, (FVnamed _ | FVrel _) -> 1 +| FVuniv_var _i1, FVevar _ -> -1 | FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1 | FVevar e1, FVevar e2 -> Evar.compare e1 e2 diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 5362f9a814..73620ae578 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -413,7 +413,7 @@ let code_makeblock ~stack_size ~arity ~tag cont = Kpush :: nest_block tag arity cont end -let compile_structured_constant cenv sc sz cont = +let compile_structured_constant _cenv sc sz cont = set_max_stack_size sz; Kconst sc :: cont @@ -534,7 +534,7 @@ let rec compile_lam env cenv lam sz cont = comp_app compile_structured_constant compile_get_univ cenv (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont - | Llet (id,def,body) -> + | Llet (_id,def,body) -> compile_lam env cenv def sz (Kpush :: compile_lam env (push_local sz cenv) body (sz+1) (add_pop 1 cont)) @@ -561,7 +561,7 @@ let rec compile_lam env cenv lam sz cont = | _ -> comp_app (compile_lam env) (compile_lam env) cenv f args sz cont end - | Lfix ((rec_args, init), (decl, types, bodies)) -> + | Lfix ((rec_args, init), (_decl, types, bodies)) -> let ndef = Array.length types in let rfv = ref empty_fv in let lbl_types = Array.make ndef Label.no in @@ -594,7 +594,7 @@ let rec compile_lam env cenv lam sz cont = (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) - | Lcofix(init, (decl,types,bodies)) -> + | Lcofix(init, (_decl,types,bodies)) -> let ndef = Array.length types in let lbl_types = Array.make ndef Label.no in let lbl_bodies = Array.make ndef Label.no in diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 31dede6f5d..c21ce22421 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -107,7 +107,7 @@ let rec pp_lam lam = | Lval _ -> str "values" | Lsort s -> pp_sort s | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i - | Lprim((kn,_u),ar,op,args) -> + | Lprim((kn,_u),_ar,_op,args) -> hov 1 (str "(PRIM " ++ pr_con kn ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ @@ -215,7 +215,7 @@ let rec map_lam_with_binders g f n lam = let u' = map_uint g f n u in if u == u' then lam else Luint u' -and map_uint g f n u = +and map_uint _g f n u = match u with | UintVal _ -> u | UintDigits(args) -> @@ -532,7 +532,7 @@ struct size = 0; } - let extend v = + let extend (v : 'a t) = if v.size = Array.length v.elems then let new_size = min (2*v.size) Sys.max_array_length in if new_size <= v.size then raise (Invalid_argument "Vect.extend"); @@ -545,12 +545,12 @@ struct v.elems.(v.size) <- a; v.size <- v.size + 1 - let popn v n = + let popn (v : 'a t) n = v.size <- max 0 (v.size - n) let pop v = popn v 1 - let get_last v n = + let get_last (v : 'a t) n = if v.size <= n then raise (Invalid_argument "Vect.get:index out of bounds"); v.elems.(v.size - n - 1) @@ -715,7 +715,7 @@ let rec lambda_of_constr env c = and lambda_of_app env f args = match Constr.kind f with - | Const (kn,u as c) -> + | Const (kn,_u as c) -> let kn = get_alias env.global_env kn in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function diff --git a/kernel/constr.ml b/kernel/constr.ml index c73fe7fbde..b25f38d630 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -360,17 +360,17 @@ let destConst c = match kind c with (* Destructs an existential variable *) let destEvar c = match kind c with - | Evar (kn, a as r) -> r + | Evar (_kn, _a as r) -> r | _ -> raise DestKO (* Destructs a (co)inductive type named kn *) let destInd c = match kind c with - | Ind (kn, a as r) -> r + | Ind (_kn, _a as r) -> r | _ -> raise DestKO (* Destructs a constructor *) let destConstruct c = match kind c with - | Construct (kn, a as r) -> r + | Construct (_kn, _a as r) -> r | _ -> raise DestKO (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) @@ -421,12 +421,12 @@ let fold f acc c = match kind c with | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l - | Proj (p,c) -> f acc c + | Proj (_p,c) -> f acc c | Evar (_,l) -> Array.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl - | Fix (_,(lna,tl,bl)) -> + | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl - | CoFix (_,(lna,tl,bl)) -> + | CoFix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl (* [iter f c] iters [f] on the immediate subterms of [c]; it is @@ -441,7 +441,7 @@ let iter f c = match kind c with | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l - | Proj (p,c) -> f c + | Proj (_p,c) -> f c | Evar (_,l) -> Array.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -463,7 +463,7 @@ let iter_with_binders g f n c = match kind c with | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> Array.Fun1.iter f n l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl - | Proj (p,c) -> f n c + | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> Array.Fun1.iter f n tl; Array.Fun1.iter f (iterate g (Array.length tl) n) bl @@ -483,19 +483,19 @@ let fold_constr_with_binders g f n acc c = | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g n) (f n acc t) c - | Lambda (na,t,c) -> f (g n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g n) (f n (f n acc b) t) c + | Prod (_na,t,c) -> f (g n) (f n acc t) c + | Lambda (_na,t,c) -> f (g n) (f n acc t) c + | LetIn (_na,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l - | Proj (p,c) -> f n acc c + | Proj (_p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in + let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in + let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -963,11 +963,11 @@ let constr_ord_int f t1 t2 = | LetIn _, _ -> -1 | _, LetIn _ -> 1 | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 | App _, _ -> -1 | _, App _ -> 1 - | Const (c1,u1), Const (c2,u2) -> Constant.CanOrd.compare c1 c2 + | Const (c1,_u1), Const (c2,_u2) -> Constant.CanOrd.compare c1 c2 | Const _, _ -> -1 | _, Const _ -> 1 - | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Ind (ind1, _u1), Ind (ind2, _u2) -> ind_ord ind1 ind2 | Ind _, _ -> -1 | _, Ind _ -> 1 - | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 + | Construct (ct1,_u1), Construct (ct2,_u2) -> constructor_ord ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 @@ -1226,9 +1226,9 @@ let rec hash t = combinesmall 11 (combine (constructor_hash c) (Instance.hash u)) | Case (_ , p, c, bl) -> combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl)) - | Fix (ln ,(_, tl, bl)) -> + | Fix (_ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) - | CoFix(ln, (_, tl, bl)) -> + | CoFix(_ln, (_, tl, bl)) -> combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl)) | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n diff --git a/kernel/context.ml b/kernel/context.ml index 4a7204b75c..3d98381fbb 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -142,8 +142,8 @@ struct (** Reduce all terms in a given declaration to a single value. *) let fold_constr f decl acc = match decl with - | LocalAssum (n,ty) -> f ty acc - | LocalDef (n,v,ty) -> f ty (f v acc) + | LocalAssum (_n,ty) -> f ty acc + | LocalDef (_n,v,ty) -> f ty (f v acc) let to_tuple = function | LocalAssum (na, ty) -> na, None, ty @@ -151,7 +151,7 @@ struct let drop_body = function | LocalAssum _ as d -> d - | LocalDef (na, v, ty) -> LocalAssum (na, ty) + | LocalDef (na, _v, ty) -> LocalAssum (na, ty) end @@ -356,7 +356,7 @@ struct let drop_body = function | LocalAssum _ as d -> d - | LocalDef (id, v, ty) -> LocalAssum (id, ty) + | LocalDef (id, _v, ty) -> LocalAssum (id, ty) let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 7ef63c1860..c74f2ab318 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -42,7 +42,7 @@ let empty = { cst_trstate = Cpred.full; } -let get_strategy { var_opacity; cst_opacity } f = function +let get_strategy { var_opacity; cst_opacity; _ } f = function | VarKey id -> (try Id.Map.find id var_opacity with Not_found -> default) @@ -51,7 +51,7 @@ let get_strategy { var_opacity; cst_opacity } f = function with Not_found -> default) | RelKey _ -> Expand -let set_strategy ({ var_opacity; cst_opacity } as oracle) k l = +let set_strategy ({ var_opacity; cst_opacity; _ } as oracle) k l = match k with | VarKey id -> let var_opacity = @@ -75,13 +75,13 @@ let set_strategy ({ var_opacity; cst_opacity } as oracle) k l = { oracle with cst_opacity; cst_trstate; } | RelKey _ -> CErrors.user_err Pp.(str "set_strategy: RelKey") -let fold_strategy f { var_opacity; cst_opacity; } accu = +let fold_strategy f { var_opacity; cst_opacity; _ } accu = let fvar id lvl accu = f (VarKey id) lvl accu in let fcst cst lvl accu = f (ConstKey cst) lvl accu in let accu = Id.Map.fold fvar var_opacity accu in Cmap.fold fcst cst_opacity accu -let get_transp_state { var_trstate; cst_trstate } = (var_trstate, cst_trstate) +let get_transp_state { var_trstate; cst_trstate; _ } = (var_trstate, cst_trstate) (* Unfold the first constant only if it is "more transparent" than the second one. In case of tie, use the recommended default. *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 657478a106..b361e36bbf 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -91,7 +91,7 @@ let update_case_info cache ci modlist = try let ind, n = match share cache (IndRef ci.ci_ind) modlist with - | (IndRef f,(u,l)) -> (f, Array.length l) + | (IndRef f,(_u,l)) -> (f, Array.length l) | _ -> assert false in { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } with Not_found -> diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index bb9231d000..8bef6aec42 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -173,7 +173,7 @@ and slot_for_fv env fv = | Some (v, _) -> v end | FVevar evk -> val_of_evar evk - | FVuniv_var idu -> + | FVuniv_var _idu -> assert false and eval_to_patch env (buff,pl,fv) = @@ -192,5 +192,5 @@ and val_of_constr env c = | Some v -> eval_to_patch env (to_memory v) | None -> assert false -let set_transparent_const kn = () (* !?! *) -let set_opaque_const kn = () (* !?! *) +let set_transparent_const _kn = () (* !?! *) +let set_opaque_const _kn = () (* !?! *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 51ec3defb3..d995786d97 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -181,7 +181,7 @@ let subst_regular_ind_arity sub s = if uar' == s.mind_user_arity then s else { mind_user_arity = uar'; mind_sort = s.mind_sort } -let subst_template_ind_arity sub s = s +let subst_template_ind_arity _sub s = s (* FIXME records *) let subst_ind_arity = @@ -240,14 +240,14 @@ let inductive_polymorphic_context mib = let inductive_is_polymorphic mib = match mib.mind_universes with | Monomorphic_ind _ -> false - | Polymorphic_ind ctx -> true - | Cumulative_ind cumi -> true + | Polymorphic_ind _ctx -> true + | Cumulative_ind _cumi -> true let inductive_is_cumulative mib = match mib.mind_universes with | Monomorphic_ind _ -> false - | Polymorphic_ind ctx -> false - | Cumulative_ind cumi -> true + | Polymorphic_ind _ctx -> false + | Cumulative_ind _cumi -> true let inductive_make_projection ind mib ~proj_arg = match mib.mind_record with diff --git a/kernel/dune b/kernel/dune index 011af9c28c..a503238907 100644 --- a/kernel/dune +++ b/kernel/dune @@ -13,3 +13,8 @@ (documentation (package coq)) + +; In dev profile, we check the kernel against a more strict set of +; warnings. +(env + (dev (flags :standard -w +a-4-44-50))) diff --git a/kernel/environ.ml b/kernel/environ.ml index 3bfcaa7f52..dffcd70282 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -296,12 +296,12 @@ let eq_named_context_val c1 c2 = (* A local const is evaluable if it is defined *) -open Context.Named.Declaration - let named_type id env = + let open Context.Named.Declaration in get_type (lookup_named id env) let named_body id env = + let open Context.Named.Declaration in get_value (lookup_named id env) let evaluable_named id env = @@ -333,7 +333,7 @@ let fold_named_context f env ~init = let rec fold_right env = match match_named_context_val env.env_named_context with | None -> init - | Some (d, v, rem) -> + | Some (d, _v, rem) -> let env = reset_with_named_context rem env in f env d (fold_right env) @@ -415,7 +415,7 @@ let constant_type env (kn,u) = let cb = lookup_constant kn env in match cb.const_universes with | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty - | Polymorphic_const ctx -> + | Polymorphic_const _ctx -> let csts = constraints_of cb u in (subst_instance_constr u cb.const_type, csts) @@ -508,14 +508,14 @@ let get_projections env ind = Declareops.inductive_make_projections ind mib (* Mutual Inductives *) -let polymorphic_ind (mind,i) env = +let polymorphic_ind (mind,_i) env = Declareops.inductive_is_polymorphic (lookup_mind mind env) let polymorphic_pind (ind,u) env = if Univ.Instance.is_empty u then false else polymorphic_ind ind env -let type_in_type_ind (mind,i) env = +let type_in_type_ind (mind,_i) env = not (lookup_mind mind env).mind_typing_flags.check_universes let template_polymorphic_ind (mind,i) env = @@ -527,7 +527,7 @@ let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env -let add_mind_key kn (mind, _ as mind_key) env = +let add_mind_key kn (_mind, _ as mind_key) env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in let new_globals = { env.env_globals with @@ -543,7 +543,7 @@ let lookup_constant_variables c env = let cmap = lookup_constant c env in Context.Named.to_vars cmap.const_hyps -let lookup_inductive_variables (kn,i) env = +let lookup_inductive_variables (kn,_i) env = let mis = lookup_mind kn env in Context.Named.to_vars mis.mind_hyps @@ -579,6 +579,7 @@ let global_vars_set env constr = contained in the types of the needed variables. *) let really_needed env needed = + let open! Context.Named.Declaration in Context.Named.fold_inside (fun need decl -> if Id.Set.mem (get_id decl) need then @@ -594,6 +595,7 @@ let really_needed env needed = (named_context env) let keep_hyps env needed = + let open Context.Named.Declaration in let really_needed = really_needed env needed in Context.Named.fold_outside (fun d nsign -> @@ -647,6 +649,7 @@ type unsafe_type_judgment = types punsafe_type_judgment exception Hyp_not_found let apply_to_hyp ctxt id f = + let open Context.Named.Declaration in let rec aux rtail ctxt = match match_named_context_val ctxt with | Some (d, v, ctxt) -> @@ -663,6 +666,7 @@ let remove_hyps ids check_context check_value ctxt = let rec remove_hyps ctxt = match match_named_context_val ctxt with | None -> empty_named_context_val, false | Some (d, v, rctxt) -> + let open Context.Named.Declaration in let (ans, seen) = remove_hyps rctxt in if Id.Set.mem (get_id d) ids then (ans, true) else if not seen then ctxt, false diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 7abf8027bd..b976469ff7 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -242,7 +242,7 @@ let check_subtyping cumi paramsctxt env_ar inds = in let env = Environ.add_constraints subtyp_constraints env in (* process individual inductive types: *) - Array.iter (fun (id,cn,lc,(sign,arity)) -> + Array.iter (fun (_id,_cn,lc,(_sign,arity)) -> match arity with | RegularArity (_, full_arity, _) -> check_subtyping_arity_constructor env dosubst full_arity numparams true; @@ -368,7 +368,7 @@ let typecheck_inductive env mie = RegularArity (not is_natural,full_arity,defu) in let template_polymorphic () = - let _, s = + let _sign, s = try dest_arity env full_arity with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) in @@ -428,7 +428,7 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum let explain_ind_err id ntyp env nparamsctxt c err = - let (lparams,c') = mind_extract_params nparamsctxt c in + let (_lparams,c') = mind_extract_params nparamsctxt c in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt)))) @@ -596,7 +596,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( discharged to the [check_positive_nested] function. *) if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else check_positive_nested ienv nmr (ind_kn, largs) - | err -> + | _err -> (** If an inductive of the mutually inductive block appears in any other way, then the positivy check gives up. *) @@ -613,7 +613,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( defined types, not one of the types of the mutually inductive block being defined). *) (* accesses to the environment are not factorised, but is it worth? *) - and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) = + and check_positive_nested (env,n,ntypes,_ra_env as ienv) nmr ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnrecpar = mib.mind_nparams_rec in let auxnnonrecpar = mib.mind_nparams - auxnrecpar in @@ -664,7 +664,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( the type [c]) is checked to be the right (properly applied) inductive type. *) and check_constructors ienv check_head nmr c = - let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = + let rec check_constr_rec (env,n,ntypes,_ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_all env c) in match kind x with @@ -813,7 +813,7 @@ let compute_projections (kn, i as ind) mib = in let projections decl (i, j, labs, pbs, letsubst) = match decl with - | LocalDef (na,c,t) -> + | LocalDef (_na,c,_t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) let c = liftn 1 j c in @@ -841,7 +841,7 @@ let compute_projections (kn, i as ind) mib = (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in - let (_, _, labs, pbs, letsubst) = + let (_, _, labs, pbs, _letsubst) = List.fold_right projections ctx (0, 1, [], [], paramsletsubst) in Array.of_list (List.rev labs), diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 1d2f22b006..9bbcf07f7e 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -154,10 +154,10 @@ let make_subst env = let rec make subst = function | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) - | d::sign, None::exp, args -> + | _d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in make subst (sign, exp, args) - | d::sign, Some u::exp, a::args -> + | _d::sign, Some u::exp, a::args -> (* We recover the level of the argument, but we don't change the *) (* level in the corresponding type in the arity; this level in the *) (* arity is a global level which, at typing time, will be enforce *) @@ -165,7 +165,7 @@ let make_subst env = (* a useless extra constraint *) let s = Sorts.univ_of_sort (snd (dest_arity env (Lazy.force a))) in make (cons_subst u s subst) (sign, exp, args) - | LocalAssum (na,t) :: sign, Some u::exp, [] -> + | LocalAssum (_na,_t) :: sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) (* template, it is identity substitution otherwise (ie. when u is *) @@ -173,7 +173,7 @@ let make_subst env = (* update its image [x] by [sup x u] in order not to forget the *) (* dependency in [u] that remains to be fullfilled. *) make (remember_subst u subst) (sign, exp, []) - | sign, [], _ -> + | _sign, [], _ -> (* Uniform parameters are exhausted *) subst | [], _, _ -> @@ -199,7 +199,7 @@ let instantiate_universes env ctx ar argsorts = (* Type of an inductive type *) -let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps = +let type_of_inductive_gen ?(polyprop=true) env ((_mib,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> @@ -215,12 +215,12 @@ let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps = let type_of_inductive env pind = type_of_inductive_gen env pind [||] -let constrained_type_of_inductive env ((mib,mip),u as pind) = +let constrained_type_of_inductive env ((mib,_mip),u as pind) = let ty = type_of_inductive env pind in let cst = instantiate_inductive_constraints mib u in (ty, cst) -let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) args = +let constrained_type_of_inductive_knowing_parameters env ((mib,_mip),u as pind) args = let ty = type_of_inductive_gen env pind args in let cst = instantiate_inductive_constraints mib u in (ty, cst) @@ -249,7 +249,7 @@ let type_of_constructor (cstr, u) (mib,mip) = if i > nconstr then user_err Pp.(str "Not enough constructors in the type."); constructor_instantiate (fst ind) u mib specif.(i-1) -let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = +let constrained_type_of_constructor (_cstr,u as cstru) (mib,_mip as ind) = let ty = type_of_constructor cstru ind in let cst = instantiate_inductive_constraints mib u in (ty, cst) @@ -279,7 +279,7 @@ let inductive_sort_family mip = let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip -let get_instantiated_arity (ind,u) (mib,mip) params = +let get_instantiated_arity (_ind,u) (mib,mip) params = let sign, s = mind_arity mip in full_inductive_instantiate mib u params sign, s @@ -563,7 +563,7 @@ let check_inductive_codomain env p = let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in - let i,l' = decompose_app (whd_all env s) in + let i,_l' = decompose_app (whd_all env s) in isInd i (* The following functions are almost duplicated from indtypes.ml, except @@ -635,10 +635,10 @@ let get_recargs_approx env tree ind args = build_recargs_nested ienv tree (ind_kn, largs) | _ -> mk_norec end - | err -> + | _err -> mk_norec - and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) = + and build_recargs_nested (env,_ra_env as ienv) tree (((mind,i),u), largs) = (* If the inferred tree already disallows recursion, no need to go further *) if eq_wf_paths tree mk_norec then tree else @@ -676,7 +676,7 @@ let get_recargs_approx env tree ind args = (Rtree.mk_rec irecargs).(i) and build_recargs_constructors ienv trees c = - let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = + let rec recargs_constr_rec (env,_ra_env as ienv) trees lrec c = let x,largs = decompose_app (whd_all env c) in match kind x with @@ -685,7 +685,7 @@ let get_recargs_approx env tree ind args = let recarg = build_recargs ienv (List.hd trees) b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d - | hd -> + | _hd -> List.rev lrec in recargs_constr_rec ienv trees [] c @@ -794,7 +794,7 @@ let rec subterm_specif renv stack t = | Proj (p, c) -> let subt = subterm_specif renv stack c in (match subt with - | Subterm (s, wf) -> + | Subterm (_s, wf) -> (* We take the subterm specs of the constructor of the record *) let wf_args = (dest_subterms wf).(0) in (* We extract the tree of the projected argument *) @@ -964,7 +964,7 @@ let check_one_fix renv recpos trees def = else check_rec_call renv' [] body) bodies - | Const (kn,u as cu) -> + | Const (kn,_u as cu) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> @@ -983,7 +983,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv [] a; check_rec_call (push_var_renv renv (x,a)) [] b - | CoFix (i,(_,typarray,bodies as recdef)) -> + | CoFix (_i,(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; Array.iter (check_rec_call renv []) typarray; let renv' = push_fix_renv renv recdef in @@ -992,13 +992,13 @@ let check_one_fix renv recpos trees def = | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l - | Proj (p, c) -> + | Proj (_p, c) -> List.iter (check_rec_call renv []) l; check_rec_call renv [] c | Var id -> begin - let open Context.Named.Declaration in + let open! Context.Named.Declaration in match lookup_named id renv.env with | LocalAssum _ -> List.iter (check_rec_call renv []) l @@ -1129,10 +1129,10 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - | Construct ((_,i as cstr_kn),u) -> + | Construct ((_,i as cstr_kn),_u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in - let (mib,mip) = lookup_mind_specif env mI in + let (mib,_mip) = lookup_mind_specif env mI in let realargs = List.skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> @@ -1157,7 +1157,7 @@ let check_one_cofix env nbfix def deftype = else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) - | CoFix (j,(_,varit,vdefs as recdef)) -> + | CoFix (_j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then if Array.for_all (noccur_with_meta n nbfix) varit then @@ -1203,7 +1203,7 @@ let check_one_cofix env nbfix def deftype = (* The function which checks that the whole block of definitions satisfies the guarded condition *) -let check_cofix env (bodynum,(names,types,bodies as recdef)) = +let check_cofix env (_bodynum,(names,types,bodies as recdef)) = let flags = Environ.typing_flags env in if flags.check_guarded then let nbfix = Array.length bodies in diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index f1d08ef6dd..bff3092655 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -319,12 +319,12 @@ let subst_con sub cst = let subst_con_kn sub con = subst_con sub (con,Univ.Instance.empty) -let subst_pcon sub (con,u as pcon) = - try let con', can = subst_con0 sub pcon in +let subst_pcon sub (_con,u as pcon) = + try let con', _can = subst_con0 sub pcon in con',u with No_subst -> pcon -let subst_pcon_term sub (con,u as pcon) = +let subst_pcon_term sub (_con,u as pcon) = try let con', can = subst_con0 sub pcon in (con',u), can with No_subst -> pcon, mkConstU pcon @@ -441,7 +441,7 @@ let replace_mp_in_kn mpfrom mpto kn = let rec mp_in_mp mp mp1 = match mp1 with | _ when ModPath.equal mp1 mp -> true - | MPdot (mp2,l) -> mp_in_mp mp mp2 + | MPdot (mp2,_l) -> mp_in_mp mp mp2 | _ -> false let subset_prefixed_by mp resolver = diff --git a/kernel/modops.ml b/kernel/modops.ml index 9435f46c6b..424d329e09 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -138,7 +138,7 @@ let rec functor_smart_map fty f0 funct = match funct with let a' = f0 a in if a==a' then funct else NoFunctor a' let rec functor_iter fty f0 = function - |MoreFunctor (mbid,ty,e) -> fty ty; functor_iter fty f0 e + |MoreFunctor (_mbid,ty,e) -> fty ty; functor_iter fty f0 e |NoFunctor a -> f0 a (** {6 Misc operations } *) @@ -171,7 +171,7 @@ let implem_iter fs fa impl = match impl with (** {6 Substitutions of modular structures } *) -let id_delta x y = x +let id_delta x _y = x let subst_with_body sub = function |WithMod(id,mp) as orig -> @@ -200,7 +200,7 @@ let rec subst_structure sub do_delta sign = and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = fun is_mod sub subst_impl do_delta mb -> - let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in + let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty; _ } = mb in let mp' = subst_mp sub mp in let sub = if ModPath.equal mp mp' then sub @@ -371,7 +371,7 @@ and strengthen_sig mp_from struc mp_to reso = match struc with let item' = l,SFBmodule mb' in let reso',rest' = strengthen_sig mp_from rest mp_to reso in add_delta_resolver reso' mb.mod_delta, item':: rest' - |(l,SFBmodtype mty as item) :: rest -> + |(_l,SFBmodtype _mty as item) :: rest -> let reso',rest' = strengthen_sig mp_from rest mp_to reso in reso',item::rest' @@ -628,7 +628,7 @@ let join_structure except otab s = let rec join_module : 'a. 'a generic_module_body -> unit = fun mb -> Option.iter join_expression mb.mod_type_alg; join_signature mb.mod_type - and join_field (l,body) = match body with + and join_field (_l,body) = match body with |SFBconst sb -> join_constant_body except otab sb |SFBmind _ -> () |SFBmodule m -> diff --git a/kernel/names.ml b/kernel/names.ml index 933cefe993..6d33f233e9 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -207,7 +207,7 @@ struct let repr mbid = mbid - let to_string (i, s, p) = + let to_string (_i, s, p) = DirPath.to_string p ^ "." ^ s let debug_to_string (i, s, p) = @@ -328,7 +328,7 @@ module ModPath = struct let rec dp = function | MPfile sl -> sl | MPbound (_,_,dp) -> dp - | MPdot (mp,l) -> dp mp + | MPdot (mp,_l) -> dp mp module Self_Hashcons = struct type t = module_path @@ -420,7 +420,7 @@ module KerName = struct let hash kn = let h = kn.refhash in if h < 0 then - let { modpath = mp; dirpath = dp; knlabel = lbl; } = kn in + let { modpath = mp; dirpath = dp; knlabel = lbl; _ } = kn in let h = combine3 (ModPath.hash mp) (DirPath.hash dp) (Label.hash lbl) in (* Ensure positivity on all platforms. *) let h = h land 0x3FFFFFFF in @@ -623,8 +623,8 @@ let constr_modpath (ind,_) = ind_modpath ind let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) -let inductive_of_constructor (ind, i) = ind -let index_of_constructor (ind, i) = i +let inductive_of_constructor (ind, _i) = ind +let index_of_constructor (_ind, i) = i let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2 let eq_user_ind (m1, i1) (m2, i2) = diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index eed25a4ca4..74b075f4a5 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1007,7 +1007,7 @@ let compile_prim decl cond paux = *) let rec opt_prim_aux paux = match paux with - | PAprim(prefix, kn, op, args) -> + | PAprim(_prefix, _kn, op, args) -> let args = Array.map opt_prim_aux args in app_prim (Coq_primitive(op,None)) args (* @@ -1071,7 +1071,7 @@ let ml_of_instance instance u = match t with | Lrel(id ,i) -> get_rel env id i | Lvar id -> get_var env id - | Lmeta(mv,ty) -> + | Lmeta(mv,_ty) -> let tyn = fresh_lname Anonymous in let i = push_symbol (SymbMeta mv) in MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|]) @@ -1184,7 +1184,7 @@ let ml_of_instance instance u = let lf,env_n = push_rels (empty_env env.env_univ ()) ids in let t_params = Array.make ndef [||] in let t_norm_f = Array.make ndef (Gnorm (l,-1)) in - let mk_let envi (id,def) t = MLlet (id,def,t) in + let mk_let _envi (id,def) t = MLlet (id,def,t) in let mk_lam_or_let (params,lets,env) (id,def) = let ln,env' = push_rel env id in match def with @@ -1217,7 +1217,7 @@ let ml_of_instance instance u = (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in (* Compilation of fix *) let fv_args = fv_args env fvn fvr in - let lf, env = push_rels env ids in + let lf, _env = push_rels env ids in let lf_args = Array.map (fun id -> MLlocal id) lf in let mk_norm = MLapp(MLglobal norm, fv_args) in let mkrec i lname = @@ -1272,9 +1272,9 @@ let ml_of_instance instance u = let mk_norm = MLapp(MLglobal norm, fv_args) in let lnorm = fresh_lname Anonymous in let ltype = fresh_lname Anonymous in - let lf, env = push_rels env ids in + let lf, _env = push_rels env ids in let lf_args = Array.map (fun id -> MLlocal id) lf in - let upd i lname cont = + let upd i _lname cont = let paramsi = t_params.(i) in let pargsi = Array.map (fun id -> MLlocal id) paramsi in let uniti = fresh_lname Anonymous in @@ -1305,7 +1305,7 @@ let ml_of_instance instance u = (lname, paramsi, body) in MLletrec(Array.mapi mkrec lf, lf_args.(start)) *) - | Lmakeblock (prefix,(cn,u),_,args) -> + | Lmakeblock (prefix,(cn,_u),_,args) -> let args = Array.map (ml_of_lam env l) args in MLconstruct(prefix,cn,args) | Lconstruct (prefix, (cn,u)) -> @@ -1561,7 +1561,7 @@ let rec list_of_mp acc = function let list_of_mp mp = list_of_mp [] mp let string_of_kn kn = - let (mp,dp,l) = KerName.repr kn in + let (mp,_dp,l) = KerName.repr kn in let mp = list_of_mp mp in String.concat "_" mp ^ "_" ^ string_of_label l @@ -1987,7 +1987,7 @@ let compile_mind mb mind stack = (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in - let add_proj proj_arg acc pb = + let add_proj proj_arg acc _pb = let tbl = ob.mind_reloc_tbl in (* Building info *) let ci = { ci_ind = ind; ci_npar = nparams; @@ -2053,9 +2053,9 @@ let compile_mind_deps env prefix ~interactive let compile_deps env sigma prefix ~interactive init t = let rec aux env lvl init t = match kind t with - | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind + | Ind ((mind,_),_u) -> compile_mind_deps env prefix ~interactive init mind | Const c -> - let c,u = get_alias env c in + let c,_u = get_alias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in if is_code_loaded ~interactive nameref @@ -2074,11 +2074,11 @@ let compile_deps env sigma prefix ~interactive init t = let comp_stack = code@comp_stack in let const_updates = Cmap_env.add c (nameref, name) const_updates in comp_stack, (mind_updates, const_updates) - | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind + | Construct (((mind,_),_),_u) -> compile_mind_deps env prefix ~interactive init mind | Proj (p,c) -> let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in aux env lvl init c - | Case (ci, p, c, ac) -> + | Case (ci, _p, _c, _ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in fold_constr_with_binders succ (aux env) lvl init t diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index c75dde843e..054b6a2d17 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -25,9 +25,9 @@ let rec conv_val env pb lvl v1 v2 cu = | Vfun f1, Vfun f2 -> let v = mk_rel_accu lvl in conv_val env CONV (lvl+1) (f1 v) (f2 v) cu - | Vfun f1, _ -> + | Vfun _f1, _ -> conv_val env CONV lvl v1 (fun x -> v2 x) cu - | _, Vfun f2 -> + | _, Vfun _f2 -> conv_val env CONV lvl (fun x -> v1 x) v2 cu | Vaccu k1, Vaccu k2 -> conv_accu env pb lvl k1 k2 cu @@ -110,7 +110,7 @@ and conv_atom env pb lvl a1 a2 cu = else if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible else conv_fix env lvl t1 f1 t2 f2 cu - | Aprod(_,d1,c1), Aprod(_,d2,c2) -> + | Aprod(_,d1,_c1), Aprod(_,d2,_c2) -> let cu = conv_val env CONV lvl d1 d2 cu in let v = mk_rel_accu lvl in conv_val env pb (lvl + 1) (d1 v) (d2 v) cu diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index ab40c643f9..70cb8691c6 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -142,7 +142,7 @@ let rec map_lam_with_binders g f n lam = let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') -and map_uint g f n u = +and map_uint _g f n u = match u with | UintVal _ -> u | UintDigits(prefix,c,args) -> @@ -203,7 +203,7 @@ let can_subst lam = let can_merge_if bt bf = match bt, bf with - | Llam(idst,_), Llam(idsf,_) -> true + | Llam(_idst,_), Llam(_idsf,_) -> true | _ -> false let merge_if t bt bf = @@ -370,7 +370,7 @@ module Cache = let is_lazy env prefix t = match kind t with - | App (f,args) -> + | App (f,_args) -> begin match kind f with | Construct (c,_) -> let gr = GlobRef.IndRef (fst c) in @@ -431,7 +431,7 @@ let rec lambda_of_constr cache env sigma c = | Sort s -> Lsort s - | Ind (ind,u as pind) -> + | Ind (ind,_u as pind) -> let prefix = get_mind_prefix env (fst ind) in Lind (prefix, pind) @@ -529,7 +529,7 @@ let rec lambda_of_constr cache env sigma c = and lambda_of_app cache env sigma f args = match kind f with - | Const (kn,u as c) -> + | Const (_kn,_u as c) -> let kn,u = get_alias env c in let cb = lookup_constant kn env in (try diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index f784509b6f..b4126dd68c 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -40,7 +40,7 @@ let include_dirs () = [Filename.get_temp_dir_name (); coqlib () / "kernel"; coqlib () / "library"] (* Pointer to the function linking an ML object into coq's toplevel *) -let load_obj = ref (fun x -> () : string -> unit) +let load_obj = ref (fun _x -> () : string -> unit) let rt1 = ref (dummy_value ()) let rt2 = ref (dummy_value ()) @@ -113,7 +113,7 @@ let call_compiler ?profile:(profile=false) ml_filename = let res = CUnix.sys_command (ocamlfind ()) args in let res = match res with | Unix.WEXITED 0 -> true - | Unix.WEXITED n | Unix.WSIGNALED n | Unix.WSTOPPED n -> + | Unix.WEXITED _n | Unix.WSIGNALED _n | Unix.WSTOPPED _n -> warn_native_compiler_failed (Inl res); false in res, link_filename @@ -158,7 +158,7 @@ let call_linker ?(fatal=true) prefix f upds = (try if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; register_native_file prefix - with Dynlink.Error e as exn -> + with Dynlink.Error _ as exn -> let exn = CErrors.push exn in if fatal then iraise exn else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index edce9367fc..8ac3538fc5 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -29,7 +29,7 @@ and translate_field prefix mp env acc (l,x) = | SFBconst cb -> let con = Constant.make3 mp DirPath.empty l in (if !Flags.debug then - let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in + let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in Feedback.msg_debug (Pp.str msg)); compile_constant_field env prefix con acc cb | SFBmind mb -> diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index f8b71e4564..303cb06c55 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -87,21 +87,21 @@ let discharge_direct_opaque ~cook_constr ci = function | Direct (d,cu) -> Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) -let join_opaque { opaque_val = prfs; opaque_dir = odp } = function +let join_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> ignore(Future.join cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp then let fp = snd (Int.Map.find i prfs) in ignore(Future.join fp) -let uuid_opaque { opaque_val = prfs; opaque_dir = odp } = function +let uuid_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> Some (Future.uuid cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp then Some (Future.uuid (snd (Int.Map.find i prfs))) else None -let force_proof { opaque_val = prfs; opaque_dir = odp } = function +let force_proof { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> fst(Future.force cu) | Indirect (l,dp,i) -> @@ -112,7 +112,7 @@ let force_proof { opaque_val = prfs; opaque_dir = odp } = function let c = Future.force pt in force_constr (List.fold_right subst_substituted l (from_val c)) -let force_constraints { opaque_val = prfs; opaque_dir = odp } = function +let force_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> snd(Future.force cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp @@ -121,14 +121,14 @@ let force_constraints { opaque_val = prfs; opaque_dir = odp } = function | None -> Univ.ContextSet.empty | Some u -> Future.force u -let get_constraints { opaque_val = prfs; opaque_dir = odp } = function +let get_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> Some(Future.chain cu snd) | Indirect (_,dp,i) -> if DirPath.equal dp odp then Some(Future.chain (snd (Int.Map.find i prfs)) snd) else !get_univ dp i -let get_proof { opaque_val = prfs; opaque_dir = odp } = function +let get_proof { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> Future.chain cu fst | Indirect (l,dp,i) -> let pt = @@ -144,7 +144,7 @@ let a_constr = Future.from_val (mkRel 1) let a_univ = Future.from_val Univ.ContextSet.empty let a_discharge : cooking_info list = [] -let dump { opaque_val = otab; opaque_len = n } = +let dump { opaque_val = otab; opaque_len = n; _ } = let opaque_table = Array.make n a_constr in let univ_table = Array.make n a_univ in let disch_table = Array.make n a_discharge in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index c701b53fe4..2abb4b485c 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -53,9 +53,9 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zproj p1::s1, Zproj p2::s2) -> + | (Zproj _p1::s1, Zproj _p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) -> + | (ZcaseT(_c1,_,_,_)::s1, ZcaseT(_c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -261,7 +261,7 @@ let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u s | Declarations.Polymorphic_ind _ -> cmp_instances u1 u2 s - | Declarations.Cumulative_ind cumi -> + | Declarations.Cumulative_ind _cumi -> let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in if not (Int.equal num_cnstr_args nargs) then cmp_instances u1 u2 s @@ -296,7 +296,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 - | (Zlproj (c1,l1),Zlproj (c2,l2)) -> + | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> if not (Projection.Repr.equal c1 c2) then raise NotConvertible else cu1 @@ -498,7 +498,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = eqappr cv_pb l2r infos (lft1, r1) appr2 cuniv | None -> match c2 with - | FConstruct ((ind2,j2),u2) -> + | FConstruct ((ind2,_j2),_u2) -> (try let v2, v1 = eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) @@ -515,7 +515,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = eqappr cv_pb l2r infos appr1 (lft2, r2) cuniv | None -> match c1 with - | FConstruct ((ind1,j1),u1) -> + | FConstruct ((ind1,_j1),_u1) -> (try let v1, v2 = eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -554,14 +554,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = else raise NotConvertible (* Eta expansion of records *) - | (FConstruct ((ind1,j1),u1), _) -> + | (FConstruct ((ind1,_j1),_u1), _) -> (try let v1, v2 = eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) - | (_, FConstruct ((ind2,j2),u2)) -> + | (_, FConstruct ((ind2,_j2),_u2)) -> (try let v2, v1 = eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) @@ -659,14 +659,14 @@ let check_sort_cmp_universes env pb s0 s1 univs = | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible | Set, Prop -> raise NotConvertible | Set, Type u -> check_pb Univ.type0_univ u - | Type u, Prop -> raise NotConvertible + | Type _u, Prop -> raise NotConvertible | Type u, Set -> check_pb u Univ.type0_univ | Type u0, Type u1 -> check_pb u0 u1 let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs -let check_convert_instances ~flex u u' univs = +let check_convert_instances ~flex:_ u u' univs = if UGraph.check_eq_instances univs u u' then univs else raise NotConvertible @@ -707,7 +707,7 @@ let infer_cmp_universes env pb s0 s1 univs = | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs | Set, Prop -> raise NotConvertible | Set, Type u -> infer_pb Univ.type0_univ u - | Type u, Prop -> raise NotConvertible + | Type _u, Prop -> raise NotConvertible | Type u, Set -> infer_pb u Univ.type0_univ | Type u0, Type u1 -> infer_pb u0 u1 @@ -781,7 +781,7 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 -let default_conv cv_pb ?(l2r=false) env t1 t2 = +let default_conv cv_pb ?l2r:_ env t1 t2 = gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL @@ -912,7 +912,7 @@ let is_arity env c = with NotArity -> false let eta_expand env t ty = - let ctxt, codom = dest_prod env ty in + let ctxt, _codom = dest_prod env ty in let ctxt',t = dest_lam env t in let d = Context.Rel.nhyps ctxt - Context.Rel.nhyps ctxt' in let eta_args = List.rev_map mkRel (List.interval 1 d) in diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 74042f9e04..bfe68671a2 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -138,7 +138,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name t1 t2 = check_conv (NotConvertibleInductiveField name) - cst (inductive_is_polymorphic mib1) infer_conv_leq env t1 t2 + cst (inductive_is_polymorphic mib1) (infer_conv_leq ?l2r:None ?evars:None ?ts:None) env t1 t2 in let check_packet cst p1 p2 = @@ -162,10 +162,10 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 cst in let mind = MutInd.make1 kn1 in - let check_cons_types i cst p1 p2 = + let check_cons_types _i cst p1 p2 = Array.fold_left3 (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst - (inductive_is_polymorphic mib1) infer_conv env t1 t2) + (inductive_is_polymorphic mib1) (infer_conv ?l2r:None ?evars:None ?ts:None) env t1 t2) cst p2.mind_consnames (arities_of_specif (mind, inst) (mib1, p1)) @@ -229,7 +229,7 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let check_conv cst poly f = check_conv_error error cst poly f in let check_type poly cst env t1 t2 = let err = NotConvertibleTypeField (env, t1, t2) in - check_conv err cst poly infer_conv_leq env t1 t2 + check_conv err cst poly (infer_conv_leq ?l2r:None ?evars:None ?ts:None) env t1 t2 in match info1 with | Constant cb1 -> @@ -268,14 +268,14 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = Anyway [check_conv] will handle that afterwards. *) let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in - check_conv NotConvertibleBodyField cst poly infer_conv env c1 c2)) - | IndType ((kn,i),mind1) -> + check_conv NotConvertibleBodyField cst poly (infer_conv ?l2r:None ?evars:None ?ts:None) env c1 c2)) + | IndType ((_kn,_i),_mind1) -> CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ "name.") - | IndConstr (((kn,i),j),mind1) -> + | IndConstr (((_kn,_i),_j),_mind1) -> CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ diff --git a/kernel/term.ml b/kernel/term.ml index 4851a9c0d0..795cdeb040 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -54,13 +54,13 @@ let mkProd_wo_LetIn decl c = let open Context.Rel.Declaration in match decl with | LocalAssum (na,t) -> mkProd (na, t, c) - | LocalDef (na,b,t) -> subst1 b c + | LocalDef (_na,b,_t) -> subst1 b c let mkNamedProd_wo_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedProd id t c - | LocalDef (id,b,t) -> subst1 b (subst_var id c) + | LocalDef (id,b,_t) -> subst1 b (subst_var id c) (* non-dependent product t1 -> t2 *) let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) @@ -81,7 +81,7 @@ let mkNamedLambda_or_LetIn decl c = (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = let rec prodrec = function - | (0, env, b) -> b + | (0, _env, b) -> b | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) | _ -> assert false in @@ -93,7 +93,7 @@ let compose_prod l b = prodn (List.length l) l b (* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *) let lamn n env b = let rec lamrec = function - | (0, env, b) -> b + | (0, _env, b) -> b | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) | _ -> assert false in @@ -276,7 +276,7 @@ let decompose_prod_n_assum n = | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c - | c -> user_err (str "decompose_prod_n_assum: not enough assumptions") + | _ -> user_err (str "decompose_prod_n_assum: not enough assumptions") in prodec_rec Context.Rel.empty n @@ -297,7 +297,7 @@ let decompose_lam_n_assum n = | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c | Cast (c,_,_) -> lamdec_rec l n c - | c -> user_err (str "decompose_lam_n_assum: not enough abstractions") + | _c -> user_err (str "decompose_lam_n_assum: not enough abstractions") in lamdec_rec Context.Rel.empty n @@ -313,7 +313,7 @@ let decompose_lam_n_decls n = | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c - | c -> user_err (str "decompose_lam_n_decls: not enough abstractions") + | _ -> user_err (str "decompose_lam_n_decls: not enough abstractions") in lamdec_rec Context.Rel.empty n diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f59e07098b..47247ff25e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -73,7 +73,7 @@ type _ trust = let uniq_seff_rev = SideEffects.repr let uniq_seff l = let ans = List.rev (SideEffects.repr l) in - List.map_append (fun { eff } -> eff) ans + List.map_append (fun { eff ; _ } -> eff) ans let empty_seff = SideEffects.empty let add_seff mb eff effs = @@ -103,12 +103,7 @@ let inline_side_effects env body ctx side_eff = if List.is_empty side_eff then (body, ctx, sigs) else (** Second step: compute the lifts and substitutions to apply *) - let cname c = - let name = Constant.to_string c in - let map c = if c == '.' || c == '#' then '_' else c in - let name = String.map map name in - Name (Id.of_string name) - in + let cname c = Name (Label.to_id (Constant.label c)) 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) @@ -122,7 +117,7 @@ let inline_side_effects env body ctx side_eff = let subst = Cmap_env.add c (Inr var) subst in let ctx = Univ.ContextSet.union ctx univs in (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) - | Polymorphic_const auctx -> + | Polymorphic_const _auctx -> (** Inline the term to emulate universe polymorphism *) let subst = Cmap_env.add c (Inl b) subst in (subst, var, ctx, args) @@ -250,9 +245,9 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = delay even in the polymorphic case. *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; - const_entry_universes = Monomorphic_const_entry univs } as c) -> + const_entry_universes = Monomorphic_const_entry univs; _ } as c) -> let env = push_context_set ~strict:true univs env in - let { const_entry_body = body; const_entry_feedback = feedback_id } = c in + let { const_entry_body = body; const_entry_feedback = feedback_id ; _ } = c in let tyj = infer_type env typ in let proofterm = Future.chain body (fun ((body,uctx),side_eff) -> @@ -288,8 +283,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> - let { const_entry_type = typ; const_entry_opaque = opaque } = c in - let { const_entry_body = body; const_entry_feedback = feedback_id } = c in + let { const_entry_type = typ; const_entry_opaque = opaque ; _ } = c in + let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in let (body, ctx), side_eff = Future.join body in let body, ctx, _ = match trust with | Pure -> body, ctx, [] @@ -348,7 +343,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 _kn env result = let open Cooking in let typ = result.cook_type in let check declared inferred = @@ -478,7 +473,7 @@ let export_eff eff = (eff.seff_constant, eff.seff_body, eff.seff_role) let export_side_effects mb env c = - let { const_entry_body = body } = c in + let { const_entry_body = body; _ } = c in let _, eff = Future.force body in let ce = { c with const_entry_body = Future.chain body @@ -493,7 +488,7 @@ let export_side_effects mb env c = let seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in let trusted = check_signatures mb signatures in let push_seff env eff = - let { seff_constant = kn; seff_body = cb } = eff in + let { seff_constant = kn; seff_body = cb ; _ } = eff in let env = Environ.add_constant kn cb env in match cb.const_universes with | Polymorphic_const _ -> env @@ -511,7 +506,7 @@ let export_side_effects mb env c = if Int.equal sl 0 then let env, cbs = List.fold_left (fun (env,cbs) eff -> - let { seff_constant = kn; seff_body = ocb; seff_env = u } = eff in + let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in let ce = constant_entry_of_side_effect ocb u in let cb = translate_constant Pure env kn ce in let eff = { eff with @@ -543,7 +538,7 @@ let translate_recipe env kn r = let hcons = DirPath.is_empty dir in build_constant_declaration kn env (Cooking.cook_constant ~hcons r) -let translate_local_def env id centry = +let translate_local_def env _id centry = let open Cooking in let body = Future.from_val ((centry.secdef_body, Univ.ContextSet.empty), ()) in let centry = { diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 25c1cbff3a..7456ecea56 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -118,14 +118,14 @@ let check_hyps_inclusion env f c sign = (* Type of constants *) -let type_of_constant env (kn,u as cst) = +let type_of_constant env (kn,_u as cst) = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in let ty, cu = constant_type env cst in let () = check_constraints cu env in ty -let type_of_constant_in env (kn,u as cst) = +let type_of_constant_in env (kn,_u as cst) = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in constant_type_in env cst @@ -142,7 +142,7 @@ let type_of_constant_in env (kn,u as cst) = and no upper constraint exists on the sort $s$, we don't need to compute $s$ *) -let type_of_abstraction env name var ty = +let type_of_abstraction _env name var ty = mkProd (name, var, ty) (* Type of an application. *) @@ -204,7 +204,7 @@ let sort_of_product env domsort rangsort = where j.uj_type is convertible to a sort s2 *) -let type_of_product env name s1 s2 = +let type_of_product env _name s1 s2 = let s = sort_of_product env s1 s2 in mkSort s @@ -247,7 +247,7 @@ let check_cast env c ct k expected_type = dynamic constraints of the form u<=v are enforced *) let type_of_inductive_knowing_parameters env (ind,u as indu) args = - let (mib,mip) as spec = lookup_mind_specif env ind in + let (mib,_mip) as spec = lookup_mind_specif env ind in check_hyps_inclusion env mkIndU indu mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters env (spec,u) args @@ -264,7 +264,7 @@ let type_of_inductive env (ind,u as indu) = (* Constructors. *) -let type_of_constructor env (c,u as cu) = +let type_of_constructor env (c,_u as cu) = let () = let ((kn,_),_) = c in let mib = lookup_mind kn env in @@ -285,7 +285,7 @@ let check_branch_types env (ind,u) c ct lft explft = | Invalid_argument _ -> error_number_branches env (make_judge c ct) (Array.length explft) -let type_of_case env ci p pt c ct lf lft = +let type_of_case env ci p pt c ct _lf lft = let (pind, _ as indspec) = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in @@ -399,7 +399,7 @@ let rec execute env cstr = let lft = execute_array env lf in type_of_case env ci p pt c ct lf lft - | Fix ((vn,i as vni),recdef) -> + | Fix ((_vn,i as vni),recdef) -> let (fix_ty,recdef') = execute_recdef env recdef i in let fix = (vni,recdef') in check_fix env fix; fix_ty @@ -432,12 +432,12 @@ and execute_array env = Array.map (execute env) (* Derived functions *) -let universe_levels_of_constr env c = +let universe_levels_of_constr _env c = let rec aux s c = match kind c with - | Const (c, u) -> + | Const (_c, u) -> LSet.fold LSet.add (Instance.levels u) s - | Ind ((mind,_), u) | Construct (((mind,_),_), u) -> + | Ind ((_mind,_), u) | Construct (((_mind,_),_), u) -> LSet.fold LSet.add (Instance.levels u) s | Sort u when not (Sorts.is_small u) -> let u = Sorts.univ_of_sort u in @@ -530,7 +530,7 @@ let judge_of_product env x varj outj = make_judge (mkProd (x, varj.utj_val, outj.utj_val)) (mkSort (sort_of_product env varj.utj_type outj.utj_type)) -let judge_of_letin env name defj typj j = +let judge_of_letin _env name defj typj j = make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) (subst1 defj.uj_val j.uj_type) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 95d71965df..9ff51fca55 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -194,7 +194,7 @@ let check_universes_invariants g = UMap.iter (fun l u -> match u with | Canonical u -> - UMap.iter (fun v strict -> + UMap.iter (fun v _strict -> incr n_edges; let v = repr g v in assert (topo_compare u v = -1); @@ -435,7 +435,7 @@ let reorder g u v = | n0::q0 -> (* Computing new root. *) let root, rank_rest = - List.fold_left (fun ((best, rank_rest) as acc) n -> + List.fold_left (fun ((best, _rank_rest) as acc) n -> if n.rank >= best.rank then n, best.rank else acc) (n0, min_int) q0 in @@ -809,7 +809,7 @@ let normalize_universes g = in UMap.fold (fun _ u g -> match u with - | Equiv u -> g + | Equiv _u -> g | Canonical u -> let _, u, g = get_ltle g u in let _, _, g = get_gtge g u in @@ -821,7 +821,7 @@ let constraints_of_universes g = let uf = UF.create () in let constraints_of u v acc = match v with - | Canonical {univ=u; ltle} -> + | Canonical {univ=u; ltle; _} -> UMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in Constraint.add (u,typ,v) acc) ltle acc @@ -943,7 +943,7 @@ let check_eq_instances g t1 t2 = (** Pretty-printing *) let pr_arc prl = function - | _, Canonical {univ=u; ltle} -> + | _, Canonical {univ=u; ltle; _} -> if UMap.is_empty ltle then mt () else prl u ++ str " " ++ @@ -963,7 +963,7 @@ let pr_universes prl g = let dump_universes output g = let dump_arc u = function - | Canonical {univ=u; ltle} -> + | Canonical {univ=u; ltle; _} -> let u_str = Level.to_string u in UMap.iter (fun v strict -> let typ = if strict then Lt else Le in diff --git a/kernel/univ.ml b/kernel/univ.ml index 311477daca..61ad1d0a82 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -86,7 +86,7 @@ struct | Level (n,d) as x -> let d' = Names.DirPath.hcons d in if d' == d then x else Level (n,d') - | Var n as x -> x + | Var _n as x -> x open Hashset.Combine @@ -160,13 +160,6 @@ module Level = struct let compare u v = if u == v then 0 - else - let c = Int.compare (hash u) (hash v) in - if c == 0 then RawLevel.compare (data u) (data v) - else c - - let natural_compare u v = - if u == v then 0 else RawLevel.compare (data u) (data v) let to_string x = @@ -206,13 +199,13 @@ module LMap = struct include M let union l r = - merge (fun k l r -> + merge (fun _k l r -> match l, r with | Some _, _ -> l | _, _ -> r) l r let subst_union l r = - merge (fun k l r -> + merge (fun _k l r -> match l, r with | Some (Some _), _ -> l | Some None, None -> l @@ -365,14 +358,14 @@ struct else f v ++ str"+" ++ int n let is_level = function - | (v, 0) -> true + | (_v, 0) -> true | _ -> false let level = function | (v,0) -> Some v | _ -> None - let get_level (v,n) = v + let get_level (v,_n) = v let map f (v, n as x) = let v' = f v in @@ -582,7 +575,7 @@ struct prl u2 ++ fnl () ) c (str "") let universes_of c = - fold (fun (u1, op, u2) unvs -> LSet.add u2 (LSet.add u1 unvs)) c LSet.empty + fold (fun (u1, _op, u2) unvs -> LSet.add u2 (LSet.add u1 unvs)) c LSet.empty end let universes_of_constraints = Constraint.universes_of @@ -907,7 +900,7 @@ let subst_instance_constraints s csts = type universe_instance = Instance.t type 'a puniverses = 'a * Instance.t -let out_punivs (x, y) = x +let out_punivs (x, _y) = x let in_punivs x = (x, Instance.empty) let eq_puniverses f (x, u) (y, u') = f x y && Instance.equal u u' @@ -932,8 +925,8 @@ struct let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) - let instance (univs, cst) = univs - let constraints (univs, cst) = cst + let instance (univs, _cst) = univs + let constraints (_univs, cst) = cst let union (univs, cst) (univs', cst') = Instance.append univs univs', Constraint.union cst cst' @@ -952,7 +945,9 @@ struct include UContext let repr (inst, cst) = - (Array.mapi (fun i l -> Level.var i) inst, cst) + (Array.mapi (fun i _l -> Level.var i) inst, cst) + + let pr f ?variance ctx = pr f ?variance (repr ctx) let instantiate inst (u, cst) = assert (Array.length u = Array.length inst); @@ -988,8 +983,8 @@ struct let hcons (univs, variance) = (* should variance be hconsed? *) (UContext.hcons univs, variance) - let univ_context (univs, subtypcst) = univs - let variance (univs, variance) = variance + let univ_context (univs, _subtypcst) = univs + let variance (_univs, variance) = variance (** This function takes a universe context representing constraints of an inductive and produces a CumulativityInfo.t with the @@ -1054,7 +1049,7 @@ struct (univs, cst) let sort_levels a = - Array.sort Level.natural_compare a; a + Array.sort Level.compare a; a let to_context (ctx, cst) = (Instance.of_array (sort_levels (Array.of_list (LSet.elements ctx))), cst) @@ -1066,8 +1061,8 @@ struct if is_empty ctx then mt() else h 0 (LSet.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) - let constraints (univs, cst) = cst - let levels (univs, cst) = univs + let constraints (_univs, cst) = cst + let levels (univs, _cst) = univs let size (univs,_) = LSet.cardinal univs end @@ -1155,7 +1150,7 @@ let make_inverse_instance_subst i = LMap.empty arr let make_abstract_instance (ctx, _) = - Array.mapi (fun i l -> Level.var i) ctx + Array.mapi (fun i _l -> Level.var i) ctx let abstract_universes ctx = let instance = UContext.instance ctx in diff --git a/kernel/vars.ml b/kernel/vars.ml index 0f588a6302..9d5d79124b 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -66,7 +66,7 @@ let isMeta c = match Constr.kind c with let noccur_with_meta n m term = let rec occur_rec n c = match Constr.kind c with | Constr.Rel p -> if n<=p && p<n+m then raise LocalOccur - | Constr.App(f,cl) -> + | Constr.App(f,_cl) -> (match Constr.kind f with | Constr.Cast (c,_,_) when isMeta c -> () | Constr.Meta _ -> () @@ -188,7 +188,7 @@ let adjust_rel_to_rel_context sign n = let open RelDecl in match sign with | LocalAssum _ :: sign' -> let (n',p) = aux sign' in (n'+1,p) - | LocalDef (_,c,_)::sign' -> let (n',p) = aux sign' in (n'+1,if n'<n then p+1 else p) + | LocalDef (_,_c,_)::sign' -> let (n',p) = aux sign' in (n'+1,if n'<n then p+1 else p) | [] -> (0,n) in snd (aux sign) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index d19bea5199..5965853e1e 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -11,7 +11,7 @@ open Csymtable let compare_zipper z1 z2 = match z1, z2 with | Zapp args1, Zapp args2 -> Int.equal (nargs args1) (nargs args2) - | Zfix(f1,args1), Zfix(f2,args2) -> Int.equal (nargs args1) (nargs args2) + | Zfix(_f1,args1), Zfix(_f2,args2) -> Int.equal (nargs args1) (nargs args2) | Zswitch _, Zswitch _ | Zproj _, Zproj _ -> true | Zapp _ , _ | Zfix _, _ | Zswitch _, _ | Zproj _, _ -> false @@ -84,7 +84,7 @@ and conv_whd env pb k whd1 whd2 cu = and conv_atom env pb k a1 stk1 a2 stk2 cu = (* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *) match a1, a2 with - | Aind ((mi,i) as ind1) , Aind ind2 -> + | Aind ((mi,_i) as ind1) , Aind ind2 -> if eq_ind ind1 ind2 && compare_stack stk1 stk2 then if Environ.polymorphic_ind ind1 env then let mib = Environ.lookup_mind mi env in diff --git a/kernel/vm.ml b/kernel/vm.ml index 9917e94a35..eaf64ba4af 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -187,5 +187,5 @@ let apply_whd k whd = interprete (cofix_upd_code to_up) (cofix_upd_val to_up) (cofix_upd_env to_up) 0 | Vatom_stk(a,stk) -> apply_stack (val_of_atom a) stk v - | Vuniv_level lvl -> assert false + | Vuniv_level _lvl -> assert false diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 8edd49f77f..217ef4b8e5 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -100,7 +100,7 @@ let eq_structured_constant c1 c2 = match c1, c2 with | Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 | Const_univ_level _ , _ -> false | Const_val v1, Const_val v2 -> eq_structured_values v1 v2 -| Const_val v1, _ -> false +| Const_val _v1, _ -> false let hash_structured_constant c = let open Hashset.Combine in @@ -245,7 +245,7 @@ type id_key = | RelKey of Int.t | EvarKey of Evar.t -let eq_id_key k1 k2 = match k1, k2 with +let eq_id_key (k1 : id_key) (k2 : id_key) = match k1, k2 with | ConstKey c1, ConstKey c2 -> Constant.equal c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey n1, RelKey n2 -> Int.equal n1 n2 @@ -304,9 +304,9 @@ let uni_lvl_val (v : values) : Univ.Level.t = | Vfun _ -> str "Vfun" | Vfix _ -> str "Vfix" | Vcofix _ -> str "Vcofix" - | Vconstr_const i -> str "Vconstr_const" - | Vconstr_block b -> str "Vconstr_block" - | Vatom_stk (a,stk) -> str "Vatom_stk" + | Vconstr_const _i -> str "Vconstr_const" + | Vconstr_block _b -> str "Vconstr_block" + | Vatom_stk (_a,_stk) -> str "Vatom_stk" | _ -> assert false in CErrors.anomaly @@ -444,7 +444,7 @@ struct type t = id_key let equal = eq_id_key open Hashset.Combine - let hash = function + let hash : t -> tag = function | ConstKey c -> combinesmall 1 (Constant.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) @@ -658,7 +658,7 @@ and pr_whd w = | Vfix _ -> str "Vfix" | Vcofix _ -> str "Vcofix" | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" - | Vconstr_block b -> str "Vconstr_block" + | Vconstr_block _b -> str "Vconstr_block" | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" | Vuniv_level _ -> assert false) and pr_stack stk = @@ -668,6 +668,6 @@ and pr_stack stk = and pr_zipper z = Pp.(match z with | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" - | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" - | Zswitch s -> str "Zswitch(...)" + | Zfix (_f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" + | Zswitch _s -> str "Zswitch(...)" | Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")") diff --git a/lib/system.ml b/lib/system.ml index 902a4f2506..eec007dcab 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -302,10 +302,10 @@ let with_time ~batch f x = raise e (* We use argv.[0] as we don't want to resolve symlinks *) -let get_toplevel_path top = +let get_toplevel_path ?(byte=not Dynlink.is_native) top = let open Filename in let dir = if String.equal (basename Sys.argv.(0)) Sys.argv.(0) then "" else dirname Sys.argv.(0) ^ dir_sep in let exe = if Sys.(os_type = "Win32" || os_type = "Cygwin") then ".exe" else "" in - let eff = if Dynlink.is_native then ".opt" else ".byte" in + let eff = if byte then ".byte" else ".opt" in dir ^ top ^ eff ^ exe diff --git a/lib/system.mli b/lib/system.mli index a34280037c..f13fd30923 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -122,4 +122,4 @@ val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b the right name you want you execution to fail rather than fall into choosing some random binary from the system-wide installation of Coq. *) -val get_toplevel_path : string -> string +val get_toplevel_path : ?byte:bool -> string -> string diff --git a/library/lib.ml b/library/lib.ml index 8ebe44890c..07026a9c2a 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -440,6 +440,21 @@ let add_section_context ctx = check_same_poly true vars; sectab := (Context ctx :: vars,repl,abs)::sl +exception PolyFound of bool (* make this a let exception once possible *) +let is_polymorphic_univ u = + try + let open Univ in + List.iter (fun (vars,_,_) -> + List.iter (function + | Variable (_,_,poly,(univs,_)) -> + if LSet.mem u univs then raise (PolyFound poly) + | Context (univs,_) -> + if LSet.mem u univs then raise (PolyFound true) + ) vars + ) !sectab; + false + with PolyFound b -> b + let extract_hyps (secs,ohyps) = let rec aux = function | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> diff --git a/library/lib.mli b/library/lib.mli index 9933b762ba..a7d21060e9 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -183,6 +183,8 @@ val add_section_kn : Decl_kinds.polymorphic -> MutInd.t -> Constr.named_context -> unit val replacement_context : unit -> Opaqueproof.work_list +val is_polymorphic_univ : Univ.Level.t -> bool + (** {6 Discharge: decrease the section level if in the current section } *) val discharge_kn : MutInd.t -> MutInd.t diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index 3bd7cd622c..d82e8ae8ad 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -1,4 +1,4 @@ -Require Import Bool DecidableClass Algebra Ring PArith ROmega Omega. +Require Import Bool DecidableClass Algebra Ring PArith Omega. Section Bool. diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index c2bc8c079c..b0f97c59b8 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -224,7 +224,7 @@ module Btauto = struct Tacticals.tclFAIL 0 msg gl let try_unification env = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let concl = EConstr.Unsafe.to_constr concl in @@ -240,7 +240,7 @@ module Btauto = struct end let tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let concl = EConstr.Unsafe.to_constr concl in let sigma = Tacmach.New.project gl in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index ce620d5312..f26ec0f401 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -26,6 +26,10 @@ let init_size=5 let cc_verbose=ref false +let print_constr t = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_econstr_env env sigma t + let debug x = if !cc_verbose then Feedback.msg_debug (x ()) @@ -483,10 +487,10 @@ let rec inst_pattern subst = function args t let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - Termops.print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" + print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" let pr_term t = str "[" ++ - Termops.print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" + print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -601,7 +605,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ + (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); add_equality state prf s t end @@ -609,7 +613,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ + (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index b13580bc03..3ae777cc9a 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -34,7 +34,7 @@ type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq = - Proofview.Goal.nf_enter begin fun gls -> + Proofview.Goal.enter begin fun gls -> Control.check_for_interrupt (); let nc = Proofview.Goal.hyps gls in let env=pf_env gls in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 489a40ed09..e114a0119e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -98,7 +98,7 @@ let functional_induction with_clean c princl pat = List.map2 (fun c pat -> ((None, - Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), (None,pat), None)) (args@c_list) diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 73490a2dfd..b0277e9cc2 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -99,7 +99,7 @@ let let_evar name typ = let hget_evar n = let open EConstr in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list sigma concl in diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 8dad6260ae..ba3fa6fa0d 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -26,6 +26,7 @@ open Termops open Equality open Namegen open Tactypes +open Tactics open Proofview.Notations open Vernacinterp @@ -780,9 +781,9 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter begin fun gl -> +| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter begin fun gl -> +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index c13bd69daf..929390b1c4 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -314,22 +314,23 @@ GEXTEND Gram range_selector_or_nth: [ [ n = natural ; "-" ; m = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) + Goal_select.SelectList ((n, m) :: Option.default [] l) | n = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + let open Goal_select in Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] ; selector_body: [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] + | test_bracket_ident; "["; id = ident; "]" -> Goal_select.SelectId id ] ] ; selector: [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] ; toplevel_selector: [ [ sel = selector_body; ":" -> sel - | "!"; ":" -> SelectAlreadyFocused - | IDENT "all"; ":" -> SelectAll ] ] + | "!"; ":" -> Goal_select.SelectAlreadyFocused + | IDENT "all"; ":" -> Goal_select.SelectAll ] ] ; tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g @@ -346,7 +347,7 @@ GEXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + Hints.HintsExtern (n,c, in_tac tac) ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -373,6 +374,7 @@ let _ = declare_int_option { } let vernac_solve n info tcom b = + let open Goal_select in let status = Proof_global.with_current_proof (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in @@ -432,7 +434,7 @@ VERNAC tactic_mode EXTEND VernacSolve VtLater ] -> [ let t = rm_abstract t in - vernac_solve SelectAll n t def + vernac_solve Goal_select.SelectAll n t def ] END diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 2e1ce814aa..571595be70 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -21,6 +21,8 @@ open Constrexpr open Libnames open Tok open Tactypes +open Tactics +open Inv open Locus open Decl_kinds diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 4357689ee2..b219ee25ca 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -28,6 +28,7 @@ open Printer open Tacexpr open Tacarg +open Tactics module Tag = struct @@ -271,6 +272,8 @@ let string_of_genarg_arg (ArgumentType arg) = in pr_sequence pr prods with Not_found -> + (* FIXME: This key, moreover printed with a low-level printer, + has no meaning user-side *) KerName.print key let pr_alias_gen pr_gen lev key l = @@ -507,7 +510,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_destruction_arg prc prlc (clear_flag,h) = pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h - let pr_inversion_kind = function + let pr_inversion_kind = let open Inv in function | SimpleInversion -> primitive "simple inversion" | FullInversion -> primitive "inversion" | FullInversionClear -> primitive "inversion_clear" @@ -516,7 +519,7 @@ let string_of_genarg_arg (ArgumentType arg) = if Int.equal i j then int i else int i ++ str "-" ++ int j -let pr_goal_selector toplevel = function +let pr_goal_selector toplevel = let open Goal_select in function | SelectAlreadyFocused -> str "!:" | SelectNth i -> int i ++ str ":" | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 59b748e25e..11d13d3a2f 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -37,16 +37,24 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use type goal_selector = Goal_select.t = | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll -[@@ocaml.deprecated "Use Vernacexpr.goal_selector"] + [@ocaml.deprecated "Use constructors in [Goal_select]"] +[@@ocaml.deprecated "Use [Goal_select.t]"] type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] [@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = @@ -55,8 +63,11 @@ type 'a destruction_arg = type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] [@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 3a0badb28f..6b131edaac 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -37,16 +37,24 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use type goal_selector = Goal_select.t = | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll + [@ocaml.deprecated "Use constructors in [Goal_select]"] [@@ocaml.deprecated "Use Vernacexpr.goal_selector"] type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] [@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = @@ -55,8 +63,11 @@ type 'a destruction_arg = type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] [@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 1444800624..5501cf92a5 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -29,6 +29,7 @@ open Stdarg open Tacarg open Namegen open Tactypes +open Tactics open Locus (** Globalization of tactic expressions : diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 71da6c7667..9f34df4608 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -37,6 +37,7 @@ open Tacarg open Printer open Pretyping open Tactypes +open Tactics open Locus open Tacintern open Taccoerce @@ -1297,7 +1298,7 @@ and tactic_of_value ist vle = match appl with UnnamedAppl -> "An unnamed user-defined tactic" | GlbAppl apps -> - let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in + let nms = List.map (fun (kn,_) -> string_of_qualid (Tacenv.shortest_qualid_of_tactic kn)) apps in match nms with [] -> assert false | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *) @@ -1468,7 +1469,7 @@ and interp_genarg ist x : Val.t Ftactic.t = independently of goals. *) and interp_genarg_constr_list ist x = - Ftactic.nf_enter begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in @@ -1600,7 +1601,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1615,7 +1616,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1695,7 +1696,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = @@ -1722,7 +1723,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (* Conversion *) | TacReduce (r,cl) -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index dd799dc131..4626378db6 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -15,6 +15,7 @@ open Genarg open Stdarg open Tacarg open Tactypes +open Tactics open Globnames open Genredexpr open Patternops diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 105b5c59ae..6bab8d0353 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -12,7 +12,6 @@ open Util open Names open Pp open Tacexpr -open Termops let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () @@ -51,14 +50,14 @@ let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) let db_pr_goal gl = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let penv = print_named_context env in - let pc = print_constr_env env (Tacmach.New.project gl) concl in + let penv = Termops.Internal.print_named_context env in + let pc = Printer.pr_econstr_env env (Tacmach.New.project gl) concl in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end @@ -243,7 +242,7 @@ let db_constr debug env sigma c = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then - msg_tac_debug (str "Evaluated term: " ++ print_constr_env env sigma c) + msg_tac_debug (str "Evaluated term: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints the pattern rule *) @@ -268,7 +267,7 @@ let db_matched_hyp debug env sigma (id,_,c) ido = is_debug debug >>= fun db -> if db then msg_tac_debug (str "Hypothesis " ++ Id.print id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env sigma c) + str " has been matched: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints the matched conclusion *) @@ -276,7 +275,7 @@ let db_matched_concl debug env sigma c = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then - msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env sigma c) + msg_tac_debug (str "Conclusion has been matched: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints a success message when the goal has been matched *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index f22147f8b0..e0a369ca5f 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1456,7 +1456,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1709,7 +1709,7 @@ let micromega_gen (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec dumpexpr prover tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -1787,7 +1787,7 @@ let micromega_order_changer cert env ff = let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -1817,7 +1817,7 @@ let micromega_genr prover tac = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index e14c4e2ec1..abae6940fa 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -588,7 +588,7 @@ let abstract_path sigma typ path t = let focused_simpl path = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in convert_concl_no_check newc DEFAULTcast end @@ -656,7 +656,7 @@ let new_hole env sigma c = let clever_rewrite_base_poly typ p result theorem = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let full = pf_concl gl in let env = pf_env gl in let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in @@ -708,7 +708,7 @@ let refine_app gl t = let clever_rewrite p vpath t = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let full = pf_concl gl in let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in @@ -1763,7 +1763,7 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let id = fresh_id Id.Set.empty id gl in tclTHEN (introduction id) (tac id) end) @@ -1771,7 +1771,7 @@ let onClearedName id tac = let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in let id2 = fresh_id Id.Set.empty (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] @@ -1956,7 +1956,7 @@ let destructure_goal = try let dec = decidability t in tclTHEN - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) end) intro diff --git a/plugins/romega/README b/plugins/romega/README deleted file mode 100644 index 86c9e58afd..0000000000 --- a/plugins/romega/README +++ /dev/null @@ -1,6 +0,0 @@ -This work was done for the RNRT Project Calife. -As such it is distributed under the LGPL licence. - -Report bugs to : - pierre.cregut@francetelecom.com - diff --git a/plugins/romega/ROmega.v b/plugins/romega/ROmega.v deleted file mode 100644 index 657aae90e8..0000000000 --- a/plugins/romega/ROmega.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -Require Import ReflOmegaCore. -Require Export Setoid. -Require Export PreOmega. -Require Export ZArith_base. -Require Import OmegaPlugin. -Declare ML Module "romega_plugin". diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v deleted file mode 100644 index da86f4274d..0000000000 --- a/plugins/romega/ReflOmegaCore.v +++ /dev/null @@ -1,1874 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence du projet : LGPL version 2.1 - - *************************************************************************) - -Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. -Declare Scope Int_scope. -Delimit Scope Int_scope with I. - -(** * Abstract Integers. *) - -Module Type Int. - - Parameter t : Set. - - Bind Scope Int_scope with t. - - Parameter Inline zero : t. - Parameter Inline one : t. - Parameter Inline plus : t -> t -> t. - Parameter Inline opp : t -> t. - Parameter Inline minus : t -> t -> t. - Parameter Inline mult : t -> t -> t. - - Notation "0" := zero : Int_scope. - Notation "1" := one : Int_scope. - Infix "+" := plus : Int_scope. - Infix "-" := minus : Int_scope. - Infix "*" := mult : Int_scope. - Notation "- x" := (opp x) : Int_scope. - - Open Scope Int_scope. - - (** First, Int is a ring: *) - Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). - - (** Int should also be ordered: *) - - Parameter Inline le : t -> t -> Prop. - Parameter Inline lt : t -> t -> Prop. - Parameter Inline ge : t -> t -> Prop. - Parameter Inline gt : t -> t -> Prop. - Notation "x <= y" := (le x y): Int_scope. - Notation "x < y" := (lt x y) : Int_scope. - Notation "x >= y" := (ge x y) : Int_scope. - Notation "x > y" := (gt x y): Int_scope. - Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i). - Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i). - Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i). - - (** Basic properties of this order *) - Axiom lt_trans : forall i j k, i<j -> j<k -> i<k. - Axiom lt_not_eq : forall i j, i<j -> i<>j. - - (** Compatibilities *) - Axiom lt_0_1 : 0<1. - Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. - Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). - Axiom mult_lt_compat_l : - forall i j k, 0 < k -> i < j -> k*i<k*j. - - (** We should have a way to decide the equality and the order*) - Parameter compare : t -> t -> comparison. - Infix "?=" := compare (at level 70, no associativity) : Int_scope. - Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. - Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j. - Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j. - - (** Up to here, these requirements could be fulfilled - by any totally ordered ring. Let's now be int-specific: *) - Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1). - - (** Btw, lt_0_1 could be deduced from this last axiom *) - - (** Now we also require a division function. - It is deliberately underspecified, since that's enough - for the proofs below. But the most appropriate variant - (and the one needed to stay in sync with the omega engine) - is "Floor" (the historical version of Coq's [Z.div]). *) - - Parameter diveucl : t -> t -> t * t. - Notation "i / j" := (fst (diveucl i j)). - Notation "i 'mod' j" := (snd (diveucl i j)). - Axiom diveucl_spec : - forall i j, j<>0 -> i = j * (i/j) + (i mod j). - -End Int. - - - -(** Of course, Z is a model for our abstract int *) - -Module Z_as_Int <: Int. - - Open Scope Z_scope. - - Definition t := Z. - Definition zero := 0. - Definition one := 1. - Definition plus := Z.add. - Definition opp := Z.opp. - Definition minus := Z.sub. - Definition mult := Z.mul. - - Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t). - Proof. - constructor. - exact Z.add_0_l. - exact Z.add_comm. - exact Z.add_assoc. - exact Z.mul_1_l. - exact Z.mul_comm. - exact Z.mul_assoc. - exact Z.mul_add_distr_r. - unfold minus, Z.sub; auto. - exact Z.add_opp_diag_r. - Qed. - - Definition le := Z.le. - Definition lt := Z.lt. - Definition ge := Z.ge. - Definition gt := Z.gt. - Definition le_lt_iff := Z.le_ngt. - Definition ge_le_iff := Z.ge_le_iff. - Definition gt_lt_iff := Z.gt_lt_iff. - - Definition lt_trans := Z.lt_trans. - Definition lt_not_eq := Z.lt_neq. - - Definition lt_0_1 := Z.lt_0_1. - Definition plus_le_compat := Z.add_le_mono. - Definition mult_lt_compat_l := Zmult_lt_compat_l. - Lemma opp_le_compat i j : i<=j -> (-j)<=(-i). - Proof. apply -> Z.opp_le_mono. Qed. - - Definition compare := Z.compare. - Definition compare_Eq := Z.compare_eq_iff. - Lemma compare_Lt i j : compare i j = Lt <-> i<j. - Proof. reflexivity. Qed. - Lemma compare_Gt i j : compare i j = Gt <-> i>j. - Proof. reflexivity. Qed. - - Definition le_lt_int := Z.lt_le_pred. - - Definition diveucl := Z.div_eucl. - Definition diveucl_spec := Z.div_mod. - -End Z_as_Int. - - -(** * Properties of abstract integers *) - -Module IntProperties (I:Int). - Import I. - Local Notation int := I.t. - - (** Primo, some consequences of being a ring theory... *) - - Definition two := 1+1. - Notation "2" := two : Int_scope. - - (** Aliases for properties packed in the ring record. *) - - Definition plus_assoc := ring.(Radd_assoc). - Definition plus_comm := ring.(Radd_comm). - Definition plus_0_l := ring.(Radd_0_l). - Definition mult_assoc := ring.(Rmul_assoc). - Definition mult_comm := ring.(Rmul_comm). - Definition mult_1_l := ring.(Rmul_1_l). - Definition mult_plus_distr_r := ring.(Rdistr_l). - Definition opp_def := ring.(Ropp_def). - Definition minus_def := ring.(Rsub_def). - - Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l - mult_plus_distr_r opp_def minus_def. - - (** More facts about [plus] *) - - Lemma plus_0_r : forall x, x+0 = x. - Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. - - Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). - Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. - - Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. - Proof. - intros. - rewrite <- (plus_0_r y), <- (plus_0_r z), <-(opp_def x). - now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. - Qed. - - (** More facts about [mult] *) - - Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. - Proof. - intros. - rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). - apply mult_plus_distr_r. - Qed. - - Lemma mult_0_l x : 0*x = 0. - Proof. - assert (H := mult_plus_distr_r 0 1 x). - rewrite plus_0_l, mult_1_l, plus_comm in H. - apply plus_reg_l with x. - now rewrite <- H, plus_0_r. - Qed. - - Lemma mult_0_r x : x*0 = 0. - Proof. - rewrite mult_comm. apply mult_0_l. - Qed. - - Lemma mult_1_r x : x*1 = x. - Proof. - rewrite mult_comm. apply mult_1_l. - Qed. - - (** More facts about [opp] *) - - Definition plus_opp_r := opp_def. - - Lemma plus_opp_l : forall x, -x + x = 0. - Proof. intros; now rewrite plus_comm, opp_def. Qed. - - Lemma mult_opp_comm : forall x y, - x * y = x * - y. - Proof. - intros. - apply plus_reg_l with (x*y). - rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. - now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. - Qed. - - Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). - Proof. - intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. - Qed. - - Lemma opp_involutive : forall x, -(-x) = x. - Proof. - intros. - apply plus_reg_l with (-x). - now rewrite opp_def, plus_comm, opp_def. - Qed. - - Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. - Proof. - intros. - apply plus_reg_l with (x+y). - rewrite opp_def. - rewrite plus_permute. - do 2 rewrite plus_assoc. - now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. - Qed. - - Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. - Proof. - intros. - rewrite <- mult_opp_comm. - apply plus_reg_l with (x*y). - now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. - Qed. - - Lemma egal_left n m : 0 = n+-m <-> n = m. - Proof. - split; intros. - - apply plus_reg_l with (-m). - rewrite plus_comm, <- H. symmetry. apply plus_opp_l. - - symmetry. subst; apply opp_def. - Qed. - - (** Specialized distributivities *) - - Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. - Hint Rewrite <- plus_assoc : int. - - Hint Rewrite plus_0_l plus_0_r mult_0_l mult_0_r mult_1_l mult_1_r : int. - - Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2) = - (v * c1 + l1) * k1 + (v * c2 + l2) * k2. - Proof. - autorewrite with int; f_equal; now rewrite plus_permute. - Qed. - - Lemma OMEGA11 v1 c1 l1 l2 k1 : - v1 * (c1 * k1) + (l1 * k1 + l2) = (v1 * c1 + l1) * k1 + l2. - Proof. - now autorewrite with int. - Qed. - - Lemma OMEGA12 v2 c2 l1 l2 k2 : - v2 * (c2 * k2) + (l1 + l2 * k2) = l1 + (v2 * c2 + l2) * k2. - Proof. - autorewrite with int; now rewrite plus_permute. - Qed. - - Lemma sum1 a b c d : 0 = a -> 0 = b -> 0 = a * c + b * d. - Proof. - intros; subst. now autorewrite with int. - Qed. - - - (** Secondo, some results about order (and equality) *) - - Lemma lt_irrefl : forall n, ~ n<n. - Proof. - intros n H. - elim (lt_not_eq _ _ H); auto. - Qed. - - Lemma lt_antisym : forall n m, n<m -> m<n -> False. - Proof. - intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. - Qed. - - Lemma lt_le_weak : forall n m, n<m -> n<=m. - Proof. - intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. - Qed. - - Lemma le_refl : forall n, n<=n. - Proof. - intros; rewrite le_lt_iff; apply lt_irrefl; auto. - Qed. - - Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. - Proof. - intros n m; do 2 rewrite le_lt_iff; intros. - rewrite <- compare_Lt in H0. - rewrite <- gt_lt_iff, <- compare_Gt in H. - rewrite <- compare_Eq. - destruct compare; intuition. - Qed. - - Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }. - Proof. - intros. - generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). - destruct compare; [ left; right | left; left | right ]; intuition. - rewrite gt_lt_iff in H1; intuition. - Qed. - - Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }. - Proof. - intros. - generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). - destruct compare; [ right | left | right ]; intuition discriminate. - Qed. - - Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n). - Proof. - intros. - rewrite le_lt_iff. - destruct (lt_dec n m); intuition. - Qed. - - Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. - Proof. - intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. - Qed. - - Lemma le_lt_dec : forall n m, { n<=m } + { m<n }. - Proof. - intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff. - Qed. - - - Definition beq i j := match compare i j with Eq => true | _ => false end. - - Infix "=?" := beq : Int_scope. - - Lemma beq_iff i j : (i =? j) = true <-> i=j. - Proof. - unfold beq. rewrite <- (compare_Eq i j). now destruct compare. - Qed. - - Lemma beq_reflect i j : reflect (i=j) (i =? j). - Proof. - apply iff_reflect. symmetry. apply beq_iff. - Qed. - - Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. - Proof. - intros n m; generalize (beq_iff n m); destruct beq; [left|right]; intuition. - Qed. - - Definition blt i j := match compare i j with Lt => true | _ => false end. - - Infix "<?" := blt : Int_scope. - - Lemma blt_iff i j : (i <? j) = true <-> i<j. - Proof. - unfold blt. rewrite <- (compare_Lt i j). now destruct compare. - Qed. - - Lemma blt_reflect i j : reflect (i<j) (i <? j). - Proof. - apply iff_reflect. symmetry. apply blt_iff. - Qed. - - Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }. - Proof. - intros n m Hnm. - destruct (eq_dec n m) as [H'|H']. - - right; intuition. - - left; rewrite lt_le_iff. - contradict H'. - now apply le_antisym. - Qed. - - Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m. - Proof. - intros n m H. now destruct (le_is_lt_or_eq _ _ H). - Qed. - - Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p. - Proof. - intros n m p; rewrite 3 le_lt_iff; intros A B C. - destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. - generalize (lt_trans _ _ _ H C); intuition. - Qed. - - Lemma not_eq (a b:int) : ~ a <> b <-> a = b. - Proof. - destruct (eq_dec a b); intuition. - Qed. - - (** Order and operations *) - - Lemma le_0_neg n : n <= 0 <-> 0 <= -n. - Proof. - rewrite <- (mult_0_l (-(1))) at 2. - rewrite <- opp_eq_mult_neg_1. - split; intros. - - now apply opp_le_compat. - - rewrite <-(opp_involutive 0), <-(opp_involutive n). - now apply opp_le_compat. - Qed. - - Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. - Proof. - intros. - replace n with ((n+p)+-p). - replace m with ((m+p)+-p). - apply plus_le_compat; auto. - apply le_refl. - now rewrite <- plus_assoc, opp_def, plus_0_r. - now rewrite <- plus_assoc, opp_def, plus_0_r. - Qed. - - Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q. - Proof. - intros. - apply le_neq_lt. - apply plus_le_compat; auto. - apply lt_le_weak; auto. - rewrite lt_le_iff in H0. - contradict H0. - apply plus_le_reg_r with m. - rewrite (plus_comm q m), <-H0, (plus_comm p m). - apply plus_le_compat; auto. - apply le_refl; auto. - Qed. - - Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q. - Proof. - intros. - apply plus_le_lt_compat; auto. - apply lt_le_weak; auto. - Qed. - - Lemma opp_lt_compat : forall n m, n<m -> -m < -n. - Proof. - intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. - rewrite <-(opp_involutive m), <-(opp_involutive n). - apply opp_le_compat; auto. - Qed. - - Lemma lt_0_neg n : n < 0 <-> 0 < -n. - Proof. - rewrite <- (mult_0_l (-(1))) at 2. - rewrite <- opp_eq_mult_neg_1. - split; intros. - - now apply opp_lt_compat. - - rewrite <-(opp_involutive 0), <-(opp_involutive n). - now apply opp_lt_compat. - Qed. - - Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. - Proof. - intros. - rewrite <- (mult_0_l n), mult_comm. - apply mult_lt_compat_l; auto. - Qed. - - Lemma mult_integral_r n m : 0 < n -> n * m = 0 -> m = 0. - Proof. - intros Hn H. - destruct (lt_eq_lt_dec 0 m) as [[Hm| <- ]|Hm]; auto; exfalso. - - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite H. - exact (lt_irrefl 0). - - rewrite lt_0_neg in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r, opp_eq_mult_neg_1, H, mult_0_l. - exact (lt_irrefl 0). - Qed. - - Lemma mult_integral n m : n * m = 0 -> n = 0 \/ m = 0. - Proof. - intros H. - destruct (lt_eq_lt_dec 0 n) as [[Hn|Hn]|Hn]. - - right; apply (mult_integral_r n m); trivial. - - now left. - - right; apply (mult_integral_r (-n) m). - + now apply lt_0_neg. - + rewrite mult_comm, <- opp_mult_distr_r, mult_comm, H. - now rewrite opp_eq_mult_neg_1, mult_0_l. - Qed. - - Lemma mult_le_compat_l i j k : - 0<=k -> i<=j -> k*i <= k*j. - Proof. - intros Hk Hij. - apply le_is_lt_or_eq in Hk. apply le_is_lt_or_eq in Hij. - destruct Hk as [Hk | <-], Hij as [Hij | <-]; - rewrite ? mult_0_l; try apply le_refl. - now apply lt_le_weak, mult_lt_compat_l. - Qed. - - Lemma mult_le_compat i j k l : - i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. - Proof. - intros Hij Hkl Hi Hk. - apply le_trans with (i*l). - - now apply mult_le_compat_l. - - rewrite (mult_comm i), (mult_comm j). - apply mult_le_compat_l; trivial. - now apply le_trans with k. - Qed. - - Lemma sum5 a b c d : 0 <> c -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. - Proof. - intros Hc Ha <-. autorewrite with int. contradict Hc. - symmetry in Hc. destruct (mult_integral _ _ Hc); congruence. - Qed. - - Lemma le_left n m : n <= m <-> 0 <= m + - n. - Proof. - split; intros. - - rewrite <- (opp_def m). - apply plus_le_compat. - apply le_refl. - apply opp_le_compat; auto. - - apply plus_le_reg_r with (-n). - now rewrite plus_opp_r. - Qed. - - Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. - Proof. - intros. - assert (y=-x). - subst x; symmetry; apply opp_involutive. - clear H1; subst y. - destruct (eq_dec 0 x) as [H'|H']; auto. - assert (H'':=le_neq_lt _ _ H H'). - generalize (plus_le_lt_compat _ _ _ _ H0 H''). - rewrite plus_opp_l, plus_0_l. - intros. - elim (lt_not_eq _ _ H1); auto. - Qed. - - Lemma sum2 a b c d : - 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. - Proof. - intros Hd <- Hb. autorewrite with int. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - Qed. - - Lemma sum3 a b c d : - 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. - Proof. - intros. - rewrite <- (plus_0_l 0). - apply plus_le_compat; auto. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - Qed. - - (** Lemmas specific to integers (they use [le_lt_int]) *) - - Lemma lt_left n m : n < m <-> 0 <= m + -n + -(1). - Proof. - rewrite <- plus_assoc, (plus_comm (-n)), plus_assoc. - rewrite <- le_left. - apply le_lt_int. - Qed. - - Lemma OMEGA4 x y z : 0 < x -> x < y -> z * y + x <> 0. - Proof. - intros H H0 H'. - assert (0 < y) by now apply lt_trans with x. - destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. - - - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). - rewrite H'. - rewrite <-(mult_1_l y) at 2. rewrite <-mult_plus_distr_r. - apply le_lt_iff. - rewrite mult_comm. rewrite <- (mult_0_r y). - apply mult_le_compat_l; auto using lt_le_weak. - apply le_0_neg. rewrite opp_plus_distr. - apply le_lt_int. now apply lt_0_neg. - - - apply (lt_not_eq 0 (z*y+x)); auto. - subst. now autorewrite with int. - - - apply (lt_not_eq 0 (z*y+x)); auto. - rewrite <- (plus_0_l 0). - auto using plus_lt_compat, mult_lt_0_compat. - Qed. - - Lemma OMEGA19 x : x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). - Proof. - intros. - do 2 rewrite <- le_lt_int. - rewrite <- opp_eq_mult_neg_1. - destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. - auto. - congruence. - right. - rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). - apply opp_lt_compat; auto. - Qed. - - Lemma mult_le_approx n m p : - 0 < n -> p < n -> 0 <= m * n + p -> 0 <= m. - Proof. - do 2 rewrite le_lt_iff; intros Hn Hpn H Hm. destruct H. - apply lt_0_neg, le_lt_int, le_left in Hm. - rewrite lt_0_neg. - rewrite opp_plus_distr, mult_comm, opp_mult_distr_r. - rewrite le_lt_int. apply lt_left. - rewrite le_lt_int. - apply le_trans with (n+-(1)); [ now apply le_lt_int | ]. - apply plus_le_compat; [ | apply le_refl ]. - rewrite <- (mult_1_r n) at 1. - apply mult_le_compat_l; auto using lt_le_weak. - Qed. - - (** Some decidabilities *) - - Lemma dec_eq : forall i j:int, decidable (i=j). - Proof. - red; intros; destruct (eq_dec i j); auto. - Qed. - - Lemma dec_ne : forall i j:int, decidable (i<>j). - Proof. - red; intros; destruct (eq_dec i j); auto. - Qed. - - Lemma dec_le : forall i j:int, decidable (i<=j). - Proof. - red; intros; destruct (le_dec i j); auto. - Qed. - - Lemma dec_lt : forall i j:int, decidable (i<j). - Proof. - red; intros; destruct (lt_dec i j); auto. - Qed. - - Lemma dec_ge : forall i j:int, decidable (i>=j). - Proof. - red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. - Qed. - - Lemma dec_gt : forall i j:int, decidable (i>j). - Proof. - red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. - Qed. - -End IntProperties. - - -(** * The Coq side of the romega tactic *) - -Module IntOmega (I:Int). -Import I. -Module IP:=IntProperties(I). -Import IP. -Local Notation int := I.t. - -(* ** Definition of reified integer expressions - - Terms are either: - - integers [Tint] - - variables [Tvar] - - operation over integers (addition, product, opposite, subtraction) - - Opposite and subtraction are translated in additions and products. - Note that we'll only deal with products for which at least one side - is [Tint]. *) - -Inductive term : Set := - | Tint : int -> term - | Tplus : term -> term -> term - | Tmult : term -> term -> term - | Tminus : term -> term -> term - | Topp : term -> term - | Tvar : N -> term. - -Declare Scope romega_scope. -Bind Scope romega_scope with term. -Delimit Scope romega_scope with term. -Arguments Tint _%I. -Arguments Tplus (_ _)%term. -Arguments Tmult (_ _)%term. -Arguments Tminus (_ _)%term. -Arguments Topp _%term. - -Infix "+" := Tplus : romega_scope. -Infix "*" := Tmult : romega_scope. -Infix "-" := Tminus : romega_scope. -Notation "- x" := (Topp x) : romega_scope. -Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. - -(* ** Definition of reified goals - - Very restricted definition of handled predicates that should be extended - to cover a wider set of operations. - Taking care of negations and disequations require solving more than a - goal in parallel. This is a major improvement over previous versions. *) - -Inductive proposition : Set := - (** First, basic equations, disequations, inequations *) - | EqTerm : term -> term -> proposition - | NeqTerm : term -> term -> proposition - | LeqTerm : term -> term -> proposition - | GeqTerm : term -> term -> proposition - | GtTerm : term -> term -> proposition - | LtTerm : term -> term -> proposition - (** Then, the supported logical connectors *) - | TrueTerm : proposition - | FalseTerm : proposition - | Tnot : proposition -> proposition - | Tor : proposition -> proposition -> proposition - | Tand : proposition -> proposition -> proposition - | Timp : proposition -> proposition -> proposition - (** Everything else is left as a propositional atom (and ignored). *) - | Tprop : nat -> proposition. - -(** Definition of goals as a list of hypothesis *) -Notation hyps := (list proposition). - -(** Definition of lists of subgoals (set of open goals) *) -Notation lhyps := (list hyps). - -(** A single goal packed in a subgoal list *) -Notation singleton := (fun a : hyps => a :: nil). - -(** An absurd goal *) -Definition absurd := FalseTerm :: nil. - -(** ** Decidable equality on terms *) - -Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := - match t1, t2 with - | Tint i1, Tint i2 => i1 =? i2 - | (t11 + t12), (t21 + t22) => eq_term t11 t21 && eq_term t12 t22 - | (t11 * t12), (t21 * t22) => eq_term t11 t21 && eq_term t12 t22 - | (t11 - t12), (t21 - t22) => eq_term t11 t21 && eq_term t12 t22 - | (- t1), (- t2) => eq_term t1 t2 - | [v1], [v2] => N.eqb v1 v2 - | _, _ => false - end%term. - -Infix "=?" := eq_term : romega_scope. - -Theorem eq_term_iff (t t' : term) : - (t =? t')%term = true <-> t = t'. -Proof. - revert t'. induction t; destruct t'; simpl in *; - rewrite ?andb_true_iff, ?beq_iff, ?N.eqb_eq, ?IHt, ?IHt1, ?IHt2; - intuition congruence. -Qed. - -Theorem eq_term_reflect (t t' : term) : reflect (t=t') (t =? t')%term. -Proof. - apply iff_reflect. symmetry. apply eq_term_iff. -Qed. - -(** ** Interpretations of terms (as integers). *) - -Fixpoint Nnth {A} (n:N)(l:list A)(default:A) := - match n, l with - | _, nil => default - | 0%N, x::_ => x - | _, _::l => Nnth (N.pred n) l default - end. - -Fixpoint interp_term (env : list int) (t : term) : int := - match t with - | Tint x => x - | (t1 + t2)%term => interp_term env t1 + interp_term env t2 - | (t1 * t2)%term => interp_term env t1 * interp_term env t2 - | (t1 - t2)%term => interp_term env t1 - interp_term env t2 - | (- t)%term => - interp_term env t - | [n]%term => Nnth n env 0 - end. - -(** ** Interpretation of predicats (as Coq propositions) *) - -Fixpoint interp_prop (envp : list Prop) (env : list int) - (p : proposition) : Prop := - match p with - | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 - | NeqTerm t1 t2 => (interp_term env t1) <> (interp_term env t2) - | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 - | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 - | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 - | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 - | TrueTerm => True - | FalseTerm => False - | Tnot p' => ~ interp_prop envp env p' - | Tor p1 p2 => interp_prop envp env p1 \/ interp_prop envp env p2 - | Tand p1 p2 => interp_prop envp env p1 /\ interp_prop envp env p2 - | Timp p1 p2 => interp_prop envp env p1 -> interp_prop envp env p2 - | Tprop n => nth n envp True - end. - -(** ** Intepretation of hypothesis lists (as Coq conjunctions) *) - -Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) - : Prop := - match l with - | nil => True - | p' :: l' => interp_prop envp env p' /\ interp_hyps envp env l' - end. - -(** ** Interpretation of conclusion + hypotheses - - Here we use Coq implications : it's less easy to manipulate, - but handy to relate to the Coq original goal (cf. the use of - [generalize], and lighter (no repetition of types in intermediate - conjunctions). *) - -Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) - (env : list int) (l : hyps) : Prop := - match l with - | nil => interp_prop envp env c - | p' :: l' => - interp_prop envp env p' -> interp_goal_concl c envp env l' - end. - -Notation interp_goal := (interp_goal_concl FalseTerm). - -(** Equivalence between these two interpretations. *) - -Theorem goal_to_hyps : - forall (envp : list Prop) (env : list int) (l : hyps), - (interp_hyps envp env l -> False) -> interp_goal envp env l. -Proof. - induction l; simpl; auto. -Qed. - -Theorem hyps_to_goal : - forall (envp : list Prop) (env : list int) (l : hyps), - interp_goal envp env l -> interp_hyps envp env l -> False. -Proof. - induction l; simpl; auto. - intros H (H1,H2). auto. -Qed. - -(** ** Interpretations of list of goals - - Here again, two flavours... *) - -Fixpoint interp_list_hyps (envp : list Prop) (env : list int) - (l : lhyps) : Prop := - match l with - | nil => False - | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' - end. - -Fixpoint interp_list_goal (envp : list Prop) (env : list int) - (l : lhyps) : Prop := - match l with - | nil => True - | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' - end. - -(** Equivalence between the two flavours. *) - -Theorem list_goal_to_hyps : - forall (envp : list Prop) (env : list int) (l : lhyps), - (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. -Proof. - induction l; simpl; intuition. now apply goal_to_hyps. -Qed. - -Theorem list_hyps_to_goal : - forall (envp : list Prop) (env : list int) (l : lhyps), - interp_list_goal envp env l -> interp_list_hyps envp env l -> False. -Proof. - induction l; simpl; intuition. eapply hyps_to_goal; eauto. -Qed. - -(** ** Stabiliy and validity of operations *) - -(** An operation on terms is stable if the interpretation is unchanged. *) - -Definition term_stable (f : term -> term) := - forall (e : list int) (t : term), interp_term e t = interp_term e (f t). - -(** An operation on one hypothesis is valid if this hypothesis implies - the result of this operation. *) - -Definition valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_prop ep e p1 -> interp_prop ep e (f p1). - -Definition valid2 (f : proposition -> proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 p2 : proposition), - interp_prop ep e p1 -> - interp_prop ep e p2 -> interp_prop ep e (f p1 p2). - -(** Same for lists of hypotheses, and for list of goals *) - -Definition valid_hyps (f : hyps -> hyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_hyps ep e (f lp). - -Definition valid_list_hyps (f : hyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_list_hyps ep e (f lp). - -Definition valid_list_goal (f : hyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_list_goal ep e (f lp) -> interp_goal ep e lp. - -(** Some results about these validities. *) - -Theorem valid_goal : - forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), - valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. -Proof. - intros; simpl; apply goal_to_hyps; intro H1; - apply (hyps_to_goal ep env (a l) H0); apply H; assumption. -Qed. - -Theorem goal_valid : - forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. -Proof. - unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps; - intro H2; apply list_hyps_to_goal with (1 := H1); - apply (H ep e lp); assumption. -Qed. - -Theorem append_valid : - forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), - interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> - interp_list_hyps ep e (l1 ++ l2). -Proof. - induction l1; simpl in *. - - now intros l2 [H| H]. - - intros l2 [[H| H]| H]. - + auto. - + right; apply IHl1; now left. - + right; apply IHl1; now right. -Qed. - -(** ** Valid operations on hypotheses *) - -(** Extract an hypothesis from the list *) - -Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. - -Theorem nth_valid : - forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), - interp_hyps ep e l -> interp_prop ep e (nth_hyps i l). -Proof. - unfold nth_hyps. induction i; destruct l; simpl in *; try easy. - intros (H1,H2). now apply IHi. -Qed. - -(** Apply a valid operation on two hypotheses from the list, and - store the result in the list. *) - -Definition apply_oper_2 (i j : nat) - (f : proposition -> proposition -> proposition) (l : hyps) := - f (nth_hyps i l) (nth_hyps j l) :: l. - -Theorem apply_oper_2_valid : - forall (i j : nat) (f : proposition -> proposition -> proposition), - valid2 f -> valid_hyps (apply_oper_2 i j f). -Proof. - intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; - intros lp Hlp; split. - - apply Hf; apply nth_valid; assumption. - - assumption. -Qed. - -(** In-place modification of an hypothesis by application of - a valid operation. *) - -Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) - (l : hyps) {struct i} : hyps := - match l with - | nil => nil - | p :: l' => - match i with - | O => f p :: l' - | S j => p :: apply_oper_1 j f l' - end - end. - -Theorem apply_oper_1_valid : - forall (i : nat) (f : proposition -> proposition), - valid1 f -> valid_hyps (apply_oper_1 i f). -Proof. - unfold valid_hyps. - induction i; intros f Hf ep e [ | p lp]; simpl; intuition. -Qed. - -(** ** A tactic for proving stability *) - -Ltac loop t := - match t with - (* Global *) - | (?X1 = ?X2) => loop X1 || loop X2 - | (_ -> ?X1) => loop X1 - (* Interpretations *) - | (interp_hyps _ _ ?X1) => loop X1 - | (interp_list_hyps _ _ ?X1) => loop X1 - | (interp_prop _ _ ?X1) => loop X1 - | (interp_term _ ?X1) => loop X1 - (* Propositions *) - | (EqTerm ?X1 ?X2) => loop X1 || loop X2 - | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 - (* Terms *) - | (?X1 + ?X2)%term => loop X1 || loop X2 - | (?X1 - ?X2)%term => loop X1 || loop X2 - | (?X1 * ?X2)%term => loop X1 || loop X2 - | (- ?X1)%term => loop X1 - | (Tint ?X1) => loop X1 - (* Eliminations *) - | (if ?X1 =? ?X2 then _ else _) => - let H := fresh "H" in - case (beq_reflect X1 X2); intro H; - try (rewrite H in *; clear H); simpl; auto; Simplify - | (if ?X1 <? ?X2 then _ else _) => - case (blt_reflect X1 X2); intro; simpl; auto; Simplify - | (if (?X1 =? ?X2)%term then _ else _) => - let H := fresh "H" in - case (eq_term_reflect X1 X2); intro H; - try (rewrite H in *; clear H); simpl; auto; Simplify - | (if _ && _ then _ else _) => rewrite andb_if; Simplify - | (if negb _ then _ else _) => rewrite negb_if; Simplify - | match N.compare ?X1 ?X2 with _ => _ end => - destruct (N.compare_spec X1 X2); Simplify - | match ?X1 with _ => _ end => destruct X1; auto; Simplify - | _ => fail - end - -with Simplify := match goal with - | |- ?X1 => try loop X1 - | _ => idtac - end. - -(** ** Operations on equation bodies *) - -(** The operations below handle in priority _normalized_ terms, i.e. - terms of the form: - [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))] - with [v1>v2>...] and all [ki<>0]. - See [normalize] below for a way to put terms in this form. - - These operations also produce a correct (but suboptimal) - result in case of non-normalized input terms, but this situation - should normally not happen when running [romega]. - - /!\ Do not modify this section (especially [fusion] and [normalize]) - without tweaking the corresponding functions in [refl_omega.ml]. -*) - -(** Multiplication and sum by two constants. Invariant: [k1<>0]. *) - -Fixpoint scalar_mult_add (t : term) (k1 k2 : int) : term := - match t with - | v1 * Tint x1 + l1 => - v1 * Tint (x1 * k1) + scalar_mult_add l1 k1 k2 - | Tint x => Tint (k1 * x + k2) - | _ => t * Tint k1 + Tint k2 (* shouldn't happen *) - end%term. - -Theorem scalar_mult_add_stable e t k1 k2 : - interp_term e (scalar_mult_add t k1 k2) = - interp_term e (t * Tint k1 + Tint k2). -Proof. - induction t; simpl; Simplify; simpl; auto. f_equal. apply mult_comm. - rewrite IHt2. simpl. apply OMEGA11. -Qed. - -(** Multiplication by a (non-nul) constant. *) - -Definition scalar_mult (t : term) (k : int) := scalar_mult_add t k 0. - -Theorem scalar_mult_stable e t k : - interp_term e (scalar_mult t k) = - interp_term e (t * Tint k). -Proof. - unfold scalar_mult. rewrite scalar_mult_add_stable. simpl. - apply plus_0_r. -Qed. - -(** Adding a constant - - Instead of using [scalar_norm_add t 1 k], the following - definition spares some computations. - *) - -Fixpoint scalar_add (t : term) (k : int) : term := - match t with - | m + l => m + scalar_add l k - | Tint x => Tint (x + k) - | _ => t + Tint k - end%term. - -Theorem scalar_add_stable e t k : - interp_term e (scalar_add t k) = interp_term e (t + Tint k). -Proof. - induction t; simpl; Simplify; simpl; auto. - rewrite IHt2. simpl. apply plus_assoc. -Qed. - -(** Division by a constant - - All the non-constant coefficients should be exactly dividable *) - -Fixpoint scalar_div (t : term) (k : int) : option (term * int) := - match t with - | v * Tint x + l => - let (q,r) := diveucl x k in - if (r =? 0)%I then - match scalar_div l k with - | None => None - | Some (u,c) => Some (v * Tint q + u, c) - end - else None - | Tint x => - let (q,r) := diveucl x k in - Some (Tint q, r) - | _ => None - end%term. - -Lemma scalar_div_stable e t k u c : k<>0 -> - scalar_div t k = Some (u,c) -> - interp_term e (u * Tint k + Tint c) = interp_term e t. -Proof. - revert u c. - induction t; simpl; Simplify; try easy. - - intros u c Hk. assert (H := diveucl_spec t0 k Hk). - simpl in H. - destruct diveucl as (q,r). simpl in H. rewrite H. - injection 1 as <- <-. simpl. f_equal. apply mult_comm. - - intros u c Hk. - destruct t1; simpl; Simplify; try easy. - destruct t1_2; simpl; Simplify; try easy. - assert (H := diveucl_spec t0 k Hk). - simpl in H. - destruct diveucl as (q,r). simpl in H. rewrite H. - case beq_reflect; [intros -> | easy]. - destruct (scalar_div t2 k) as [(u',c')|] eqn:E; [|easy]. - injection 1 as <- ->. simpl. - rewrite <- (IHt2 u' c Hk); simpl; auto. - rewrite plus_0_r , (mult_comm k q). symmetry. apply OMEGA11. -Qed. - - -(** Fusion of two equations. - - From two normalized equations, this fusion will produce - a normalized output corresponding to the coefficiented sum. - Invariant: [k1<>0] and [k2<>0]. -*) - -Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := - match t1 with - | [v1] * Tint x1 + l1 => - (fix fusion_t1 t2 : term := - match t2 with - | [v2] * Tint x2 + l2 => - match N.compare v1 v2 with - | Eq => - let k := (k1 * x1 + k2 * x2)%I in - if (k =? 0)%I then fusion l1 l2 k1 k2 - else [v1] * Tint k + fusion l1 l2 k1 k2 - | Lt => [v2] * Tint (k2 * x2) + fusion_t1 l2 - | Gt => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 - end - | Tint x2 => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 - | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) - end) t2 - | Tint x1 => scalar_mult_add t2 k2 (k1 * x1) - | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) - end%term. - -Theorem fusion_stable e t1 t2 k1 k2 : - interp_term e (fusion t1 t2 k1 k2) = - interp_term e (t1 * Tint k1 + t2 * Tint k2). -Proof. - revert t2; induction t1; simpl; Simplify; simpl; auto. - - intros; rewrite scalar_mult_add_stable. simpl. - rewrite plus_comm. f_equal. apply mult_comm. - - intros. Simplify. induction t2; simpl; Simplify; simpl; auto. - + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. - + rewrite IHt1_2. simpl. subst n0. - rewrite (mult_comm k1), (mult_comm k2) in H0. - rewrite <- OMEGA10, H0. now autorewrite with int. - + rewrite IHt1_2. simpl. subst n0. - rewrite (mult_comm k1), (mult_comm k2); apply OMEGA10. - + rewrite IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12. - + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. -Qed. - -(** Term normalization. - - Precondition: all [Tmult] should be on at least one [Tint]. - Postcondition: a normalized equivalent term (see below). -*) - -Fixpoint normalize t := - match t with - | Tint n => Tint n - | [n]%term => ([n] * Tint 1 + Tint 0)%term - | (t + t')%term => fusion (normalize t) (normalize t') 1 1 - | (- t)%term => scalar_mult (normalize t) (-(1)) - | (t - t')%term => fusion (normalize t) (normalize t') 1 (-(1)) - | (Tint k * t)%term | (t * Tint k)%term => - if k =? 0 then Tint 0 else scalar_mult (normalize t) k - | (t1 * t2)%term => (t1 * t2)%term (* shouldn't happen *) - end. - -Theorem normalize_stable : term_stable normalize. -Proof. - intros e t. - induction t; simpl; Simplify; simpl; - rewrite ?scalar_mult_stable; simpl in *; rewrite <- ?IHt1; - rewrite ?fusion_stable; simpl; autorewrite with int; auto. - - now f_equal. - - rewrite mult_comm. now f_equal. - - rewrite <- opp_eq_mult_neg_1, <-minus_def. now f_equal. - - rewrite <- opp_eq_mult_neg_1. now f_equal. -Qed. - -(** ** Normalization of a proposition. - - The only basic facts left after normalization are - [0 = ...] or [0 <> ...] or [0 <= ...]. - When a fact is in negative position, we factorize a [Tnot] - out of it, and normalize the reversed fact inside. - - /!\ Here again, do not change this code without corresponding - modifications in [refl_omega.ml]. -*) - -Fixpoint normalize_prop (negated:bool)(p:proposition) := - match p with - | EqTerm t1 t2 => - if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2))) - else EqTerm (Tint 0) (normalize (t1-t2)) - | NeqTerm t1 t2 => - if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2))) - else NeqTerm (Tint 0) (normalize (t1-t2)) - | LeqTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))) - else LeqTerm (Tint 0) (normalize (t2-t1)) - | GeqTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))) - else LeqTerm (Tint 0) (normalize (t1-t2)) - | LtTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2))) - else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))) - | GtTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1))) - else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))) - | Tnot p => Tnot (normalize_prop (negb negated) p) - | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p') - | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p') - | Timp p p' => Timp (normalize_prop (negb negated) p) - (normalize_prop negated p') - | Tprop _ | TrueTerm | FalseTerm => p - end. - -Definition normalize_hyps := List.map (normalize_prop false). - -Local Ltac simp := cbn -[normalize]. - -Theorem normalize_prop_valid b e ep p : - interp_prop e ep (normalize_prop b p) <-> interp_prop e ep p. -Proof. - revert b. - induction p; intros; simp; try tauto. - - destruct b; simp; - rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. - + rewrite not_eq. apply egal_left. - + apply egal_left. - - destruct b; simp; - rewrite <- ?normalize_stable; simpl; rewrite ?minus_def; - apply not_iff_compat, egal_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + symmetry. rewrite le_lt_iff. apply not_iff_compat, lt_left. - + now rewrite <- le_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + symmetry. rewrite ge_le_iff, le_lt_iff. - apply not_iff_compat, lt_left. - + rewrite ge_le_iff. now rewrite <- le_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. - now rewrite <- le_left. - + symmetry. rewrite gt_lt_iff. apply lt_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite lt_le_iff. apply not_iff_compat. - now rewrite <- le_left. - + symmetry. apply lt_left. - - now rewrite IHp. - - now rewrite IHp1, IHp2. - - now rewrite IHp1, IHp2. - - now rewrite IHp1, IHp2. -Qed. - -Theorem normalize_hyps_valid : valid_hyps normalize_hyps. -Proof. - intros e ep l. induction l; simpl; intuition. - now rewrite normalize_prop_valid. -Qed. - -Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : - interp_goal ep env (normalize_hyps l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. -Qed. - -(** ** A simple decidability checker - - For us, everything is considered decidable except - propositional atoms [Tprop _]. *) - -Fixpoint decidability (p : proposition) : bool := - match p with - | Tnot t => decidability t - | Tand t1 t2 => decidability t1 && decidability t2 - | Timp t1 t2 => decidability t1 && decidability t2 - | Tor t1 t2 => decidability t1 && decidability t2 - | Tprop _ => false - | _ => true - end. - -Theorem decidable_correct : - forall (ep : list Prop) (e : list int) (p : proposition), - decidability p = true -> decidable (interp_prop ep e p). -Proof. - induction p; simpl; intros Hp; try destruct (andb_prop _ _ Hp). - - apply dec_eq. - - apply dec_ne. - - apply dec_le. - - apply dec_ge. - - apply dec_gt. - - apply dec_lt. - - left; auto. - - right; unfold not; auto. - - apply dec_not; auto. - - apply dec_or; auto. - - apply dec_and; auto. - - apply dec_imp; auto. - - discriminate. -Qed. - -(** ** Omega steps - - The following inductive type describes steps as they can be - found in the trace coming from the decision procedure Omega. - We consider here only normalized equations [0=...], disequations - [0<>...] or inequations [0<=...]. - - First, the final steps leading to a contradiction: - - [O_BAD_CONSTANT i] : hypothesis i has a constant body - and this constant is not compatible with the kind of i. - - [O_NOT_EXACT_DIVIDE i k] : - equation i can be factorized as some [k*t+c] with [0<c<k]. - - Now, the intermediate steps leading to a new hypothesis: - - [O_DIVIDE i k cont] : - the body of hypothesis i could be factorized as [k*t+c] - with either [k<>0] and [c=0] for a (dis)equation, or - [0<k] and [c<k] for an inequation. We change in-place the - body of i for [t]. - - [O_SUM k1 i1 k2 i2 cont] : creates a new hypothesis whose - kind depends on the kind of hypotheses [i1] and [i2], and - whose body is [k1*body(i1) + k2*body(i2)]. Depending of the - situation, [k1] or [k2] might have to be positive or non-nul. - - [O_MERGE_EQ i j cont] : - inequations i and j have opposite bodies, we add an equation - with one these bodies. - - [O_SPLIT_INEQ i cont1 cont2] : - disequation i is split into a disjonction of inequations. -*) - -Definition idx := nat. (** Index of an hypothesis in the list *) - -Inductive t_omega : Set := - | O_BAD_CONSTANT : idx -> t_omega - | O_NOT_EXACT_DIVIDE : idx -> int -> t_omega - - | O_DIVIDE : idx -> int -> t_omega -> t_omega - | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega - | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega - | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega. - -(** ** Actual resolution steps of an omega normalized goal *) - -(** First, the final steps, leading to a contradiction *) - -(** [O_BAD_CONSTANT] *) - -Definition bad_constant (i : nat) (h : hyps) := - match nth_hyps i h with - | EqTerm (Tint Nul) (Tint n) => if n =? Nul then h else absurd - | NeqTerm (Tint Nul) (Tint n) => if n =? Nul then absurd else h - | LeqTerm (Tint Nul) (Tint n) => if n <? Nul then absurd else h - | _ => h - end. - -Theorem bad_constant_valid i : valid_hyps (bad_constant i). -Proof. - unfold valid_hyps, bad_constant; intros ep e lp H. - generalize (nth_valid ep e i lp H); Simplify. - rewrite le_lt_iff. intuition. -Qed. - -(** [O_NOT_EXACT_DIVIDE] *) - -Definition not_exact_divide (i : nat) (k : int) (l : hyps) := - match nth_hyps i l with - | EqTerm (Tint Nul) b => - match scalar_div b k with - | Some (body,c) => - if (Nul =? 0) && (0 <? c) && (c <? k) then absurd - else l - | None => l - end - | _ => l - end. - -Theorem not_exact_divide_valid i k : - valid_hyps (not_exact_divide i k). -Proof. - unfold valid_hyps, not_exact_divide; intros. - generalize (nth_valid ep e i lp). - destruct (nth_hyps i lp); simpl; auto. - destruct t0; auto. - destruct (scalar_div t1 k) as [(body,c)|] eqn:E; auto. - Simplify. - assert (k <> 0). - { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } - apply (scalar_div_stable e) in E; auto. simpl in E. - intros H'; rewrite <- H' in E; auto. - exfalso. revert E. now apply OMEGA4. -Qed. - -(** Now, the steps generating a new equation. *) - -(** [O_DIVIDE] *) - -Definition divide (k : int) (prop : proposition) := - match prop with - | EqTerm (Tint o) b => - match scalar_div b k with - | Some (body,c) => - if (o =? 0) && (c =? 0) && negb (k =? 0) - then EqTerm (Tint 0) body - else TrueTerm - | None => TrueTerm - end - | NeqTerm (Tint o) b => - match scalar_div b k with - | Some (body,c) => - if (o =? 0) && (c =? 0) && negb (k =? 0) - then NeqTerm (Tint 0) body - else TrueTerm - | None => TrueTerm - end - | LeqTerm (Tint o) b => - match scalar_div b k with - | Some (body,c) => - if (o =? 0) && (0 <? k) && (c <? k) - then LeqTerm (Tint 0) body - else prop - | None => prop - end - | _ => TrueTerm - end. - -Theorem divide_valid k : valid1 (divide k). -Proof. - unfold valid1, divide; intros ep e p; - destruct p; simpl; auto; - destruct t0; simpl; auto; - destruct scalar_div as [(body,c)|] eqn:E; simpl; Simplify; auto. - - apply (scalar_div_stable e) in E; auto. simpl in E. - intros H'; rewrite <- H' in E. rewrite plus_0_r in E. - apply mult_integral in E. intuition. - - apply (scalar_div_stable e) in E; auto. simpl in E. - intros H' H''. now rewrite <- H'', mult_0_l, plus_0_l in E. - - assert (k <> 0). - { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } - apply (scalar_div_stable e) in E; auto. simpl in E. rewrite <- E. - intro H'. now apply mult_le_approx with (3 := H'). -Qed. - -(** [O_SUM]. Invariant: [k1] and [k2] non-nul. *) - -Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint o) b1 => - match prop2 with - | EqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) - then EqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | LeqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && (0 <? k2) - then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | NeqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && negb (k2 =? 0) - then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - | LeqTerm (Tint o) b1 => - if (o =? 0) && (0 <? k1) - then match prop2 with - | EqTerm (Tint o') b2 => - if o' =? 0 then - LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | LeqTerm (Tint o') b2 => - if (o' =? 0) && (0 <? k2) - then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - else TrueTerm - | NeqTerm (Tint o) b1 => - match prop2 with - | EqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && negb (k1 =? 0) - then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem sum_valid : - forall (k1 k2 : int), valid2 (sum k1 k2). -Proof. - unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; - Simplify; simpl; rewrite ?fusion_stable; - simpl; intros; auto. - - apply sum1; auto. - - rewrite plus_comm. apply sum5; auto. - - apply sum2; auto using lt_le_weak. - - apply sum5; auto. - - rewrite plus_comm. apply sum2; auto using lt_le_weak. - - apply sum3; auto using lt_le_weak. -Qed. - -(** [MERGE_EQ] *) - -Definition merge_eq (prop1 prop2 : proposition) := - match prop1 with - | LeqTerm (Tint o) b1 => - match prop2 with - | LeqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && - (b1 =? scalar_mult b2 (-(1)))%term - then EqTerm (Tint 0) b1 - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem merge_eq_valid : valid2 merge_eq. -Proof. - unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. - rewrite scalar_mult_stable. simpl. - intros; symmetry ; apply OMEGA8 with (2 := H0). - - assumption. - - elim opp_eq_mult_neg_1; trivial. -Qed. - -(** [O_SPLIT_INEQ] (only step to produce two subgoals). *) - -Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := - match nth_hyps i l with - | NeqTerm (Tint o) b1 => - if o =? 0 then - f1 (LeqTerm (Tint 0) (scalar_add b1 (-(1))) :: l) ++ - f2 (LeqTerm (Tint 0) (scalar_mult_add b1 (-(1)) (-(1))) :: l) - else l :: nil - | _ => l :: nil - end. - -Theorem split_ineq_valid : - forall (i : nat) (f1 f2 : hyps -> lhyps), - valid_list_hyps f1 -> - valid_list_hyps f2 -> valid_list_hyps (split_ineq i f1 f2). -Proof. - unfold valid_list_hyps, split_ineq; intros i f1 f2 H1 H2 ep e lp H; - generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); - simpl; auto; intros t1 t2; case t1; simpl; - auto; intros z; simpl; auto; intro H3. - Simplify. - apply append_valid; elim (OMEGA19 (interp_term e t2)). - - intro H4; left; apply H1; simpl; rewrite scalar_add_stable; - simpl; auto. - - intro H4; right; apply H2; simpl; rewrite scalar_mult_add_stable; - simpl; auto. - - generalize H3; unfold not; intros E1 E2; apply E1; - symmetry ; trivial. -Qed. - -(** ** Replaying the resolution trace *) - -Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := - match t with - | O_BAD_CONSTANT i => singleton (bad_constant i l) - | O_NOT_EXACT_DIVIDE i k => singleton (not_exact_divide i k l) - | O_DIVIDE i k cont => - execute_omega cont (apply_oper_1 i (divide k) l) - | O_SUM k1 i1 k2 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l) - | O_MERGE_EQ i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 merge_eq l) - | O_SPLIT_INEQ i cont1 cont2 => - split_ineq i (execute_omega cont1) (execute_omega cont2) l - end. - -Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). -Proof. - simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. - - intros; left; now apply bad_constant_valid. - - intros; left; now apply not_exact_divide_valid. - - intros m k t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (divide k) - (divide_valid k) ep e lp H). - - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e - lp H). - - intros i1 i2 t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_2_valid i1 i2 merge_eq merge_eq_valid ep e - lp H). - - intros i k1 H1 k2 H2 ep e lp H; - apply - (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e - lp H). -Qed. - - -(** ** Rules for decomposing the hypothesis - - This type allows navigation in the logical constructors that - form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a conjunction. - NB: negations are now silently traversed. *) - -Inductive direction : Set := - | D_left : direction - | D_right : direction. - -(** This type allows extracting useful components from hypothesis, either - hypothesis generated by splitting a disjonction, or equations. - The last constructor indicates how to solve the obtained system - via the use of the trace type of Omega [t_omega] *) - -Inductive e_step : Set := - | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step - | E_EXTRACT : nat -> list direction -> e_step -> e_step - | E_SOLVE : t_omega -> e_step. - -(** Selection of a basic fact inside an hypothesis. *) - -Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : - proposition := - match p, s with - | Tand x y, D_left :: l => extract_hyp_pos l x - | Tand x y, D_right :: l => extract_hyp_pos l y - | Tnot x, _ => extract_hyp_neg s x - | _, _ => p - end - - with extract_hyp_neg (s : list direction) (p : proposition) : - proposition := - match p, s with - | Tor x y, D_left :: l => extract_hyp_neg l x - | Tor x y, D_right :: l => extract_hyp_neg l y - | Timp x y, D_left :: l => - if decidability x then extract_hyp_pos l x else Tnot p - | Timp x y, D_right :: l => extract_hyp_neg l y - | Tnot x, _ => if decidability x then extract_hyp_pos s x else Tnot p - | _, _ => Tnot p - end. - -Theorem extract_valid : - forall s : list direction, valid1 (extract_hyp_pos s). -Proof. - assert (forall p s ep e, - (interp_prop ep e p -> - interp_prop ep e (extract_hyp_pos s p)) /\ - (interp_prop ep e (Tnot p) -> - interp_prop ep e (extract_hyp_neg s p))). - { induction p; destruct s; simpl; auto; split; try destruct d; try easy; - intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto; - destruct decidability eqn:D; auto; - apply (decidable_correct ep e) in D; unfold decidable in D; - (apply IHp || apply IHp1); tauto. } - red. intros. now apply H. -Qed. - -(** Attempt to shorten error messages if romega goes rogue... - NB: [interp_list_goal _ _ BUG = False /\ True]. *) -Definition BUG : lhyps := nil :: nil. - -(** Split and extract in hypotheses *) - -Fixpoint decompose_solve (s : e_step) (h : hyps) : lhyps := - match s with - | E_SPLIT i dl s1 s2 => - match extract_hyp_pos dl (nth_hyps i h) with - | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) - | Tnot (Tand x y) => - if decidability x - then - decompose_solve s1 (Tnot x :: h) ++ - decompose_solve s2 (Tnot y :: h) - else BUG - | Timp x y => - if decidability x then - decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) - else BUG - | _ => BUG - end - | E_EXTRACT i dl s1 => - decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) - | E_SOLVE t => execute_omega t h - end. - -Theorem decompose_solve_valid (s : e_step) : - valid_list_goal (decompose_solve s). -Proof. - apply goal_valid. red. induction s; simpl; intros ep e lp H. - - assert (H' : interp_prop ep e (extract_hyp_pos l (nth_hyps n lp))). - { now apply extract_valid, nth_valid. } - destruct extract_hyp_pos; simpl in *; auto. - + destruct p; simpl; auto. - destruct decidability eqn:D; [ | simpl; auto]. - apply (decidable_correct ep e) in D. - apply append_valid. simpl in *. destruct D. - * right. apply IHs2. simpl; auto. - * left. apply IHs1. simpl; auto. - + apply append_valid. destruct H'. - * left. apply IHs1. simpl; auto. - * right. apply IHs2. simpl; auto. - + destruct decidability eqn:D; [ | simpl; auto]. - apply (decidable_correct ep e) in D. - apply append_valid. destruct D. - * right. apply IHs2. simpl; auto. - * left. apply IHs1. simpl; auto. - - apply IHs; simpl; split; auto. - now apply extract_valid, nth_valid. - - now apply omega_valid. -Qed. - -(** Reduction of subgoal list by discarding the contradictory subgoals. *) - -Definition valid_lhyps (f : lhyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : lhyps), - interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). - -Fixpoint reduce_lhyps (lp : lhyps) : lhyps := - match lp with - | nil => nil - | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' - | x :: lp' => BUG - end. - -Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. -Proof. - unfold valid_lhyps; intros ep e lp; elim lp. - - simpl; auto. - - intros a l HR; elim a. - + simpl; tauto. - + intros a1 l1; case l1; case a1; simpl; tauto. -Qed. - -Theorem do_reduce_lhyps : - forall (envp : list Prop) (env : list int) (l : lhyps), - interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. -Proof. - intros envp env l H; apply list_goal_to_hyps; intro H1; - apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; - assumption. -Qed. - -(** Pushing the conclusion into the hypotheses. *) - -Definition concl_to_hyp (p : proposition) := - if decidability p then Tnot p else TrueTerm. - -Definition do_concl_to_hyp : - forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), - interp_goal envp env (concl_to_hyp c :: l) -> - interp_goal_concl c envp env l. -Proof. - induction l; simpl. - - unfold concl_to_hyp; simpl. - destruct decidability eqn:D; [ | simpl; tauto ]. - apply (decidable_correct envp env) in D. unfold decidable in D. - simpl. tauto. - - simpl in *; tauto. -Qed. - -(** The omega tactic : all steps together *) - -Definition omega_tactic (t1 : e_step) (c : proposition) (l : hyps) := - reduce_lhyps (decompose_solve t1 (normalize_hyps (concl_to_hyp c :: l))). - -Theorem do_omega : - forall (t : e_step) (envp : list Prop) - (env : list int) (c : proposition) (l : hyps), - interp_list_goal envp env (omega_tactic t c l) -> - interp_goal_concl c envp env l. -Proof. - unfold omega_tactic; intros t ep e c l H. - apply do_concl_to_hyp. - apply normalize_hyps_goal. - apply (decompose_solve_valid t). - now apply do_reduce_lhyps. -Qed. - -End IntOmega. - -(** For now, the above modular construction is instanciated on Z, - in order to retrieve the initial ROmega. *) - -Module ZOmega := IntOmega(Z_as_Int). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml deleted file mode 100644 index 949cba2dbe..0000000000 --- a/plugins/romega/const_omega.ml +++ /dev/null @@ -1,332 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -open Names - -let module_refl_name = "ReflOmegaCore" -let module_refl_path = ["Coq"; "romega"; module_refl_name] - -type result = - | Kvar of string - | Kapp of string * EConstr.t list - | Kimp of EConstr.t * EConstr.t - | Kufo - -let meaningful_submodule = [ "Z"; "N"; "Pos" ] - -let string_of_global r = - let dp = Nametab.dirpath_of_global r in - let prefix = match Names.DirPath.repr dp with - | [] -> "" - | m::_ -> - let s = Names.Id.to_string m in - if Util.String.List.mem s meaningful_submodule then s^"." else "" - in - prefix^(Names.Id.to_string (Nametab.basename_of_global r)) - -let destructurate sigma t = - let c, args = EConstr.decompose_app sigma t in - let open Constr in - match EConstr.kind sigma c, args with - | Const (sp,_), args -> - Kapp (string_of_global (Globnames.ConstRef sp), args) - | Construct (csp,_) , args -> - Kapp (string_of_global (Globnames.ConstructRef csp), args) - | Ind (isp,_), args -> - Kapp (string_of_global (Globnames.IndRef isp), args) - | Var id, [] -> Kvar(Names.Id.to_string id) - | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) - | _ -> Kufo - -exception DestConstApp - -let dest_const_apply sigma t = - let open Constr in - let f,args = EConstr.decompose_app sigma t in - let ref = - match EConstr.kind sigma f with - | Const (sp,_) -> Globnames.ConstRef sp - | Construct (csp,_) -> Globnames.ConstructRef csp - | Ind (isp,_) -> Globnames.IndRef isp - | _ -> raise DestConstApp - in Nametab.basename_of_global ref, args - -let logic_dir = ["Coq";"Logic";"Decidable"] - -let coq_modules = - Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules - @ [["Coq"; "Lists"; "List"]] - @ [module_refl_path] - @ [module_refl_path@["ZOmega"]] - -let bin_module = [["Coq";"Numbers";"BinNums"]] -let z_module = [["Coq";"ZArith";"BinInt"]] - -let init_constant x = - EConstr.of_constr @@ - UnivGen.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x -let constant x = - EConstr.of_constr @@ - UnivGen.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" coq_modules x -let z_constant x = - EConstr.of_constr @@ - UnivGen.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" z_module x -let bin_constant x = - EConstr.of_constr @@ - UnivGen.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" bin_module x - -(* Logic *) -let coq_refl_equal = lazy(init_constant "eq_refl") -let coq_and = lazy(init_constant "and") -let coq_not = lazy(init_constant "not") -let coq_or = lazy(init_constant "or") -let coq_True = lazy(init_constant "True") -let coq_False = lazy(init_constant "False") -let coq_I = lazy(init_constant "I") - -(* ReflOmegaCore/ZOmega *) - -let coq_t_int = lazy (constant "Tint") -let coq_t_plus = lazy (constant "Tplus") -let coq_t_mult = lazy (constant "Tmult") -let coq_t_opp = lazy (constant "Topp") -let coq_t_minus = lazy (constant "Tminus") -let coq_t_var = lazy (constant "Tvar") - -let coq_proposition = lazy (constant "proposition") -let coq_p_eq = lazy (constant "EqTerm") -let coq_p_leq = lazy (constant "LeqTerm") -let coq_p_geq = lazy (constant "GeqTerm") -let coq_p_lt = lazy (constant "LtTerm") -let coq_p_gt = lazy (constant "GtTerm") -let coq_p_neq = lazy (constant "NeqTerm") -let coq_p_true = lazy (constant "TrueTerm") -let coq_p_false = lazy (constant "FalseTerm") -let coq_p_not = lazy (constant "Tnot") -let coq_p_or = lazy (constant "Tor") -let coq_p_and = lazy (constant "Tand") -let coq_p_imp = lazy (constant "Timp") -let coq_p_prop = lazy (constant "Tprop") - -let coq_s_bad_constant = lazy (constant "O_BAD_CONSTANT") -let coq_s_divide = lazy (constant "O_DIVIDE") -let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") -let coq_s_sum = lazy (constant "O_SUM") -let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") -let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") - -(* construction for the [extract_hyp] tactic *) -let coq_direction = lazy (constant "direction") -let coq_d_left = lazy (constant "D_left") -let coq_d_right = lazy (constant "D_right") - -let coq_e_split = lazy (constant "E_SPLIT") -let coq_e_extract = lazy (constant "E_EXTRACT") -let coq_e_solve = lazy (constant "E_SOLVE") - -let coq_interp_sequent = lazy (constant "interp_goal_concl") -let coq_do_omega = lazy (constant "do_omega") - -(* Nat *) - -let coq_S = lazy(init_constant "S") -let coq_O = lazy(init_constant "O") - -let rec mk_nat = function - | 0 -> Lazy.force coq_O - | n -> EConstr.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) - -(* Lists *) - -let mkListConst c = - let r = - Coqlib.coq_reference "" ["Init";"Datatypes"] c - in - let inst = - if Global.is_polymorphic r then - fun u -> EConstr.EInstance.make (Univ.Instance.of_array [|u|]) - else - fun _ -> EConstr.EInstance.empty - in - fun u -> EConstr.mkConstructU (Globnames.destConstructRef r, inst u) - -let coq_cons univ typ = EConstr.mkApp (mkListConst "cons" univ, [|typ|]) -let coq_nil univ typ = EConstr.mkApp (mkListConst "nil" univ, [|typ|]) - -let mk_list univ typ l = - let rec loop = function - | [] -> coq_nil univ typ - | (step :: l) -> - EConstr.mkApp (coq_cons univ typ, [| step; loop l |]) in - loop l - -let mk_plist = - let type1lev = UnivGen.new_univ_level () in - fun l -> mk_list type1lev EConstr.mkProp l - -let mk_list = mk_list Univ.Level.set - -type parse_term = - | Tplus of EConstr.t * EConstr.t - | Tmult of EConstr.t * EConstr.t - | Tminus of EConstr.t * EConstr.t - | Topp of EConstr.t - | Tsucc of EConstr.t - | Tnum of Bigint.bigint - | Tother - -type parse_rel = - | Req of EConstr.t * EConstr.t - | Rne of EConstr.t * EConstr.t - | Rlt of EConstr.t * EConstr.t - | Rle of EConstr.t * EConstr.t - | Rgt of EConstr.t * EConstr.t - | Rge of EConstr.t * EConstr.t - | Rtrue - | Rfalse - | Rnot of EConstr.t - | Ror of EConstr.t * EConstr.t - | Rand of EConstr.t * EConstr.t - | Rimp of EConstr.t * EConstr.t - | Riff of EConstr.t * EConstr.t - | Rother - -let parse_logic_rel sigma c = match destructurate sigma c with - | Kapp("True",[]) -> Rtrue - | Kapp("False",[]) -> Rfalse - | Kapp("not",[t]) -> Rnot t - | Kapp("or",[t1;t2]) -> Ror (t1,t2) - | Kapp("and",[t1;t2]) -> Rand (t1,t2) - | Kimp(t1,t2) -> Rimp (t1,t2) - | Kapp("iff",[t1;t2]) -> Riff (t1,t2) - | _ -> Rother - -(* Binary numbers *) - -let coq_Z = lazy (bin_constant "Z") -let coq_xH = lazy (bin_constant "xH") -let coq_xO = lazy (bin_constant "xO") -let coq_xI = lazy (bin_constant "xI") -let coq_Z0 = lazy (bin_constant "Z0") -let coq_Zpos = lazy (bin_constant "Zpos") -let coq_Zneg = lazy (bin_constant "Zneg") -let coq_N0 = lazy (bin_constant "N0") -let coq_Npos = lazy (bin_constant "Npos") - -let rec mk_positive n = - if Bigint.equal n Bigint.one then Lazy.force coq_xH - else - let (q,r) = Bigint.euclid n Bigint.two in - EConstr.mkApp - ((if Bigint.equal r Bigint.zero - then Lazy.force coq_xO else Lazy.force coq_xI), - [| mk_positive q |]) - -let mk_N = function - | 0 -> Lazy.force coq_N0 - | n -> EConstr.mkApp (Lazy.force coq_Npos, - [| mk_positive (Bigint.of_int n) |]) - -module type Int = sig - val typ : EConstr.t Lazy.t - val is_int_typ : Proofview.Goal.t -> EConstr.t -> bool - val plus : EConstr.t Lazy.t - val mult : EConstr.t Lazy.t - val opp : EConstr.t Lazy.t - val minus : EConstr.t Lazy.t - - val mk : Bigint.bigint -> EConstr.t - val parse_term : Evd.evar_map -> EConstr.t -> parse_term - val parse_rel : Proofview.Goal.t -> EConstr.t -> parse_rel - (* check whether t is built only with numbers and + * - *) - val get_scalar : Evd.evar_map -> EConstr.t -> Bigint.bigint option -end - -module Z : Int = struct - -let typ = coq_Z -let plus = lazy (z_constant "Z.add") -let mult = lazy (z_constant "Z.mul") -let opp = lazy (z_constant "Z.opp") -let minus = lazy (z_constant "Z.sub") - -let recognize_pos sigma t = - let rec loop t = - let f,l = dest_const_apply sigma t in - match Id.to_string f,l with - | "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) - | "xO",[t] -> Bigint.mult Bigint.two (loop t) - | "xH",[] -> Bigint.one - | _ -> raise DestConstApp - in - try Some (loop t) with DestConstApp -> None - -let recognize_Z sigma t = - try - let f,l = dest_const_apply sigma t in - match Id.to_string f,l with - | "Zpos",[t] -> recognize_pos sigma t - | "Zneg",[t] -> Option.map Bigint.neg (recognize_pos sigma t) - | "Z0",[] -> Some Bigint.zero - | _ -> None - with DestConstApp -> None - -let mk_Z n = - if Bigint.equal n Bigint.zero then Lazy.force coq_Z0 - else if Bigint.is_strictly_pos n then - EConstr.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) - else - EConstr.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) - -let mk = mk_Z - -let parse_term sigma t = - match destructurate sigma t with - | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) - | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) - | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) - | Kapp("Z.opp",[t]) -> Topp t - | Kapp("Z.succ",[t]) -> Tsucc t - | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (match recognize_Z sigma t with Some t -> Tnum t | None -> Tother) - | _ -> Tother - -let is_int_typ gl t = - Tacmach.New.pf_apply Reductionops.is_conv gl t (Lazy.force coq_Z) - -let parse_rel gl t = - let sigma = Proofview.Goal.sigma gl in - match destructurate sigma t with - | Kapp("eq",[typ;t1;t2]) when is_int_typ gl typ -> Req (t1,t2) - | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) - | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) - | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) - | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) - | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) - | _ -> parse_logic_rel sigma t - -let rec get_scalar sigma t = - match destructurate sigma t with - | Kapp("Z.add", [t1;t2]) -> - Option.lift2 Bigint.add (get_scalar sigma t1) (get_scalar sigma t2) - | Kapp ("Z.sub",[t1;t2]) -> - Option.lift2 Bigint.sub (get_scalar sigma t1) (get_scalar sigma t2) - | Kapp ("Z.mul",[t1;t2]) -> - Option.lift2 Bigint.mult (get_scalar sigma t1) (get_scalar sigma t2) - | Kapp("Z.opp", [t]) -> Option.map Bigint.neg (get_scalar sigma t) - | Kapp("Z.succ", [t]) -> Option.map Bigint.add_1 (get_scalar sigma t) - | Kapp("Z.pred", [t]) -> Option.map Bigint.sub_1 (get_scalar sigma t) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> recognize_Z sigma t - | _ -> None - -end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli deleted file mode 100644 index 64668df007..0000000000 --- a/plugins/romega/const_omega.mli +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - - -(** Coq objects used in romega *) - -(* from Logic *) -val coq_refl_equal : EConstr.t lazy_t -val coq_and : EConstr.t lazy_t -val coq_not : EConstr.t lazy_t -val coq_or : EConstr.t lazy_t -val coq_True : EConstr.t lazy_t -val coq_False : EConstr.t lazy_t -val coq_I : EConstr.t lazy_t - -(* from ReflOmegaCore/ZOmega *) - -val coq_t_int : EConstr.t lazy_t -val coq_t_plus : EConstr.t lazy_t -val coq_t_mult : EConstr.t lazy_t -val coq_t_opp : EConstr.t lazy_t -val coq_t_minus : EConstr.t lazy_t -val coq_t_var : EConstr.t lazy_t - -val coq_proposition : EConstr.t lazy_t -val coq_p_eq : EConstr.t lazy_t -val coq_p_leq : EConstr.t lazy_t -val coq_p_geq : EConstr.t lazy_t -val coq_p_lt : EConstr.t lazy_t -val coq_p_gt : EConstr.t lazy_t -val coq_p_neq : EConstr.t lazy_t -val coq_p_true : EConstr.t lazy_t -val coq_p_false : EConstr.t lazy_t -val coq_p_not : EConstr.t lazy_t -val coq_p_or : EConstr.t lazy_t -val coq_p_and : EConstr.t lazy_t -val coq_p_imp : EConstr.t lazy_t -val coq_p_prop : EConstr.t lazy_t - -val coq_s_bad_constant : EConstr.t lazy_t -val coq_s_divide : EConstr.t lazy_t -val coq_s_not_exact_divide : EConstr.t lazy_t -val coq_s_sum : EConstr.t lazy_t -val coq_s_merge_eq : EConstr.t lazy_t -val coq_s_split_ineq : EConstr.t lazy_t - -val coq_direction : EConstr.t lazy_t -val coq_d_left : EConstr.t lazy_t -val coq_d_right : EConstr.t lazy_t - -val coq_e_split : EConstr.t lazy_t -val coq_e_extract : EConstr.t lazy_t -val coq_e_solve : EConstr.t lazy_t - -val coq_interp_sequent : EConstr.t lazy_t -val coq_do_omega : EConstr.t lazy_t - -val mk_nat : int -> EConstr.t -val mk_N : int -> EConstr.t - -(** Precondition: the type of the list is in Set *) -val mk_list : EConstr.t -> EConstr.t list -> EConstr.t -val mk_plist : EConstr.types list -> EConstr.types - -(** Analyzing a coq term *) - -(* The generic result shape of the analysis of a term. - One-level depth, except when a number is found *) -type parse_term = - Tplus of EConstr.t * EConstr.t - | Tmult of EConstr.t * EConstr.t - | Tminus of EConstr.t * EConstr.t - | Topp of EConstr.t - | Tsucc of EConstr.t - | Tnum of Bigint.bigint - | Tother - -(* The generic result shape of the analysis of a relation. - One-level depth. *) -type parse_rel = - Req of EConstr.t * EConstr.t - | Rne of EConstr.t * EConstr.t - | Rlt of EConstr.t * EConstr.t - | Rle of EConstr.t * EConstr.t - | Rgt of EConstr.t * EConstr.t - | Rge of EConstr.t * EConstr.t - | Rtrue - | Rfalse - | Rnot of EConstr.t - | Ror of EConstr.t * EConstr.t - | Rand of EConstr.t * EConstr.t - | Rimp of EConstr.t * EConstr.t - | Riff of EConstr.t * EConstr.t - | Rother - -(* A module factorizing what we should now about the number representation *) -module type Int = - sig - (* the coq type of the numbers *) - val typ : EConstr.t Lazy.t - (* Is a constr expands to the type of these numbers *) - val is_int_typ : Proofview.Goal.t -> EConstr.t -> bool - (* the operations on the numbers *) - val plus : EConstr.t Lazy.t - val mult : EConstr.t Lazy.t - val opp : EConstr.t Lazy.t - val minus : EConstr.t Lazy.t - (* building a coq number *) - val mk : Bigint.bigint -> EConstr.t - (* parsing a term (one level, except if a number is found) *) - val parse_term : Evd.evar_map -> EConstr.t -> parse_term - (* parsing a relation expression, including = < <= >= > *) - val parse_rel : Proofview.Goal.t -> EConstr.t -> parse_rel - (* Is a particular term only made of numbers and + * - ? *) - val get_scalar : Evd.evar_map -> EConstr.t -> Bigint.bigint option - end - -(* Currently, we only use Z numbers *) -module Z : Int diff --git a/plugins/romega/g_romega.mlg b/plugins/romega/g_romega.mlg deleted file mode 100644 index ac4f30b1db..0000000000 --- a/plugins/romega/g_romega.mlg +++ /dev/null @@ -1,63 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - - -DECLARE PLUGIN "romega_plugin" - -{ - -open Ltac_plugin -open Names -open Refl_omega -open Stdarg - -let eval_tactic name = - let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in - let tac = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic tac - -let romega_tactic unsafe l = - let tacs = List.map - (function - | "nat" -> eval_tactic "zify_nat" - | "positive" -> eval_tactic "zify_positive" - | "N" -> eval_tactic "zify_N" - | "Z" -> eval_tactic "zify_op" - | s -> CErrors.user_err Pp.(str ("No ROmega knowledge base for type "^s))) - (Util.List.sort_uniquize String.compare l) - in - Tacticals.New.tclTHEN - (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs))) - (Tacticals.New.tclTHEN - (* because of the contradiction process in (r)omega, - we'd better leave as little as possible in the conclusion, - for an easier decidability argument. *) - (Tactics.intros) - (total_reflexive_omega_tactic unsafe)) - -let romega_depr = - Vernacinterp.mk_deprecation - ~since:(Some "8.9") - ~note:(Some "Use lia instead.") - () - -} - -TACTIC EXTEND romega -DEPRECATED { romega_depr } -| [ "romega" ] -> { romega_tactic false [] } -| [ "unsafe_romega" ] -> { romega_tactic true [] } -END - -TACTIC EXTEND romega' -DEPRECATED { romega_depr } -| [ "romega" "with" ne_ident_list(l) ] -> - { romega_tactic false (List.map Names.Id.to_string l) } -| [ "romega" "with" "*" ] -> { romega_tactic false ["nat";"positive";"N";"Z"] } -END diff --git a/plugins/romega/plugin_base.dune b/plugins/romega/plugin_base.dune deleted file mode 100644 index 49b0e10edf..0000000000 --- a/plugins/romega/plugin_base.dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name romega_plugin) - (public_name coq.plugins.romega) - (synopsis "Coq's romega plugin") - (libraries coq.plugins.omega)) diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml deleted file mode 100644 index e603480656..0000000000 --- a/plugins/romega/refl_omega.ml +++ /dev/null @@ -1,1071 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -open Pp -open Util -open Constr -open Const_omega -module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) -open OmegaSolver - -module Id = Names.Id -module IntSet = Int.Set -module IntHtbl = Hashtbl.Make(Int) - -(* \section{Useful functions and flags} *) -(* Especially useful debugging functions *) -let debug = ref false - -let show_goal = Tacticals.New.tclIDTAC - -let pp i = print_int i; print_newline (); flush stdout - -(* More readable than the prefix notation *) -let (>>) = Tacticals.New.tclTHEN - -(* \section{Types} - \subsection{How to walk in a term} - To represent how to get to a proposition. Only choice points are - kept (branch to choose in a disjunction and identifier of the disjunctive - connector) *) -type direction = Left of int | Right of int - -(* Step to find a proposition (operators are at most binary). A list is - a path *) -type occ_step = O_left | O_right | O_mono -type occ_path = occ_step list - -(* chemin identifiant une proposition sous forme du nom de l'hypothèse et - d'une liste de pas à partir de la racine de l'hypothèse *) -type occurrence = {o_hyp : Id.t; o_path : occ_path} - -type atom_index = int - -(* \subsection{reifiable formulas} *) -type oformula = - (* integer *) - | Oint of Bigint.bigint - (* recognized binary and unary operations *) - | Oplus of oformula * oformula - | Omult of oformula * oformula (* Invariant : one side is [Oint] *) - | Ominus of oformula * oformula - | Oopp of oformula - (* an atom in the environment *) - | Oatom of atom_index - -(* Operators for comparison recognized by Omega *) -type comparaison = Eq | Leq | Geq | Gt | Lt | Neq - -(* Representation of reified predicats (fragment of propositional calculus, - no quantifier here). *) -(* Note : in [Pprop p], the non-reified constr [p] should be closed - (it could contains some [Term.Var] but no [Term.Rel]). So no need to - lift when breaking or creating arrows. *) -type oproposition = - Pequa of EConstr.t * oequation (* constr = copy of the Coq formula *) - | Ptrue - | Pfalse - | Pnot of oproposition - | Por of int * oproposition * oproposition - | Pand of int * oproposition * oproposition - | Pimp of int * oproposition * oproposition - | Pprop of EConstr.t - -(* The equations *) -and oequation = { - e_comp: comparaison; (* comparaison *) - e_left: oformula; (* formule brute gauche *) - e_right: oformula; (* formule brute droite *) - e_origin: occurrence; (* l'hypothèse dont vient le terme *) - e_negated: bool; (* vrai si apparait en position nié - après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont - dépend l'accès à l'équation avec la - direction (branche) pour y accéder *) - e_omega: OmegaSolver.afine (* normalized formula *) - } - -(* \subsection{Proof context} - This environment codes - \begin{itemize} - \item the terms and propositions that are given as - parameters of the reified proof (and are represented as variables in the - reified goals) - \item translation functions linking the decision procedure and the Coq proof - \end{itemize} *) - -type environment = { - (* La liste des termes non reifies constituant l'environnement global *) - mutable terms : EConstr.t list; - (* La meme chose pour les propositions *) - mutable props : EConstr.t list; - (* Traduction des indices utilisés ici en les indices finaux utilisés par - * la tactique Omega après dénombrement des variables utiles *) - real_indices : int IntHtbl.t; - mutable cnt_connectors : int; - equations : oequation IntHtbl.t; - constructors : occurrence IntHtbl.t -} - -(* \subsection{Solution tree} - Définition d'une solution trouvée par Omega sous la forme d'un identifiant, - d'un ensemble d'équation dont dépend la solution et d'une trace *) - -type solution = { - s_index : int; - s_equa_deps : IntSet.t; - s_trace : OmegaSolver.action list } - -(* Arbre de solution résolvant complètement un ensemble de systèmes *) -type solution_tree = - Leaf of solution - (* un noeud interne représente un point de branchement correspondant à - l'élimination d'un connecteur générant plusieurs buts - (typ. disjonction). Le premier argument - est l'identifiant du connecteur *) - | Tree of int * solution_tree * solution_tree - -(* Représentation de l'environnement extrait du but initial sous forme de - chemins pour extraire des equations ou d'hypothèses *) - -type context_content = - CCHyp of occurrence - | CCEqua of int - -(** Some dedicated equality tests *) - -let occ_step_eq s1 s2 = match s1, s2 with -| O_left, O_left | O_right, O_right | O_mono, O_mono -> true -| _ -> false - -let rec oform_eq f f' = match f,f' with - | Oint i, Oint i' -> Bigint.equal i i' - | Oplus (f1,f2), Oplus (f1',f2') - | Omult (f1,f2), Omult (f1',f2') - | Ominus (f1,f2), Ominus (f1',f2') -> oform_eq f1 f1' && oform_eq f2 f2' - | Oopp f, Oopp f' -> oform_eq f f' - | Oatom a, Oatom a' -> Int.equal a a' - | _ -> false - -let dir_eq d d' = match d, d' with - | Left i, Left i' | Right i, Right i' -> Int.equal i i' - | _ -> false - -(* \section{Specific utility functions to handle base types} *) -(* Nom arbitraire de l'hypothèse codant la négation du but final *) -let id_concl = Id.of_string "__goal__" - -(* Initialisation de l'environnement de réification de la tactique *) -let new_environment () = { - terms = []; props = []; cnt_connectors = 0; - real_indices = IntHtbl.create 7; - equations = IntHtbl.create 7; - constructors = IntHtbl.create 7; -} - -(* Génération d'un nom d'équation *) -let new_connector_id env = - env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors - -(* Calcul de la branche complémentaire *) -let barre = function Left x -> Right x | Right x -> Left x - -(* Identifiant associé à une branche *) -let indice = function Left x | Right x -> x - -(* Affichage de l'environnement de réification (termes et propositions) *) -let print_env_reification env = - let rec loop c i = function - [] -> str " ===============================\n\n" - | t :: l -> - let sigma, env = Pfedit.get_current_context () in - let s = Printf.sprintf "(%c%02d)" c i in - spc () ++ str s ++ str " := " ++ Printer.pr_econstr_env env sigma t ++ fnl () ++ - loop c (succ i) l - in - let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in - let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in - Feedback.msg_debug (prop_info ++ fnl () ++ term_info) - -(* \subsection{Gestion des environnements de variable pour Omega} *) -(* generation d'identifiant d'equation pour Omega *) - -let new_omega_eq, rst_omega_eq = - let cpt = ref (-1) in - (function () -> incr cpt; !cpt), - (function () -> cpt:=(-1)) - -(* generation d'identifiant de variable pour Omega *) - -let new_omega_var, rst_omega_var, set_omega_maxvar = - let cpt = ref (-1) in - (function () -> incr cpt; !cpt), - (function () -> cpt:=(-1)), - (function n -> cpt:=n) - -(* Affichage des variables d'un système *) - -let display_omega_var i = Printf.sprintf "OV%d" i - -(* \subsection{Gestion des environnements de variable pour la réflexion} - Gestion des environnements de traduction entre termes des constructions - non réifiés et variables des termes reifies. Attention il s'agit de - l'environnement initial contenant tout. Il faudra le réduire après - calcul des variables utiles. *) - -let add_reified_atom sigma t env = - try List.index0 (EConstr.eq_constr sigma) t env.terms - with Not_found -> - let i = List.length env.terms in - env.terms <- env.terms @ [t]; i - -let get_reified_atom env = - try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom" - -(** When the omega resolution has created a variable [v], we re-sync - the environment with this new variable. To be done in the right order. *) - -let set_reified_atom v t env = - assert (Int.equal v (List.length env.terms)); - env.terms <- env.terms @ [t] - -(* \subsection{Gestion de l'environnement de proposition pour Omega} *) -(* ajout d'une proposition *) -let add_prop sigma env t = - try List.index0 (EConstr.eq_constr sigma) t env.props - with Not_found -> - let i = List.length env.props in env.props <- env.props @ [t]; i - -(* accès a une proposition *) -let get_prop v env = - try List.nth v env with Invalid_argument _ -> failwith "get_prop" - -(* \subsection{Gestion du nommage des équations} *) -(* Ajout d'une equation dans l'environnement de reification *) -let add_equation env e = - let id = e.e_omega.id in - if IntHtbl.mem env.equations id then () else IntHtbl.add env.equations id e - -(* accès a une equation *) -let get_equation env id = - try IntHtbl.find env.equations id - with Not_found as e -> - Printf.printf "Omega Equation %d non trouvée\n" id; raise e - -(* Affichage des termes réifiés *) -let rec oprint ch = function - | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) - | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 - | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 - | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 - | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 - | Oatom n -> Printf.fprintf ch "V%02d" n - -let print_comp = function - | Eq -> "=" | Leq -> "<=" | Geq -> ">=" - | Gt -> ">" | Lt -> "<" | Neq -> "!=" - -let rec pprint ch = function - Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - Printf.fprintf ch "%a %s %a" oprint t1 (print_comp comp) oprint t2 - | Ptrue -> Printf.fprintf ch "TT" - | Pfalse -> Printf.fprintf ch "FF" - | Pnot t -> Printf.fprintf ch "not(%a)" pprint t - | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 - | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 - | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 - | Pprop c -> Printf.fprintf ch "Prop" - -(* \subsection{Omega vers Oformula} *) - -let oformula_of_omega af = - let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Omult(Oatom v,Oint n),loop r) - | [] -> Oint af.constant - in - loop af.body - -let app f v = EConstr.mkApp(Lazy.force f,v) - -(* \subsection{Oformula vers COQ reel} *) - -let coq_of_formula env t = - let rec loop = function - | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] - | Oopp t -> app Z.opp [| loop t |] - | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] - | Oint v -> Z.mk v - | Oatom var -> - (* attention ne traite pas les nouvelles variables si on ne les - * met pas dans env.term *) - get_reified_atom env var - | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in - loop t - -(* \subsection{Oformula vers COQ reifié} *) - -let reified_of_atom env i = - try IntHtbl.find env.real_indices i - with Not_found -> - Printf.printf "Atome %d non trouvé\n" i; - IntHtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; - raise Not_found - -let reified_binop = function - | Oplus _ -> app coq_t_plus - | Ominus _ -> app coq_t_minus - | Omult _ -> app coq_t_mult - | _ -> assert false - -let rec reified_of_formula env t = match t with - | Oplus (t1,t2) | Omult (t1,t2) | Ominus (t1,t2) -> - reified_binop t [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oopp t -> app coq_t_opp [| reified_of_formula env t |] - | Oint v -> app coq_t_int [| Z.mk v |] - | Oatom i -> app coq_t_var [| mk_N (reified_of_atom env i) |] - -let reified_of_formula env f = - try reified_of_formula env f - with reraise -> oprint stderr f; raise reraise - -let reified_cmp = function - | Eq -> app coq_p_eq - | Leq -> app coq_p_leq - | Geq -> app coq_p_geq - | Gt -> app coq_p_gt - | Lt -> app coq_p_lt - | Neq -> app coq_p_neq - -let reified_conn = function - | Por _ -> app coq_p_or - | Pand _ -> app coq_p_and - | Pimp _ -> app coq_p_imp - | _ -> assert false - -let rec reified_of_oprop sigma env t = match t with - | Pequa (_,{ e_comp=cmp; e_left=t1; e_right=t2 }) -> - reified_cmp cmp [| reified_of_formula env t1; reified_of_formula env t2 |] - | Ptrue -> Lazy.force coq_p_true - | Pfalse -> Lazy.force coq_p_false - | Pnot t -> app coq_p_not [| reified_of_oprop sigma env t |] - | Por (_,t1,t2) | Pand (_,t1,t2) | Pimp (_,t1,t2) -> - reified_conn t - [| reified_of_oprop sigma env t1; reified_of_oprop sigma env t2 |] - | Pprop t -> app coq_p_prop [| mk_nat (add_prop sigma env t) |] - -let reified_of_proposition sigma env f = - try reified_of_oprop sigma env f - with reraise -> pprint stderr f; raise reraise - -let reified_of_eq env (l,r) = - app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |] - -(* \section{Opérations sur les équations} -Ces fonctions préparent les traces utilisées par la tactique réfléchie -pour faire des opérations de normalisation sur les équations. *) - -(* \subsection{Extractions des variables d'une équation} *) -(* Extraction des variables d'une équation. *) -(* Chaque fonction retourne une liste triée sans redondance *) - -let (@@) = IntSet.union - -let rec vars_of_formula = function - | Oint _ -> IntSet.empty - | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Oopp e -> vars_of_formula e - | Oatom i -> IntSet.singleton i - -let rec vars_of_equations = function - | [] -> IntSet.empty - | e::l -> - (vars_of_formula e.e_left) @@ - (vars_of_formula e.e_right) @@ - (vars_of_equations l) - -let rec vars_of_prop = function - | Pequa(_,e) -> vars_of_equations [e] - | Pnot p -> vars_of_prop p - | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pprop _ | Ptrue | Pfalse -> IntSet.empty - -(* Normalized formulas : - - - sorted list of monomials, largest index first, - with non-null coefficients - - a constant coefficient - - /!\ Keep in sync with the corresponding functions in ReflOmegaCore ! -*) - -type nformula = - { coefs : (atom_index * Bigint.bigint) list; - cst : Bigint.bigint } - -let scale n { coefs; cst } = - { coefs = List.map (fun (v,k) -> (v,k*n)) coefs; - cst = cst*n } - -let shuffle nf1 nf2 = - let rec merge l1 l2 = match l1,l2 with - | [],_ -> l2 - | _,[] -> l1 - | (v1,k1)::r1,(v2,k2)::r2 -> - if Int.equal v1 v2 then - let k = k1+k2 in - if Bigint.equal k Bigint.zero then merge r1 r2 - else (v1,k) :: merge r1 r2 - else if v1 > v2 then (v1,k1) :: merge r1 l2 - else (v2,k2) :: merge l1 r2 - in - { coefs = merge nf1.coefs nf2.coefs; - cst = nf1.cst + nf2.cst } - -let rec normalize = function - | Oplus(t1,t2) -> shuffle (normalize t1) (normalize t2) - | Ominus(t1,t2) -> normalize (Oplus (t1, Oopp(t2))) - | Oopp(t) -> scale negone (normalize t) - | Omult(t,Oint n) | Omult (Oint n, t) -> - if Bigint.equal n Bigint.zero then { coefs = []; cst = zero } - else scale n (normalize t) - | Omult _ -> assert false (* invariant on Omult *) - | Oint n -> { coefs = []; cst = n } - | Oatom v -> { coefs = [v,Bigint.one]; cst=Bigint.zero} - -(* From normalized formulas to omega representations *) - -let omega_of_nformula env kind nf = - { id = new_omega_eq (); - kind; - constant=nf.cst; - body = List.map (fun (v,c) -> { v; c }) nf.coefs } - - -let negate_oper = function - Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq - -let normalize_equation env (negated,depends,origin,path) oper t1 t2 = - let mk_step t kind = - let equa = omega_of_nformula env kind (normalize t) in - { e_comp = oper; e_left = t1; e_right = t2; - e_negated = negated; e_depends = depends; - e_origin = { o_hyp = origin; o_path = List.rev path }; - e_omega = equa } - in - try match (if negated then (negate_oper oper) else oper) with - | Eq -> mk_step (Oplus (t1,Oopp t2)) EQUA - | Neq -> mk_step (Oplus (t1,Oopp t2)) DISE - | Leq -> mk_step (Oplus (t2,Oopp t1)) INEQ - | Geq -> mk_step (Oplus (t1,Oopp t2)) INEQ - | Lt -> mk_step (Oplus (Oplus(t2,Oint negone),Oopp t1)) INEQ - | Gt -> mk_step (Oplus (Oplus(t1,Oint negone),Oopp t2)) INEQ - with e when Logic.catchable_exception e -> raise e - -(* \section{Compilation des hypothèses} *) - -let mkPor i x y = Por (i,x,y) -let mkPand i x y = Pand (i,x,y) -let mkPimp i x y = Pimp (i,x,y) - -let rec oformula_of_constr sigma env t = - match Z.parse_term sigma t with - | Tplus (t1,t2) -> binop sigma env (fun x y -> Oplus(x,y)) t1 t2 - | Tminus (t1,t2) -> binop sigma env (fun x y -> Ominus(x,y)) t1 t2 - | Tmult (t1,t2) -> - (match Z.get_scalar sigma t1 with - | Some n -> Omult (Oint n,oformula_of_constr sigma env t2) - | None -> - match Z.get_scalar sigma t2 with - | Some n -> Omult (oformula_of_constr sigma env t1, Oint n) - | None -> Oatom (add_reified_atom sigma t env)) - | Topp t -> Oopp(oformula_of_constr sigma env t) - | Tsucc t -> Oplus(oformula_of_constr sigma env t, Oint one) - | Tnum n -> Oint n - | Tother -> Oatom (add_reified_atom sigma t env) - -and binop sigma env c t1 t2 = - let t1' = oformula_of_constr sigma env t1 in - let t2' = oformula_of_constr sigma env t2 in - c t1' t2' - -and binprop sigma env (neg2,depends,origin,path) - add_to_depends neg1 gl c t1 t2 = - let i = new_connector_id env in - let depends1 = if add_to_depends then Left i::depends else depends in - let depends2 = if add_to_depends then Right i::depends else depends in - if add_to_depends then - IntHtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; - let t1' = - oproposition_of_constr sigma env (neg1,depends1,origin,O_left::path) gl t1 in - let t2' = - oproposition_of_constr sigma env (neg2,depends2,origin,O_right::path) gl t2 in - (* On numérote le connecteur dans l'environnement. *) - c i t1' t2' - -and mk_equation sigma env ctxt c connector t1 t2 = - let t1' = oformula_of_constr sigma env t1 in - let t2' = oformula_of_constr sigma env t2 in - (* On ajoute l'equation dans l'environnement. *) - let omega = normalize_equation env ctxt connector t1' t2' in - add_equation env omega; - Pequa (c,omega) - -and oproposition_of_constr sigma env ((negated,depends,origin,path) as ctxt) gl c = - match Z.parse_rel gl c with - | Req (t1,t2) -> mk_equation sigma env ctxt c Eq t1 t2 - | Rne (t1,t2) -> mk_equation sigma env ctxt c Neq t1 t2 - | Rle (t1,t2) -> mk_equation sigma env ctxt c Leq t1 t2 - | Rlt (t1,t2) -> mk_equation sigma env ctxt c Lt t1 t2 - | Rge (t1,t2) -> mk_equation sigma env ctxt c Geq t1 t2 - | Rgt (t1,t2) -> mk_equation sigma env ctxt c Gt t1 t2 - | Rtrue -> Ptrue - | Rfalse -> Pfalse - | Rnot t -> - let ctxt' = (not negated, depends, origin,(O_mono::path)) in - Pnot (oproposition_of_constr sigma env ctxt' gl t) - | Ror (t1,t2) -> binprop sigma env ctxt (not negated) negated gl mkPor t1 t2 - | Rand (t1,t2) -> binprop sigma env ctxt negated negated gl mkPand t1 t2 - | Rimp (t1,t2) -> - binprop sigma env ctxt (not negated) (not negated) gl mkPimp t1 t2 - | Riff (t1,t2) -> - (* No lifting here, since Omega only works on closed propositions. *) - binprop sigma env ctxt negated negated gl mkPand - (EConstr.mkArrow t1 t2) (EConstr.mkArrow t2 t1) - | _ -> Pprop c - -(* Destructuration des hypothèses et de la conclusion *) - -let display_gl env t_concl t_lhyps = - Printf.printf "REIFED PROBLEM\n\n"; - Printf.printf " CONCL: %a\n" pprint t_concl; - List.iter - (fun (i,_,t) -> Printf.printf " %s: %a\n" (Id.to_string i) pprint t) - t_lhyps; - print_env_reification env - -type defined = Defined | Assumed - -let reify_hyp sigma env gl i = - let open Context.Named.Declaration in - let ctxt = (false,[],i,[]) in - match Tacmach.New.pf_get_hyp i gl with - | LocalDef (_,d,t) when Z.is_int_typ gl t -> - let dummy = Lazy.force coq_True in - let p = mk_equation sigma env ctxt dummy Eq (EConstr.mkVar i) d in - i,Defined,p - | LocalDef (_,_,t) | LocalAssum (_,t) -> - let p = oproposition_of_constr sigma env ctxt gl t in - i,Assumed,p - -let reify_gl env gl = - let sigma = Proofview.Goal.sigma gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_ids_of_hyps gl in - let ctxt_concl = (true,[],id_concl,[O_mono]) in - let t_concl = oproposition_of_constr sigma env ctxt_concl gl concl in - let t_lhyps = List.map (reify_hyp sigma env gl) hyps in - let () = if !debug then display_gl env t_concl t_lhyps in - t_concl, t_lhyps - -let rec destruct_pos_hyp eqns = function - | Pequa (_,e) -> [e :: eqns] - | Ptrue | Pfalse | Pprop _ -> [eqns] - | Pnot t -> destruct_neg_hyp eqns t - | Por (_,t1,t2) -> - let s1 = destruct_pos_hyp eqns t1 in - let s2 = destruct_pos_hyp eqns t2 in - s1 @ s2 - | Pand(_,t1,t2) -> - List.map_append - (fun le1 -> destruct_pos_hyp le1 t2) - (destruct_pos_hyp eqns t1) - | Pimp(_,t1,t2) -> - let s1 = destruct_neg_hyp eqns t1 in - let s2 = destruct_pos_hyp eqns t2 in - s1 @ s2 - -and destruct_neg_hyp eqns = function - | Pequa (_,e) -> [e :: eqns] - | Ptrue | Pfalse | Pprop _ -> [eqns] - | Pnot t -> destruct_pos_hyp eqns t - | Pand (_,t1,t2) -> - let s1 = destruct_neg_hyp eqns t1 in - let s2 = destruct_neg_hyp eqns t2 in - s1 @ s2 - | Por(_,t1,t2) -> - List.map_append - (fun le1 -> destruct_neg_hyp le1 t2) - (destruct_neg_hyp eqns t1) - | Pimp(_,t1,t2) -> - List.map_append - (fun le1 -> destruct_neg_hyp le1 t2) - (destruct_pos_hyp eqns t1) - -let rec destructurate_hyps = function - | [] -> [[]] - | (i,_,t) :: l -> - let l_syst1 = destruct_pos_hyp [] t in - let l_syst2 = destructurate_hyps l in - List.cartesian (@) l_syst1 l_syst2 - -(* \subsection{Affichage d'un système d'équation} *) - -(* Affichage des dépendances de système *) -let display_depend = function - Left i -> Printf.printf " L%d" i - | Right i -> Printf.printf " R%d" i - -let display_systems syst_list = - let display_omega om_e = - Printf.printf " E%d : %a %s 0\n" - om_e.id - (fun _ -> display_eq display_omega_var) - (om_e.body, om_e.constant) - (operator_of_eq om_e.kind) in - - let display_equation oformula_eq = - pprint stdout (Pequa (Lazy.force coq_I,oformula_eq)); print_newline (); - display_omega oformula_eq.e_omega; - Printf.printf " Depends on:"; - List.iter display_depend oformula_eq.e_depends; - Printf.printf "\n Path: %s" - (String.concat "" - (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") - oformula_eq.e_origin.o_path)); - Printf.printf "\n Origin: %s (negated : %s)\n\n" - (Id.to_string oformula_eq.e_origin.o_hyp) - (if oformula_eq.e_negated then "yes" else "no") in - - let display_system syst = - Printf.printf "=SYSTEM===================================\n"; - List.iter display_equation syst in - List.iter display_system syst_list - -(* Extraction des prédicats utilisées dans une trace. Permet ensuite le - calcul des hypothèses *) - -let rec hyps_used_in_trace = function - | [] -> IntSet.empty - | act :: l -> - match act with - | HYP e -> IntSet.add e.id (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - hyps_used_in_trace act1 @@ hyps_used_in_trace act2 - | _ -> hyps_used_in_trace l - -(** Retreive variables declared as extra equations during resolution - and declare them into the environment. - We should consider these variables in their introduction order, - otherwise really bad things will happen. *) - -let state_cmp x y = Int.compare x.st_var y.st_var - -module StateSet = - Set.Make (struct type t = state_action let compare = state_cmp end) - -let rec stated_in_trace = function - | [] -> StateSet.empty - | [SPLIT_INEQ (_,(_,t1),(_,t2))] -> - StateSet.union (stated_in_trace t1) (stated_in_trace t2) - | STATE action :: l -> StateSet.add action (stated_in_trace l) - | _ :: l -> stated_in_trace l - -let rec stated_in_tree = function - | Tree(_,t1,t2) -> StateSet.union (stated_in_tree t1) (stated_in_tree t2) - | Leaf s -> stated_in_trace s.s_trace - -let mk_refl t = app coq_refl_equal [|Lazy.force Z.typ; t|] - -let digest_stated_equations env tree = - let do_equation st (vars,gens,eqns,ids) = - (** We turn the definition of [v] - - into a reified formula : *) - let v_def = oformula_of_omega st.st_def in - (** - into a concrete Coq formula - (this uses only older vars already in env) : *) - let coq_v = coq_of_formula env v_def in - (** We then update the environment *) - set_reified_atom st.st_var coq_v env; - (** The term we'll introduce *) - let term_to_generalize = mk_refl coq_v in - (** Its representation as equation (but not reified yet, - we lack the proper env to do that). *) - let term_to_reify = (v_def,Oatom st.st_var) in - (st.st_var::vars, - term_to_generalize::gens, - term_to_reify::eqns, - CCEqua st.st_def.id :: ids) - in - let (vars,gens,eqns,ids) = - StateSet.fold do_equation (stated_in_tree tree) ([],[],[],[]) - in - (List.rev vars, List.rev gens, List.rev eqns, List.rev ids) - -(* Calcule la liste des éclatements à réaliser sur les hypothèses - nécessaires pour extraire une liste d'équations donnée *) - -(* PL: experimentally, the result order of the following function seems - _very_ crucial for efficiency. No idea why. Do not remove the List.rev - or modify the current semantics of Util.List.union (some elements of first - arg, then second arg), unless you know what you're doing. *) - -let rec get_eclatement env = function - | [] -> [] - | i :: r -> - let l = try (get_equation env i).e_depends with Not_found -> [] in - List.union dir_eq (List.rev l) (get_eclatement env r) - -let select_smaller l = - let comp (_,x) (_,y) = Int.compare (List.length x) (List.length y) in - try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" - -let filter_compatible_systems required systems = - let rec select = function - | [] -> [] - | (x::l) -> - if List.mem_f dir_eq x required then select l - else if List.mem_f dir_eq (barre x) required then raise Exit - else x :: select l - in - List.map_filter - (function (sol, splits) -> - try Some (sol, select splits) with Exit -> None) - systems - -let rec equas_of_solution_tree = function - | Tree(_,t1,t2) -> - (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) - | Leaf s -> s.s_equa_deps - -(** [maximize_prop] pushes useless props in a new Pprop atom. - The reified formulas get shorter, but be careful with decidabilities. - For instance, anything that contains a Pprop is considered to be - undecidable in [ReflOmegaCore], whereas a Pfalse for instance at - the same spot will lead to a decidable formula. - In particular, do not use this function on the conclusion. - Even in hypotheses, we could probably build pathological examples - that romega won't handle correctly, but they should be pretty rare. -*) - -let maximize_prop equas c = - let rec loop c = match c with - | Pequa(t,e) -> if IntSet.mem e.e_omega.id equas then c else Pprop t - | Pnot t -> - (match loop t with - | Pprop p -> Pprop (app coq_not [|p|]) - | t' -> Pnot t') - | Por(i,t1,t2) -> - (match loop t1, loop t2 with - | Pprop p1, Pprop p2 -> Pprop (app coq_or [|p1;p2|]) - | t1', t2' -> Por(i,t1',t2')) - | Pand(i,t1,t2) -> - (match loop t1, loop t2 with - | Pprop p1, Pprop p2 -> Pprop (app coq_and [|p1;p2|]) - | t1', t2' -> Pand(i,t1',t2')) - | Pimp(i,t1,t2) -> - (match loop t1, loop t2 with - | Pprop p1, Pprop p2 -> Pprop (EConstr.mkArrow p1 p2) (* no lift (closed) *) - | t1', t2' -> Pimp(i,t1',t2')) - | Ptrue -> Pprop (app coq_True [||]) - | Pfalse -> Pprop (app coq_False [||]) - | Pprop _ -> c - in loop c - -let rec display_solution_tree ch = function - Leaf t -> - output_string ch - (Printf.sprintf "%d[%s]" - t.s_index - (String.concat " " (List.map string_of_int - (IntSet.elements t.s_equa_deps)))) - | Tree(i,t1,t2) -> - Printf.fprintf ch "S%d(%a,%a)" i - display_solution_tree t1 display_solution_tree t2 - -let rec solve_with_constraints all_solutions path = - let rec build_tree sol buf = function - [] -> Leaf sol - | (Left i :: remainder) -> - Tree(i, - build_tree sol (Left i :: buf) remainder, - solve_with_constraints all_solutions (List.rev(Right i :: buf))) - | (Right i :: remainder) -> - Tree(i, - solve_with_constraints all_solutions (List.rev (Left i :: buf)), - build_tree sol (Right i :: buf) remainder) in - let weighted = filter_compatible_systems path all_solutions in - let (winner_sol,winner_deps) = - try select_smaller weighted - with reraise -> - Printf.printf "%d - %d\n" - (List.length weighted) (List.length all_solutions); - List.iter display_depend path; raise reraise - in - build_tree winner_sol (List.rev path) winner_deps - -let find_path {o_hyp=id;o_path=p} env = - let rec loop_path = function - ([],l) -> Some l - | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2) - | _ -> None in - let rec loop_id i = function - CCHyp{o_hyp=id';o_path=p'} :: l when Id.equal id id' -> - begin match loop_path (p',p) with - Some r -> i,r - | None -> loop_id (succ i) l - end - | _ :: l -> loop_id (succ i) l - | [] -> failwith "find_path" in - loop_id 0 env - -let mk_direction_list l = - let trans = function - | O_left -> Some (Lazy.force coq_d_left) - | O_right -> Some (Lazy.force coq_d_right) - | O_mono -> None (* No more [D_mono] constructor now *) - in - mk_list (Lazy.force coq_direction) (List.map_filter trans l) - - -(* \section{Rejouer l'historique} *) - -let hyp_idx env_hyp i = - let rec loop count = function - | [] -> failwith (Printf.sprintf "get_hyp %d" i) - | CCEqua i' :: _ when Int.equal i i' -> mk_nat count - | _ :: l -> loop (succ count) l - in loop 0 env_hyp - - -(* We now expand NEGATE_CONTRADICT and CONTRADICTION into - a O_SUM followed by a O_BAD_CONSTANT *) - -let sum_bad inv i1 i2 = - let open EConstr in - mkApp (Lazy.force coq_s_sum, - [| Z.mk Bigint.one; i1; - Z.mk (if inv then negone else Bigint.one); i2; - mkApp (Lazy.force coq_s_bad_constant, [| mk_nat 0 |])|]) - -let rec reify_trace env env_hyp = - let open EConstr in - function - | CONSTANT_NOT_NUL(e,_) :: [] - | CONSTANT_NEG(e,_) :: [] - | CONSTANT_NUL e :: [] -> - mkApp (Lazy.force coq_s_bad_constant,[| hyp_idx env_hyp e |]) - | NEGATE_CONTRADICT(e1,e2,direct) :: [] -> - sum_bad direct (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) - | CONTRADICTION (e1,e2) :: [] -> - sum_bad false (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) - | NOT_EXACT_DIVIDE (e1,k) :: [] -> - mkApp (Lazy.force coq_s_not_exact_divide, - [| hyp_idx env_hyp e1.id; Z.mk k |]) - | DIVIDE_AND_APPROX (e1,_,k,_) :: l - | EXACT_DIVIDE (e1,k) :: l -> - mkApp (Lazy.force coq_s_divide, - [| hyp_idx env_hyp e1.id; Z.mk k; - reify_trace env env_hyp l |]) - | MERGE_EQ(e3,e1,e2) :: l -> - mkApp (Lazy.force coq_s_merge_eq, - [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2; - reify_trace env (CCEqua e3:: env_hyp) l |]) - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - mkApp (Lazy.force coq_s_sum, - [| Z.mk k1; hyp_idx env_hyp e1.id; - Z.mk k2; hyp_idx env_hyp e2.id; - reify_trace env (CCEqua e3 :: env_hyp) l |]) - | STATE {st_new_eq; st_def; st_orig; st_coef } :: l -> - (* we now produce a [O_SUM] here *) - mkApp (Lazy.force coq_s_sum, - [| Z.mk Bigint.one; hyp_idx env_hyp st_orig.id; - Z.mk st_coef; hyp_idx env_hyp st_def.id; - reify_trace env (CCEqua st_new_eq.id :: env_hyp) l |]) - | HYP _ :: l -> reify_trace env env_hyp l - | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: _ -> - let r1 = reify_trace env (CCEqua e1 :: env_hyp) l1 in - let r2 = reify_trace env (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, - [| hyp_idx env_hyp e.id; r1 ; r2 |]) - | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> reify_trace env env_hyp l - | WEAKEN _ :: l -> failwith "not_treated" - | _ -> failwith "bad history" - -let rec decompose_tree env ctxt = function - Tree(i,left,right) -> - let org = - try IntHtbl.find env.constructors i - with Not_found -> - failwith (Printf.sprintf "Cannot find constructor %d" i) in - let (index,path) = find_path org ctxt in - let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in - let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in - app coq_e_split - [| mk_nat index; - mk_direction_list path; - decompose_tree env (left_hyp::ctxt) left; - decompose_tree env (right_hyp::ctxt) right |] - | Leaf s -> - decompose_tree_hyps s.s_trace env ctxt (IntSet.elements s.s_equa_deps) -and decompose_tree_hyps trace env ctxt = function - [] -> app coq_e_solve [| reify_trace env ctxt trace |] - | (i::l) -> - let equation = - try IntHtbl.find env.equations i - with Not_found -> - failwith (Printf.sprintf "Cannot find equation %d" i) in - let (index,path) = find_path equation.e_origin ctxt in - let cont = - decompose_tree_hyps trace env - (CCEqua equation.e_omega.id :: ctxt) l in - app coq_e_extract [|mk_nat index; mk_direction_list path; cont |] - -let solve_system env index list_eq = - let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - OmegaSolver.simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system - in - (* Hypotheses used for this solution *) - let vars = hyps_used_in_trace trace in - let splits = get_eclatement env (IntSet.elements vars) in - if !debug then - begin - Printf.printf "SYSTEME %d\n" index; - display_action display_omega_var trace; - print_string "\n Depend :"; - IntSet.iter (fun i -> Printf.printf " %d" i) vars; - print_string "\n Split points :"; - List.iter display_depend splits; - Printf.printf "\n------------------------------------\n" - end; - {s_index = index; s_trace = trace; s_equa_deps = vars}, splits - -(* \section{La fonction principale} *) - (* Cette fonction construit la -trace pour la procédure de décision réflexive. A partir des résultats -de l'extraction des systèmes, elle lance la résolution par Omega, puis -l'extraction d'un ensemble minimal de solutions permettant la -résolution globale du système et enfin construit la trace qui permet -de faire rejouer cette solution par la tactique réflexive. *) - -let resolution unsafe sigma env (reified_concl,reified_hyps) systems_list = - if !debug then Printf.printf "\n====================================\n"; - let all_solutions = List.mapi (solve_system env) systems_list in - let solution_tree = solve_with_constraints all_solutions [] in - if !debug then begin - display_solution_tree stdout solution_tree; - print_newline() - end; - (** Collect all hypotheses and variables used in the solution tree *) - let useful_equa_ids = equas_of_solution_tree solution_tree in - let useful_hypnames, useful_vars = - IntSet.fold - (fun i (hyps,vars) -> - let e = get_equation env i in - Id.Set.add e.e_origin.o_hyp hyps, - vars_of_equations [e] @@ vars) - useful_equa_ids - (Id.Set.empty, vars_of_prop reified_concl) - in - let useful_hypnames = - Id.Set.elements (Id.Set.remove id_concl useful_hypnames) - in - - (** Parts coming from equations introduced by omega: *) - let stated_vars, l_generalize_arg, to_reify_stated, hyp_stated_vars = - digest_stated_equations env solution_tree - in - (** The final variables are either coming from: - - useful hypotheses (and conclusion) - - equations introduced during resolution *) - let all_vars_env = (IntSet.elements useful_vars) @ stated_vars - in - (** We prepare the renumbering from all variables to useful ones. - Since [all_var_env] is sorted, this renumbering will preserve - order: this way, the equations in ReflOmegaCore will have - the same normal forms as here. *) - let reduced_term_env = - let rec loop i = function - | [] -> [] - | var :: l -> - let t = get_reified_atom env var in - IntHtbl.add env.real_indices var i; t :: loop (succ i) l - in - mk_list (Lazy.force Z.typ) (loop 0 all_vars_env) - in - (** The environment [env] (and especially [env.real_indices]) is now - ready for the coming reifications: *) - let l_reified_stated = List.map (reified_of_eq env) to_reify_stated in - let reified_concl = reified_of_proposition sigma env reified_concl in - let l_reified_terms = - List.map - (fun id -> - match Id.Map.find id reified_hyps with - | Defined,p -> - reified_of_proposition sigma env p, mk_refl (EConstr.mkVar id) - | Assumed,p -> - reified_of_proposition sigma env (maximize_prop useful_equa_ids p), - EConstr.mkVar id - | exception Not_found -> assert false) - useful_hypnames - in - let l_reified_terms, l_reified_hypnames = List.split l_reified_terms in - let env_props_reified = mk_plist env.props in - let reified_goal = - mk_list (Lazy.force coq_proposition) - (l_reified_stated @ l_reified_terms) in - let reified = - app coq_interp_sequent - [| reified_concl;env_props_reified;reduced_term_env;reified_goal|] - in - let mk_occ id = {o_hyp=id;o_path=[]} in - let initial_context = - List.map (fun id -> CCHyp (mk_occ id)) useful_hypnames in - let context = - CCHyp (mk_occ id_concl) :: hyp_stated_vars @ initial_context in - let decompose_tactic = decompose_tree env context solution_tree in - - Tactics.generalize (l_generalize_arg @ l_reified_hypnames) >> - Tactics.convert_concl_no_check reified DEFAULTcast >> - Tactics.apply (app coq_do_omega [|decompose_tactic|]) >> - show_goal >> - (if unsafe then - (* Trust the produced term. Faster, but might fail later at Qed. - Also handy when debugging, e.g. via a Show Proof after romega. *) - Tactics.convert_concl_no_check (Lazy.force coq_True) VMcast - else - Tactics.normalise_vm_in_concl) >> - Tactics.apply (Lazy.force coq_I) - -let total_reflexive_omega_tactic unsafe = - Proofview.Goal.nf_enter begin fun gl -> - Coqlib.check_required_library ["Coq";"romega";"ROmega"]; - rst_omega_eq (); - rst_omega_var (); - try - let env = new_environment () in - let (concl,hyps) = reify_gl env gl in - (* Register all atom indexes created during reification as omega vars *) - set_omega_maxvar (pred (List.length env.terms)); - let full_reified_goal = (id_concl,Assumed,Pnot concl) :: hyps in - let systems_list = destructurate_hyps full_reified_goal in - let hyps = - List.fold_left (fun s (id,d,p) -> Id.Map.add id (d,p) s) Id.Map.empty hyps - in - if !debug then display_systems systems_list; - let sigma = Proofview.Goal.sigma gl in - resolution unsafe sigma env (concl,hyps) systems_list - with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system") - end - diff --git a/plugins/romega/romega_plugin.mlpack b/plugins/romega/romega_plugin.mlpack deleted file mode 100644 index 38d0e94111..0000000000 --- a/plugins/romega/romega_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Const_omega -Refl_omega -G_romega diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 1f3c758e5c..f2f236f448 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1088,7 +1088,7 @@ let () = CLexer.set_keyword_state frozen_lexer ;; (** Basic tactics *) -let rec fst_prod red tac = Proofview.Goal.nf_enter begin fun gl -> +let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in match EConstr.kind (Proofview.Goal.sigma gl) concl with | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 8b9c94f2db..e4a0910673 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -342,7 +342,7 @@ let interp_index ist gl idx = open Pltac -ARGUMENT EXTEND ssrindex TYPED AS ssrindex PRINTED BY pr_ssrindex +ARGUMENT EXTEND ssrindex PRINTED BY pr_ssrindex INTERPRETED BY interp_index | [ int_or_var(i) ] -> [ mk_index ~loc i ] END @@ -1949,7 +1949,7 @@ ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg END let vmexacttac pf = - Goal.nf_enter begin fun gl -> + Goal.enter begin fun gl -> exact_no_check (EConstr.mkCast (pf, _vmcast, Tacmach.New.pf_concl gl)) end diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 20ea8b3667..aadb4fe5f6 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -1366,7 +1366,7 @@ let ssrpatterntac _ist arg gl = let concl0 = pf_concl gl in let concl0 = EConstr.Unsafe.to_constr concl0 in let (t, uc), concl_x = - fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in + fill_occ_pattern (pf_env gl) sigma0 concl0 pat noindex 1 in let t = EConstr.of_constr t in let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 5e36fbeb81..53153198f9 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -94,7 +94,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = sc; - pt_uid = sc; + pt_interp_info = Uid sc; pt_required = (ascii_path,ascii_module); pt_refs = [static_glob_Ascii]; pt_in_match = true } diff --git a/plugins/syntax/g_numeral.ml4 b/plugins/syntax/g_numeral.ml4 index ec14df3baa..55f61a58f9 100644 --- a/plugins/syntax/g_numeral.ml4 +++ b/plugins/syntax/g_numeral.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "numeral_notation_plugin" +open Notation open Numeral open Pp open Names diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index d3ffe936a9..e34a401c2c 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -108,7 +108,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = int31_scope; - pt_uid = int31_scope; + pt_interp_info = Uid int31_scope; pt_required = (int31_path,int31_module); pt_refs = [int31_construct]; pt_in_match = true } diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index fee93593d0..10a0af0b8f 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -15,351 +15,18 @@ open Libnames open Globnames open Constrexpr open Constrexpr_ops -open Constr +open Notation (** * Numeral notation *) -(** Reduction - - The constr [c] below isn't necessarily well-typed, since we - built it via an [mkApp] of a conversion function on a term - that starts with the right constructor but might be partially - applied. - - At least [c] is known to be evar-free, since it comes from - our own ad-hoc [constr_of_glob] or from conversions such - as [coqint_of_rawnum]. -*) - -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let sigma,t = Typing.type_of env sigma c in - let c' = Vnorm.cbv_vm env sigma c t in - EConstr.Unsafe.to_constr c' - -(* For testing with "compute" instead of "vm_compute" : -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let c' = Tacred.compute env sigma c in - EConstr.Unsafe.to_constr c' -*) - -let eval_constr_app env sigma c1 c2 = - eval_constr env sigma (mkApp (c1,[| c2 |])) - -exception NotANumber - -let warn_large_num = - CWarnings.create ~name:"large-number" ~category:"numbers" - (fun ty -> - strbrk "Stack overflow or segmentation fault happens when " ++ - strbrk "working with large numbers in " ++ pr_qualid ty ++ - strbrk " (threshold may vary depending" ++ - strbrk " on your system limits and on the command executed).") - -let warn_abstract_large_num = - CWarnings.create ~name:"abstract-large-number" ~category:"numbers" - (fun (ty,f) -> - strbrk "To avoid stack overflow, large numbers in " ++ - pr_qualid ty ++ strbrk " are interpreted as applications of " ++ - Printer.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") - let warn_abstract_large_num_no_op = CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" (fun f -> strbrk "The 'abstract after' directive has no effect when " ++ strbrk "the parsing function (" ++ - Printer.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ strbrk "option type.") -(** Comparing two raw numbers (base 10, big-endian, non-negative). - A bit nasty, but not critical: only used to decide when a - number is considered as large (see warnings above). *) - -exception Comp of int - -let rec rawnum_compare s s' = - let l = String.length s and l' = String.length s' in - if l < l' then - rawnum_compare s' s - else - let d = l-l' in - try - for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; - for i = d to l-1 do - let c = Pervasives.compare s.[i] s'.[i-d] in - if c != 0 then raise (Comp c) - done; - 0 - with Comp c -> c - -(***********************************************************************) - -(** ** Conversion between Coq [Decimal.int] and internal raw string *) - -type int_ty = - { uint : Names.inductive; - int : Names.inductive } - -(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) - -let digit_of_char c = - assert ('0' <= c && c <= '9'); - Char.code c - Char.code '0' + 2 - -let char_of_digit n = - assert (2<=n && n<=11); - Char.chr (n-2 + Char.code '0') - -let coquint_of_rawnum uint str = - let nil = mkConstruct (uint,1) in - let rec do_chars s i acc = - if i < 0 then acc - else - let dg = mkConstruct (uint, digit_of_char s.[i]) in - do_chars s (i-1) (mkApp(dg,[|acc|])) - in - do_chars str (String.length str - 1) nil - -let coqint_of_rawnum inds (str,sign) = - let uint = coquint_of_rawnum inds.uint str in - mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) - -let rawnum_of_coquint c = - let rec of_uint_loop c buf = - match Constr.kind c with - | Construct ((_,1), _) (* Nil *) -> () - | App (c, [|a|]) -> - (match Constr.kind c with - | Construct ((_,n), _) (* D0 to D9 *) -> - let () = Buffer.add_char buf (char_of_digit n) in - of_uint_loop a buf - | _ -> raise NotANumber) - | _ -> raise NotANumber - in - let buf = Buffer.create 64 in - let () = of_uint_loop c buf in - if Int.equal (Buffer.length buf) 0 then - (* To avoid ambiguities between Nil and (D0 Nil), we choose - to not display Nil alone as "0" *) - raise NotANumber - else Buffer.contents buf - -let rawnum_of_coqint c = - match Constr.kind c with - | App (c,[|c'|]) -> - (match Constr.kind c with - | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) - | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) - | _ -> raise NotANumber) - | _ -> raise NotANumber - - -(***********************************************************************) - -(** ** Conversion between Coq [Z] and internal bigint *) - -type z_pos_ty = - { z_ty : Names.inductive; - pos_ty : Names.inductive } - -(** First, [positive] from/to bigint *) - -let rec pos_of_bigint posty n = - match Bigint.div2_with_rest n with - | (q, false) -> - let c = mkConstruct (posty, 2) in (* xO *) - mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) when not (Bigint.equal q Bigint.zero) -> - let c = mkConstruct (posty, 1) in (* xI *) - mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) -> - mkConstruct (posty, 3) (* xH *) - -let rec bigint_of_pos c = match Constr.kind c with - | Construct ((_, 3), _) -> (* xH *) Bigint.one - | App (c, [| d |]) -> - begin match Constr.kind c with - | Construct ((_, n), _) -> - begin match n with - | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) - | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) - | n -> assert false (* no other constructor of type positive *) - end - | x -> raise NotANumber - end - | x -> raise NotANumber - -(** Now, [Z] from/to bigint *) - -let z_of_bigint { z_ty; pos_ty } n = - if Bigint.equal n Bigint.zero then - mkConstruct (z_ty, 1) (* Z0 *) - else - let (s, n) = - if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) - else (3, Bigint.neg n) (* Zneg *) - in - let c = mkConstruct (z_ty, s) in - mkApp (c, [| pos_of_bigint pos_ty n |]) - -let bigint_of_z z = match Constr.kind z with - | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero - | App (c, [| d |]) -> - begin match Constr.kind c with - | Construct ((_, n), _) -> - begin match n with - | 2 -> (* Zpos *) bigint_of_pos d - | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) - | n -> assert false (* no other constructor of type Z *) - end - | _ -> raise NotANumber - end - | _ -> raise NotANumber - -(** The uninterp function below work at the level of [glob_constr] - which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) - -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) - | _ -> - raise NotANumber - -let rec glob_of_constr ?loc c = match Constr.kind c with - | App (c, ca) -> - let c = glob_of_constr ?loc c in - let cel = List.map (glob_of_constr ?loc) (Array.to_list ca) in - DAst.make ?loc (Glob_term.GApp (c, cel)) - | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) - | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) - | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) - | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) - | _ -> let (sigma, env) = Pfedit.get_current_context () in - CErrors.user_err ?loc - (strbrk "Unexpected term " ++ - Printer.pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") - -let no_such_number ?loc ty = - CErrors.user_err ?loc - (str "Cannot interpret this number as a value of type " ++ - pr_qualid ty) - -let interp_option ty ?loc c = - match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr ?loc c - | App (_None, [| _ |]) -> no_such_number ?loc ty - | x -> let (sigma, env) = Pfedit.get_current_context () in - CErrors.user_err ?loc - (strbrk "Unexpected non-option term " ++ - Printer.pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") - -let uninterp_option c = - match Constr.kind c with - | App (_Some, [| _; x |]) -> x - | _ -> raise NotANumber - -let big2raw n = - if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) - else (Bigint.to_string (Bigint.neg n), false) - -let raw2big (n,s) = - if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) - -type target_kind = - | Int of int_ty (* Coq.Init.Decimal.int + uint *) - | UInt of Names.inductive (* Coq.Init.Decimal.uint *) - | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - -type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind - -type numnot_option = - | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number - -type numeral_notation_obj = - { to_kind : conversion_kind; - to_ty : GlobRef.t; - of_kind : conversion_kind; - of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } - -let interp o ?loc n = - begin match o.warning with - | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> - warn_large_num o.num_ty - | _ -> () - end; - let c = match fst o.to_kind with - | Int int_ty -> coqint_of_rawnum int_ty n - | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) - | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty - | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) - in - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in - let to_ty = EConstr.Unsafe.to_constr to_ty in - match o.warning, snd o.to_kind with - | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> - warn_abstract_large_num (o.num_ty,o.to_ty); - glob_of_constr ?loc (mkApp (to_ty,[|c|])) - | _ -> - let res = eval_constr_app env sigma to_ty c in - match snd o.to_kind with - | Direct -> glob_of_constr ?loc res - | Option -> interp_option o.num_ty ?loc res - -let uninterp o (Glob_term.AnyGlobConstr n) = - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in - let of_ty = EConstr.Unsafe.to_constr of_ty in - try - let sigma,n = constr_of_glob env sigma n in - let c = eval_constr_app env sigma of_ty n in - let c = if snd o.of_kind == Direct then c else uninterp_option c in - match fst o.of_kind with - | Int _ -> Some (rawnum_of_coqint c) - | UInt _ -> Some (rawnum_of_coquint c, true) - | Z _ -> Some (big2raw (bigint_of_z c)) - with - | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) - | NotANumber -> None (* all other functions except big2raw *) - -(* Here we only register the interp and uninterp functions - for a particular Numeral Notation (determined by a unique - string). The actual activation of the notation will be done - later (cf. Notation.enable_prim_token_interpretation). - This registration of interp/uninterp must be added in the - libstack, otherwise this won't work through a Require. *) - -let load_numeral_notation _ (_, (uid,opts)) = - Notation.register_rawnumeral_interpretation - ~allow_overwrite:true uid (interp opts, uninterp opts) - -let cache_numeral_notation x = load_numeral_notation 1 x - -(* TODO: substitution ? - TODO: uid pas stable par substitution dans opts - *) - -let inNumeralNotation : string * numeral_notation_obj -> Libobject.obj = - Libobject.declare_object { - (Libobject.default_object "NUMERAL NOTATION") with - Libobject.cache_function = cache_numeral_notation; - Libobject.load_function = load_numeral_notation } - let get_constructors ind = let mib,oib = Global.lookup_inductive ind in let mc = oib.Declarations.mind_consnames in @@ -464,15 +131,12 @@ let vernac_numeral_notation local ty f g scope opts = (match opts, to_kind with | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty | _ -> ()); - (* TODO: un hash suffit-il ? *) - let uid = Marshal.to_string o [] in - let i = Notation.( + let i = { pt_local = local; pt_scope = scope; - pt_uid = uid; + pt_interp_info = NumeralNotation o; pt_required = Nametab.path_of_global (IndRef tyc),[]; pt_refs = constructors; - pt_in_match = true }) + pt_in_match = true } in - Lib.add_anonymous_leaf (inNumeralNotation (uid,o)); - Notation.enable_prim_token_interpretation i + enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index 83ede6f48f..f96b8321f8 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -9,14 +9,9 @@ (************************************************************************) open Libnames -open Constrexpr open Vernacexpr +open Notation (** * Numeral notation *) -type numnot_option = - | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number - val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 04946c158b..49497aef54 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -143,7 +143,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = r_scope; - pt_uid = r_scope; + pt_interp_info = Uid r_scope; pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); pt_refs = [glob_IZR]; pt_in_match = false } diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 640bcfde91..7478c1e978 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -75,7 +75,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = sc; - pt_uid = sc; + pt_interp_info = Uid sc; pt_required = (string_path,["Coq";"Strings";"String"]); pt_refs = [static_glob_String; static_glob_EmptyString]; pt_in_match = true } diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 81e8bd06f5..37dd3708b3 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -250,14 +250,13 @@ let push_history_pattern n pci cont = type 'a pattern_matching_problem = { env : GlobEnv.t; - evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; history : pattern_continuation; mat : 'a matrix; caseloc : Loc.t option; casestyle : case_style; - typing_function: type_constraint -> GlobEnv.t -> evar_map ref -> 'a option -> unsafe_judgment } + typing_function: type_constraint -> GlobEnv.t -> evar_map -> 'a option -> evar_map * unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * @@ -282,30 +281,30 @@ let rec find_row_ind = function | PatVar _ -> find_row_ind l | PatCstr(c,_,_) -> Some (p.CAst.loc,c) -let inductive_template evdref env tmloc ind = - let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in +let inductive_template env sigma tmloc ind = + let sigma, indu = Evd.fresh_inductive_instance env sigma ind in let arsign = inductive_alldecls_env env indu in let indu = on_snd EInstance.make indu in let hole_source i = match tmloc with | Some loc -> Loc.tag ~loc @@ Evar_kinds.TomatchTypeParameter (ind,i) | None -> Loc.tag @@ Evar_kinds.TomatchTypeParameter (ind,i) in - let (_,evarl,_) = + let (sigma, _, evarl, _) = List.fold_right - (fun decl (subst,evarl,n) -> + (fun decl (sigma, subst, evarl, n) -> match decl with | LocalAssum (na,ty) -> let ty = EConstr.of_constr ty in let ty' = substl subst ty in - let e = evd_comb1 - (Evarutil.new_evar env ~src:(hole_source n)) - evdref ty' + let sigma, e = + Evarutil.new_evar env ~src:(hole_source n) + sigma ty' in - (e::subst,e::evarl,n+1) + (sigma, e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> let b = EConstr.of_constr b in - (substl subst b::subst,evarl,n+1)) - arsign ([],[],1) in - applist (mkIndU indu,List.rev evarl) + (sigma, substl subst b::subst,evarl,n+1)) + arsign (sigma, [], [], 1) in + sigma, applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = let (IndType(indf,realargs) as ind) = find_rectype env sigma typ in @@ -317,16 +316,15 @@ let try_find_ind env sigma typ realnames = List.make (inductive_nrealdecls ind) Anonymous in IsInd (typ,ind,names) -let inh_coerce_to_ind evdref env loc ty tyi = - let orig = !evdref in - let expected_typ = inductive_template evdref env loc tyi in +let inh_coerce_to_ind env sigma0 loc ty tyi = + let sigma, expected_typ = inductive_template env sigma0 loc tyi in (* Try to refine the type with inductive information coming from the constructor and renounce if not able to give more information *) (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) - match cumul env !evdref expected_typ ty with - | Some sigma -> evdref := sigma - | None -> evdref := orig + match cumul env sigma expected_typ ty with + | Some sigma -> sigma + | None -> sigma0 let binding_vars_of_inductive sigma = function | NotInd _ -> [] @@ -347,20 +345,21 @@ let extract_inductive_data env sigma decl = | LocalDef (_,_,t) -> (NotInd (None, t), []) -let unify_tomatch_with_patterns evdref env loc typ pats realnames = +let unify_tomatch_with_patterns env sigma loc typ pats realnames = match find_row_ind pats with - | None -> NotInd (None,typ) + | None -> sigma, NotInd (None,typ) | Some (_,(ind,_)) -> - inh_coerce_to_ind evdref env loc typ ind; - try try_find_ind env !evdref typ realnames - with Not_found -> NotInd (None,typ) + let sigma = inh_coerce_to_ind env sigma loc typ ind in + try sigma, try_find_ind env sigma typ realnames + with Not_found -> sigma, NotInd (None,typ) -let find_tomatch_tycon evdref env loc = function +let find_tomatch_tycon env sigma loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) | Some {CAst.v=(ind,realnal)} -> - mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) + let sigma, tycon = inductive_template env sigma loc ind in + sigma, mk_tycon tycon, Some (List.rev realnal) | None -> - empty_tycon,None + sigma, empty_tycon, None let make_return_predicate_ltac_lvar env sigma na tm c = (* If we have an [x as x return ...] clause and [x] expands to [c], @@ -380,41 +379,39 @@ let is_patvar pat = | PatVar _ -> true | _ -> false -let coerce_row typing_fun evdref env pats (tomatch,(na,indopt)) = +let coerce_row typing_fun env sigma pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in - let tycon,realnames = find_tomatch_tycon evdref !!env loc indopt in - let j = typing_fun tycon env evdref tomatch in - let j = evd_comb1 (Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) !!env) evdref j in - let typ = nf_evar !evdref j.uj_type in - let env = make_return_predicate_ltac_lvar env !evdref na tomatch j.uj_val in - let t = - if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else - try try_find_ind !!env !evdref typ realnames + let sigma, tycon, realnames = find_tomatch_tycon !!env sigma loc indopt in + let sigma, j = typing_fun tycon env sigma tomatch in + let sigma, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) !!env sigma j in + let typ = nf_evar sigma j.uj_type in + let env = make_return_predicate_ltac_lvar env sigma na tomatch j.uj_val in + let sigma, t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then + sigma, NotInd (None,typ) + else + try sigma, try_find_ind !!env sigma typ realnames with Not_found -> - unify_tomatch_with_patterns evdref !!env loc typ pats realnames in - (env,(j.uj_val,t)) + unify_tomatch_with_patterns !!env sigma loc typ pats realnames + in + ((env, sigma), (j.uj_val,t)) -let coerce_to_indtype typing_fun evdref env matx tomatchl = +let coerce_to_indtype typing_fun env sigma matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) | m -> m in - let env,tms = List.fold_left2_map (fun env -> coerce_row typing_fun evdref env) env matx' tomatchl in - env,tms + let (env, sigma), tms = List.fold_left2_map (fun (env, sigma) -> coerce_row typing_fun env sigma) (env, sigma) matx' tomatchl in + env, sigma, tms (************************************************************************) (* Utils *) -let mkExistential env ?(src=(Loc.tag Evar_kinds.InternalHole)) evdref = - let (e, u) = evd_comb1 (new_type_evar env ~src:src) evdref univ_flexible_alg in - e +let mkExistential ?(src=(Loc.tag Evar_kinds.InternalHole)) env sigma = + let sigma, (e, u) = new_type_evar env sigma ~src:src univ_flexible_alg in + sigma, e -let evd_comb2 f evdref x y = - let (evd',y) = f !evdref x y in - evdref := evd'; - y - -let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = +let adjust_tomatch_to_pattern sigma pb ((current,typ),deps,dep) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an @@ -423,26 +420,27 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = let typ,names = match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in let tmtyp = - try try_find_ind !!(pb.env) !(pb.evdref) typ names + try try_find_ind !!(pb.env) sigma typ names with Not_found -> NotInd (None,typ) in match tmtyp with | NotInd (None,typ) -> let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in (match find_row_ind tm1 with - | None -> (current,tmtyp) + | None -> sigma, (current, tmtyp) | Some (_,(ind,_)) -> - let indt = inductive_template pb.evdref !!(pb.env) None ind in - let current = - if List.is_empty deps && isEvar !(pb.evdref) typ then + let sigma, indt = inductive_template !!(pb.env) sigma None ind in + let sigma, current = + if List.is_empty deps && isEvar sigma typ then (* Don't insert coercions if dependent; only solve evars *) - let () = Option.iter ((:=) pb.evdref) (cumul !!(pb.env) !(pb.evdref) indt typ) in - current + match cumul !!(pb.env) sigma indt typ with + | None -> sigma, current + | Some sigma -> sigma, current else - (evd_comb2 (Coercion.inh_conv_coerce_to true !!(pb.env)) - pb.evdref (make_judge current typ) indt).uj_val in - let sigma = !(pb.evdref) in - (current,try_find_ind !!(pb.env) sigma indt names)) - | _ -> (current,tmtyp) + let sigma, j = Coercion.inh_conv_coerce_to true !!(pb.env) sigma (make_judge current typ) indt in + sigma, j.uj_val + in + sigma, (current, try_find_ind !!(pb.env) sigma indt names)) + | _ -> sigma, (current, tmtyp) let type_of_tomatch = function | IsInd (t,_,_) -> t @@ -1015,7 +1013,7 @@ let add_assert_false_case pb tomatch = eqn_loc = None; used = ref false } ] -let adjust_impossible_cases pb pred tomatch submat = +let adjust_impossible_cases sigma pb pred tomatch submat = match submat with | [] -> (** FIXME: This breaks if using evar-insensitive primitives. In particular, @@ -1023,17 +1021,20 @@ let adjust_impossible_cases pb pred tomatch submat = evar. See e.g. first definition of test for bug #3388. *) let pred = EConstr.Unsafe.to_constr pred in begin match Constr.kind pred with - | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> - if not (Evd.is_defined !(pb.evdref) evk) then begin - let default = evd_comb0 use_unit_judge pb.evdref in - pb.evdref := Evd.define evk default.uj_type !(pb.evdref) - end; - add_assert_false_case pb tomatch + | Evar (evk,_) when snd (evar_source evk sigma) == Evar_kinds.ImpossibleCase -> + let sigma = + if not (Evd.is_defined sigma evk) then + let sigma, default = use_unit_judge sigma in + let sigma = Evd.define evk default.uj_type sigma in + sigma + else sigma + in + sigma, add_assert_false_case pb tomatch | _ -> - submat + sigma, submat end | _ -> - submat + sigma, submat (*****************************************************************************) (* Let pred = PI [X;x:I(X)]. PI tms. P be a typing predicate for the *) @@ -1090,9 +1091,9 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) snd (List.fold_left (expand_arg tms) (1,ccl''') newtomatchs) -let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms = - let pred = abstract_predicate env !evdref indf current realargs dep tms p in - (pred, whd_betaiota !evdref +let find_predicate loc env sigma p current (IndType (indf,realargs)) dep tms = + let pred = abstract_predicate env sigma indf current realargs dep tms p in + (pred, whd_betaiota sigma (applist (pred, realargs@[current]))) (* Take into account that a type has been discovered to be inductive, leading @@ -1239,34 +1240,34 @@ let group_equations pb ind current cstrs mat = (* Here starts the pattern-matching compilation algorithm *) (* Abstracting over dependent subterms to match *) -let rec generalize_problem names pb = function +let rec generalize_problem names sigma pb = function | [] -> pb, [] | i::l -> - let pb',deps = generalize_problem names pb l in + let pb',deps = generalize_problem names sigma pb l in let d = map_constr (lift i) (lookup_rel i !!(pb.env)) in begin match d with | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) - let d = RelDecl.map_type (fun c -> whd_betaiota !(pb.evdref) c) d in + let d = RelDecl.map_type (fun c -> whd_betaiota sigma c) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in - let tomatch = relocate_index_tomatch !(pb.evdref) (i+1) 1 tomatch in + let tomatch = relocate_index_tomatch sigma (i+1) 1 tomatch in { pb' with tomatch = Abstract (i,d) :: tomatch; - pred = generalize_predicate !(pb'.evdref) names i d pb'.tomatch pb'.pred }, + pred = generalize_predicate sigma names i d pb'.tomatch pb'.pred }, i::deps end (* No more patterns: typing the right-hand side of equations *) -let build_leaf pb = +let build_leaf sigma pb = let rhs = extract_rhs pb in - let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in - j_nf_evar !(pb.evdref) j + let sigma, j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env sigma rhs.it in + sigma, j_nf_evar sigma j (* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *) (* spiwack: the [initial] argument keeps track whether the branch is a toplevel branch ([true]) or a deep one ([false]). *) -let build_branch initial current realargs deps (realnames,curname) pb arsign eqns const_info = +let build_branch initial current realargs deps (realnames,curname) sigma pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in @@ -1276,7 +1277,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs_args in - let names,aliasname = get_names (GlobEnv.vars_of_env pb.env) !!(pb.env) !(pb.evdref) cs_args eqns in + let names,aliasname = get_names (GlobEnv.vars_of_env pb.env) !!(pb.env) sigma cs_args eqns in let typs = List.map2 RelDecl.set_name names cs_args in @@ -1284,7 +1285,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* This is a bit too strong I think, in the sense that what we would *) (* really like is to have beta-iota reduction only at the positions where *) (* parameters are substituted *) - let typs = List.map (map_type (nf_betaiota !!(pb.env) !(pb.evdref))) typs in + let typs = List.map (map_type (nf_betaiota !!(pb.env) sigma)) typs in (* We build the matrix obtained by expanding the matching on *) (* "C x1..xn as x" followed by a residual matching on eqn into *) @@ -1296,17 +1297,17 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let typs' = List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in - let typs,extenv = push_rel_context !(pb.evdref) typs pb.env in + let typs,extenv = push_rel_context sigma typs pb.env in let typs' = List.map (fun (c,d) -> - (c,extract_inductive_data !!extenv !(pb.evdref) d,d)) typs' in + (c,extract_inductive_data !!extenv sigma d,d)) typs' in (* We compute over which of x(i+1)..xn and x matching on xi will need a *) (* generalization *) let dep_sign = - find_dependencies_signature !(pb.evdref) - (dependencies_in_rhs !(pb.evdref) const_info.cs_nargs current pb.tomatch eqns) + find_dependencies_signature sigma + (dependencies_in_rhs sigma const_info.cs_nargs current pb.tomatch eqns) (List.rev typs') in (* The dependent term to subst in the types of the remaining UnPushed @@ -1322,13 +1323,13 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* Do the specialization for terms to match *) let tomatch = List.fold_right2 (fun par arg tomatch -> - match EConstr.kind !(pb.evdref) par with - | Rel i -> replace_tomatch !(pb.evdref) (i+const_info.cs_nargs) arg tomatch + match EConstr.kind sigma par with + | Rel i -> replace_tomatch sigma (i+const_info.cs_nargs) arg tomatch | _ -> tomatch) (current::realargs) (ci::cirealargs) (lift_tomatch_stack const_info.cs_nargs pb.tomatch) in let pred_is_not_dep = - noccur_predicate_between !(pb.evdref) 1 (List.length realnames + 1) pb.pred tomatch in + noccur_predicate_between sigma 1 (List.length realnames + 1) pb.pred tomatch in let typs' = List.map2 @@ -1362,20 +1363,20 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let tomatch = List.rev_append (alias :: currents) tomatch in - let submat = adjust_impossible_cases pb pred tomatch submat in + let sigma, submat = adjust_impossible_cases sigma pb pred tomatch submat in let () = match submat with | [] -> raise_pattern_matching_error (!!(pb.env), Evd.empty, NonExhaustive (complete_history history)) | _ -> () in - typs, + sigma, typs, { pb with env = extenv; tomatch = tomatch; pred = pred; history = history; - mat = List.map (push_rels_eqn_with_names !(pb.evdref) typs) submat } + mat = List.map (push_rels_eqn_with_names sigma typs) submat } (********************************************************************** INVARIANT: @@ -1390,23 +1391,23 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (**********************************************************************) (* Main compiling descent *) -let rec compile pb = +let rec compile sigma pb = match pb.tomatch with - | Pushed cur :: rest -> match_current { pb with tomatch = rest } cur - | Alias (initial,x) :: rest -> compile_alias initial pb x rest - | NonDepAlias :: rest -> compile_non_dep_alias pb rest - | Abstract (i,d) :: rest -> compile_generalization pb i d rest - | [] -> build_leaf pb + | Pushed cur :: rest -> match_current sigma { pb with tomatch = rest } cur + | Alias (initial,x) :: rest -> compile_alias initial sigma pb x rest + | NonDepAlias :: rest -> compile_non_dep_alias sigma pb rest + | Abstract (i,d) :: rest -> compile_generalization sigma pb i d rest + | [] -> build_leaf sigma pb (* Case splitting *) -and match_current pb (initial,tomatch) = - let tm = adjust_tomatch_to_pattern pb tomatch in +and match_current sigma pb (initial,tomatch) = + let sigma, tm = adjust_tomatch_to_pattern sigma pb tomatch in let pb,tomatch = adjust_predicate_from_tomatch tomatch tm pb in let ((current,typ),deps,dep) = tomatch in match typ with | NotInd (_,typ) -> - check_all_variables !!(pb.env) !(pb.evdref) typ pb.mat; - compile_all_variables initial tomatch pb + check_all_variables !!(pb.env) sigma typ pb.mat; + compile_all_variables initial tomatch sigma pb | IsInd (_,(IndType(indf,realargs) as indt),names) -> let mind,_ = dest_ind_family indf in let mind = Tacred.check_privacy !!(pb.env) mind in @@ -1415,102 +1416,105 @@ and match_current pb (initial,tomatch) = let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then - compile_all_variables initial tomatch pb + compile_all_variables initial tomatch sigma pb else (* We generalize over terms depending on current term to match *) - let pb,deps = generalize_problem (names,dep) pb deps in + let pb,deps = generalize_problem (names,dep) sigma pb deps in (* We compile branches *) - let brvals = Array.map2 (compile_branch initial current realargs (names,dep) deps pb arsign) eqns cstrs in + let fold_br sigma eqn cstr = + compile_branch initial current realargs (names,dep) deps sigma pb arsign eqn cstr + in + let sigma, brvals = Array.fold_left2_map fold_br sigma eqns cstrs in (* We build the (elementary) case analysis *) - let depstocheck = current::binding_vars_of_inductive !(pb.evdref) typ in + let depstocheck = current::binding_vars_of_inductive sigma typ in let brvals,tomatch,pred,inst = - postprocess_dependencies !(pb.evdref) depstocheck + postprocess_dependencies sigma depstocheck brvals pb.tomatch pb.pred deps cstrs in let brvals = Array.map (fun (sign,body) -> it_mkLambda_or_LetIn body sign) brvals in let (pred,typ) = - find_predicate pb.caseloc pb.env pb.evdref + find_predicate pb.caseloc pb.env sigma pred current indt (names,dep) tomatch in let ci = make_case_info !!(pb.env) (fst mind) pb.casestyle in - let pred = nf_betaiota !!(pb.env) !(pb.evdref) pred in + let pred = nf_betaiota !!(pb.env) sigma pred in let case = - make_case_or_project !!(pb.env) !(pb.evdref) indf ci pred current brvals + make_case_or_project !!(pb.env) sigma indf ci pred current brvals in - let _ = Evarutil.evd_comb1 (Typing.type_of !!(pb.env)) pb.evdref pred in - Typing.check_allowed_sort !!(pb.env) !(pb.evdref) mind current pred; - { uj_val = applist (case, inst); - uj_type = prod_applist !(pb.evdref) typ inst } + let sigma, _ = Typing.type_of !!(pb.env) sigma pred in + Typing.check_allowed_sort !!(pb.env) sigma mind current pred; + sigma, { uj_val = applist (case, inst); + uj_type = prod_applist sigma typ inst } (* Building the sub-problem when all patterns are variables. Case where [current] is an intially pushed term. *) -and shift_problem ((current,t),_,na) pb = +and shift_problem ((current,t),_,na) sigma pb = let ty = type_of_tomatch t in let tomatch = lift_tomatch_stack 1 pb.tomatch in let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in let env = Name.fold_left (fun env id -> hide_variable env Anonymous id) pb.env na in let pb = { pb with - env = snd (push_rel !(pb.evdref) (LocalDef (na,current,ty)) env); + env = snd (push_rel sigma (LocalDef (na,current,ty)) env); tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; - mat = List.map (push_current_pattern !(pb.evdref) (current,ty)) pb.mat } in - let j = compile pb in - { uj_val = subst1 current j.uj_val; + mat = List.map (push_current_pattern sigma (current,ty)) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = subst1 current j.uj_val; uj_type = subst1 current j.uj_type } (* Building the sub-problem when all patterns are variables, non-initial case. Variables which appear as subterms of constructor are already introduced in the context, we avoid creating aliases to themselves by treating this case specially. *) -and pop_problem ((current,t),_,na) pb = +and pop_problem ((current,t),_,na) sigma pb = let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in let pb = { pb with pred = pred; history = pop_history pb.history; mat = List.map push_noalias_current_pattern pb.mat } in - compile pb + compile sigma pb (* Building the sub-problem when all patterns are variables. *) -and compile_all_variables initial cur pb = - if initial then shift_problem cur pb - else pop_problem cur pb +and compile_all_variables initial cur sigma pb = + if initial then shift_problem cur sigma pb + else pop_problem cur sigma pb (* Building the sub-problem when all patterns are variables *) -and compile_branch initial current realargs names deps pb arsign eqns cstr = - let sign, pb = build_branch initial current realargs deps names pb arsign eqns cstr in - sign, (compile pb).uj_val +and compile_branch initial current realargs names deps sigma pb arsign eqns cstr = + let sigma, sign, pb = build_branch initial current realargs deps names sigma pb arsign eqns cstr in + let sigma, j = compile sigma pb in + sigma, (sign, j.uj_val) (* Abstract over a declaration before continuing splitting *) -and compile_generalization pb i d rest = +and compile_generalization sigma pb i d rest = let pb = { pb with - env = snd (push_rel !(pb.evdref) d pb.env); + env = snd (push_rel sigma d pb.env); tomatch = rest; - mat = List.map (push_generalized_decl_eqn pb.env !(pb.evdref) i d) pb.mat } in - let j = compile pb in - { uj_val = mkLambda_or_LetIn d j.uj_val; + mat = List.map (push_generalized_decl_eqn pb.env sigma i d) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = mkLambda_or_LetIn d j.uj_val; uj_type = mkProd_wo_LetIn d j.uj_type } (* spiwack: the [initial] argument keeps track whether the alias has been introduced by a toplevel branch ([true]) or a deep one ([false]). *) -and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = +and compile_alias initial sigma pb (na,orig,(expanded,expanded_typ)) rest = let f c t = let alias = LocalDef (na,c,t) in let pb = { pb with - env = snd (push_rel !(pb.evdref) alias pb.env); + env = snd (push_rel sigma alias pb.env); tomatch = lift_tomatch_stack 1 rest; pred = lift_predicate 1 pb.pred pb.tomatch; history = pop_history_pattern pb.history; - mat = List.map (push_alias_eqn !(pb.evdref) alias) pb.mat } in - let j = compile pb in - let sigma = !(pb.evdref) in - { uj_val = + mat = List.map (push_alias_eqn sigma alias) pb.mat } in + let sigma, j = compile sigma pb in + sigma, { uj_val = if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then subst1 c j.uj_val else @@ -1519,15 +1523,14 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* spiwack: when an alias appears on a deep branch, its non-expanded form is automatically a variable of the same name. We avoid introducing such superfluous aliases so that refines are elegant. *) - let just_pop () = + let just_pop sigma = let pb = { pb with tomatch = rest; history = pop_history_pattern pb.history; mat = List.map drop_alias_eqn pb.mat } in - compile pb + compile sigma pb in - let sigma = !(pb.evdref) in (* If the "match" was orginally over a variable, as in "match x with O => true | n => n end", we give preference to non-expansion in the default clause (i.e. "match x with O => true | n => n end" @@ -1540,11 +1543,10 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* Try to compile first using non expanded alias *) try if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) - else just_pop () + else just_pop sigma with e when precatchable_exception e -> (* Try then to compile using expanded alias *) (* Could be needed in case of dependent return clause *) - pb.evdref := sigma; f expanded expanded_typ else (* Try to compile first using expanded alias *) @@ -1553,19 +1555,18 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* Try then to compile using non expanded alias *) (* Could be needed in case of a recursive call which requires to be on a variable for size reasons *) - pb.evdref := sigma; - if initial then f orig (Retyping.get_type_of !!(pb.env) !(pb.evdref) orig) - else just_pop () + if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) + else just_pop sigma (* Remember that a non-trivial pattern has been consumed *) -and compile_non_dep_alias pb rest = +and compile_non_dep_alias sigma pb rest = let pb = { pb with tomatch = rest; history = pop_history_pattern pb.history; mat = List.map drop_alias_eqn pb.mat } in - compile pb + compile sigma pb (* pour les alias des initiaux, enrichir les env de ce qu'il faut et substituer après par les initiaux *) @@ -1671,88 +1672,94 @@ let rec list_assoc_in_triple x = function * similarly for each ti. *) -let abstract_tycon ?loc env evdref subst tycon extenv t = - let t = nf_betaiota !!env !evdref t in (* it helps in some cases to remove K-redex*) - let src = match EConstr.kind !evdref t with +let abstract_tycon ?loc env sigma subst tycon extenv t = + let t = nf_betaiota !!env sigma t in (* it helps in some cases to remove K-redex*) + let src = match EConstr.kind sigma t with | Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar (None,evk)) | _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in - let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv !evdref subst t in + let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv sigma subst t in (* We traverse the type T of the original problem Xi looking for subterms that match the non-constructor part of the constraints (this part is in subst); these subterms are the "good" subterms and we replace them by an evar that may depend (and only depend) on the corresponding convertible subterms of the substitution *) + let evdref = ref sigma in let rec aux (k,env,subst as x) t = - match EConstr.kind !evdref t with + (** Use a reference because the [map_constr_with_full_binders] does not + allow threading a state. *) + let sigma = !evdref in + match EConstr.kind sigma t with | Rel n when is_local_def (lookup_rel n !!env) -> t | Evar ev -> - let ty = get_type_of !!env !evdref t in - let ty = Evarutil.evd_comb1 (refresh_universes (Some false) !!env) evdref ty in + let ty = get_type_of !!env sigma t in + let sigma, ty = refresh_universes (Some false) !!env sigma ty in let inst = List.map_i (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context !!env) in - let ev' = evd_comb1 (Evarutil.new_evar !!env ~src) evdref ty in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) !!env !evdref (None,ev,substl inst ev') with + let sigma, ev' = Evarutil.new_evar ~src !!env sigma ty in + begin match solve_simple_eqn (evar_conv_x full_transparent_state) !!env sigma (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; ev' | _ -> - let good = List.filter (fun (_,u,_) -> is_conv_leq !!env !evdref t u) subst in + let good = List.filter (fun (_,u,_) -> is_conv_leq !!env sigma t u) subst in match good with | [] -> - map_constr_with_full_binders !evdref (push_binder !evdref) aux x t + map_constr_with_full_binders sigma (push_binder sigma) aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = - let ty = get_type_of !!env !evdref t in + let ty = get_type_of !!env sigma t in Evarutil.evd_comb1 (refresh_universes (Some false) !!env) evdref ty in let dummy_subst = List.init k (fun _ -> mkProp) in let ty = substl dummy_subst (aux x ty) in - let depvl = free_rels !evdref ty in + let sigma = !evdref in + let depvl = free_rels sigma ty in let inst = List.map_i (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 (rel_context !!extenv) in - let map a = match EConstr.kind !evdref a with - | Rel n -> not (noccurn !evdref n u) || Int.Set.mem n depvl + let map a = match EConstr.kind sigma a with + | Rel n -> not (noccurn sigma n u) || Int.Set.mem n depvl | _ -> true in let rel_filter = List.map map inst in let named_filter = - List.map (fun d -> local_occur_var !evdref (NamedDecl.get_id d) u) + List.map (fun d -> local_occur_var sigma (NamedDecl.get_id d) u) (named_context !!extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = List.rev (u :: List.map mkRel vl) in - let ev = evd_comb1 (Evarutil.new_evar !!extenv ~src ~filter ~candidates) evdref ty in + let sigma, ev = Evarutil.new_evar !!extenv ~src ~filter ~candidates sigma ty in + let () = evdref := sigma in lift k ev in - aux (0,extenv,subst0) t0 + let ans = aux (0,extenv,subst0) t0 in + !evdref, ans -let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = - let t,tt = match t with +let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = + let sigma, t, tt = match t with | None -> (* This is the situation we are building a return predicate and we are in an impossible branch *) let n = Context.Rel.length (rel_context !!env) in let n' = Context.Rel.length (rel_context !!tycon_env) in - let impossible_case_type, u = - evd_comb1 - (new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase)) - evdref univ_flexible_alg + let sigma, (impossible_case_type, u) = + new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) + sigma univ_flexible_alg in - (lift (n'-n) impossible_case_type, mkSort u) + (sigma, lift (n'-n) impossible_case_type, mkSort u) | Some t -> - let t = abstract_tycon ?loc tycon_env evdref subst tycon extenv t in - let tt = evd_comb1 (Typing.type_of !!extenv) evdref t in - (t,tt) in - match cumul !!env !evdref tt (mkSort s) with + let sigma, t = abstract_tycon ?loc tycon_env sigma subst tycon extenv t in + let sigma, tt = Typing.type_of !!extenv sigma t in + (sigma, t, tt) in + match cumul !!env sigma tt (mkSort s) with | None -> anomaly (Pp.str "Build_tycon: should be a type."); - | Some sigma -> evdref := sigma; - { uj_val = t; uj_type = tt } + | Some sigma -> + sigma, { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return @@ -1865,10 +1872,8 @@ let build_inversion_problem loc env sigma tms t = let s' = Retyping.get_sort_of !!env sigma t in let sigma, s = Evd.new_sort_variable univ_flexible sigma in let sigma = Evd.set_leq_sort !!env sigma s' s in - let evdref = ref sigma in let pb = { env = pb_env; - evdref = evdref; pred = (*ty *) mkSort s; tomatch = sub_tms; history = start_history n; @@ -1876,8 +1881,8 @@ let build_inversion_problem loc env sigma tms t = caseloc = loc; casestyle = RegularStyle; typing_function = build_tycon ?loc env pb_env s subst} in - let pred = (compile pb).uj_val in - (!evdref,pred) + let sigma, j = compile sigma pb in + (sigma, j.uj_val) (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) @@ -1929,24 +1934,35 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) -let inh_conv_coerce_to_tycon ?loc env evdref j tycon = +let inh_conv_coerce_to_tycon ?loc env sigma j tycon = match tycon with - | Some p -> - evd_comb2 (Coercion.inh_conv_coerce_to ?loc true env) evdref j p - | None -> j + | Some p -> Coercion.inh_conv_coerce_to ?loc true env sigma j p + | None -> sigma, j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) +let add_subst sigma c len (rel_subst,var_subst) = + match EConstr.kind sigma c with + | Rel n -> (n,len) :: rel_subst, var_subst + | Var id -> rel_subst, (id,len) :: var_subst + | _ -> assert false + +let dependent_rel_or_var sigma tm c = + match EConstr.kind sigma tm with + | Rel n -> not (noccurn sigma n c) + | Var id -> Termops.local_occur_var sigma id c + | _ -> assert false + let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in - let subst, len = + let (rel_subst,var_subst), len = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match EConstr.kind sigma tm with - | Rel n when Int.equal signlen 1 && not (noccurn sigma n c) + | Rel _ | Var _ when Int.equal signlen 1 && dependent_rel_or_var sigma tm c (* The term to match is not of a dependent type itself *) -> - ((n, len) :: subst, len - signlen) - | Rel n when signlen > 1 (* The term is of a dependent type, + (add_subst sigma tm len subst, len - signlen) + | Rel _ | Var _ when signlen > 1 (* The term is of a dependent type, maybe some variable in its type appears in the tycon. *) -> (match tmtype with NotInd _ -> (subst, len - signlen) @@ -1955,28 +1971,36 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_left (fun (subst, len) arg -> match EConstr.kind sigma arg with - | Rel n when not (noccurn sigma n c) -> - ((n, len) :: subst, pred len) + | Rel _ | Var _ when dependent_rel_or_var sigma arg c -> + (add_subst sigma arg len subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs in let subst = - if not (noccurn sigma n c) && List.for_all (isRel sigma) realargs - then (n, len) :: subst else subst + if dependent_rel_or_var sigma tm c && List.for_all (fun c -> isRel sigma c || isVar sigma c) realargs + then add_subst sigma tm len subst else subst in (subst, pred len)) | _ -> (subst, len - signlen)) - (List.rev tomatchs) arsign ([], nar) + (List.rev tomatchs) arsign (([],[]), nar) in let rec predicate lift c = match EConstr.kind sigma c with | Rel n when n > lift -> (try (* Make the predicate dependent on the matched variable *) - let idx = Int.List.assoc (n - lift) subst in + let idx = Int.List.assoc (n - lift) rel_subst in mkRel (idx + lift) with Not_found -> - (* A variable that is not matched, lift over the arsign. *) + (* A variable that is not matched, lift over the arsign *) mkRel (n + nar)) + | Var id -> + (try + (* Make the predicate dependent on the matched variable *) + let idx = Id.List.assoc id var_subst in + mkRel (idx + lift) + with Not_found -> + (* A variable that is not matched *) + c) | _ -> EConstr.map_with_binders sigma succ predicate lift c in @@ -1992,27 +2016,9 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = * type and 1 assumption for each term not _syntactically_ in an * inductive type. - * Each matched terms are independently considered dependent or not. - - * A type constraint but no annotation case: we try to specialize the - * tycon to make the predicate if it is not closed. + * Each matched term is independently considered dependent or not. *) -exception LocalOccur - -let noccur_with_meta sigma n m term = - let rec occur_rec n c = match EConstr.kind sigma c with - | Rel p -> if n<=p && p<n+m then raise LocalOccur - | App(f,cl) -> - (match EConstr.kind sigma f with - | Cast (c,_,_) when isMeta sigma c -> () - | Meta _ -> () - | _ -> EConstr.iter_with_binders sigma succ occur_rec n c) - | Evar (_, _) -> () - | _ -> EConstr.iter_with_binders sigma succ occur_rec n c - in - try (occur_rec n term; true) with LocalOccur -> false - let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = let refresh_tycon sigma t = (** If we put the typing constraint in the term, it has to be @@ -2022,43 +2028,41 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = !!env sigma t in let preds = - match pred, tycon with + match pred with (* No return clause *) - | None, Some t when not (noccur_with_meta sigma 0 max_int t) -> - (* If the tycon is not closed w.r.t real variables, we try *) - (* two different strategies *) - (* First strategy: we abstract the tycon wrt to the dependencies *) - let sigma, t = refresh_tycon sigma t in - let p1 = + | None -> + let sigma,t = + match tycon with + | Some t -> refresh_tycon sigma t + | None -> + (* No type constraint: we first create a generic evar type constraint *) + let src = (loc, Evar_kinds.CasesType false) in + let sigma, (t, _) = new_type_evar !!env sigma univ_flexible_alg ~src in + sigma, t in + (* First strategy: we build an "inversion" predicate, also replacing the *) + (* dependencies with existential variables *) + let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in + (* Optional second strategy: we abstract the tycon wrt to the dependencies *) + let p2 = prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in - (* Second strategy: we build an "inversion" predicate *) - let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in - (match p1 with - | Some (sigma1,pred1,arsign) -> [sigma1, pred1, arsign; sigma2, pred2, arsign] - | None -> [sigma2, pred2, arsign]) - | None, _ -> - (* No dependent type constraint, or no constraints at all: *) - (* we use two strategies *) - let sigma,t = match tycon with - | Some t -> refresh_tycon sigma t - | None -> - let (sigma, (t, _)) = - new_type_evar !!env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in - sigma, t - in - (* First strategy: we build an "inversion" predicate *) - let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in - (* Second strategy: we directly use the evar as a non dependent pred *) - let pred2 = lift (List.length (List.flatten arsign)) t in - [sigma1, pred1, arsign; sigma, pred2, arsign] + (* Third strategy: we take the type constraint as it is; of course we could *) + (* need something inbetween, abstracting some but not all of the dependencies *) + (* the "inversion" strategy deals with that but unification may not be *) + (* powerful enough so strategy 2 and 3 helps; moreover, inverting does not *) + (* work (yet) when a constructor has a type not precise enough for the inversion *) + (* see log message for details *) + let pred3 = lift (List.length (List.flatten arsign)) t in + (match p2 with + | Some (sigma2,pred2,arsign) when not (EConstr.eq_constr sigma pred2 pred3) -> + [sigma1, pred1, arsign; sigma2, pred2, arsign; sigma, pred3, arsign] + | _ -> + [sigma1, pred1, arsign; sigma, pred3, arsign]) (* Some type annotation *) - | Some rtntyp, _ -> + | Some rtntyp -> (* We extract the signature of the arity *) let building_arsign,envar = List.fold_right_map (push_rel_context sigma) arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in - let evdref = ref sigma in - let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in - let sigma = !evdref in + let sigma, predcclj = typing_fun (mk_tycon (mkSort newt)) envar sigma rtntyp in let predccl = nf_evar sigma predcclj.uj_val in [sigma, predccl, building_arsign] in @@ -2097,12 +2101,17 @@ let eq_id avoid id = let hid' = next_ident_away hid avoid in hid' -let mk_eq evdref typ x y = papp evdref coq_eq_ind [| typ; x ; y |] -let mk_eq_refl evdref typ x = papp evdref coq_eq_refl [| typ; x |] -let mk_JMeq evdref typ x typ' y = - papp evdref coq_JMeq_ind [| typ; x ; typ'; y |] -let mk_JMeq_refl evdref typ x = - papp evdref coq_JMeq_refl [| typ; x |] +let papp sigma gr args = + let evdref = ref sigma in + let ans = papp evdref gr args in + !evdref, ans + +let mk_eq sigma typ x y = papp sigma coq_eq_ind [| typ; x ; y |] +let mk_eq_refl sigma typ x = papp sigma coq_eq_refl [| typ; x |] +let mk_JMeq sigma typ x typ' y = + papp sigma coq_JMeq_ind [| typ; x ; typ'; y |] +let mk_JMeq_refl sigma typ x = + papp sigma coq_JMeq_refl [| typ; x |] let hole na = DAst.make @@ GHole (Evar_kinds.QuestionMark { @@ -2111,8 +2120,8 @@ let hole na = DAst.make @@ Evar_kinds.qm_record_field=None}, IntroAnonymous, None) -let constr_of_pat env evdref arsign pat avoid = - let rec typ env (ty, realargs) pat avoid = +let constr_of_pat env sigma arsign pat avoid = + let rec typ env sigma (ty, realargs) pat avoid = let loc = pat.CAst.loc in match DAst.get pat with | PatVar name -> @@ -2122,14 +2131,14 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, Id.Set.add id avoid in - ((DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, + (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = - try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) - with Not_found -> error_case_not_inductive env !evdref - {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} + try find_rectype env sigma (lift (-(List.length realargs)) ty) + with Not_found -> error_case_not_inductive env sigma + {uj_val = ty; uj_type = Typing.unsafe_type_of env sigma ty} in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in @@ -2138,18 +2147,18 @@ let constr_of_pat env evdref arsign pat avoid = let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in assert (Int.equal nb_args_constr (List.length args)); - let patargs, args, sign, env, n, m, avoid = + let sigma, patargs, args, sign, env, n, m, avoid = List.fold_right2 - (fun decl ua (patargs, args, sign, env, n, m, avoid) -> + (fun decl ua (sigma, patargs, args, sign, env, n, m, avoid) -> let t = EConstr.of_constr (RelDecl.get_type decl) in - let pat', sign', arg', typ', argtypargs, n', avoid = + let sigma, pat', sign', arg', typ', argtypargs, n', avoid = let liftt = liftn (List.length sign) (succ (List.length args)) t in - typ env (substl args liftt, []) ua avoid + typ env sigma (substl args liftt, []) ua avoid in let args' = arg' :: List.map (lift n') args in let env' = EConstr.push_rel_context sign' env in - (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) - ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid) + (sigma, pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) + ci.cs_args (List.rev args) (sigma, [], [], [], env, 0, 0, avoid) in let args = List.rev args in let patargs = List.rev patargs in @@ -2157,32 +2166,32 @@ let constr_of_pat env evdref arsign pat avoid = let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in let app = applist (cstr, List.map (lift (List.length sign)) params) in let app = applist (app, args) in - let apptype = Retyping.get_type_of env ( !evdref) app in - let IndType (indf, realargs) = find_rectype env (!evdref) apptype in + let apptype = Retyping.get_type_of env sigma app in + let IndType (indf, realargs) = find_rectype env sigma apptype in match alias with Anonymous -> - pat', sign, app, apptype, realargs, n, avoid + sigma, pat', sign, app, apptype, realargs, n, avoid | Name id -> let sign = LocalAssum (alias, lift m ty) :: sign in let avoid = Id.Set.add id avoid in - let sign, i, avoid = + let sigma, sign, i, avoid = try let env = EConstr.push_rel_context sign env in - evdref := the_conv_x_leq (EConstr.push_rel_context sign env) - (lift (succ m) ty) (lift 1 apptype) !evdref; - let eq_t = mk_eq evdref (lift (succ m) ty) + let sigma = the_conv_x_leq (EConstr.push_rel_context sign env) + (lift (succ m) ty) (lift 1 apptype) sigma in + let sigma, eq_t = mk_eq sigma (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in - LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid - with Reduction.NotConvertible -> sign, 1, avoid + sigma, LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid + with Reduction.NotConvertible -> sigma, sign, 1, avoid in (* Mark the equality as a hole *) - pat', sign, lift i app, lift i apptype, realargs, n + i, avoid + sigma, pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid + let sigma, pat', sign, patc, patty, args, z, avoid = typ env sigma (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in + sigma, pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -2234,57 +2243,59 @@ let lift_rel_context n l = Hence pats is already typed in its full signature. However prevpatterns are in the original one signature per pattern form. *) -let build_ineqs evdref prevpatterns pats liftsign = - let diffs = +let build_ineqs sigma prevpatterns pats liftsign = + let sigma, diffs = List.fold_left - (fun c eqnpats -> - let acc = List.fold_left2 + (fun (sigma, c) eqnpats -> + let sigma, acc = List.fold_left2 (* ppat is the pattern we are discriminating against, curpat is the current one. *) - (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) + (fun (sigma, acc) (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> match acc with - None -> None + None -> sigma, None | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) if is_included curpat ppat then (* Length of previous pattern's signature *) let lens = List.length ppat_sign in (* Accumulated length of previous pattern's signatures *) let len' = lens + len in + let sigma, c' = + papp sigma coq_eq_ind + [| lift (len' + liftsign) curpat_ty; + liftn (len + liftsign) (succ lens) ppat_c ; + lift len' curpat_c |] + in let acc = ((* Jump over previous prevpat signs *) lift_rel_context len ppat_sign @ sign, len', succ n, (* nth pattern *) - (papp evdref coq_eq_ind - [| lift (len' + liftsign) curpat_ty; - liftn (len + liftsign) (succ lens) ppat_c ; - lift len' curpat_c |]) :: - List.map (lift lens (* Jump over this prevpat signature *)) c) - in Some acc - else None) - (Some ([], 0, 0, [])) eqnpats pats + c' :: List.map (lift lens (* Jump over this prevpat signature *)) c) + in sigma, Some acc + else sigma, None) + (sigma, Some ([], 0, 0, [])) eqnpats pats in match acc with - None -> c + None -> sigma, c | Some (sign, len, _, c') -> - let sigma, conj = mk_coq_and !evdref c' in + let sigma, conj = mk_coq_and sigma c' in let sigma, neg = mk_coq_not sigma conj in let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in - evdref := sigma; conj :: c) - [] prevpatterns - in match diffs with [] -> None - | _ -> Some (let sigma, conj = mk_coq_and !evdref diffs in evdref := sigma; conj) + sigma, conj :: c) + (sigma, []) prevpatterns + in match diffs with [] -> sigma, None + | _ -> let sigma, conj = mk_coq_and sigma diffs in sigma, Some conj -let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = +let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = let i = ref 0 in - let (x, y, z) = + let (sigma, x, y, z) = List.fold_left - (fun (branches, eqns, prevpatterns) eqn -> - let _, newpatterns, pats = + (fun (sigma, branches, eqns, prevpatterns) eqn -> + let sigma, _, newpatterns, pats = List.fold_left2 - (fun (idents, newpatterns, pats) pat arsign -> - let pat', cpat, idents = constr_of_pat !!env evdref arsign pat idents in - (idents, pat' :: newpatterns, cpat :: pats)) - (Id.Set.empty, [], []) eqn.patterns sign + (fun (sigma, idents, newpatterns, pats) pat arsign -> + let sigma, pat', cpat, idents = constr_of_pat !!env sigma arsign pat idents in + (sigma, idents, pat' :: newpatterns, cpat :: pats)) + (sigma, Id.Set.empty, [], []) eqn.patterns sign in let newpatterns = List.rev newpatterns and opats = List.rev pats in let rhs_rels, pats, signlen = @@ -2303,13 +2314,13 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = (* lift to get outside of past patterns to get terms in the combined environment. *) (fun (pats, n) (sign, c, (s, args), p) -> let len = List.length sign in - ((rels_of_patsign !evdref sign, lift n c, + ((rels_of_patsign sigma sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) ([], 0) pats in - let ineqs = build_ineqs evdref prevpatterns pats signlen in - let rhs_rels' = rels_of_patsign !evdref rhs_rels in - let _signenv,_ = push_rel_context !evdref rhs_rels' env in + let sigma, ineqs = build_ineqs sigma prevpatterns pats signlen in + let rhs_rels' = rels_of_patsign sigma rhs_rels in + let _signenv,_ = push_rel_context sigma rhs_rels' env in let arity = let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> @@ -2326,19 +2337,19 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = | Some ineqs -> [LocalAssum (Anonymous, ineqs)], lift 1 arity in - let eqs_rels, arity = decompose_prod_n_assum !evdref neqs arity in + let eqs_rels, arity = decompose_prod_n_assum sigma neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity in - let _,rhs_env = push_rel_context !evdref rhs_rels' env in - let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in + let _,rhs_env = push_rel_context sigma rhs_rels' env in + let sigma, j = typing_fun (mk_tycon tycon) rhs_env sigma eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let _btype = evd_comb1 (Typing.type_of !!env) evdref bbody in + let sigma, _btype = Typing.type_of !!env sigma bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = let bref = DAst.make @@ GVar branch_name in - match vars_of_ctx !evdref rhs_rels with + match vars_of_ctx sigma rhs_rels with [] -> bref | l -> DAst.make @@ GApp (bref, l) in @@ -2348,11 +2359,12 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = in incr i; let rhs = { eqn.rhs with it = Some branch } in - (branch_decl :: branches, + (sigma, branch_decl :: branches, { eqn with patterns = newpatterns; rhs = rhs } :: eqns, opats :: prevpatterns)) - ([], [], []) eqns - in x, y + (sigma, [], [], []) eqns + in + sigma, x, y (* Builds the predicate. If the predicate is dependent, its context is * made of 1+nrealargs assumptions for each matched term in an inductive @@ -2389,14 +2401,14 @@ let abstract_tomatch env sigma tomatchs tycon = ([], [], Id.Set.empty, tycon) tomatchs in List.rev prev, ctx, tycon -let build_dependent_signature env evdref avoid tomatchs arsign = +let build_dependent_signature env sigma avoid tomatchs arsign = let avoid = ref avoid in let arsign = List.rev arsign in let allnames = List.rev_map (List.map RelDecl.get_name) arsign in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in - let eqs, neqs, refls, slift, arsign' = + let sigma, eqs, neqs, refls, slift, arsign' = List.fold_left2 - (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> + (fun (sigma, eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> (* The accumulator: previous eqs, number of previous eqs, @@ -2412,49 +2424,56 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let appn = RelDecl.get_name app_decl in let appt = RelDecl.get_type app_decl in let argsign = List.rev argsign in (* arguments in application order *) - let env', nargeqs, argeqs, refl_args, slift, argsign' = + let sigma, env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 - (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> + (fun (sigma, env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> let name = RelDecl.get_name decl in let t = RelDecl.get_type decl in - let argt = Retyping.get_type_of env !evdref arg in - let eq, refl_arg = - if Reductionops.is_conv env !evdref argt t then - (mk_eq evdref (lift (nargeqs + slift) argt) - (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) arg), - mk_eq_refl evdref argt arg) + let argt = Retyping.get_type_of env sigma arg in + let sigma, eq, refl_arg = + if Reductionops.is_conv env sigma argt t then + let sigma, eq = + mk_eq sigma (lift (nargeqs + slift) argt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) arg) + in + let sigma, refl = mk_eq_refl sigma argt arg in + sigma, eq, refl else - (mk_JMeq evdref (lift (nargeqs + slift) t) - (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) argt) - (lift (nargeqs + nar) arg), - mk_JMeq_refl evdref argt arg) + let sigma, eq = + mk_JMeq sigma (lift (nargeqs + slift) t) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) argt) + (lift (nargeqs + nar) arg) + in + let sigma, refl = mk_JMeq_refl sigma argt arg in + (sigma, eq, refl) in let previd, id = let name = - match EConstr.kind !evdref arg with + match EConstr.kind sigma arg with Rel n -> RelDecl.get_name (lookup_rel n env) | _ -> name in make_prime avoid name in - (env, succ nargeqs, + (sigma, env, succ nargeqs, (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, RelDecl.set_name (Name id) decl :: argsign')) - (env, neqs, [], [], slift, []) args argsign + (sigma, env, neqs, [], [], slift, []) args argsign in - let eq = mk_JMeq evdref - (lift (nargeqs + slift) appt) - (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) ty) - (lift (nargeqs + nar) tm) + let sigma, eq = + mk_JMeq sigma + (lift (nargeqs + slift) appt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) ty) + (lift (nargeqs + nar) tm) in - let refl_eq = mk_JMeq_refl evdref ty tm in + let sigma, refl_eq = mk_JMeq_refl sigma ty tm in let previd, id = make_prime avoid appn in - ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, + (sigma, (LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, succ nargeqs, refl_eq :: refl_args, pred slift, @@ -2466,18 +2485,20 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let previd, id = make_prime avoid name in let arsign' = RelDecl.set_name (Name id) decl in let tomatch_ty = type_of_tomatch ty in - let eq = - mk_eq evdref (lift nar tomatch_ty) - (mkRel slift) (lift nar tm) - in - ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, - (mk_eq_refl evdref tomatch_ty tm) :: refl_args, - pred slift, (arsign' :: []) :: arsigns)) - ([], 0, [], nar, []) tomatchs arsign + let sigma, eq = + mk_eq sigma (lift nar tomatch_ty) + (mkRel slift) (lift nar tm) + in + let sigma, refl = mk_eq_refl sigma tomatch_ty tm in + (sigma, + [LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, + refl :: refl_args, + pred slift, (arsign' :: []) :: arsigns)) + (sigma, [], 0, [], nar, []) tomatchs arsign in let arsign'' = List.rev arsign' in assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *) - arsign'', allnames, nar, eqs, neqs, refls + sigma, arsign'', allnames, nar, eqs, neqs, refls let context_of_arsign l = let (x, _) = List.fold_right @@ -2486,55 +2507,57 @@ let context_of_arsign l = l ([], 0) in x -let compile_program_cases ?loc style (typing_function, evdref) tycon env +let compile_program_cases ?loc style (typing_function, sigma) tycon env (predopt, tomatchl, eqns) = - let typing_fun tycon env = function - | Some t -> typing_function tycon env evdref t - | None -> Evarutil.evd_comb0 use_unit_judge evdref in + let typing_fun tycon env sigma = function + | Some t -> typing_function tycon env sigma t + | None -> use_unit_judge sigma in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let env,tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in + let env, sigma, tomatchs = coerce_to_indtype typing_function env sigma matx tomatchl in let tycon = valcon_of_tycon tycon in - let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env !evdref tomatchs tycon in - let _,env = push_rel_context !evdref tomatchs_lets env in + let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env sigma tomatchs tycon in + let _,env = push_rel_context sigma tomatchs_lets env in let len = List.length eqns in - let sign, allnames, signlen, eqs, neqs, args = + let sigma, sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) let arsign = extract_arity_signature ~dolift:false !!env tomatchs tomatchl in (* Build the dependent arity signature, the equalities which makes the first part of the predicate and their instantiations. *) let avoid = Id.Set.empty in - build_dependent_signature !!env evdref avoid tomatchs arsign + build_dependent_signature !!env sigma avoid tomatchs arsign in - let tycon, arity = + let sigma, tycon, arity = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in match tycon' with - | None -> let ev = mkExistential !!env evdref in ev, lift nar ev + | None -> + let sigma, ev = mkExistential !!env sigma in + sigma, ev, lift nar ev | Some t -> - let pred = - match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with - | Some (evd, pred, arsign) -> evdref := evd; pred - | None -> - lift nar t - in Option.get tycon, pred + let sigma, pred = + match prepare_predicate_from_arsign_tycon env sigma loc tomatchs sign t with + | Some (evd, pred, arsign) -> evd, pred + | None -> sigma, lift nar t + in + sigma, Option.get tycon, pred in let neqs, arity = let ctx = context_of_arsign eqs in let neqs = List.length ctx in neqs, it_mkProd_or_LetIn (lift neqs arity) ctx in - let lets, matx = + let sigma, lets, matx = (* Type the rhs under the assumption of equations *) - constrs_of_pats typing_fun env evdref matx tomatchs sign neqs arity + constrs_of_pats typing_fun env sigma matx tomatchs sign neqs arity in let matx = List.rev matx in let _ = assert (Int.equal len (List.length lets)) in - let _,env = push_rel_context !evdref lets env in + let _,env = push_rel_context sigma lets env in let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in let args = List.rev_map (lift len) args in @@ -2550,30 +2573,29 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = - List.map (fun (c,d) -> (c,extract_inductive_data !!env !evdref d,d)) typs in + List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in let dep_sign = - find_dependencies_signature !evdref + find_dependencies_signature sigma (List.make (List.length typs) true) typs in let typs' = List.map3 (fun (tm,tmt) deps (na,realnames) -> - let deps = if not (isRel !evdref tm) then [] else deps in + let deps = if not (isRel sigma tm) then [] else deps in let tmt = set_tomatch_realnames realnames tmt in ((tm,tmt),deps,na)) tomatchs dep_sign nal in let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in - let typing_function tycon env evdref = function - | Some t -> typing_function tycon env evdref t - | None -> evd_comb0 use_unit_judge evdref in + let typing_function tycon env sigma = function + | Some t -> typing_function tycon env sigma t + | None -> use_unit_judge sigma in let pb = { env = env; - evdref = evdref; pred = pred; tomatch = initial_pushed; history = start_history (List.length initial_pushed); @@ -2582,22 +2604,22 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env casestyle= style; typing_function = typing_function } in - let j = compile pb in + let sigma, j = compile sigma pb in (* We check for unused patterns *) List.iter (check_unused_pattern !!env) matx; let body = it_mkLambda_or_LetIn (applist (j.uj_val, args)) lets in let j = { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; (* XXX: is this normalization needed? *) - uj_type = Evarutil.nf_evar !evdref tycon; } - in j + uj_type = Evarutil.nf_evar sigma tycon; } + in sigma, j (**************************************************************************) (* Main entry of the matching compilation *) -let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = +let compile_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, eqns) = if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then - compile_program_cases ?loc style (typing_fun, evdref) + compile_program_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, eqns) else @@ -2606,13 +2628,13 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let predenv,tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in + let predenv, sigma, tomatchs = coerce_to_indtype typing_fun env sigma matx tomatchl in (* If an elimination predicate is provided, we check it is compatible with the type of arguments to match; if none is provided, we build alternative possible predicates *) let arsign = extract_arity_signature !!env tomatchs tomatchl in - let preds = prepare_predicate ?loc typing_fun predenv !evdref tomatchs arsign tycon predopt in + let preds = prepare_predicate ?loc typing_fun predenv sigma tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) @@ -2628,14 +2650,14 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in let dep_sign = - find_dependencies_signature !evdref + find_dependencies_signature sigma (List.make (List.length typs) true) typs in let typs' = List.map3 (fun (tm,tmt) deps (na,realnames) -> - let deps = if not (isRel !evdref tm) then [] else deps in + let deps = if not (isRel sigma tm) then [] else deps in let tmt = set_tomatch_realnames realnames tmt in ((tm,tmt),deps,na)) tomatchs dep_sign nal in @@ -2643,15 +2665,12 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in (* A typing function that provides with a canonical term for absurd cases*) - let typing_fun tycon env evdref = function - | Some t -> typing_fun tycon env evdref t - | None -> evd_comb0 use_unit_judge evdref in - - let myevdref = ref sigma in + let typing_fun tycon env sigma = function + | Some t -> typing_fun tycon env sigma t + | None -> use_unit_judge sigma in let pb = { env = env; - evdref = myevdref; pred = pred; tomatch = initial_pushed; history = start_history (List.length initial_pushed); @@ -2660,12 +2679,11 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, casestyle = style; typing_function = typing_fun } in - let j = compile pb in + let sigma, j = compile sigma pb in (* We coerce to the tycon (if an elim predicate was provided) *) - let j = inh_conv_coerce_to_tycon ?loc !!env myevdref j tycon in - evdref := !myevdref; - j in + inh_conv_coerce_to_tycon ?loc !!env sigma j tycon + in (* Return the term compiled with the first possible elimination *) (* predicate for which the compilation succeeds *) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 76b81a58c1..36cfa0a70d 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -41,18 +41,18 @@ val irrefutable : env -> cases_pattern -> bool val compile_cases : ?loc:Loc.t -> case_style -> - (type_constraint -> GlobEnv.t -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref -> + (type_constraint -> GlobEnv.t -> evar_map -> glob_constr -> evar_map * unsafe_judgment) * evar_map -> type_constraint -> GlobEnv.t -> glob_constr option * tomatch_tuples * cases_clauses -> - unsafe_judgment + evar_map * unsafe_judgment val constr_of_pat : Environ.env -> - Evd.evar_map ref -> + Evd.evar_map -> rel_context -> Glob_term.cases_pattern -> Names.Id.Set.t -> - Glob_term.cases_pattern * + Evd.evar_map * Glob_term.cases_pattern * (rel_context * constr * (types * constr list) * Glob_term.cases_pattern) * Names.Id.Set.t @@ -103,20 +103,19 @@ and pattern_continuation = type 'a pattern_matching_problem = { env : GlobEnv.t; - evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; history : pattern_continuation; mat : 'a matrix; caseloc : Loc.t option; casestyle : case_style; - typing_function: type_constraint -> GlobEnv.t -> evar_map ref -> 'a option -> unsafe_judgment } + typing_function: type_constraint -> GlobEnv.t -> evar_map -> 'a option -> evar_map * unsafe_judgment } -val compile : 'a pattern_matching_problem -> unsafe_judgment +val compile : evar_map -> 'a pattern_matching_problem -> evar_map * unsafe_judgment val prepare_predicate : ?loc:Loc.t -> (type_constraint -> - GlobEnv.t -> Evd.evar_map ref -> glob_constr -> unsafe_judgment) -> + GlobEnv.t -> Evd.evar_map -> glob_constr -> Evd.evar_map * unsafe_judgment) -> GlobEnv.t -> Evd.evar_map -> (types * tomatch_type) list -> diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index fc24e9b3a9..265909980b 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -187,7 +187,7 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> debug_cbv:=a); } -let pr_key = function +let debug_pr_key = function | ConstKey (sp,_) -> Names.Constant.print sp | VarKey id -> Names.Id.print id | RelKey n -> Pp.(str "REL_" ++ int n) @@ -320,14 +320,14 @@ and norm_head_ref k info env stack normt = if red_set_ref (info_flags info.infos) normt then match ref_value_cache info.infos info.tab normt with | Some body -> - if !debug_cbv then Feedback.msg_debug Pp.(str "Unfolding " ++ pr_key normt); + if !debug_cbv then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); strip_appl (shift_value k body) stack | None -> - if !debug_cbv then Feedback.msg_debug Pp.(str "Not unfolding " ++ pr_key normt); + if !debug_cbv then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); (VAL(0,make_constr_ref k normt),stack) else begin - if !debug_cbv then Feedback.msg_debug Pp.(str "Not unfolding " ++ pr_key normt); + if !debug_cbv then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); (VAL(0,make_constr_ref k normt),stack) end diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 6c52dacaa9..7d480b8d48 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -588,7 +588,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ())) in + Feedback.msg_notice (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in match (flex_kind_of_term (fst ts) env evd term1 sk1, flex_kind_of_term (fst ts) env evd term2 sk2) with | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> @@ -1225,8 +1225,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ print_constr t1 - ++ cut () ++ print_constr t2 ++ cut ())) in + Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ + Termops.Internal.print_constr_env env evd t1 ++ cut () ++ + Termops.Internal.print_constr_env env evd t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar (evk1,args1), (Rel _|Var _) when app_empty diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index b452755b10..571be7466c 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -201,4 +201,4 @@ let lift_tycon n = Option.map (lift n) let pr_tycon env sigma = function None -> str "None" - | Some t -> Termops.print_constr_env env sigma t + | Some t -> Termops.Internal.print_constr_env env sigma t diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 12788e5ec5..63a66b471b 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -55,16 +55,16 @@ let env env = env.static_env let vars_of_env env = Id.Set.union (Id.Map.domain env.lvar.ltac_genargs) (vars_of_env env.static_env) -let ltac_interp_name { ltac_idents ; ltac_genargs } = function - | Anonymous -> Anonymous - | Name id as na -> - try Name (Id.Map.find id ltac_idents) - with Not_found -> - if Id.Map.mem id ltac_genargs then - user_err (str "Ltac variable" ++ spc () ++ Id.print id ++ - spc () ++ str "is not bound to an identifier." ++ - spc () ++str "It cannot be used in a binder.") - else na +let ltac_interp_id { ltac_idents ; ltac_genargs } id = + try Id.Map.find id ltac_idents + with Not_found -> + if Id.Map.mem id ltac_genargs then + user_err (str "Ltac variable" ++ spc () ++ Id.print id ++ + spc () ++ str "is not bound to an identifier." ++ + spc () ++str "It cannot be used in a binder.") + else id + +let ltac_interp_name lvar = Nameops.Name.map (ltac_interp_id lvar) let push_rel sigma d env = let d' = Context.Rel.Declaration.map_name (ltac_interp_name env.lvar) d in @@ -140,7 +140,7 @@ let protected_get_type_of env sigma c = try Retyping.get_type_of ~lax:true env sigma c with Retyping.RetypeError _ -> user_err - (str "Cannot reinterpret " ++ quote (print_constr c) ++ + (str "Cannot reinterpret " ++ quote (Termops.Internal.print_constr_env env sigma c) ++ str " in the current environment.") let invert_ltac_bound_name env id0 id = @@ -182,6 +182,8 @@ let interp_ltac_variable ?loc typing_fun env sigma id = end; raise Not_found +let interp_ltac_id env id = ltac_interp_id env.lvar id + module ConstrInterpObj = struct type ('r, 'g, 't) obj = diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 4038523211..70a7ee6e2f 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -76,6 +76,11 @@ val hide_variable : t -> Name.t -> Id.t -> t val interp_ltac_variable : ?loc:Loc.t -> (t -> Glob_term.glob_constr -> unsafe_judgment) -> t -> evar_map -> Id.t -> unsafe_judgment +(** Interp an identifier as an ltac variable bound to an identifier, + or as the identifier itself if not bound to an ltac variable *) + +val interp_ltac_id : t -> Id.t -> Id.t + (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index dc900ab814..418fdf2a26 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -40,7 +40,7 @@ type recursion_scheme_error = | NotMutualInScheme of inductive * inductive | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive -exception RecursionSchemeError of recursion_scheme_error +exception RecursionSchemeError of env * recursion_scheme_error let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na let name_assumption env = function @@ -86,7 +86,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = if not (Sorts.List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (false, fst (UnivGen.fresh_sort_in_family kind), pind))) + (env, NotAllowedCaseAnalysis (false, fst (UnivGen.fresh_sort_in_family kind), pind))) in let ndepar = mip.mind_nrealdecls + 1 in @@ -490,7 +490,7 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = let build_case_analysis_scheme env sigma pity dep kind = let (mib,mip) = lookup_mind_specif env (fst pity) in if dep && not (Inductiveops.has_dependent_elim mib) then - raise (RecursionSchemeError (NotAllowedDependentAnalysis (false, fst pity))); + raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (false, fst pity))); mis_make_case_com dep env sigma pity (mib,mip) kind let is_in_prop mip = @@ -550,9 +550,9 @@ let check_arities env listdepkind = let kelim = elim_sorts (mibi,mipi) in if not (Sorts.List.mem kind kelim) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (true, fst (UnivGen.fresh_sort_in_family kind),(mind,u)))) + (env, NotAllowedCaseAnalysis (true, fst (UnivGen.fresh_sort_in_family kind),(mind,u)))) else if Int.List.mem ni ln then raise - (RecursionSchemeError (NotMutualInScheme (mind,mind))) + (RecursionSchemeError (env, NotMutualInScheme (mind,mind))) else ni::ln) [] listdepkind in true @@ -561,7 +561,7 @@ let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function | ((mind,u),dep,s)::lrecspec -> let (mib,mip) = lookup_mind_specif env mind in if dep && not (Inductiveops.has_dependent_elim mib) then - raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, mind))); + raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (true, mind))); let (sp,tyi) = mind in let listdepkind = ((mind,u),mib,mip,dep,s):: @@ -572,7 +572,7 @@ let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function let (mibi',mipi') = lookup_mind_specif env mind' in ((mind',u'),mibi',mipi',dep',s') else - raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) + raise (RecursionSchemeError (env, NotMutualInScheme (mind,mind')))) lrecspec) in let _ = check_arities env listdepkind in @@ -582,7 +582,7 @@ let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function let build_induction_scheme env sigma pind dep kind = let (mib,mip) = lookup_mind_specif env (fst pind) in if dep && not (Inductiveops.has_dependent_elim mib) then - raise (RecursionSchemeError (NotAllowedDependentAnalysis (true, fst pind))); + raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (true, fst pind))); let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in sigma, List.hd l diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index de9d3a0abf..91a5651f7f 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -20,7 +20,7 @@ type recursion_scheme_error = | NotMutualInScheme of inductive * inductive | NotAllowedDependentAnalysis of (*isrec:*) bool * inductive -exception RecursionSchemeError of recursion_scheme_error +exception RecursionSchemeError of env * recursion_scheme_error (** Eliminations *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index ec0ff73062..0fa573b9a6 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -358,7 +358,7 @@ let make_case_or_project env sigma indf ci pred c branches = not (has_dependent_elim mib) then user_err ~hdr:"make_case_or_project" Pp.(str"Dependent case analysis not allowed" ++ - str" on inductive type " ++ Names.MutInd.print (fst ind)) + str" on inductive type " ++ Termops.Internal.print_constr_env env sigma (mkInd ind)) in let branch = branches.(0) in let ctx, br = decompose_lam_n_assum sigma (Array.length ps) branch in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index d10c00fa6e..162adf0626 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -480,6 +480,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref | GEvar (id, inst) -> (* Ne faudrait-il pas s'assurer que hyps est bien un sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) + let id = interp_ltac_id env id in let evk = try Evd.evar_key id !evdref with Not_found -> @@ -499,6 +500,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } | GHole (k, naming, None) -> + let open Namegen in + let naming = match naming with + | IntroIdentifier id -> IntroIdentifier (interp_ltac_id env id) + | IntroAnonymous -> IntroAnonymous + | IntroFresh id -> IntroFresh (interp_ltac_id env id) in let ty = match tycon with | Some ty -> ty @@ -913,7 +919,15 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref inh_conv_coerce_to_tycon ?loc env evdref cj tycon | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc sty (pretype,evdref) tycon env (po,tml,eqns) + let pretype tycon env sigma c = + let evdref = ref sigma in + let t = pretype tycon env evdref c in + !evdref, t + in + let sigma = !evdref in + let sigma, j = Cases.compile_cases ?loc sty (pretype, sigma) tycon env (po,tml,eqns) in + let () = evdref := sigma in + j | GCast (c,k) -> let cj = @@ -960,20 +974,50 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref and pretype_instance k0 resolve_tc env evdref loc hyps evk update = let f decl (subst,update) = let id = NamedDecl.get_id decl in + let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in let t = replace_vars subst (NamedDecl.get_type decl) in + let check_body id c = + match b, c with + | Some b, Some c -> + if not (is_conv !!env !evdref b c) then + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key !evdref evk ++ + strbrk " in current context: binding for " ++ Id.print id ++ + strbrk " is not convertible to its expected definition (cannot unify " ++ + quote (Termops.Internal.print_constr_env !!env !evdref b) ++ + strbrk " and " ++ + quote (Termops.Internal.print_constr_env !!env !evdref c) ++ + str ").") + | Some b, None -> + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key !evdref evk ++ + strbrk " in current context: " ++ Id.print id ++ + strbrk " should be bound to a local definition.") + | None, _ -> () in + let check_type id t' = + if not (is_conv !!env !evdref t t') then + user_err ?loc (str "Cannot interpret " ++ + pr_existential_key !evdref evk ++ + strbrk " in current context: binding for " ++ Id.print id ++ + strbrk " is not well-typed.") in let c, update = try let c = List.assoc id update in let c = pretype k0 resolve_tc (mk_tycon t) env evdref c in + check_body id (Some c.uj_val); c.uj_val, List.remove_assoc id update with Not_found -> try - let (n,_,t') = lookup_rel_id id (rel_context !!env) in - if is_conv !!env !evdref t (lift n t') then mkRel n, update else raise Not_found + let (n,b',t') = lookup_rel_id id (rel_context !!env) in + check_type id (lift n t'); + check_body id (Option.map (lift n) b'); + mkRel n, update with Not_found -> try - let t' = !!env |> lookup_named id |> NamedDecl.get_type in - if is_conv !!env !evdref t t' then mkVar id, update else raise Not_found + let decl = lookup_named id !!env in + check_type id (NamedDecl.get_type decl); + check_body id (NamedDecl.get_value decl); + mkVar id, update with Not_found -> user_err ?loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index bd41e61b34..c25416405e 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -229,7 +229,7 @@ let warn_projection_no_head_constant = let env = Termops.push_rels_assum sign env in let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) in let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in - let term_pp = Termops.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in + let term_pp = Termops.Internal.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in strbrk "Projection value has no head constant: " ++ term_pp ++ strbrk " in canonical instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") @@ -295,8 +295,12 @@ let add_canonical_structure warn o = in match ocs with | None -> object_table := GlobRef.Map.add proj ((pat,s)::l) !object_table; | Some (c, cs) -> - let old_can_s = (Termops.print_constr (EConstr.of_constr cs.o_DEF)) - and new_can_s = (Termops.print_constr (EConstr.of_constr s.o_DEF)) in + (* XXX: Undesired global access to env *) + let env = Global.env () in + let sigma = Evd.from_env env in + let old_can_s = (Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF)) + and new_can_s = (Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF)) + in let prj = (Nametab.pr_global_env Id.Set.empty proj) and hd_val = (pr_cs_pattern cs_pat) in if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s)) @@ -334,19 +338,19 @@ let error_not_structure ref description = user_err ~hdr:"object_declare" (str"Could not declare a canonical structure " ++ (Id.print (basename_of_global ref) ++ str"." ++ spc() ++ - str(description))) + description)) let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp - | _ -> error_not_structure ref "Expected an instance of a record or structure." + | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in let env = Global.env () in let u = Univ.make_abstract_instance (Environ.constant_context env sp) in let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc - | None -> error_not_structure ref "Could not find its value in the global environment." in + | None -> error_not_structure ref (str "Could not find its value in the global environment.") in let env = Global.env () in let evd = Evd.from_env env in let body = snd (splay_lam (Global.env()) evd (EConstr.of_constr vc)) in @@ -354,18 +358,18 @@ let check_and_decompose_canonical_structure ref = let f,args = match kind body with | App (f,args) -> f,args | _ -> - error_not_structure ref "Expected a record or structure constructor applied to arguments." in + error_not_structure ref (str "Expected a record or structure constructor applied to arguments.") in let indsp = match kind f with | Construct ((indsp,1),u) -> indsp - | _ -> error_not_structure ref "Expected an instance of a record or structure." in + | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in let s = try lookup_structure indsp with Not_found -> error_not_structure ref - ("Could not find the record or structure " ^ (MutInd.to_string (fst indsp))) in + (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env evd (EConstr.mkInd indsp)) in let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then - error_not_structure ref "Got too few arguments to the record or structure constructor."; + error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (sp,indsp) let declare_canonical_structure ref = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index f4c8a6cd66..e8c3b3e2b3 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -254,9 +254,9 @@ module Cst_stack = struct (applist (cst, List.rev params)) t) cst_l c - let pr l = + let pr env sigma l = let open Pp in - let p_c c = Termops.print_constr c in + let p_c c = Termops.Internal.print_constr_env env sigma c in prlist_with_sep pr_semicolon (fun (c,params,args) -> hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++ @@ -341,6 +341,7 @@ struct | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list + (* Debugging printer *) let rec pr_member pr_c member = let open Pp in let pr_c x = hov 1 (pr_c x) in @@ -351,7 +352,7 @@ struct prvect_with_sep (pr_bar) pr_c br ++ str ")" | Proj (p,cst) -> - str "ZProj(" ++ Constant.print (Projection.constant p) ++ str ")" + str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix pr_c f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -368,11 +369,11 @@ struct let open Pp in match c with | Cst_const (c, u) -> - if Univ.Instance.is_empty u then Constant.print c - else str"(" ++ Constant.print c ++ str ", " ++ + if Univ.Instance.is_empty u then Constant.debug_print c + else str"(" ++ Constant.debug_print c ++ str ", " ++ Univ.Instance.pr Univ.Level.pr u ++ str")" | Cst_proj p -> - str".(" ++ Constant.print (Projection.constant p) ++ str")" + str".(" ++ Constant.debug_print (Projection.constant p) ++ str")" let empty = [] let is_empty = CList.is_empty @@ -614,9 +615,9 @@ type contextual_state_reduction_function = type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state -let pr_state (tm,sk) = +let pr_state env sigma (tm,sk) = let open Pp in - let pr c = Termops.print_constr c in + let pr c = Termops.Internal.print_constr_env env sigma c in h 0 (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) (*************************************) @@ -854,10 +855,10 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then let open Pp in - let pr c = Termops.print_constr c in + let pr c = Termops.Internal.print_constr_env env sigma c in Feedback.msg_notice (h 0 (str "<<" ++ pr x ++ - str "|" ++ cut () ++ Cst_stack.pr cst_l ++ + str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ str ">>")) in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index dd3cd26f0f..c0ff6723f6 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -60,7 +60,7 @@ module Cst_stack : sig val best_cst : t -> (constr * constr list) option val best_replace : Evd.evar_map -> constr -> t -> constr -> constr val reference : Evd.evar_map -> t -> Constant.t option - val pr : t -> Pp.t + val pr : env -> Evd.evar_map -> t -> Pp.t end module Stack : sig @@ -140,7 +140,7 @@ type contextual_state_reduction_function = type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state -val pr_state : state -> Pp.t +val pr_state : env -> evar_map -> state -> Pp.t (** {6 Reduction Function Operators } *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index fc1f6fc81e..e223674579 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -684,8 +684,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and cN = Evarutil.whd_head_evar sigma curn in let () = if !debug_unification then - Feedback.msg_debug (print_constr_env curenv sigma cM ++ str" ~= " ++ print_constr_env curenv sigma cN) - in + Feedback.msg_debug ( + Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ + Termops.Internal.print_constr_env curenv sigma cN) + in match (EConstr.kind sigma cM, EConstr.kind sigma cN) with | Meta k1, Meta k2 -> if Int.equal k1 k2 then substn else diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 9ed985195f..66f748454d 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -71,17 +71,17 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref udecl = - let typ, ctx = Global.type_of_global_in_context (Global.env ()) ref in - let typ = Vars.subst_instance_constr (Univ.AUContext.instance ctx) typ in + let typ, univs = Global.type_of_global_in_context (Global.env ()) ref in + let inst = Univ.make_abstract_instance univs in + let bl = UnivNames.universe_binders_with_opt_names ref udecl in + let sigma = Evd.from_ctx (UState.of_binders bl) in let typ = EConstr.of_constr typ in let typ = if reduce then let env = Global.env () in - let sigma = Evd.from_env env in let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in - let univs = Global.universes_of_global ref in let variance = match ref with | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> @@ -91,19 +91,14 @@ let print_ref reduce ref udecl = | Declarations.Cumulative_ind cumi -> Some (Univ.ACumulativityInfo.variance cumi) end in - let inst = Univ.AUContext.instance univs in - let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in let env = Global.env () in - let bl = UnivNames.universe_binders_with_opt_names ref - (Array.to_list (Univ.Instance.to_array inst)) udecl in - let sigma = Evd.from_ctx (UState.of_binders bl) in let inst = if Global.is_polymorphic ref - then Printer.pr_universe_instance sigma (Univ.UContext.instance univs) + then Printer.pr_universe_instance sigma inst else mt () in hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ - Printer.pr_universe_ctx sigma ?variance univs) + Printer.pr_abstract_universe_ctx sigma ?variance univs) (********************************) (** Printing implicit arguments *) @@ -552,48 +547,31 @@ let print_typed_body env evd (val_0,typ) = let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then let univs = Declareops.constant_polymorphic_context cb in - let inst = Univ.AUContext.instance univs in + let inst = Univ.make_abstract_instance univs in pr_universe_instance sigma inst else mt() let print_constant with_values sep sp udecl = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in - let typ = - match cb.const_universes with - | Monomorphic_const _ -> cb.const_type - | Polymorphic_const univs -> - let inst = Univ.AUContext.instance univs in - Vars.subst_instance_constr inst cb.const_type - in - let univs, ulist = - let open Entries in + let typ = cb.const_type in + let univs = let open Univ in let otab = Global.opaque_tables () in match cb.const_body with - | Undef _ | Def _ -> - begin - match cb.const_universes with - | Monomorphic_const ctx -> Monomorphic_const_entry ctx, [] - | Polymorphic_const ctx -> - let inst = AUContext.instance ctx in - Polymorphic_const_entry (UContext.make (inst, AUContext.instantiate inst ctx)), - Array.to_list (Instance.to_array inst) - end + | Undef _ | Def _ -> cb.const_universes | OpaqueDef o -> let body_uctxs = Opaqueproof.force_constraints otab o in match cb.const_universes with | Monomorphic_const ctx -> - Monomorphic_const_entry (ContextSet.union body_uctxs ctx), [] + Monomorphic_const (ContextSet.union body_uctxs ctx) | Polymorphic_const ctx -> assert(ContextSet.is_empty body_uctxs); - let inst = AUContext.instance ctx in - Polymorphic_const_entry (UContext.make (inst, AUContext.instantiate inst ctx)), - Array.to_list (Instance.to_array inst) + Polymorphic_const ctx in let ctx = UState.of_binders - (UnivNames.universe_binders_with_opt_names (ConstRef sp) ulist udecl) + (UnivNames.universe_binders_with_opt_names (ConstRef sp) udecl) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in @@ -605,7 +583,6 @@ let print_constant with_values sep sp udecl = str" ]" ++ Printer.pr_constant_universes sigma univs | Some (c, ctx) -> - let c = Vars.subst_instance_constr (Univ.AUContext.instance ctx) c in print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ Printer.pr_constant_universes sigma univs) @@ -712,11 +689,6 @@ let print_eval x = !object_pr.print_eval x (**** Printing declarations and judgments *) (**** Abstract layer *****) -let print_typed_value x = - let env = Global.env () in - let sigma = Evd.from_env env in - print_typed_value_in_env env sigma x - let print_judgment env sigma {uj_val=trm;uj_type=typ} = print_typed_value_in_env env sigma (trm, typ) @@ -852,11 +824,9 @@ let print_opaque_name env sigma qid = print_inductive sp None | ConstructRef cstr as gr -> let ty, ctx = Global.type_of_global_in_context env gr in - let inst = Univ.AUContext.instance ctx in - let ty = Vars.subst_instance_constr inst ty in let ty = EConstr.of_constr ty in let open EConstr in - print_typed_value (mkConstruct cstr, ty) + print_typed_value_in_env env sigma (mkConstruct cstr, ty) | VarRef id -> env |> lookup_named id |> print_named_decl env sigma diff --git a/printing/printer.ml b/printing/printer.ml index 67d71332b0..6cd4daa374 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -192,7 +192,7 @@ let pr_constr_pattern t = let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) -let _ = Termops.set_print_constr +let _ = Termops.Internal.set_print_constr (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma t)) let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" @@ -270,9 +270,16 @@ let pr_universe_ctx sigma ?variance c = else mt() +let pr_abstract_universe_ctx sigma ?variance c = + if !Detyping.print_universes && not (Univ.AUContext.is_empty c) then + fnl()++pr_in_comment (fun c -> v 0 + (Univ.pr_abstract_universe_context (Termops.pr_evd_level sigma) ?variance c)) c + else + mt() + let pr_constant_universes sigma = function - | Entries.Monomorphic_const_entry ctx -> pr_universe_ctx_set sigma ctx - | Entries.Polymorphic_const_entry ctx -> pr_universe_ctx sigma ctx + | Declarations.Monomorphic_const ctx -> pr_universe_ctx_set sigma ctx + | Declarations.Polymorphic_const ctx -> pr_abstract_universe_ctx sigma ctx let pr_cumulativity_info sigma cumi = if !Detyping.print_universes @@ -282,6 +289,14 @@ let pr_cumulativity_info sigma cumi = else mt() +let pr_abstract_cumulativity_info sigma cumi = + if !Detyping.print_universes + && not (Univ.AUContext.is_empty (Univ.ACumulativityInfo.univ_context cumi)) then + fnl()++pr_in_comment (fun uii -> v 0 + (Univ.pr_abstract_cumulativity_info (Termops.pr_evd_level sigma) uii)) cumi + else + mt() + (**********************************************************************) (* Global references *) @@ -944,9 +959,16 @@ let pr_assumptionset env sigma s = let safe_pr_constant env kn = try pr_constant env kn with Not_found -> + (* FIXME? *) let mp,_,lab = Constant.repr3 kn in str (ModPath.to_string mp) ++ str "." ++ Label.print lab in + let safe_pr_inductive env kn = + try pr_inductive env (kn,0) + with Not_found -> + (* FIXME? *) + MutInd.print kn + in let safe_pr_ltype env sigma typ = try str " : " ++ pr_ltype_env env sigma typ with e when CErrors.noncritical e -> mt () @@ -961,7 +983,7 @@ let pr_assumptionset env sigma s = | Constant kn -> safe_pr_constant env kn ++ safe_pr_ltype env sigma typ | Positive m -> - hov 2 (MutInd.print m ++ spc () ++ strbrk"is positive.") + hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is positive.") | Guarded kn -> hov 2 (safe_pr_constant env kn ++ spc () ++ strbrk"is positive.") in diff --git a/printing/printer.mli b/printing/printer.mli index 518c5b930b..96db7091a6 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -123,9 +123,12 @@ val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t +val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> + Univ.AUContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t -val pr_constant_universes : evar_map -> Entries.constant_universes_entry -> Pp.t +val pr_constant_universes : evar_map -> Declarations.constant_universes -> Pp.t val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t +val pr_abstract_cumulativity_info : evar_map -> Univ.ACumulativityInfo.t -> Pp.t (** Printing global references using names as short as possible *) diff --git a/printing/printmod.ml b/printing/printmod.ml index e2d9850bf8..1fc308ac99 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -90,9 +90,7 @@ let build_ind_type env mip = Inductive.type_of_inductive env mip let print_one_inductive env sigma mib ((_,i) as ind) = - let u = if Declareops.inductive_is_polymorphic mib then - Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) - else Univ.Instance.empty in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in let nparamdecls = Context.Rel.length params in @@ -111,16 +109,6 @@ let print_one_inductive env sigma mib ((_,i) as ind) = str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ str " :=") ++ brk(0,2) ++ print_constructors envpar sigma mip.mind_consnames cstrtypes -let instantiate_cumulativity_info cumi = - let open Univ in - let univs = ACumulativityInfo.univ_context cumi in - let expose ctx = - let inst = AUContext.instance ctx in - let cst = AUContext.instantiate inst ctx in - UContext.make (inst, cst) - in - CumulativityInfo.make (expose univs, ACumulativityInfo.variance cumi) - let print_mutual_inductive env mind mib udecl = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in @@ -131,14 +119,7 @@ let print_mutual_inductive env mind mib udecl = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in - let univs = - let open Univ in - if Declareops.inductive_is_polymorphic mib then - Array.to_list (Instance.to_array - (AUContext.instance (Declareops.inductive_polymorphic_context mib))) - else [] - in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) univs udecl in + let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ Printer.pr_cumulative @@ -150,8 +131,7 @@ let print_mutual_inductive env mind mib udecl = match mib.mind_universes with | Monomorphic_ind _ | Polymorphic_ind _ -> str "" | Cumulative_ind cumi -> - Printer.pr_cumulativity_info - sigma (instantiate_cumulativity_info cumi)) + Printer.pr_abstract_cumulativity_info sigma cumi) let get_fields = let rec prodec_rec l subst c = @@ -167,11 +147,7 @@ let get_fields = prodec_rec [] [] let print_record env mind mib udecl = - let u = - if Declareops.inductive_is_polymorphic mib then - Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) - else Univ.Instance.empty - in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let mip = mib.mind_packets.(0) in let params = Inductive.inductive_paramdecls (mib,u) in let nparamdecls = Context.Rel.length params in @@ -181,8 +157,7 @@ let print_record env mind mib udecl = let cstrtype = hnf_prod_applist_assum env nparamdecls cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) - (Array.to_list (Univ.Instance.to_array u)) udecl in + let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let keyword = let open Declarations in @@ -210,8 +185,7 @@ let print_record env mind mib udecl = match mib.mind_universes with | Monomorphic_ind _ | Polymorphic_ind _ -> str "" | Cumulative_ind cumi -> - Printer.pr_cumulativity_info - sigma (instantiate_cumulativity_info cumi) + Printer.pr_abstract_cumulativity_info sigma cumi ) let pr_mutual_inductive_body env mind mib udecl = @@ -315,12 +289,6 @@ let print_body is_impl env mp (l,body) = | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name | SFBconst cb -> let ctx = Declareops.constant_polymorphic_context cb in - let u = - if Declareops.constant_is_polymorphic cb then - Univ.AUContext.instance ctx - else Univ.Instance.empty - in - let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in (match cb.const_body with | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () @@ -328,18 +296,17 @@ let print_body is_impl env mp (l,body) = (match env with | None -> mt () | Some env -> + let bl = UnivNames.universe_binders_with_opt_names (ConstRef (Constant.make2 mp l)) None in + let sigma = Evd.from_ctx (UState.of_binders bl) in str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env (Evd.from_env env) - (Vars.subst_instance_constr u - cb.const_type)) ++ + hov 0 (Printer.pr_ltype_env env sigma cb.const_type) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ hov 2 (str ":= " ++ - Printer.pr_lconstr_env env (Evd.from_env env) - (Vars.subst_instance_constr u (Mod_subst.force_constr l))) + Printer.pr_lconstr_env env sigma (Mod_subst.force_constr l)) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx (Evd.from_env env) ctx) + Printer.pr_abstract_universe_ctx sigma ctx) | SFBmind mib -> try let env = Option.get env in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 79b7e1599b..95e908c4dd 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -575,8 +575,8 @@ let make_clenv_binding env sigma = make_clenv_binding_gen false None env sigma let pr_clenv clenv = h 0 - (str"TEMPL: " ++ print_constr clenv.templval.rebus ++ - str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++ + (str"TEMPL: " ++ Termops.Internal.print_constr_env clenv.env clenv.evd clenv.templval.rebus ++ + str" : " ++ Termops.Internal.print_constr_env clenv.env clenv.evd clenv.templtyp.rebus ++ fnl () ++ pr_evar_map (Some 2) clenv.evd) (****************************************************************) diff --git a/proofs/logic.ml b/proofs/logic.ml index e8ca719932..613581ade7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -62,6 +62,7 @@ let is_unification_error = function let catchable_exception = function | CErrors.UserError _ | TypeError _ + | Notation.NumeralNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 092bb5c276..182b38d350 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -127,8 +127,8 @@ open Pp let db_pr_goal sigma g = let env = Goal.V82.env sigma g in - let penv = print_named_context env in - let pc = print_constr_env env sigma (Goal.V82.concl sigma g) in + let penv = Termops.Internal.print_named_context env in + let pc = Termops.Internal.print_constr_env env sigma (Goal.V82.concl sigma g) in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () diff --git a/stm/stm.ml b/stm/stm.ml index 635bf9bf31..b7ba163309 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2009,7 +2009,7 @@ end = struct (* {{{ *) 1 goals in TaskQueue.join queue; let assign_tac : unit Proofview.tactic = - Proofview.(Goal.nf_enter begin fun g -> + Proofview.(Goal.enter begin fun g -> let gid = Goal.goal g in let f = try List.assoc gid res @@ -2301,7 +2301,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `Leaks -> Exninfo.iraise exn | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin let tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> if CList.mem_f Evar.equal (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index c8fd0b7a75..8e296de617 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -162,7 +162,7 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids end) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 9c5fdcd1ce..f3581f17dd 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -416,7 +416,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm if get_typeclasses_filtered_unification () then let tac = matches_pattern concl p <*> - Proofview.Goal.nf_enter + Proofview.Goal.enter (fun gl -> unify_resolve_refine poly flags gl (c,None,clenv)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else @@ -693,8 +693,9 @@ module Search = struct let msg = match fst ie with | Pretype_errors.PretypeError (env, evd, Pretype_errors.CannotUnify (x,y,_)) -> - str"Cannot unify " ++ print_constr_env env evd x ++ str" and " ++ - print_constr_env env evd y + str"Cannot unify " ++ + Printer.pr_econstr_env env evd x ++ str" and " ++ + Printer.pr_econstr_env env evd y | ReachedLimitEx -> str "Proof-search reached its limit." | NoApplicableEx -> str "Proof-search failed." | e -> CErrors.iprint ie diff --git a/tactics/equality.ml b/tactics/equality.ml index 0e39215701..d0f4b2c680 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -249,7 +249,7 @@ let rewrite_elim with_evars frzevars cls c e = let tclNOTSAMEGOAL tac = let goal gl = Proofview.Goal.goal gl in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let ev = goal gl in tac >>= fun () -> diff --git a/tactics/inv.ml b/tactics/inv.ml index 43786c8e19..f718b13a63 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -495,7 +495,7 @@ let raw_inversion inv_kind id status names = (* Error messages of the inversion tactics *) let wrap_inv_error id = function (e, info) -> match e with | Indrec.RecursionSchemeError - (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Set as k),i)) -> + (_, Indrec.NotAllowedCaseAnalysis (_,(Type _ | Set as k),i)) -> Proofview.tclENV >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> tclZEROMSG ( diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 837865e644..596feeec8b 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -655,12 +655,11 @@ module New = struct | _ -> let name_elim = match EConstr.kind sigma elim with - | Const (kn, _) -> Constant.to_string kn - | Var id -> Id.to_string id - | _ -> "\b" + | Const _ | Var _ -> str " " ++ Printer.pr_econstr_env (pf_env gl) sigma elim + | _ -> mt () in user_err ~hdr:"Tacticals.general_elim_then_using" - (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") + (str "The elimination combinator " ++ name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in let branchsigns = compute_constructor_signatures ~rec_flag ind in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 95d545b046..6999b17d8e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2824,7 +2824,7 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let generalize_dep ?(with_let=false) c = let open Tacmach.New in let open Tacticals.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let sign = Proofview.Goal.hyps gl in let sigma = project gl in diff --git a/test-suite/bugs/closed/4612.v b/test-suite/bugs/closed/4612.v new file mode 100644 index 0000000000..ce95f26acc --- /dev/null +++ b/test-suite/bugs/closed/4612.v @@ -0,0 +1,7 @@ +(* While waiting for support, check at least that it does not raise an anomaly *) + +Inductive ctype := +| Struct: list ctype -> ctype +| Bot : ctype. + +Fail Scheme Equality for ctype. diff --git a/test-suite/bugs/closed/4717.v b/test-suite/bugs/closed/4717.v index 1507fa4bf0..bd9bac37ef 100644 --- a/test-suite/bugs/closed/4717.v +++ b/test-suite/bugs/closed/4717.v @@ -19,8 +19,6 @@ Proof. omega. Qed. -Require Import ZArith ROmega. - Open Scope Z_scope. Definition Z' := Z. @@ -32,6 +30,4 @@ Theorem Zle_not_eq_lt : forall n m, Proof. intros. omega. - Undo. - romega. Qed. diff --git a/test-suite/bugs/closed/4859.v b/test-suite/bugs/closed/4859.v new file mode 100644 index 0000000000..7be0bedcfc --- /dev/null +++ b/test-suite/bugs/closed/4859.v @@ -0,0 +1,7 @@ +(* Not supported but check at least that it does not raise an anomaly *) + +Inductive Fin{n : nat} : Set := +| F1{i : nat}{e : n = S i} +| FS{i : nat}(f : @ Fin i){e : n = S i}. + +Fail Scheme Equality for Fin. diff --git a/test-suite/bugs/closed/8215.v b/test-suite/bugs/closed/8215.v new file mode 100644 index 0000000000..c4b29a6354 --- /dev/null +++ b/test-suite/bugs/closed/8215.v @@ -0,0 +1,14 @@ +(* Check that instances for local definitions in evars have compatible body *) +Goal False. +Proof. + pose (n := 1). + evar (m:nat). + subst n. + pose (n := 0). + Fail Check ?m. (* n cannot be reinterpreted with a value convertible to 1 *) + clearbody n. + Fail Check ?m. (* n cannot be reinterpreted with a value convertible to 1 *) + clear n. + pose (n := 0+1). + Check ?m. (* Should be ok *) +Abort. diff --git a/test-suite/bugs/closed/8478.v b/test-suite/bugs/closed/8478.v new file mode 100644 index 0000000000..8baaf8686a --- /dev/null +++ b/test-suite/bugs/closed/8478.v @@ -0,0 +1,11 @@ +Set Universe Polymorphism. +Set Printing Universes. +Unset Strict Universe Declaration. + +Monomorphic Universe v. + +Section Foo. + Let bar := Type@{u}. + Fail Monomorphic Constraint bar.u < v. + +End Foo. (* was anomaly undeclared universe due to the constraint *) diff --git a/test-suite/bugs/closed/8532.v b/test-suite/bugs/closed/8532.v new file mode 100644 index 0000000000..00aa66e701 --- /dev/null +++ b/test-suite/bugs/closed/8532.v @@ -0,0 +1,8 @@ +(* Checking Print Assumptions relatively to a bound module *) + +Module Type Typ. + Parameter Inline(10) t : Type. +End Typ. +Module Terms_mod (SetVars : Typ). +Print Assumptions SetVars.t. +End Terms_mod. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index dfab400baa..cb835ab48d 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -64,14 +64,9 @@ In environment texpDenote : forall t : type, texp t -> typeDenote t t : type e : texp t -t1 : type -t2 : type -t0 : type -b : tbinop t1 t2 t0 -e1 : texp t1 -e2 : texp t2 -The term "0" has type "nat" while it is expected to have type - "typeDenote t0". +n : nat +The term "n" has type "nat" while it is expected to have type + "typeDenote ?t@{t1:=Nat}". fun '{{n, m, _}} => n + m : J -> nat fun '{{n, m, p}} => n + m + p diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 926114a1e1..f8f11d7cf6 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -86,10 +86,10 @@ Type@{M} -> Type@{N} -> Type@{E} (* E M N |= *) foo is universe polymorphic -foo@{Top.16 Top.17 Top.18} = -Type@{Top.17} -> Type@{Top.18} -> Type@{Top.16} - : Type@{max(Top.16+1,Top.17+1,Top.18+1)} -(* Top.16 Top.17 Top.18 |= *) +foo@{u Top.17 v} = +Type@{Top.17} -> Type@{v} -> Type@{u} + : Type@{max(u+1,Top.17+1,v+1)} +(* u Top.17 v |= *) foo is universe polymorphic NonCumulative Inductive Empty@{E} : Type@{E} := @@ -129,11 +129,19 @@ insec@{v} = Type@{u} -> Type@{v} (* v |= *) insec is universe polymorphic +NonCumulative Inductive insecind@{k} : Type@{k+1} := + inseccstr : Type@{k} -> insecind@{k} + +For inseccstr: Argument scope is [type_scope] insec@{u v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) insec is universe polymorphic +NonCumulative Inductive insecind@{u k} : Type@{k+1} := + inseccstr : Type@{k} -> insecind@{u k} + +For inseccstr: Argument scope is [type_scope] inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) @@ -155,24 +163,24 @@ inmod@{u} -> Type@{v} (* u v |= *) Applied.infunct is universe polymorphic -axfoo@{i Top.48 Top.49} : Type@{Top.48} -> Type@{i} -(* i Top.48 Top.49 |= *) +axfoo@{i Top.55 Top.56} : Type@{Top.55} -> Type@{i} +(* i Top.55 Top.56 |= *) axfoo is universe polymorphic Argument scope is [type_scope] Expands to: Constant Top.axfoo -axbar@{i Top.48 Top.49} : Type@{Top.49} -> Type@{i} -(* i Top.48 Top.49 |= *) +axbar@{i Top.55 Top.56} : Type@{Top.56} -> Type@{i} +(* i Top.55 Top.56 |= *) axbar is universe polymorphic Argument scope is [type_scope] Expands to: Constant Top.axbar -axfoo' : Type@{Top.51} -> Type@{axbar'.i} +axfoo' : Type@{Top.58} -> Type@{axbar'.i} axfoo' is not universe polymorphic Argument scope is [type_scope] Expands to: Constant Top.axfoo' -axbar' : Type@{Top.51} -> Type@{axbar'.i} +axbar' : Type@{Top.58} -> Type@{axbar'.i} axbar' is not universe polymorphic Argument scope is [type_scope] diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index f806a9f4f7..9aebce1b9a 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -122,8 +122,12 @@ Section SomeSec. Universe u. Definition insec@{v} := Type@{u} -> Type@{v}. Print insec. + + Inductive insecind@{k} := inseccstr : Type@{k} -> insecind. + Print insecind. End SomeSec. Print insec. +Print insecind. Module SomeMod. Definition inmod@{u} := Type@{u}. diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out index 7326f137c2..8a00cd3fe5 100644 --- a/test-suite/output/ltac_missing_args.out +++ b/test-suite/output/ltac_missing_args.out @@ -1,25 +1,25 @@ The command has indeed failed with message: -The user-defined tactic "Top.foo" was not fully applied: +The user-defined tactic "foo" was not fully applied: There is a missing argument for variable x, no arguments at all were provided. The command has indeed failed with message: -The user-defined tactic "Top.bar" was not fully applied: +The user-defined tactic "bar" was not fully applied: There is a missing argument for variable x, no arguments at all were provided. The command has indeed failed with message: -The user-defined tactic "Top.bar" was not fully applied: +The user-defined tactic "bar" was not fully applied: There are missing arguments for variables y and _, an argument was provided for variable x. The command has indeed failed with message: -The user-defined tactic "Top.baz" was not fully applied: +The user-defined tactic "baz" was not fully applied: There is a missing argument for variable x, no arguments at all were provided. The command has indeed failed with message: -The user-defined tactic "Top.qux" was not fully applied: +The user-defined tactic "qux" was not fully applied: There is a missing argument for variable x, no arguments at all were provided. The command has indeed failed with message: -The user-defined tactic "Top.mydo" was not fully applied: +The user-defined tactic "mydo" was not fully applied: There is a missing argument for variable _, no arguments at all were provided. The command has indeed failed with message: @@ -31,7 +31,7 @@ An unnamed user-defined tactic was not fully applied: There is a missing argument for variable _, no arguments at all were provided. The command has indeed failed with message: -The user-defined tactic "Top.rec" was not fully applied: +The user-defined tactic "rec" was not fully applied: There is a missing argument for variable x, no arguments at all were provided. The command has indeed failed with message: diff --git a/test-suite/ssr/ssrpattern.v b/test-suite/ssr/ssrpattern.v new file mode 100644 index 0000000000..422bb95fdf --- /dev/null +++ b/test-suite/ssr/ssrpattern.v @@ -0,0 +1,7 @@ +Require Import ssrmatching. + +Goal forall n, match n with 0 => 0 | _ => 0 end = 0. +Proof. + intro n. + ssrpattern (match _ with 0 => _ | S n' => _ end). +Abort. diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v index 8f95484cfd..356a67efec 100644 --- a/test-suite/success/Case13.v +++ b/test-suite/success/Case13.v @@ -87,3 +87,41 @@ Check fun (x : E) => match x with c => e c end. Inductive C' : bool -> Set := c' : C' true. Inductive E' (b : bool) : Set := e' :> C' b -> E' b. Check fun (x : E' true) => match x with c' => e' true c' end. + +(* Check use of the no-dependency strategy when a type constraint is + given (and when the "inversion-and-dependencies-as-evars" strategy + is not strong enough because of a constructor with a type whose + pattern structure is not refined enough for it to be captured by + the inversion predicate) *) + +Inductive K : bool -> bool -> Type := F : K true true | G x : K x x. + +Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y, P y -> Q y z) => + match y with + | F => f y H1 + | G _ => f y H2 + end : Q y z. + +(* Check use of the maximal-dependency-in-variable strategy even when + no explicit type constraint is given (and when the + "inversion-and-dependencies-as-evars" strategy is not strong enough + because of a constructor with a type whose pattern structure is not + refined enough for it to be captured by the inversion predicate) *) + +Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z) => + match y with + | F => f y true H1 + | G b => f y b H2 + end. + +(* Check use of the maximal-dependency-in-variable strategy for "Var" + variables *) + +Goal forall z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z), Q y z. +intros z P Q y H1 H2 f. +Show. +refine (match y with + | F => f y true H1 + | G b => f y b H2 + end). +Qed. diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v index 0df3d5685d..a97afa7ff0 100644 --- a/test-suite/success/ROmega.v +++ b/test-suite/success/ROmega.v @@ -1,5 +1,7 @@ - -Require Import ZArith ROmega. +(* This file used to test the `romega` tactics. + In Coq 8.9 (end of 2018), these tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) +Require Import ZArith Lia. (* Submitted by Xavier Urbain 18 Jan 2002 *) @@ -7,14 +9,14 @@ Lemma lem1 : forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. Proof. intros x y. -romega. +lia. Qed. (* Proposed by Pierre Crégut *) Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. intro. - romega. + lia. Qed. (* Proposed by Jean-Christophe Filliâtre *) @@ -22,7 +24,7 @@ Qed. Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. -romega. +lia. Qed. (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) @@ -32,7 +34,7 @@ Section A. Variable x y : Z. Hypothesis H : (x > y)%Z. Lemma lem4 : (x > y)%Z. - romega. + lia. Qed. End A. @@ -48,7 +50,7 @@ Hypothesis L : (R1 >= 0)%Z -> S2 = S1. Hypothesis M : (H <= 2 * S)%Z. Hypothesis N : (S < H)%Z. Lemma lem5 : (H > 0)%Z. - romega. + lia. Qed. End B. @@ -56,11 +58,10 @@ End B. Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. - romega. + lia. Qed. (* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) -Require Import Omega. Section C. Parameter g : forall m : nat, m <> 0 -> Prop. Parameter f : forall (m : nat) (H : m <> 0), g m H. @@ -68,23 +69,21 @@ Variable n : nat. Variable ap_n : n <> 0. Let delta := f n ap_n. Lemma lem7 : n = n. - romega with nat. + lia. Qed. End C. (* Problem of dependencies *) -Require Import Omega. Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. intros. -romega with nat. +lia. Qed. (* Bug that what caused by the use of intro_using in Omega *) -Require Import Omega. Lemma lem9 : forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. intros. -romega with nat. +lia. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) @@ -92,5 +91,5 @@ Qed. (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m : nat, le n (plus n (mult n m)). Proof. -intros; romega with nat. +intros; lia. Qed. diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v index 3ddf6a40fb..7f69422ab3 100644 --- a/test-suite/success/ROmega0.v +++ b/test-suite/success/ROmega0.v @@ -1,25 +1,27 @@ -Require Import ZArith ROmega. +Require Import ZArith Lia. Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) +(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) -Lemma test_romega_0 : +Lemma test_lia_0 : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_0b : +Lemma test_lia_0b : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. -romega. +lia. Qed. -Lemma test_romega_1 : +Lemma test_lia_1 : forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> @@ -29,10 +31,10 @@ Lemma test_romega_1 : z >= 0. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_1b : +Lemma test_lia_1b : forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> @@ -42,24 +44,24 @@ Lemma test_romega_1b : z >= 0. Proof. intros z z1 z2. -romega. +lia. Qed. -Lemma test_romega_2 : forall a b c:Z, +Lemma test_lia_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_2b : forall a b c:Z, +Lemma test_lia_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. -romega. +lia. Qed. -Lemma test_romega_3 : forall a b h hl hr ha hb, +Lemma test_lia_3 : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> @@ -70,10 +72,10 @@ Lemma test_romega_3 : forall a b h hl hr ha hb, 0 <= hb - h <= 1. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_3b : forall a b h hl hr ha hb, +Lemma test_lia_3b : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> @@ -84,79 +86,79 @@ Lemma test_romega_3b : forall a b h hl hr ha hb, 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. -romega. +lia. Qed. -Lemma test_romega_4 : forall hr ha, +Lemma test_lia_4 : forall hr ha, ha = 0 -> (ha = 0 -> hr =0) -> hr = 0. Proof. intros hr ha. -romega. +lia. Qed. -Lemma test_romega_5 : forall hr ha, +Lemma test_lia_5 : forall hr ha, ha = 0 -> (~ha = 0 \/ hr =0) -> hr = 0. Proof. intros hr ha. -romega. +lia. Qed. -Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. +Lemma test_lia_6 : forall z, z>=0 -> 0>z+2 -> False. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. +Lemma test_lia_6b : forall z, z>=0 -> 0>z+2 -> False. Proof. intros z. -romega. +lia. Qed. -Lemma test_romega_7 : forall z, +Lemma test_lia_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_7b : forall z, +Lemma test_lia_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -romega. +lia. Qed. (* Magaud BZ#240 *) -Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +Lemma test_lia_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. Proof. intros. -romega. +lia. Qed. -Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +Lemma test_lia_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. Proof. intros x y. -romega. +lia. Qed. (* Besson BZ#1298 *) -Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False. +Lemma test_lia9 : forall z z':Z, z<>z' -> z'=z -> False. Proof. intros. -romega. +lia. Qed. (* Letouzey, May 2017 *) -Lemma test_romega10 : forall x a a' b b', +Lemma test_lia10 : forall x a a' b b', a' <= b -> a <= b' -> b < b' -> @@ -164,5 +166,5 @@ Lemma test_romega10 : forall x a a' b b', a <= x < b' <-> a <= x < b \/ a' <= x < b'. Proof. intros. - romega. + lia. Qed. diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v index 43eda67ea3..e3b090699d 100644 --- a/test-suite/success/ROmega2.v +++ b/test-suite/success/ROmega2.v @@ -1,4 +1,6 @@ -Require Import ZArith ROmega. +(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) +Require Import ZArith Lia. (* Submitted by Yegor Bryukhov (BZ#922) *) @@ -13,7 +15,7 @@ forall v1 v2 v5 : Z, 0 < v2 -> 4*v2 <> 5*v1. intros. -romega. +lia. Qed. @@ -37,5 +39,5 @@ forall v1 v2 v3 v4 v5 : Z, ((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) -> False. intros. -romega. +lia. Qed. diff --git a/test-suite/success/ROmega3.v b/test-suite/success/ROmega3.v index fd4ff260b5..ef9cb17b4b 100644 --- a/test-suite/success/ROmega3.v +++ b/test-suite/success/ROmega3.v @@ -1,10 +1,14 @@ -Require Import ZArith ROmega. +Require Import ZArith Lia. Local Open Scope Z_scope. (** Benchmark provided by Chantal Keller, that romega used to solve far too slowly (compared to omega or lia). *) +(* In Coq 8.9 (end of 2018), the `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) + + Parameter v4 : Z. Parameter v3 : Z. Parameter o4 : Z. @@ -27,5 +31,5 @@ Lemma lemma_5833 : (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 1024. Proof. -Timeout 1 romega. (* should take a few milliseconds, not seconds *) +Timeout 1 lia. (* should take a few milliseconds, not seconds *) Timeout 1 Qed. (* ditto *) diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v index fa659273e1..6ca32f450f 100644 --- a/test-suite/success/ROmegaPre.v +++ b/test-suite/success/ROmegaPre.v @@ -1,127 +1,123 @@ -Require Import ZArith Nnat ROmega. +Require Import ZArith Nnat Lia. Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) +(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) (* More details in file PreOmega.v - - (r)omega with Z : starts with zify_op - (r)omega with nat : starts with zify_nat - (r)omega with positive : starts with zify_positive - (r)omega with N : starts with uses zify_N - (r)omega with * : starts zify (a saturation of the others) *) (* zify_op *) Goal forall a:Z, Z.max a a = a. intros. -romega with *. +lia. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. -romega with *. +lia. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. -romega with *. +lia. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. -romega with *. +lia. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. zify. -intuition; subst; romega. (* pure multiplication: omega alone can't do it *) +intuition; subst; lia. (* pure multiplication: omega alone can't do it *) Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. -romega with *. +lia. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. -romega with *. +lia. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. -romega with *. +lia. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. -romega with *. +lia. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. -romega with *. +lia. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. -romega with *. +lia. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. -romega with *. +lia. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. -romega with *. +lia. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. -romega with *. +lia. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. -romega with *. +lia. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. -romega with *. +lia. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. -romega with *. +lia. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. -romega with *. +lia. Qed. Goal forall m:N, (m*m>=0)%N. intros. -romega with *. +lia. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. -romega with *. +lia. Qed. diff --git a/test-suite/success/SchemeEquality.v b/test-suite/success/SchemeEquality.v new file mode 100644 index 0000000000..85d5c3e123 --- /dev/null +++ b/test-suite/success/SchemeEquality.v @@ -0,0 +1,29 @@ +(* Examples of use of Scheme Equality *) + +Module A. +Definition N := nat. +Inductive list := nil | cons : N -> list -> list. +Scheme Equality for list. +End A. + +Module B. + Section A. + Context A (eq_A:A->A->bool) + (A_bl : forall x y, eq_A x y = true -> x = y) + (A_lb : forall x y, x = y -> eq_A x y = true). + Inductive I := C : A -> I. + Scheme Equality for I. + End A. +End B. + +Module C. + Parameter A : Type. + Parameter eq_A : A->A->bool. + Parameter A_bl : forall x y, eq_A x y = true -> x = y. + Parameter A_lb : forall x y, x = y -> eq_A x y = true. + Hint Resolve A_bl A_lb : core. + Inductive I := C : A -> I. + Scheme Equality for I. + Inductive J := D : list A -> J. + Scheme Equality for J. +End C. diff --git a/test-suite/success/attribute-syntax.v b/test-suite/success/attribute-syntax.v index 83fb3d0c8e..241d4eb200 100644 --- a/test-suite/success/attribute-syntax.v +++ b/test-suite/success/attribute-syntax.v @@ -1,4 +1,4 @@ -From Coq Require Program. +From Coq Require Program.Wf. Section Scope. @@ -21,3 +21,13 @@ Fixpoint f (n: nat) {wf lt n} : nat := _. #[deprecated(since="8.9.0")] Ltac foo := foo. + +Module M. + #[local] #[polymorphic] Definition zed := Type. + + #[local, polymorphic] Definition kats := Type. +End M. +Check M.zed@{_}. +Fail Check zed. +Check M.kats@{_}. +Fail Check kats. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 4404ff3f16..448febed25 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -377,3 +377,30 @@ f y true. Abort. End LtacNames. + +(* Test binding of the name of existential variables in Ltac *) + +Module EvarNames. + +Ltac pick x := eexists ?[x]. +Goal exists y, y = 0. +pick foo. +[foo]:exact 0. +auto. +Qed. + +Ltac goal x := refine ?[x]. + +Goal forall n, n + 0 = n. +Proof. + induction n; [ goal Base | goal Rec ]. + [Base]: { + easy. + } + [Rec]: { + simpl. + now f_equal. + } +Qed. + +End EvarNames. diff --git a/test-suite/vio/numeral.v b/test-suite/vio/numeral.v new file mode 100644 index 0000000000..f28355bb29 --- /dev/null +++ b/test-suite/vio/numeral.v @@ -0,0 +1,21 @@ +Lemma foo : True. +Proof. +Check 0 : nat. +Check 0 : nat. +exact I. +Qed. + +Lemma bar : True. +Proof. +pose (0 : nat). +exact I. +Qed. + +Require Import Coq.Strings.Ascii. +Open Scope char_scope. + +Lemma baz : True. +Proof. +pose "s". +exact I. +Qed. diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index aecdb59dbe..3d615485b9 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -70,6 +70,8 @@ Definition BVor := @Vector.map2 _ _ _ orb. Definition BVxor := @Vector.map2 _ _ _ xorb. +Definition BVeq m n := @Vector.eqb bool eqb m n. + Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) := Bcons carry n (Vector.shiftout bv). @@ -99,3 +101,13 @@ Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := End BOOLEAN_VECTORS. +Module BvectorNotations. +Declare Scope Bvector_scope. +Delimit Scope Bvector_scope with Bvector. +Notation "^~ x" := (Bneg _ x) (at level 35, right associativity) : Bvector_scope. +Infix "^&" := (BVand _) (at level 40, left associativity) : Bvector_scope. +Infix "^⊕" := (BVxor _) (at level 45, left associativity) : Bvector_scope. +Infix "^|" := (BVor _) (at level 50, left associativity) : Bvector_scope. +Infix "=?" := (BVeq _ _) (at level 70, no associativity) : Bvector_scope. +Open Scope Bvector_scope. +End BvectorNotations. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index 68a98e4292..a2a2430e91 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -578,6 +578,7 @@ Qed. (** To state nonetheless a second result about composition of conversions, we define a conversion on a given number of bits : *) +#[deprecated(since = "8.9.0", note = "Use N2Bv_sized instead.")] Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n := match n return Bvector n with | 0 => Bnil @@ -705,3 +706,10 @@ Proof with simpl; auto. destruct (Bv2N n v) as [|[]]; rewrite <- IHv... Qed. + +Lemma N2Bv_N2Bv_sized_above (a : N) (k : nat) : + N2Bv_sized (N.size_nat a + k) a = N2Bv a ++ Bvect_false k. +Proof with auto. + destruct a... + induction p; simpl; f_equal... +Qed. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index ca7d3ec074..3a2503d6b7 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -19,7 +19,7 @@ Require Export DoubleType. (** This file contains basic definitions of a 31-bit integer arithmetic. In fact it is more general than that. The only reason - for this use of 31 is the underlying mecanism for hardware-efficient + for this use of 31 is the underlying mechanism for hardware-efficient computations by A. Spiwack. Apart from this, a switch to, say, 63-bit integers is now just a matter of replacing every occurrences of 31 by 63. This is actually made possible by the use of diff --git a/tools/coqc.ml b/tools/coqc.ml index 90d8e67c1e..2cbf05bd8b 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -24,7 +24,7 @@ let environment = Unix.environment () -let binary = ref "coqtop" +let use_bytecode = ref false let image = ref "" let verbose = ref false @@ -69,8 +69,8 @@ let parse_args () = verbose := true ; parse (cfiles,args) rem | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem | "-image" :: [] -> usage () - | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem - | "-opt" :: rem -> binary := "coqtop"; parse (cfiles,args) rem + | "-byte" :: rem -> use_bytecode := true; parse (cfiles,args) rem + | "-opt" :: rem -> use_bytecode := false; parse (cfiles,args) rem (* Informative options *) @@ -155,7 +155,7 @@ let main () = end; let coqtopname = if !image <> "" then !image - else Filename.concat Envars.coqbin (!binary ^ Coq_config.exec_extension) + else System.get_toplevel_path ~byte:!use_bytecode "coqtop" in (* List.iter (compile coqtopname args) cfiles*) Unix.handle_unix_error (compile coqtopname args) cfiles diff --git a/topbin/dune b/topbin/dune index e89f6c4b13..5f07492a10 100644 --- a/topbin/dune +++ b/topbin/dune @@ -1,6 +1,10 @@ +(install + (section bin) + (files (coqtop_bin.exe as coqtop))) + (executable (name coqtop_bin) - (public_name coqtop) + (public_name coqtop.opt) (package coq) (modules coqtop_bin) (libraries coq.toplevel) diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 0bcd3c64eb..b000745961 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -71,7 +71,7 @@ let rec fields_of_functor f subs mp0 args = function let rec lookup_module_in_impl mp = match mp with | MPfile _ -> Global.lookup_module mp - | MPbound _ -> assert false + | MPbound _ -> Global.lookup_module mp | MPdot (mp',lab') -> if ModPath.equal mp' (Global.current_modpath ()) then Global.lookup_module mp diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index e33aa38173..dee7541d37 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -59,6 +59,8 @@ exception ParameterWithoutEquality of GlobRef.t exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported exception NoDecidabilityCoInductive +exception ConstructorWithNonParametricInductiveType of inductive +exception DecidabilityIndicesNotSupported let constr_of_global g = lazy (UnivGen.constr_of_global g) @@ -120,6 +122,10 @@ let check_bool_is_defined () = try let _ = Global.type_of_global_in_context (Global.env ()) Coqlib.glob_bool in () with e when CErrors.noncritical e -> raise (UndefinedCst "bool") +let check_no_indices mib = + if Array.exists (fun mip -> mip.mind_nrealargs <> 0) mib.mind_packets then + raise DecidabilityIndicesNotSupported + let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") let build_beq_scheme mode kn = @@ -133,6 +139,7 @@ let build_beq_scheme mode kn = (* number of params in the type *) let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in + check_no_indices mib; (* params context divided *) let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in @@ -193,6 +200,7 @@ let build_beq_scheme mode kn = match Constr.kind c with | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants | Var x -> + (* Support for working in a context with "eq_x : x -> x -> bool" *) let eid = Id.of_string ("eq_"^(Id.to_string x)) in let () = try ignore (Environ.lookup_named eid env) @@ -225,9 +233,17 @@ let build_beq_scheme mode kn = | Lambda _-> raise (EqUnknown "abstraction") | LetIn _ -> raise (EqUnknown "let-in") | Const (kn, u) -> - (match Environ.constant_opt_value_in env (kn, u) with - | None -> raise (ParameterWithoutEquality (ConstRef kn)) - | Some c -> aux (Term.applist (c,a))) + (match Environ.constant_opt_value_in env (kn, u) with + | Some c -> aux (Term.applist (c,a)) + | None -> + (* Support for working in a context with "eq_x : x -> x -> bool" *) + (* Needs Hints, see test suite *) + let eq_lbl = Label.make ("eq_" ^ Label.to_string (Constant.label kn)) in + let kneq = Constant.change_label kn eq_lbl in + try let _ = Environ.constant_opt_value_in env (kneq, u) in + Term.applist (mkConst kneq,a), + Safe_typing.empty_private_constants + with Not_found -> raise (ParameterWithoutEquality (ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -341,13 +357,10 @@ let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind (* This function tryies to get the [inductive] between a constr the constr should be Ind i or App(Ind i,[|args|]) *) -let destruct_ind sigma c = +let destruct_ind env sigma c = let open EConstr in - try let u,v = destApp sigma c in - let indc = destInd sigma u in - indc,v - with DestKO -> let indc = destInd sigma c in - indc,[||] + let (c,v) = Reductionops.whd_all_stack env sigma c in + destInd sigma c, Array.of_list v (* In the following, avoid is the list of names to avoid. @@ -361,10 +374,10 @@ so from Ai we can find the correct eq_Ai bl_ai or lb_ai let do_replace_lb mode lb_scheme_key aavoid narg p q = let open EConstr in let avoid = Array.of_list aavoid in - let do_arg sigma v offset = - try + let do_arg sigma hd v offset = + match kind sigma v with + | Var s -> let x = narg*offset in - let s = destVar sigma v in let n = Array.length avoid in let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) @@ -373,22 +386,20 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = (str "Var " ++ Id.print s ++ str " seems unknown.") ) in mkVar (find 1) - with e when CErrors.noncritical e -> - (* if this happen then the args have to be already declared as a - Parameter*) - ( - let mp,dir,lbl = Constant.repr3 (fst (destConst sigma v)) in - mkConst (Constant.make3 mp dir (Label.make ( - if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) - else ((Label.to_string lbl)^"_lb") - ))) - ) + | Const (cst,_) -> + (* Works in specific situations where the args have to be already declared as a + Parameter (see example "J" in test file SchemeEquality.v) *) + let lbl = Label.to_string (Constant.label cst) in + let newlbl = if Int.equal offset 1 then ("eq_" ^ lbl) else (lbl ^ "_lb") in + mkConst (Constant.change_label cst (Label.make newlbl)) + | _ -> raise (ConstructorWithNonParametricInductiveType (fst hd)) + in Proofview.Goal.enter begin fun gl -> let type_of_pq = Tacmach.New.pf_unsafe_type_of gl p in let sigma = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in - let u,v = destruct_ind sigma type_of_pq + let u,v = destruct_ind env sigma type_of_pq in let lb_type_of_p = try let c, eff = find_scheme ~mode lb_scheme_key (fst u) (*FIXME*) in @@ -409,8 +420,8 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Proofview.tclEVARMAP >>= fun sigma -> let lb_args = Array.append (Array.append v - (Array.Smart.map (fun x -> do_arg sigma x 1) v)) - (Array.Smart.map (fun x -> do_arg sigma x 2) v) + (Array.Smart.map (fun x -> do_arg sigma u x 1) v)) + (Array.Smart.map (fun x -> do_arg sigma u x 2) v) in let app = if Array.is_empty lb_args then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in @@ -419,14 +430,14 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Equality.replace p q ; apply app ; Auto.default_auto] end -(* used in the bool -> leib side *) +(* used in the bool -> leb side *) let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let open EConstr in let avoid = Array.of_list aavoid in - let do_arg sigma v offset = - try + let do_arg sigma hd v offset = + match kind sigma v with + | Var s -> let x = narg*offset in - let s = destVar sigma v in let n = Array.length avoid in let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) @@ -435,16 +446,13 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = (str "Var " ++ Id.print s ++ str " seems unknown.") ) in mkVar (find 1) - with e when CErrors.noncritical e -> - (* if this happen then the args have to be already declared as a - Parameter*) - ( - let mp,dir,lbl = Constant.repr3 (fst (destConst sigma v)) in - mkConst (Constant.make3 mp dir (Label.make ( - if Int.equal offset 1 then ("eq_"^(Label.to_string lbl)) - else ((Label.to_string lbl)^"_bl") - ))) - ) + | Const (cst,_) -> + (* Works in specific situations where the args have to be already declared as a + Parameter (see example "J" in test file SchemeEquality.v) *) + let lbl = Label.to_string (Constant.label cst) in + let newlbl = if Int.equal offset 1 then ("eq_" ^ lbl) else (lbl ^ "_bl") in + mkConst (Constant.change_label cst (Label.make newlbl)) + | _ -> raise (ConstructorWithNonParametricInductiveType (fst hd)) in let rec aux l1 l2 = @@ -456,7 +464,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let env = Tacmach.New.pf_env gl in if EConstr.eq_constr sigma t1 t2 then aux q1 q2 else ( - let u,v = try destruct_ind sigma tt1 + let u,v = try destruct_ind env sigma tt1 (* trick so that the good sequence is returned*) with e when CErrors.noncritical e -> indu,[||] in if eq_ind (fst u) ind @@ -480,8 +488,8 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = in let bl_args = Array.append (Array.append v - (Array.Smart.map (fun x -> do_arg sigma x 1) v)) - (Array.Smart.map (fun x -> do_arg sigma x 2) v ) + (Array.Smart.map (fun x -> do_arg sigma u x 1) v)) + (Array.Smart.map (fun x -> do_arg sigma u x 2) v ) in let app = if Array.is_empty bl_args then bl_t1 else mkApp (bl_t1,bl_args) @@ -543,7 +551,7 @@ let eqI ind l = and e, eff = try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" - (str "The boolean equality on " ++ MutInd.print (fst ind) ++ str " is needed."); + (str "The boolean equality on " ++ Printer.pr_inductive (Global.env ()) ind ++ str " is needed."); in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)), eff (**********************************************************************) diff --git a/vernac/auto_ind_decl.mli b/vernac/auto_ind_decl.mli index 11f26c7c36..647ff3d8d6 100644 --- a/vernac/auto_ind_decl.mli +++ b/vernac/auto_ind_decl.mli @@ -27,6 +27,8 @@ exception ParameterWithoutEquality of GlobRef.t exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported exception NoDecidabilityCoInductive +exception ConstructorWithNonParametricInductiveType of inductive +exception DecidabilityIndicesNotSupported val beq_scheme_kind : mutual scheme_kind val build_beq_scheme : mutual_scheme_object_function diff --git a/vernac/classes.ml b/vernac/classes.ml index bf734ab36d..e491761aec 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -42,7 +42,7 @@ let typeclasses_db = "typeclass_instances" let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] - (Hints.HintsTransparencyEntry (Vernacexpr.HintsReferences [c], b)) + (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) let _ = Hook.set Typeclasses.add_instance_hint_hook diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 504e7095b0..b37fce645a 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,6 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) + | Notation.NumeralNotationError(ctx,sigma,te) -> + wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> @@ -74,8 +76,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_module_error e) | Modintern.ModuleInternalizationError e -> wrap_vernac_error exn (Himsg.explain_module_internalization_error e) - | RecursionSchemeError e -> - wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e) + | RecursionSchemeError (env,e) -> + wrap_vernac_error exn (Himsg.explain_recursion_scheme_error env e) | Cases.PatternMatchingError (env,sigma,e) -> wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e) | Tacred.ReductionTacticError e -> diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index dacef6e211..ecc7d3ff88 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -13,6 +13,7 @@ open Glob_term open Constrexpr open Vernacexpr +open Hints open Proof_global open Pcoq diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 650b28ea67..7dd5471f3f 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -83,11 +83,10 @@ GRAMMAR EXTEND Gram ] ; decorated_vernac: - [ [ a = attributes ; fv = vernac -> { let (f, v) = fv in (List.append a f, v) } - | fv = vernac -> { fv } ] - ] + [ [ a = LIST0 quoted_attributes ; fv = vernac -> + { let (f, v) = fv in (List.append (List.flatten a) f, v) } ] ] ; - attributes: + quoted_attributes: [ [ "#[" ; a = attribute_list ; "]" -> { a } ] ] ; diff --git a/vernac/himsg.ml b/vernac/himsg.ml index a4650cfd92..a4b3a75c9f 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -601,12 +601,12 @@ let explain_var_not_found env id = spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "." let explain_wrong_case_info env (ind,u) ci = - let pi = pr_inductive (Global.env()) ind in + let pi = pr_inductive env ind in if eq_ind ci.ci_ind ind then str "Pattern-matching expression on an object of inductive type" ++ spc () ++ pi ++ spc () ++ str "has invalid information." else - let pc = pr_inductive (Global.env()) ci.ci_ind in + let pc = pr_inductive env ci.ci_ind in str "A term of inductive type" ++ spc () ++ pi ++ spc () ++ str "was given to a pattern-matching expression on the inductive type" ++ spc () ++ pc ++ str "." @@ -896,7 +896,8 @@ let explain_not_match_error = function quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t2) | IncompatibleConstraints cst -> str " the expected (polymorphic) constraints do not imply " ++ - let cst = Univ.AUContext.instantiate (Univ.AUContext.instance cst) cst in + let cst = Univ.UContext.constraints (Univ.AUContext.repr cst) in + (** FIXME: provide a proper naming for the bound variables *) quote (Univ.pr_constraints (Termops.pr_evd_level Evd.empty) cst) let explain_signature_mismatch l spec why = @@ -1155,24 +1156,24 @@ let error_large_non_prop_inductive_not_in_type () = (* Recursion schemes errors *) -let error_not_allowed_case_analysis isrec kind i = +let error_not_allowed_case_analysis env isrec kind i = str (if isrec then "Induction" else "Case analysis") ++ strbrk " on sort " ++ pr_sort Evd.empty kind ++ strbrk " is not allowed for inductive definition " ++ - pr_inductive (Global.env()) (fst i) ++ str "." + pr_inductive env (fst i) ++ str "." -let error_not_allowed_dependent_analysis isrec i = +let error_not_allowed_dependent_analysis env isrec i = str "Dependent " ++ str (if isrec then "induction" else "case analysis") ++ strbrk " is not allowed for inductive definition " ++ - pr_inductive (Global.env()) i ++ str "." + pr_inductive env i ++ str "." -let error_not_mutual_in_scheme ind ind' = +let error_not_mutual_in_scheme env ind ind' = if eq_ind ind ind' then - str "The inductive type " ++ pr_inductive (Global.env()) ind ++ + str "The inductive type " ++ pr_inductive env ind ++ str " occurs twice." else - str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++ - str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++ + str "The inductive types " ++ pr_inductive env ind ++ spc () ++ + str "and" ++ spc () ++ pr_inductive env ind' ++ spc () ++ str "are not mutually defined." (* Inductive constructions errors *) @@ -1193,12 +1194,12 @@ let explain_inductive_error = function (* Recursion schemes errors *) -let explain_recursion_scheme_error = function +let explain_recursion_scheme_error env = function | NotAllowedCaseAnalysis (isrec,k,i) -> - error_not_allowed_case_analysis isrec k i - | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind' + error_not_allowed_case_analysis env isrec k i + | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme env ind ind' | NotAllowedDependentAnalysis (isrec, i) -> - error_not_allowed_dependent_analysis isrec i + error_not_allowed_dependent_analysis env isrec i (* Pattern-matching errors *) @@ -1315,3 +1316,13 @@ let explain_reduction_tactic_error = function quote (pr_goal_concl_style_env env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e + +let explain_numeral_notation_error env sigma = function + | Notation.UnexpectedTerm c -> + (strbrk "Unexpected term " ++ + pr_constr_env env sigma c ++ + strbrk " while parsing a numeral notation.") + | Notation.UnexpectedNonOptionTerm c -> + (strbrk "Unexpected non-option term " ++ + pr_constr_env env sigma c ++ + strbrk " while parsing a numeral notation.") diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 91caddcf13..db05aaa125 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -29,7 +29,7 @@ val explain_mismatched_contexts : env -> contexts -> Constrexpr.constr_expr list val explain_typeclass_error : env -> typeclass_error -> Pp.t -val explain_recursion_scheme_error : recursion_scheme_error -> Pp.t +val explain_recursion_scheme_error : env -> recursion_scheme_error -> Pp.t val explain_refiner_error : env -> Evd.evar_map -> refiner_error -> Pp.t @@ -46,3 +46,5 @@ val explain_module_internalization_error : val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error + +val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index e86e108772..3ee836a828 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -142,7 +142,8 @@ let try_declare_scheme what f internal names kn = try f internal names kn with e -> let e = CErrors.push e in - let msg = match fst e with + let rec extract_exn = function Logic_monad.TacticFailure e -> extract_exn e | e -> e in + let msg = match extract_exn (fst e) with | ParameterWithoutEquality cst -> alarm what internal (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ @@ -176,6 +177,14 @@ let try_declare_scheme what f internal names kn = | NoDecidabilityCoInductive -> alarm what internal (str "Scheme Equality is only for inductive types.") + | DecidabilityIndicesNotSupported -> + alarm what internal + (str "Inductive types with annotations not supported.") + | ConstructorWithNonParametricInductiveType ind -> + alarm what internal + (strbrk "Unsupported constructor with an argument whose type is a non-parametric inductive type." ++ + strbrk " Type " ++ quote (Printer.pr_inductive (Global.env()) ind) ++ + str " is applied to an argument which is not a variable.") | e when CErrors.noncritical e -> alarm what internal (str "Unexpected error during scheme creation: " ++ CErrors.print e) @@ -321,11 +330,10 @@ let declare_sym_scheme ind = (* Scheme command *) let smart_global_inductive y = smart_global_inductive y -let rec split_scheme l = - let env = Global.env() in +let rec split_scheme env l = match l with | [] -> [],[] - | (Some id,t)::q -> let l1,l2 = split_scheme q in + | (Some id,t)::q -> let l1,l2 = split_scheme env q in ( match t with | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 @@ -336,7 +344,7 @@ let rec split_scheme l = requested *) | (None,t)::q -> - let l1,l2 = split_scheme q in + let l1,l2 = split_scheme env q in let names inds recs isdep y z = let ind = smart_global_inductive y in let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in @@ -399,12 +407,12 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let _ = List.fold_right2 declare listdecl lrecnames [] in fixpoint_message None lrecnames -let get_common_underlying_mutual_inductive = function +let get_common_underlying_mutual_inductive env = function | [] -> assert false | (id,(mind,i as ind))::l as all -> match List.filter (fun (_,(mind',_)) -> not (MutInd.equal mind mind')) l with | (_,ind')::_ -> - raise (RecursionSchemeError (NotMutualInScheme (ind,ind'))) + raise (RecursionSchemeError (env, NotMutualInScheme (ind,ind'))) | [] -> if not (List.distinct_f Int.compare (List.map snd (List.map snd all))) then user_err Pp.(str "A type occurs twice"); @@ -413,7 +421,8 @@ let get_common_underlying_mutual_inductive = function (function (Some id,(_,i)) -> Some (i,id.CAst.v) | (None,_) -> None) all let do_scheme l = - let ischeme,escheme = split_scheme l in + let env = Global.env() in + let ischeme,escheme = split_scheme env l in (* we want 1 kind of scheme at a time so we check if the user tried to declare different schemes at once *) if not (List.is_empty ischeme) && not (List.is_empty escheme) @@ -422,7 +431,7 @@ tried to declare different schemes at once *) else ( if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme else - let mind,l = get_common_underlying_mutual_inductive escheme in + let mind,l = get_common_underlying_mutual_inductive env escheme in declare_beq_scheme_with l mind; declare_eq_decidability_scheme_with l mind ) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e15e57a003..b4b3aead91 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -178,11 +178,11 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = function + let pr_reference_or_constr pr_c = let open Hints in function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c - let pr_hint_mode = function + let pr_hint_mode = let open Hints in function | ModeInput -> str"+" | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" @@ -194,6 +194,7 @@ open Pputils let pr_hints db h pr_c pr_pat = let opth = pr_opt_hintbases db in let pph = + let open Hints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 0c0204a728..a5601d8c85 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -16,11 +16,11 @@ open Libnames type class_rawexpr = FunClass | SortClass | RefClass of qualid or_by_notation type goal_selector = Goal_select.t = - | SelectAlreadyFocused - | SelectNth of int - | SelectList of (int * int) list - | SelectId of Id.t - | SelectAll + | SelectAlreadyFocused [@ocaml.deprecated "Use Goal_select.SelectAlreadyFocused"] + | SelectNth of int [@ocaml.deprecated "Use Goal_select.SelectNth"] + | SelectList of (int * int) list [@ocaml.deprecated "Use Goal_select.SelectList"] + | SelectId of Id.t [@ocaml.deprecated "Use Goal_select.SelectId"] + | SelectAll [@ocaml.deprecated "Use Goal_select.SelectAll"] [@@ocaml.deprecated "Use Goal_select.t"] type goal_identifier = string @@ -103,38 +103,41 @@ type comment = | CommentInt of int type reference_or_constr = Hints.reference_or_constr = - | HintsReference of qualid - | HintsConstr of constr_expr + | HintsReference of qualid [@ocaml.deprecated "Use Hints.HintsReference"] + | HintsConstr of constr_expr [@ocaml.deprecated "Use Hints.HintsConstr"] [@@ocaml.deprecated "Please use [Hints.reference_or_constr]"] type hint_mode = Hints.hint_mode = - | ModeInput (* No evars *) - | ModeNoHeadEvar (* No evar at the head *) - | ModeOutput (* Anything *) + | ModeInput [@ocaml.deprecated "Use Hints.ModeInput"] + | ModeNoHeadEvar [@ocaml.deprecated "Use Hints.ModeNoHeadEvar"] + | ModeOutput [@ocaml.deprecated "Use Hints.ModeOutput"] [@@ocaml.deprecated "Please use [Hints.hint_mode]"] type 'a hint_info_gen = 'a Typeclasses.hint_info_gen = - { hint_priority : int option; - hint_pattern : 'a option } + { hint_priority : int option; [@ocaml.deprecated "Use Typeclasses.hint_priority"] + hint_pattern : 'a option [@ocaml.deprecated "Use Typeclasses.hint_pattern"] } [@@ocaml.deprecated "Please use [Typeclasses.hint_info_gen]"] type hint_info_expr = Hints.hint_info_expr [@@ocaml.deprecated "Please use [Hints.hint_info_expr]"] -type 'a hints_transparency_target = 'a Hints.hints_transparency_target = - | HintsVariables - | HintsConstants - | HintsReferences of 'a list - type hints_expr = Hints.hints_expr = | HintsResolve of (Hints.hint_info_expr * bool * Hints.reference_or_constr) list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsResolveIFF of bool * qualid list * int option + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsImmediate of Hints.reference_or_constr list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsUnfold of qualid list - | HintsTransparency of qualid hints_transparency_target * bool + [@ocaml.deprecated "Use the constructor in module [Hints]"] + | HintsTransparency of qualid Hints.hints_transparency_target * bool + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsMode of qualid * Hints.hint_mode list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsConstructors of qualid list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument + [@ocaml.deprecated "Use the constructor in module [Hints]"] [@@ocaml.deprecated "Please use [Hints.hints_expr]"] type search_restriction = @@ -143,7 +146,9 @@ type search_restriction = type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) -type opacity_flag = Proof_global.opacity_flag = Opaque | Transparent +type opacity_flag = Proof_global.opacity_flag = + Opaque [@ocaml.deprecated "Use Proof_global.Opaque"] + | Transparent [@ocaml.deprecated "Use Proof_global.Transparent"] [@ocaml.deprecated "Please use [Proof_global.opacity_flag]"] type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option @@ -289,7 +294,9 @@ type bullet = Proof_bullet.t type 'a module_signature = 'a Declaremods.module_signature = | Enforce of 'a (** ... : T *) + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] [@@ocaml.deprecated "please use [Declaremods.module_signature]."] (** Which module inline annotations should we honor, @@ -298,8 +305,11 @@ type 'a module_signature = 'a Declaremods.module_signature = type inline = Declaremods.inline = | NoInline + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | DefaultInline + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | InlineAt of int + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] [@@ocaml.deprecated "please use [Declaremods.inline]."] type module_ast_inl = module_ast * Declaremods.inline |