diff options
352 files changed, 5123 insertions, 3145 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index fe7913a3d2..9e2af04e28 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -14,7 +14,7 @@ /configure* @coq/legacy-build-maintainers @coq/build-maintainers -/META.coq.in @coq/legacy-build-maintainers +/META.coq-core.in @coq/legacy-build-maintainers ########## CI infrastructure ########## @@ -228,6 +228,7 @@ /toplevel/ @coq/toplevel-maintainers /topbin/ @coq/toplevel-maintainers +/sysinit/ @coq/toplevel-maintainers ########## Vernacular ########## diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f5527192e0..7ec3ba1bd7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -63,18 +63,18 @@ jobs: MACOSX_DEPLOYMENT_TARGET: "10.11" NJOBS: "2" + - name: Install Coq + run: | + make install install-byte + - name: Run Coq Test Suite run: | eval $(opam env) - export OCAMLPATH=$(pwd):"$OCAMLPATH" + export OCAMLPATH="$(pwd)/_install_ci/lib":"$OCAMLPATH" make -j "$NJOBS" test-suite PRINT_LOGS=1 env: NJOBS: "2" - - name: Install Coq - run: | - make install - - name: Create the dmg bundle run: | eval $(opam env) diff --git a/.gitignore b/.gitignore index aab1d1ede7..bf7430cc2e 100644 --- a/.gitignore +++ b/.gitignore @@ -152,6 +152,7 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +kernel/byterun/coq_arity.h kernel/genOpcodeFiles.exe kernel/vmopcodes.ml kernel/uint63.ml @@ -183,6 +184,7 @@ plugins/ssr/ssrvernac.ml # ocaml dev files .merlin META.coq +META.coq-core # Files automatically generated by Dune. *.install diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 754c09776e..d0ffedab2a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,7 +20,7 @@ variables: # Format: $IMAGE-V$DATE-$hash # The $hash is the first 10 characters of the md5 of the Dockerfile. e.g. # echo $(md5sum dev/ci/docker/bionic_coq/Dockerfile | head -c 10) - CACHEKEY: "bionic_coq-V2020-12-25-95a34df128" + CACHEKEY: "bionic_coq-V2021-02-11-b601de5a7b" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -260,7 +260,7 @@ before_script: stage: stage-1 interruptible: true variables: - PLATFORM: "https://github.com/coq/platform/archive/master.zip" + PLATFORM: "https://github.com/coq/platform/archive/dev-ci.zip" artifacts: name: "$CI_JOB_NAME" paths: @@ -351,6 +351,9 @@ windows64: - call dev/ci/platform-windows.bat tags: - windows-inria + only: + variables: + - $WINDOWS =~ /enabled/ lint: stage: stage-1 @@ -372,7 +375,8 @@ pkg:opam: # OPAM will build out-of-tree so no point in importing artifacts script: - set -e - - opam pin add --kind=path coq.dev . + - opam pin add --kind=path coq-core.dev . + - opam pin add --kind=path coq-stdlib.dev . - opam pin add --kind=path coqide-server.dev . - opam pin add --kind=path coqide.dev . - set +e @@ -828,7 +832,7 @@ plugin:ci-coq_dpdgraph: extends: .ci-template plugin:ci-coqhammer: - extends: .ci-template + extends: .ci-template-flambda plugin:ci-elpi: extends: .ci-template diff --git a/META.coq.in b/META.coq-core.in index 68ab0733ee..c58513979d 100644 --- a/META.coq.in +++ b/META.coq-core.in @@ -35,7 +35,7 @@ package "lib" ( directory = "lib" - requires = "coq.clib, coq.config, dynlink" + requires = "coq-core.clib, coq-core.config, dynlink" archive(byte) = "lib.cma" archive(native) = "lib.cmxa" @@ -68,7 +68,7 @@ package "kernel" ( directory = "kernel" - requires = "coq.lib, coq.vm" + requires = "coq-core.lib, coq-core.vm" archive(byte) = "kernel.cma" archive(native) = "kernel.cmxa" @@ -80,7 +80,7 @@ package "library" ( description = "Coq Libraries (vo) support" version = "8.14" - requires = "coq.kernel" + requires = "coq-core.kernel" directory = "library" @@ -94,7 +94,7 @@ package "engine" ( description = "Coq Tactic Engine" version = "8.14" - requires = "coq.library" + requires = "coq-core.library" directory = "engine" archive(byte) = "engine.cma" @@ -107,7 +107,7 @@ package "pretyping" ( description = "Coq Pretyper" version = "8.14" - requires = "coq.engine" + requires = "coq-core.engine" directory = "pretyping" archive(byte) = "pretyping.cma" @@ -120,7 +120,7 @@ package "interp" ( description = "Coq Term Interpretation" version = "8.14" - requires = "zarith, coq.pretyping" + requires = "zarith, coq-core.pretyping" directory = "interp" archive(byte) = "interp.cma" @@ -133,7 +133,7 @@ package "proofs" ( description = "Coq Proof Engine" version = "8.14" - requires = "coq.interp" + requires = "coq-core.interp" directory = "proofs" archive(byte) = "proofs.cma" @@ -146,7 +146,7 @@ package "gramlib" ( description = "Coq Grammar Engine" version = "8.14" - requires = "coq.lib" + requires = "coq-core.lib" directory = "gramlib/.pack" archive(byte) = "gramlib.cma" @@ -158,7 +158,7 @@ package "parsing" ( description = "Coq Parsing Engine" version = "8.14" - requires = "coq.gramlib, coq.proofs" + requires = "coq-core.gramlib, coq-core.proofs" directory = "parsing" archive(byte) = "parsing.cma" @@ -171,7 +171,7 @@ package "printing" ( description = "Coq Printing Engine" version = "8.14" - requires = "coq.parsing" + requires = "coq-core.parsing" directory = "printing" archive(byte) = "printing.cma" @@ -184,7 +184,7 @@ package "tactics" ( description = "Coq Basic Tactics" version = "8.14" - requires = "coq.printing" + requires = "coq-core.printing" directory = "tactics" archive(byte) = "tactics.cma" @@ -197,7 +197,7 @@ package "vernac" ( description = "Coq Vernacular Interpreter" version = "8.14" - requires = "coq.tactics" + requires = "coq-core.tactics" directory = "vernac" archive(byte) = "vernac.cma" @@ -207,10 +207,10 @@ package "vernac" ( package "stm" ( - description = "Coq State Transactional Machine" + description = "Coq State Transaction Machine" version = "8.14" - requires = "coq.vernac" + requires = "coq-core.sysinit" directory = "stm" archive(byte) = "stm.cma" @@ -218,12 +218,25 @@ package "stm" ( ) +package "sysinit" ( + + description = "Coq initialization" + version = "8.14" + + requires = "coq-core.vernac" + directory = "sysinit" + + archive(byte) = "sysinit.cma" + archive(native) = "sysinit.cmxa" + +) + package "toplevel" ( description = "Coq Toplevel" version = "8.14" - requires = "coq.stm" + requires = "coq-core.stm" directory = "toplevel" archive(byte) = "toplevel.cma" @@ -236,7 +249,7 @@ package "idetop" ( description = "Coq IDE Libraries" version = "8.14" - requires = "coq.toplevel" + requires = "coq-core.toplevel" directory = "ide" archive(byte) = "coqidetop.cma" @@ -249,7 +262,7 @@ package "ide" ( description = "Coq IDE Libraries" version = "8.14" - requires = "coq.lib, coq.ideprotocol, lablgtk3, lablgtk3-sourceview3" + requires = "coq-core.lib, coq-core.ideprotocol, lablgtk3, lablgtk3-sourceview3" directory = "ide" archive(byte) = "ide.cma" @@ -262,7 +275,7 @@ package "ideprotocol" ( description = "Coq IDE protocol" version = "8.14" - requires = "coq.toplevel" + requires = "coq-core.toplevel" directory = "ide/protocol" archive(byte) = "ideprotocol.cma" @@ -282,7 +295,7 @@ package "plugins" ( description = "Coq LTAC Plugin" version = "8.14" - requires = "coq.stm" + requires = "coq-core.stm" directory = "ltac" archive(byte) = "ltac_plugin.cmo" @@ -297,7 +310,7 @@ package "plugins" ( description = "Coq tauto plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "ltac" archive(byte) = "tauto_plugin.cmo" @@ -312,7 +325,7 @@ package "plugins" ( description = "Coq omega plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "omega" archive(byte) = "omega_plugin.cmo" @@ -327,7 +340,7 @@ package "plugins" ( description = "Coq micromega plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "micromega" archive(byte) = "micromega_plugin.cmo" @@ -342,7 +355,7 @@ package "plugins" ( description = "Coq Zify plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "micromega" archive(byte) = "zify_plugin.cmo" @@ -372,7 +385,7 @@ package "plugins" ( description = "Coq extraction plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "extraction" archive(byte) = "extraction_plugin.cmo" @@ -387,7 +400,7 @@ package "plugins" ( description = "Coq cc plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "cc" archive(byte) = "cc_plugin.cmo" @@ -402,7 +415,7 @@ package "plugins" ( description = "Coq ground plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "firstorder" archive(byte) = "ground_plugin.cmo" @@ -417,7 +430,7 @@ package "plugins" ( description = "Coq rtauto plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "rtauto" archive(byte) = "rtauto_plugin.cmo" @@ -432,7 +445,7 @@ package "plugins" ( description = "Coq btauto plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "btauto" archive(byte) = "btauto_plugin.cmo" @@ -447,7 +460,7 @@ package "plugins" ( description = "Coq recdef plugin" version = "8.14" - requires = "coq.plugins.extraction" + requires = "coq-core.plugins.extraction" directory = "funind" archive(byte) = "recdef_plugin.cmo" @@ -462,7 +475,7 @@ package "plugins" ( description = "Coq nsatz plugin" version = "8.14" - requires = "zarith, coq.plugins.ltac" + requires = "zarith, coq-core.plugins.ltac" directory = "nsatz" archive(byte) = "nsatz_plugin.cmo" @@ -487,27 +500,12 @@ package "plugins" ( plugin(native) = "r_syntax_plugin.cmxs" ) - package "int63syntax" ( - - description = "Coq int63syntax plugin" - version = "8.14" - - requires = "" - directory = "syntax" - - archive(byte) = "int63_syntax_plugin.cmo" - archive(native) = "int63_syntax_plugin.cmx" - - plugin(byte) = "int63_syntax_plugin.cmo" - plugin(native) = "int63_syntax_plugin.cmxs" - ) - package "string_notation" ( description = "Coq string_notation plugin" version = "8.14" - requires = "coq.vernac" + requires = "coq-core.vernac" directory = "syntax" archive(byte) = "string_notation_plugin.cmo" @@ -521,7 +519,7 @@ package "plugins" ( description = "Coq numeral notation plugin" version = "8.14" - requires = "coq.vernac" + requires = "coq-core.vernac" directory = "numeral_notation" archive(byte) = "numeral_notation_plugin.cmo" @@ -551,7 +549,7 @@ package "plugins" ( description = "Coq ssrmatching plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "ssrmatching" archive(byte) = "ssrmatching_plugin.cmo" @@ -566,7 +564,7 @@ package "plugins" ( description = "Coq ssreflect plugin" version = "8.14" - requires = "coq.plugins.ssrmatching" + requires = "coq-core.plugins.ssrmatching" directory = "ssr" archive(byte) = "ssreflect_plugin.cmo" @@ -581,7 +579,7 @@ package "plugins" ( description = "Coq Ltac2 Plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "../user-contrib/Ltac2" archive(byte) = "ltac2_plugin.cmo" diff --git a/Makefile.build b/Makefile.build index b307bde5df..d619fd3c85 100644 --- a/Makefile.build +++ b/Makefile.build @@ -367,6 +367,10 @@ kernel/byterun/coq_jumptbl.h: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< jump > $@ +kernel/byterun/coq_arity.h: kernel/genOpcodeFiles.exe + $(SHOW)'WRITE $@' + $(HIDE)$< arity > $@ + kernel/vmopcodes.ml: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< copml > $@ diff --git a/Makefile.common b/Makefile.common index 82d9b89c4f..dc40413078 100644 --- a/Makefile.common +++ b/Makefile.common @@ -99,7 +99,7 @@ CORESRCDIRS:=\ coqpp \ config clib lib kernel kernel/byterun library \ engine pretyping interp proofs gramlib/.pack parsing printing \ - tactics vernac stm toplevel + tactics vernac stm sysinit toplevel PLUGINDIRS:=\ omega micromega \ @@ -132,7 +132,7 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ gramlib/.pack/gramlib.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma + sysinit/sysinit.cma stm/stm.cma toplevel/toplevel.cma ########################################################################### # plugins object files @@ -149,7 +149,6 @@ CCCMO:=plugins/cc/cc_plugin.cmo BTAUTOCMO:=plugins/btauto/btauto_plugin.cmo RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ - int63_syntax_plugin.cmo \ float_syntax_plugin.cmo \ number_string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo diff --git a/Makefile.dev b/Makefile.dev index 5825a884c2..cfb02b6d80 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -91,10 +91,11 @@ interp: interp/interp.cma parsing: parsing/parsing.cma pretyping: pretyping/pretyping.cma stm: stm/stm.cma +sysinit: sysinit/sysinit.cma toplevel: toplevel/toplevel.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine stm toplevel +.PHONY: engine stm sysinit toplevel ###################### ### 3) theories files diff --git a/Makefile.dune b/Makefile.dune index c2899dcaba..c338405f2c 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -56,7 +56,8 @@ help-install: @echo "" @echo " Provided opam/dune packages are:" @echo "" - @echo " - coq: base Coq package, toplevel compilers, tools, stdlib, no GTK" + @echo " - coq-core: base Coq package, toplevel compilers, plugins, tools, no stdlib, no GTK" + @echo " - coq-stdlib: Coq's standard library" @echo " - coqide-server: XML protocol language server" @echo " - coqide: CoqIDE gtk application" @echo "" @@ -82,7 +83,7 @@ voboot: states: dune build $(DUNEOPT) dev/shim/coqtop-prelude -NONDOC_INSTALL_TARGETS:=coq.install coqide-server.install coqide.install +NONDOC_INSTALL_TARGETS:=coq-core.install coq-stdlib.install coqide-server.install coqide.install world: dune build $(DUNEOPT) $(NONDOC_INSTALL_TARGETS) diff --git a/Makefile.install b/Makefile.install index 4977bb38e1..0dd4c1bc24 100644 --- a/Makefile.install +++ b/Makefile.install @@ -162,8 +162,9 @@ install-latex: $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) -install-meta: META.coq - $(INSTALLLIB) META.coq $(FULLCOQLIB)/META +install-meta: META.coq-core + $(INSTALLLIB) META.coq-core $(FULLCOQLIB)/META + cd $(FULLCOQLIB)/.. && rm -f coq-core && ln -s coq coq-core # For emacs: # Local Variables: diff --git a/Makefile.make b/Makefile.make index 2f6781439c..9f0e06dffc 100644 --- a/Makefile.make +++ b/Makefile.make @@ -109,7 +109,7 @@ GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml no GENMLGFILES:= $(MLGFILES:.mlg=.ml) GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/vmopcodes.ml kernel/uint63.ml kernel/float64.ml GENMLIFILES:=$(GRAMMLIFILES) -GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +GENHFILES:=$(addprefix kernel/byterun/, coq_instruct.h coq_jumptbl.h coq_arity.h) GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe COQ_EXPORTED += GRAMFILES GRAMMLFILES GRAMMLIFILES GENMLFILES GENHFILES GENFILES @@ -187,10 +187,10 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; ########################################################################### # OCaml dev files ########################################################################### -camldevfiles: $(MERLINFILES) META.coq +camldevfiles: $(MERLINFILES) META.coq-core # prevent submake dependency -META.coq.in $(MERLININFILES): ; +META.coq-core.in $(MERLININFILES): ; .merlin: .merlin.in cp -a "$<" "$@" @@ -198,7 +198,7 @@ META.coq.in $(MERLININFILES): ; %/.merlin: %/.merlin.in cp -a "$<" "$@" -META.coq: META.coq.in +META.coq-core: META.coq-core.in cp -a "$<" "$@" ########################################################################### @@ -222,7 +222,7 @@ cruftclean: mlgclean rm -f gmon.out core camldevfilesclean: - rm -f $(MERLINFILES) META.coq + rm -f $(MERLINFILES) META.coq-core indepclean: rm -f $(GENFILES) @@ -274,7 +274,7 @@ depclean: find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + cacheclean: - find theories test-suite -name '.*.aux' -exec rm -f {} + + find theories user-contrib test-suite -name '.*.aux' -exec rm -f {} + cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-coq config/Info-*.plist @@ -282,12 +282,12 @@ cleanconfig: distclean: clean cleanconfig cacheclean timingclean voclean: - find theories plugins test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.glob' -o -name "*.cmxs" \ + find theories plugins user-contrib test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -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 -rf {} + + find theories plugins user-contrib test-suite -name .coq-native -empty -exec rm -rf {} + timingclean: - find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ + find theories plugins user-contrib test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" \ -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + @@ -65,12 +65,9 @@ environment for semi-interactive development of machine-checked proofs. [coqorg-badge]: https://images.microbadger.com/badges/version/coqorg/coq.svg [coqorg-link]: https://github.com/coq-community/docker-coq/wiki#docker-coq-images "coqorg/coq:latest" -Download the pre-built packages of the [latest release][] for Windows and macOS; -read the [help page][opam-using] on how to install Coq with OPAM; -or refer to the [`INSTALL.md`](INSTALL.md) file for the procedure to install from source. - -[latest release]: https://github.com/coq/coq/releases/latest -[opam-using]: https://coq.inria.fr/opam/www/using.html +Please see https://coq.inria.fr/download. +Information on how to build and install from sources can be found in +[`INSTALL.md`](INSTALL.md). ## Documentation diff --git a/checker/check.ml b/checker/check.ml index 1ff1425dea..587bb90d43 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -149,7 +149,7 @@ let remove_load_path dir = load_paths := List.filter2 (fun p d -> p <> dir) physical logical let add_load_path (phys_path,coq_path) = - if !Flags.debug then + if CDebug.(get_flag misc) then Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = CUnix.canonical_path_name phys_path in diff --git a/checker/checker.ml b/checker/checker.ml index bdfc5f07be..f55ed9e8d6 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -48,19 +48,17 @@ let path_of_string s = let ( / ) = Filename.concat -let get_version_date () = +let get_version () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in - (ver,rev) - with _ -> (Coq_config.version,Coq_config.date) + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let print_header () = - let (ver,rev) = (get_version_date ()) in - Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; - flush stdout + Printf.printf "Welcome to Chicken %s\n%!" (get_version ()) (* Adding files to Coq loadpath *) @@ -109,7 +107,15 @@ let init_load_path () = let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs in let coqpath = Envars.coqpath in - let plugins = coqlib/"plugins" in + let plugins = + CPath.choose_existing + [ CPath.make [ coqlib ; "plugins" ] + ; CPath.make [ coqlib ; ".."; "coq-core"; "plugins" ] + ] |> function + | None -> + CErrors.user_err (Pp.str "Cannot find plugins directory") + | Some f -> (f :> string) + in (* NOTE: These directories are searched from last to first *) (* first standard library *) add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.DirPath.make[coq_root]); @@ -132,8 +138,6 @@ let init_load_path () = includes := [] -let set_debug () = Flags.debug := true - let impredicative_set = ref Declarations.PredicativeSet let set_impredicative_set () = impredicative_set := Declarations.ImpredicativeSet @@ -170,9 +174,7 @@ let compile_files senv = ~check:(List.rev !compile_list) let version () = - Printf.printf "The Coq Proof Checker, version %s (%s)\n" - Coq_config.version Coq_config.date; - Printf.printf "compiled on %s\n" Coq_config.compile_date; + Printf.printf "The Coq Proof Checker, version %s\n" Coq_config.version; exit 0 (* print the usage of coqtop (or coqc) on channel co *) @@ -222,7 +224,7 @@ let guill s = str "\"" ++ str s ++ str "\"" let where = function | None -> mt () | Some s -> - if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) + if CDebug.(get_flag misc) then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let explain_exn = function | Stream.Failure -> @@ -251,7 +253,7 @@ let explain_exn = function hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency i -> let msg = - if !Flags.debug then + if CDebug.(get_flag misc) then str "." ++ spc() ++ Univ.explain_universe_inconsistency Univ.Level.pr i else @@ -339,7 +341,7 @@ let parse_args argv = | ("-Q"|"-R") :: d :: p :: rem -> set_include d p;parse rem | ("-Q"|"-R") :: ([] | [_]) -> usage () - | "-debug" :: rem -> set_debug (); parse rem + | "-debug" :: rem -> CDebug.set_debug_all true; parse rem | "-where" :: _ -> Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); @@ -377,7 +379,7 @@ let init_with_argv argv = try parse_args argv; CWarnings.set_flags ("+"^Typeops.warn_bad_relevance_name); - if !Flags.debug then Printexc.record_backtrace true; + if CDebug.(get_flag misc) then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); init_load_path (); @@ -392,7 +394,7 @@ let run senv = let senv = compile_files senv in flush_all(); senv with e -> - if !Flags.debug then Printexc.print_backtrace stderr; + if CDebug.(get_flag misc) then Printexc.print_backtrace stderr; fatal_error (explain_exn e) (is_anomaly e) let start () = diff --git a/checker/dune b/checker/dune index af7d4f2923..78b4032141 100644 --- a/checker/dune +++ b/checker/dune @@ -7,13 +7,14 @@ (synopsis "Coq's Standalone Proof Checker") (modules :standard \ coqchk votour) (wrapped true) - (libraries coq.kernel)) + (libraries coq-core.kernel)) (executable (name coqchk) (public_name coqchk) (modes exe byte) - (package coq) + ; Move to coq-checker? + (package coq-core) (modules coqchk) (flags :standard -open Coq_checklib) (libraries coq_checklib)) @@ -21,7 +22,7 @@ (executable (name votour) (public_name votour) - (package coq) + (package coq-core) (modules votour) (flags :standard -open Coq_checklib) (libraries coq_checklib)) diff --git a/checker/values.ml b/checker/values.ml index 907f9f7e32..f7a367b986 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -240,7 +240,7 @@ let v_template_universes = v_tuple "template_universes" [|List(Opt v_level);v_context_set|] let v_primitive = - v_enum "primitive" 50 (* Number of "Primitive" in Int63.v and PrimFloat.v *) + v_enum "primitive" 54 (* Number of constructors of the CPrimitives.t type *) let v_cst_def = v_sum "constant_def" 0 diff --git a/clib/cPath.ml b/clib/cPath.ml new file mode 100644 index 0000000000..66d03078dc --- /dev/null +++ b/clib/cPath.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This API is loosely inspired by [Stdune.Path], for now we keep it + minimal, but at some point we may extend it, see developer notes in + the implementation file. *) + +type t = string + +(* Note that in general, make is not safe, due to its type, however + relative is as you can enforce a particular root. So we eventually + should remove [make] *) +let make = List.fold_left Filename.concat "" + +let relative = Filename.concat + +let rec choose_existing = function + | [] -> None + | f :: fs -> + if Sys.file_exists f then Some f else choose_existing fs diff --git a/clib/cPath.mli b/clib/cPath.mli new file mode 100644 index 0000000000..762279a218 --- /dev/null +++ b/clib/cPath.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This API is loosely inspired by [Stdune.Path], for now we keep it + minimal, but at some point we may extend it, see developer notes in + the implementation file. *) + +(* To be made opaque one day, for now we force users to go thru the + constructor *) +type t = private string + +(** [make path_components] build a path from its components *) +val make : string list -> t + +(** [relative path string] build a path relative to an existing one *) +val relative : t -> string -> t + +(** [choose_existing paths] will return [Some f] for the first file + [f] in [paths] that exists, [None] otherwise. *) +val choose_existing : t list -> t option + +(* We should gradually add some more functions to handle common dirs + here such the theories directories or share files. Abstracting it + here does allow to use system-specific functionalities *) diff --git a/clib/clib.mllib b/clib/clib.mllib index be3b5971be..02f2ec8e56 100644 --- a/clib/clib.mllib +++ b/clib/clib.mllib @@ -37,3 +37,5 @@ Terminal Monad Diff2 + +CPath @@ -1,8 +1,7 @@ (library (name clib) (synopsis "Coq's Utility Library [general purpose]") - (public_name coq.clib) + (public_name coq-core.clib) (wrapped false) (modules_without_implementation cSig) (libraries str unix threads)) - diff --git a/config/coq_config.mli b/config/coq_config.mli index 809fa3d758..035574475d 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -33,8 +33,6 @@ val arch_is_win32 : bool val version : string (* version number of Coq *) val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) -val date : string (* release date *) -val compile_date : string (* compile date *) val vo_version : int32 val state_magic_number : int diff --git a/config/dune b/config/dune index 83d1364b0c..777201f29f 100644 --- a/config/dune +++ b/config/dune @@ -1,7 +1,7 @@ (library (name config) (synopsis "Coq Configuration Variables") - (public_name coq.config) + (public_name coq-core.config) (modules :standard \ list_plugins) (wrapped false)) diff --git a/configure.ml b/configure.ml index 40d77ed109..abea59bd60 100644 --- a/configure.ml +++ b/configure.ml @@ -196,31 +196,6 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false -let build_date = - try - float_of_string (Sys.getenv "SOURCE_DATE_EPOCH") - with - Not_found -> Unix.time () - -(** * Date *) - -(** The short one is displayed when starting coqtop, - The long one is used as compile date *) - -let months = - [| "January";"February";"March";"April";"May";"June"; - "July";"August";"September";"October";"November";"December" |] - -let get_date () = - let now = Unix.gmtime build_date in - let year = 1900+now.Unix.tm_year in - let month = months.(now.Unix.tm_mon) in - sprintf "%s %d" month year, - sprintf "%s %d %d %d:%02d:%02d" (String.sub month 0 3) now.Unix.tm_mday year - now.Unix.tm_hour now.Unix.tm_min now.Unix.tm_sec - -let short_date, full_date = get_date () - (** * Command-line parsing *) type ide = Opt | Byte | No @@ -361,9 +336,16 @@ let arg_profile = Arg.String (fun s -> prefs := Profiles.get s !prefs) (* TODO : earlier any option -foo was also available as --foo *) +let check_absolute = function + | None -> () + | Some path -> + if Filename.is_relative path then + die "argument to -prefix must be an absolute path" + else () + let args_options = Arg.align [ - "-prefix", arg_string_option (fun p prefix -> { p with prefix }), - "<dir> Set installation directory to <dir>"; + "-prefix", arg_string_option (fun p prefix -> check_absolute prefix; { p with prefix }), + "<dir> Set installation directory to <dir> (absolute path required)"; "-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 }), @@ -1096,8 +1078,6 @@ let write_configml f = pr_s "version" coq_version; pr_s "caml_version" caml_version; pr_li "caml_version_nums" caml_version_nums; - pr_s "date" short_date; - pr_s "compile_date" full_date; pr_s "arch" arch; pr_b "arch_is_win32" arch_is_win32; pr_s "exec_extension" exe; diff --git a/coq-core.opam b/coq-core.opam new file mode 100644 index 0000000000..8b8c43f66e --- /dev/null +++ b/coq-core.opam @@ -0,0 +1,54 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" +synopsis: "The Coq Proof Assistant -- Core Binaries and Tools" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq core binaries, plugins, and tools, but +not the vernacular standard library. + +Note that in this setup, Coq needs to be started with the -boot and +-noinit options, as will otherwise fail to find the regular Coq +prelude, now living in the coq-stdlib package.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" +homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" +bug-reports: "https://github.com/coq/coq/issues" +depends: [ + "dune" {>= "2.5"} + "ocaml" {>= "4.05.0"} + "ocamlfind" {>= "1.8.1"} + "zarith" {>= "1.10"} + "ounit2" {with-test} +] +build: [ + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/coq/coq.git" +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] diff --git a/coq.opam.template b/coq-core.opam.template index c0efccdc0f..c0efccdc0f 100644 --- a/coq.opam.template +++ b/coq-core.opam.template diff --git a/coq-doc.opam b/coq-doc.opam index 3a872db33d..37bf1e95fe 100644 --- a/coq-doc.opam +++ b/coq-doc.opam @@ -17,11 +17,12 @@ doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ "dune" {build & >= "2.5.0"} + "conf-python-3" {build} "coq" {build & = version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coq-stdlib.opam b/coq-stdlib.opam new file mode 100644 index 0000000000..20d994abcb --- /dev/null +++ b/coq-stdlib.opam @@ -0,0 +1,44 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" +synopsis: "The Coq Proof Assistant -- Standard Library" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq Standard Library, that is to say, the +set of modules usually bound to the Coq.* namespace.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" +homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" +bug-reports: "https://github.com/coq/coq/issues" +depends: [ + "dune" {>= "2.5"} + "coq-core" {= version} +] +build: [ + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/coq/coq.git" @@ -20,14 +20,12 @@ homepage: "https://coq.inria.fr/" doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ - "ocaml" {>= "4.05.0"} - "dune" {>= "2.5.0"} - "ocamlfind" {>= "1.8.1"} - "zarith" {>= "1.10"} + "dune" {>= "2.5"} + "coq-core" {= version} + "coq-stdlib" {= version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + ["dune" "subst"] {pinned} [ "dune" "build" @@ -41,6 +39,3 @@ build: [ ] ] dev-repo: "git+https://github.com/coq/coq.git" -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] -] diff --git a/coqide-server.opam b/coqide-server.opam index cbb0db2893..8359b5f04e 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -19,12 +19,12 @@ homepage: "https://coq.inria.fr/" doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ - "dune" {>= "2.5.0"} - "coq" {= version} + "dune" {>= "2.5"} + "coq-core" {= version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coqide.opam b/coqide.opam index 9e4fb05701..3c59f7fd9c 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,12 +17,12 @@ homepage: "https://coq.inria.fr/" doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ - "dune" {>= "2.5.0"} + "dune" {>= "2.5"} "coqide-server" {= version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8affe58824..2de103a2ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -360,7 +360,7 @@ let print_body_fun state fmt r = print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_state state) r let print_body state fmt r = - fprintf fmt "@[(%afun %a~atts@ -> coqpp_body %a%a)@]" + fprintf fmt "@[(%afun %a?loc ~atts@ -> coqpp_body %a%a)@]" (print_body_fun state) r print_binders r.vernac_toks print_binders r.vernac_toks print_atts_right r.vernac_atts diff --git a/coqpp/dune b/coqpp/dune index d4b49301fb..e4cdc33b3d 100644 --- a/coqpp/dune +++ b/coqpp/dune @@ -10,6 +10,6 @@ (executable (name coqpp_main) (public_name coqpp) - (package coq) + (package coq-core) (libraries coqpp) (modules coqpp_main)) diff --git a/default.nix b/default.nix index 0b23bdb48c..f838f17d07 100644 --- a/default.nix +++ b/default.nix @@ -98,7 +98,7 @@ stdenv.mkDerivation rec { createFindlibDestdir = !shell; - postInstall = "ln -s $out/lib/coq $OCAMLFIND_DESTDIR/coq"; + postInstall = "ln -s $out/lib/coq-core $OCAMLFIND_DESTDIR/coq-core"; inherit doInstallCheck; diff --git a/dev/base_include b/dev/base_include index daee2d97c5..f375a867bc 100644 --- a/dev/base_include +++ b/dev/base_include @@ -134,7 +134,6 @@ open ComDefinition open Indschemes open Ind_tables open Auto_ind_decl -open Coqinit open Coqtop open Himsg open Metasyntax diff --git a/dev/bench/gitlab-bench.yml b/dev/bench/gitlab-bench.yml index 25545cf565..69136ee773 100644 --- a/dev/bench/gitlab-bench.yml +++ b/dev/bench/gitlab-bench.yml @@ -4,9 +4,7 @@ bench: when: manual before_script: - printenv -0 | sort -z | tr '\0' '\n' - script: - - . ~/.opam/opam-init/init.sh - - ./dev/bench/gitlab.sh + script: dev/bench/gitlab.sh tags: - timing variables: diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh index b616371ef8..569977f76b 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -52,7 +52,7 @@ check_variable "CI_JOB_URL" : "${new_coq_opam_archive_git_branch:=master}" : "${old_coq_opam_archive_git_branch:=master}" : "${num_of_iterations:=1}" -: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-perennial}" +: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-perennial coq-vst}" new_coq_commit=$(git rev-parse HEAD^2) old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index b4b6411d28..8f14625c63 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -44,7 +44,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages ENV BASE_OPAM="zarith.1.10 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.1" \ CI_OPAM="ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.12.0" + BASE_ONLY_OPAM="elpi.1.13.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" diff --git a/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh b/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh new file mode 100644 index 0000000000..d80363c49f --- /dev/null +++ b/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/SkySkimmer/coq-elpi debug-infra 13202 diff --git a/dev/ci/user-overlays/13842-proux01-remove-decimal.sh b/dev/ci/user-overlays/13842-proux01-remove-decimal.sh new file mode 100644 index 0000000000..5ede8221ce --- /dev/null +++ b/dev/ci/user-overlays/13842-proux01-remove-decimal.sh @@ -0,0 +1 @@ +overlay hott https://github.com/proux01/HoTT coq-13842 13842 diff --git a/dev/ci/user-overlays/13844-gares-command-loc.sh b/dev/ci/user-overlays/13844-gares-command-loc.sh new file mode 100644 index 0000000000..d9a1736532 --- /dev/null +++ b/dev/ci/user-overlays/13844-gares-command-loc.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/LPCIC/coq-elpi command-loc 13844 diff --git a/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh b/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh new file mode 100644 index 0000000000..6847bde6d8 --- /dev/null +++ b/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/LPCIC/coq-elpi coq-master+1.9.0 13847 diff --git a/dev/core.dbg b/dev/core.dbg index 6d52bae773..dcf9910b0b 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -16,5 +16,6 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/core_dune.dbg b/dev/core_dune.dbg index 3f73cf126a..da3022644d 100644 --- a/dev/core_dune.dbg +++ b/dev/core_dune.dbg @@ -17,5 +17,6 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 79c2155823..4452baf513 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -332,6 +332,18 @@ Conversion machines GH issue number: ocaml/ocaml#6385, #11170 risk: unlikely to be activated by chance, might happen for autogenerated code + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow, arbitrary code execution on floating-point operations + introduced: 8.13 + impacted released versions: 8.13.0 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.1 + found by: Melquiond + GH issue number: #13867 + risk: none, unless using floating-point operations; high otherwise; + noticeable if activated by chance, since it usually breaks + control-flow integrity + Side-effects component: side-effects diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 19562b60a2..57c325f698 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -1,176 +1,162 @@ -# Release process # - -## As soon as the previous version branched off master ## - -In principle, these steps should be undertaken by the RM of the next -release. Unfortunately, we have not yet been able to nominate RMs -early enough in the process for this person to be known at that point -in time. - -- [ ] Create a new issue to track the release process where you can copy-paste - the present checklist from `dev/doc/release-process.md`. -- [ ] Change the version name to the next major version and the magic - numbers (see [#7008](https://github.com/coq/coq/pull/7008/files)). +# Release checklist # + +## When the release managers for version `X.X` get nominated ## + +- [ ] Create a new issue to track the release process where you can + copy-paste the present checklist from `dev/doc/release-process.md`. +- [ ] Decide the release calendar with the team (date of branching, + preview and final release). +- [ ] Create a wiki page that you link to from + https://github.com/coq/coq/wiki/Release-Plan with this information + and the link to the issue. + +## About one month before the branching date ## + +- [ ] Create both the upcoming final release (`X.X.0`) and the + following major release (`Y.Y+rc1`) milestones if they do not + already exist. +- [ ] Send an announcement of the upcoming branching date on Coqdev + + the Coq development category on Discourse (coqdev@inria.fr + + coq+coq-development@discoursemail.com) and ask people to remove from + the `X.X+rc1` milestone any feature and clean up PRs that they + already know won't be ready on time. +- [ ] In a PR on `master`, call + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--release` flag; this sets up Coq to support three `-compat` flag + arguments including the upcoming one (instead of four). To ensure + that CI passes, you will have to decide what to do about all + test-suite files which mention `-compat U.U` or `Coq.Comapt.CoqUU` + (which is no longer valid, since we only keep compatibility against + the two previous versions), and you may have to ping maintainers of + projects that are still relying on the old compatibility flag so + that they fix this. +- [ ] Make sure that this change is merged in time for the branching + date. + +## On the branching date ## + +- [ ] In a PR on `master`, change the version name to the next major + version and the magic numbers (see + [#7008](https://github.com/coq/coq/pull/7008/files)). Additionally, in the same commit, update the compatibility infrastructure, which consists of invoking [`dev/tools/update-compat.py`](../tools/update-compat.py) with the `--master` flag. - Note that the `update-compat.py` script must be run twice: once - *immediately after* branching with the `--master` flag (which sets - up Coq to support four `-compat` flag arguments), *in the same - commit* as the one that updates `coq_version` in - [`configure.ml`](../../configure.ml), and once again later on before - the next branch point with the `--release` flag (see next section). -- [ ] Put the corresponding alpha tag using `git tag -s`. - The `VX.X+alpha` tag marks the first commit to be in `master` and not in the - branch of the previous version. Note that this commit is the first commit + Note that the `update-compat.py` script must be run twice: once in + preparation of the release with the `--release` flag (see previous + section) and once on the branching date with the `--master` flag to + mark the start of the next version. +- [ ] Merge the above PR and create the `vX.X` branch from the last + merge commit before this one (using this name will ensure that the + branch will be automatically protected). +- [ ] Set the next major version alpha tag using `git tag -s`. The + `VY.Y+alpha` tag marks the first commit to be in `master` and not in + the `vX.X` release branch. Note that this commit is the first commit in the first PR merged in master, not the merge commit for that PR. - After tagging double check that `git describe` picks up - the tag you just made (if not, you tagged the wrong commit). -- [ ] Create the `X.X+beta1` milestone if it did not already exist. -- [ ] Decide the release calendar with the team (freeze date, beta date, final - release date) and put this information in the milestone (using the - description and due date fields). - -## Anytime after the previous version is branched off master ## - -- [ ] Update the compatibility infrastructure to the next release, - which consists of invoking - [`dev/tools/update-compat.py`](../tools/update-compat.py) with the - `--release` flag; this sets up Coq to support three `-compat` flag - arguments. To ensure that CI passes, you will have to decide what - to do about all test-suite files which mention `-compat U.U` or - `Coq.Comapt.CoqUU` (which is no longer valid, since we only keep - compatibility against the two previous versions on releases), and - you may have to prepare overlays for projects using the - compatibility flags. - -## About one month before the beta ## - -- [ ] Create the `X.X.0` milestone and set its due date. -- [ ] Send an announcement of the upcoming freeze on Coqdev and ask people to - remove from the beta milestone what they already know won't be ready on time - (possibly postponing to the `X.X.0` milestone for minor bug fixes, - infrastructure and documentation updates). -- [ ] Determine which issues should / must be fixed before the beta, add them - to the beta milestone, possibly with a - ["priority: blocker"](https://github.com/coq/coq/labels/priority%3A%20blocker) - label. Make sure that all these issues are assigned (and that the assignee - provides an ETA). -- [ ] Ping the development coordinator (**@mattam82**) to get him started on - the update to the Credits chapter of the reference manual. - See also [#7058](https://github.com/coq/coq/issues/7058). - - The command that was used in the previous versions to get the list - of contributors for this version is `git shortlog -s -n - VX.X+alpha..master | cut -f2 | sort -k 2`. Note that the ordering is - approximative as it will misplace people with middle names. It is - also probably not correctly handling `Co-authored-by` info that we - have been using more lately, so should probably be updated to - account for this. - -## On the date of the feature freeze ## - -- [ ] Create the new version branch `vX.X` (using this name will ensure that - the branch will be automatically protected). -- [ ] Pin the versions of libraries and plugins in - `dev/ci/ci-basic-overlays.sh` to use commit hashes or tag (or, if it - exists, a branch dedicated to compatibility with the corresponding - Coq branch). You can use the `dev/tools/pin-ci.sh` script to do this - semi-automatically. - - [ ] Notify upstream authors about the pinning, see - `dev/tools/notify-upstream-pins.sh`. As of today there is no automated - way to track these issues. -- [ ] Remove all remaining unmerged feature PRs from the beta milestone. + Therefore, if you proceeded as described above, this should be the + commit updating the version, magic numbers and compatibility + infrastructure. After tagging, double-check that `git describe` + picks up the tag you just made (if not, you tagged the wrong + commit). +- [ ] Push the new tag with `git push upstream VY.Y+alpha --dry-run` + (remove the `--dry-run` and redo if everything looks OK). - [ ] Start a new project to track PR backporting. The project should - have a "Request X.X+beta1 inclusion" column for the PRs that were + have a `Request X.X+rc1 inclusion` column for the PRs that were merged in `master` that are to be considered for backporting, and a - "Shipped in X.X+beta1" columns to put what was backported. A message - to **@coqbot** in the milestone description tells it to - automatically add merged PRs to the "Request ... inclusion" column - and backported PRs to the "Shipped in ..." column. See previous - milestones for examples. When moving to the next milestone - (e.g. X.X.0), you can clear and remove the "Request X.X+beta1 - inclusion" column and create new "Request X.X.0 inclusion" and - "Shipped in X.X.0" columns. + `Shipped in X.X+rc1` columns to put what was backported. A message + to `@coqbot` in the milestone description tells it to automatically + add merged PRs to the `Request ... inclusion` column and backported + PRs to the `Shipped in ...` column. See previous milestones for + examples. When moving to the next milestone (e.g. `X.X.0`), you can + clear and remove the `Request X.X+rc1 inclusion` column and create + new `Request X.X.0 inclusion` and `Shipped in X.X.0` columns. The release manager is the person responsible for merging PRs that - target the version branch and backporting appropriate PRs that are - merged into `master`. -- [ ] Delay non-blocking issues to the appropriate milestone and ensure - blocking issues are solved. If required to solve some blocking issues, - it is possible to revert some feature PRs in the version branch only. -- [ ] Add a new link to the ``'versions'`` list of the refman (in - ``html_context`` in ``doc/sphinx/conf.py``). - -## Before the beta release date ## - -- [ ] Ensure the Credits chapter has been updated. -- [ ] Prepare the release notes (see e.g., - [#10833](https://github.com/coq/coq/pull/10833)): in a PR against the `master` - branch, move the contents from all files of `doc/changelog/` that appear in - the release branch into the manual `doc/sphinx/changes.rst`. Merge that PR - into the `master` branch and backport it to the version branch. -- [ ] Ensure that an appropriate version of the plugins we will distribute with - Coq has been tagged. -- [ ] Have some people test the recently auto-generated Windows and MacOS - packages. + target the release branch and backporting appropriate PRs (mostly + safe bug fixes, user message improvements and documentation updates) + that are merged into `master`. +- [ ] Pin the versions of libraries and plugins in + [`dev/ci/ci-basic-overlay.sh`](../ci/ci-basic-overlay.sh) to use + commit hashes. You can use the + [`dev/tools/pin-ci.sh`](../tools/pin-ci.sh) script to do this + semi-automatically. +- [ ] In a PR on `master` to be backported, add a new link to the + `'versions'` list of the refman (in `html_context` in + [`doc/sphinx/conf.py`](../../doc/sphinx/conf.py)). + +## In the days following the branching ## + +- [ ] Make sure that all the last feature PRs that you want to include + in the release are finished and backported quickly and clean up the + milestone. We recommend backporting as few feature PRs as possible + after branching. In particular, any PR with overlays will require + manually bumping the pinned commits when backporting. +- [ ] Delay non-blocking issues to the appropriate milestone and + ensure blocking issues are solved. If required to solve some + blocking issues, it is possible to revert some feature PRs in the + release branch only (but in this case, the blocking issue should be + postponed to the next major release instead of being closed). +- [ ] Once the final list of features is known, in a PR on `master` to + be backported, generate the release changelog by calling + [`dev/tools/generate-release-changelog.sh`](../tools/generate-release-changelog.sh) + and include it in a new section in + [`doc/sphinx/changes.rst`](../../doc/sphinx/changes.rst). + + At the moment, the script doesn't do it automatically, but we + recommend reordering the entries to show first the **Changed**, then + the **Removed**, **Deprecated**, **Added** and last the **Fixed**. +- [ ] Ping the development coordinator (`@mattam82`) to get him + started on writing the release summary. + + The `dev/tools/list-contributors.sh` script computes the number and + list of contributors between Coq revisions. Typically used with + `VX.X+alpha..vX.X` to check the contributors of version `VX.X`. + +## For each release (preview, final, patch-level) ## + +- [ ] Ensure that there exists a milestone for the following version. +- [ ] Ensure the release changelog has been merged (the release + summary is required for the final release). - [ ] In a PR against `vX.X` (for testing): - - Change the version name from alpha to beta1 (see - [#7009](https://github.com/coq/coq/pull/7009/files)). - - We generally do not update the magic numbers at this point. + - Update the version number. + - Only update the magic numbers for the final release (see + [#7271](https://github.com/coq/coq/pull/7271/files)). - Set `is_a_released_version` to `true` in `configure.ml`. -- [ ] Put the `VX.X+beta1` tag using `git tag -s`. -- [ ] Push the new tag with `git push upstream VX.X+beta1 --dry-run` - (remove the `--dry-run` and redo if all looks OK). -- [ ] Set `is_a_released_version` to `false` in `configure.ml` - (if you forget about it, you'll be reminded whenever you try to - backport a PR with a changelog entry). - -### These steps are the same for all releases (beta, final, patch-level) ### - -- [ ] Send an e-mail on Coqdev announcing that the tag has been put so that - package managers can start preparing package updates (including a - `coq-bignums` compatible version). -- [ ] When opening the corresponding PR for `coq` in the opam repository ([`coq/opam-coq-archive`](https://github.com/coq/opam-coq-archive) or [`ocaml/opam-repository`](https://github.com/ocaml/opam-repository)), - the package managers can Cc `@erikmd` to request that he prepare the necessary configuration for the Docker release in [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) - (namely, he'll need to make sure a `coq-bignums` opam package is available in [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), respectively [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), so the Docker image gathering `coq` and `coq-bignums` can be built). -- [ ] Draft a release on GitHub. -- [ ] Sign the Windows and MacOS packages and upload them on GitHub. - + The Windows packages must be signed by the Inria IT security service. They - should be sent as a link to the binary (via [filesender](https://filesender.renater.fr) for example) - together with its SHA256 hash in a signed e-mail to `dsi.securite` @ `inria.fr` - putting `@maximedenes` in carbon copy. - + The MacOS packages should be signed with our own certificate. A detailed step-by-step guide can be found [on the wiki](https://github.com/coq/coq/wiki/SigningReleases). -- [ ] Prepare a page of news on the website with the link to the GitHub release - (see [coq/www#63](https://github.com/coq/www/pull/63)). -- [ ] Merge the website update, publish the release - and send announcement e-mails, typically on - the `coq-club@inria.fr` mailing list and the discourse forum - ([posting by mail](https://github.com/coq/coq/wiki/Discourse)) +- [ ] Set the tag `VX.X...` using `git tag -s`. +- [ ] Push the new tag with `git push upstream VX.X... --dry-run` + (remove the `--dry-run` and redo if everything looks OK). +- [ ] Set `is_a_released_version` to `false` in `configure.ml` (if you + forget about it, you'll be reminded by the test-suite failing + whenever you try to backport a PR with a changelog entry). - [ ] Close the milestone - -## At the final release time ## - -- [ ] Prepare the release notes (see above) -- [ ] In a PR against `vX.X` (for testing): - - Change the version name from X.X.0 and the magic numbers (see - [#7271](https://github.com/coq/coq/pull/7271/files)). - - Set `is_a_released_version` to `true` in `configure.ml`. -- [ ] Put the `VX.X.0` tag. -- [ ] Push the new tag with `git push upstream VX.X.0 --dry-run` - (remove the `--dry-run` and redo if all looks OK). -- [ ] Set `is_a_released_version` to `false` in `configure.ml` - (if you forget about it, you'll be reminded whenever you try to - backport a PR with a changelog entry). - -Repeat the generic process documented above for all releases. - -Ping `@Zimmi48` to: - -- [ ] Switch the default version of the reference manual on the website. +- [ ] Send an e-mail on Coqdev + the Coq development category on + Discourse (coqdev@inria.fr + coq+coq-development@discoursemail.com) + announcing that the tag has been set so that package managers can + start preparing package updates (including a `coq-bignums` + compatible version). +- [ ] In particular, ensure that someone is working on providing an + opam package (either in the main + [ocaml/opam-repository](https://github.com/ocaml/opam-repository) + for standard releases or in the `core-dev` category of the + [coq/opam-coq-archive](https://github.com/coq/opam-coq-archive) + for preview releases. +- [ ] Make sure to cc `@erikmd` to request that he prepare the + necessary configuration for the Docker release in + [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) (namely, he'll + need to make sure a `coq-bignums` opam package is available in + [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), + respectively + [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), + so the Docker image gathering `coq` and `coq-bignums` can be built). +- [ ] Publish a release on GitHub with the PDF version of the + reference manual attached. + +## For each non-preview release ## + +- [ ] Ping `@Zimmi48` to switch the default version of the reference + manual on the website. This is done by logging into the server (`vps697916.ovh.net`), editing two `ProxyPass` lines (one for the refman and one for the @@ -181,11 +167,30 @@ Ping `@Zimmi48` to: repository. See [coq/www#111](https://github.com/coq/www/issues/111) and [coq/www#131](https://github.com/coq/www/issues/131). -- [ ] Publish a new version on Zenodo (only once per major version). +## Only for the final release of each major version ## + +- [ ] Ping `@Zimmi48` to publish a new version on Zenodo. *TODO:* automate this with coqbot. -## At the patch-level release time ## +## This is now delegated to the platform maintainers ## -We generally do not update the magic numbers at this point (see -[`2881a18`](https://github.com/coq/coq/commit/2881a18)). +- [ ] Sign the Windows and MacOS packages and upload them on GitHub. + + The Windows packages must be signed by the Inria IT security + service. They should be sent as a link to the binary (via + [filesender](https://filesender.renater.fr) for example) together + with its SHA256 hash in a signed e-mail to `dsi.securite` @ + `inria.fr` putting `@maximedenes` in carbon copy. + + The MacOS packages should be signed with our own certificate. A + detailed step-by-step guide can be found [on the + wiki](https://github.com/coq/coq/wiki/SigningReleases). + + The Snap package has to be built and uploaded to the snap store by + running a [platform CI job + manually](https://github.com/coq/platform/tree/v8.13/linux/snap/github_actions). + Then ask `@gares` to publish the upload or give you the password + for the `coq-team` account on the store so that you can do it + yourself. +- [ ] Prepare a PR on [coq/www](https://github.com/coq/www) adding a + page of news on the website. +- [ ] Announce the release to Coq-Club and Discourse + (coq-club@inria.fr + coq+announcements@discoursemail.com). @@ -1,11 +1,11 @@ (library (name top_printers) - (public_name coq.top_printers) + (public_name coq-core.top_printers) (synopsis "Coq's Debug Printers") (wrapped false) (modules top_printers) (optional) - (libraries coq.toplevel coq.plugins.ltac)) + (libraries coq-core.toplevel coq-core.plugins.ltac)) (rule (targets dune-dbg) @@ -17,26 +17,27 @@ ; We require all the OCaml libs to be in place and searchable ; by OCamlfind, this is a bit of a hack but until Dune gets ; proper ocamldebug support we have to live with that. - %{lib:coq.config:config.cma} - %{lib:coq.clib:clib.cma} - %{lib:coq.lib:lib.cma} - %{lib:coq.kernel:kernel.cma} - %{lib:coq.vm:byterun.cma} - %{lib:coq.vm:../../stublibs/dllbyterun_stubs.so} - %{lib:coq.library:library.cma} - %{lib:coq.engine:engine.cma} - %{lib:coq.pretyping:pretyping.cma} - %{lib:coq.gramlib:gramlib.cma} - %{lib:coq.interp:interp.cma} - %{lib:coq.proofs:proofs.cma} - %{lib:coq.parsing:parsing.cma} - %{lib:coq.printing:printing.cma} - %{lib:coq.tactics:tactics.cma} - %{lib:coq.vernac:vernac.cma} - %{lib:coq.stm:stm.cma} - %{lib:coq.toplevel:toplevel.cma} - %{lib:coq.plugins.ltac:ltac_plugin.cma} - %{lib:coq.top_printers:top_printers.cmi} - %{lib:coq.top_printers:top_printers.cma} - %{lib:coq.top_printers:../META}) + %{lib:coq-core.config:config.cma} + %{lib:coq-core.clib:clib.cma} + %{lib:coq-core.lib:lib.cma} + %{lib:coq-core.kernel:kernel.cma} + %{lib:coq-core.vm:byterun.cma} + %{lib:coq-core.vm:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.library:library.cma} + %{lib:coq-core.engine:engine.cma} + %{lib:coq-core.pretyping:pretyping.cma} + %{lib:coq-core.gramlib:gramlib.cma} + %{lib:coq-core.interp:interp.cma} + %{lib:coq-core.proofs:proofs.cma} + %{lib:coq-core.parsing:parsing.cma} + %{lib:coq-core.printing:printing.cma} + %{lib:coq-core.tactics:tactics.cma} + %{lib:coq-core.vernac:vernac.cma} + %{lib:coq-core.stm:stm.cma} + %{lib:coq-core.sysinit:sysinit.cma} + %{lib:coq-core.toplevel:toplevel.cma} + %{lib:coq-core.plugins.ltac:ltac_plugin.cma} + %{lib:coq-core.top_printers:top_printers.cmi} + %{lib:coq-core.top_printers:top_printers.cma} + %{lib:coq-core.top_printers:../META}) (action (copy dune-dbg.in dune-dbg))) diff --git a/dev/dune_db_408 b/dev/dune_db_408 index 5f826fe383..bc86020d56 100644 --- a/dev/dune_db_408 +++ b/dev/dune_db_408 @@ -17,6 +17,7 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/dune_db_409 b/dev/dune_db_409 index 2e58272c75..adb1f76872 100644 --- a/dev/dune_db_409 +++ b/dev/dune_db_409 @@ -16,6 +16,7 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 534f20f85b..db15d9705a 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -19,7 +19,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar -I $COQTOP/clib \ -I $COQTOP/gramlib/.pack \ -I $COQTOP/lib -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ - -I $COQTOP/library -I $COQTOP/engine \ + -I $COQTOP/library -I $COQTOP/engine -I $COQTOP/sysinit \ -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ diff --git a/dev/shim/dune b/dev/shim/dune index 8006c629ed..e4cc7699f0 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -26,7 +26,7 @@ (targets coqbyte-prelude) (deps %{bin:coqtop.byte} - %{lib:coq.kernel:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.kernel:../../stublibs/dllbyterun_stubs.so} %{project_root}/theories/Init/Prelude.vo) (action (with-stdout-to %{targets} diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index 5f9f326750..d4f599484f 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -33,7 +33,7 @@ (defun coqdev-default-directory () "Return the Coq repository containing `default-directory'." - (let ((dir (locate-dominating-file default-directory "META.coq.in"))) + (let ((dir (locate-dominating-file default-directory "META.coq-core.in"))) (when dir (expand-file-name dir)))) (defun coqdev-setup-compile-command () diff --git a/dev/tools/list-contributors.sh b/dev/tools/list-contributors.sh new file mode 100644 index 0000000000..c968f2e952 --- /dev/null +++ b/dev/tools/list-contributors.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash +# For compat with OSX which has a non-gnu sed which doesn't support -z +SED=`which gsed || which sed` + +if [ $# != 1 ]; then + error "usage: $0 rev0..rev1" + exit 1 +fi + +git shortlog -s -n --group=author --group=trailer:Co-authored-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > contributors.tmp + +cat contributors.tmp | wc -l | xargs echo "Contributors:" +cat contributors.tmp | gsed -z "s/\n/, /g" +echo +rm contributors.tmp diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index 666fb6cc91..a14b98c73c 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -64,7 +64,7 @@ DEFAULT_NUMBER_OF_OLD_VERSIONS = 2 RELEASE_NUMBER_OF_OLD_VERSIONS = 2 MASTER_NUMBER_OF_OLD_VERSIONS = 3 EXTRA_HEADER = '\n(** Compatibility file for making Coq act similar to Coq v%s *)\n' -COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') +COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'sysinit', 'coqargs.ml') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f3d6239c6f..f8fd8b3d5b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -576,7 +576,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts = VtDefault (fun () -> in_current_context econstr_display c) in + let cmd_fn c ?loc:_ ~atts = VtDefault (fun () -> in_current_context econstr_display c) in let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintConstr" [cmd] @@ -585,7 +585,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in + let cmd_fn c ?loc:_ ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintPureConstr" [cmd] diff --git a/dev/top_printers.mli b/dev/top_printers.mli index e8ed6c709e..b4b24d743a 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -165,6 +165,7 @@ val ppobj : Libobject.obj -> unit (* Some super raw printers *) val cast_kind_display : Constr.cast_kind -> string val constr_display : Constr.constr -> unit +val econstr_display : EConstr.constr -> unit val print_pure_constr : Constr.types -> unit val print_pure_econstr : EConstr.types -> unit diff --git a/doc/changelog/01-kernel/13853-delay-native.rst b/doc/changelog/01-kernel/13853-delay-native.rst new file mode 100644 index 0000000000..59bf960a0f --- /dev/null +++ b/doc/changelog/01-kernel/13853-delay-native.rst @@ -0,0 +1,6 @@ +- **Changed:** + Native-code libraries used by :tacn:`native_compute` are now delayed + until an actual call to the :tacn:`native_compute` machinery is + performed. This should make Coq more responsive on some systems + (`#13853 <https://github.com/coq/coq/pull/13853>`_, fixes `#13849 + <https://github.com/coq/coq/issues/13849>`_, by Guillaume Melquiond). diff --git a/doc/changelog/03-notations/13842-remove-decimal.rst b/doc/changelog/03-notations/13842-remove-decimal.rst new file mode 100644 index 0000000000..4bc26ef6a8 --- /dev/null +++ b/doc/changelog/03-notations/13842-remove-decimal.rst @@ -0,0 +1,3 @@ +- **Removed:** + Remove decimal-only number notations which were deprecated in 8.12. + (`#13842 <https://github.com/coq/coq/pull/13842>`_, by Pierre Roux). diff --git a/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst b/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst new file mode 100644 index 0000000000..1aa57ff8b1 --- /dev/null +++ b/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst @@ -0,0 +1,4 @@ +- **Removed:** + convert_concl_no_check. Use :tacn:`change_no_check` instead + (`#13761 <https://github.com/coq/coq/pull/13761>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13762-remove_double_induction.rst b/doc/changelog/04-tactics/13762-remove_double_induction.rst new file mode 100644 index 0000000000..4ea54a1ab6 --- /dev/null +++ b/doc/changelog/04-tactics/13762-remove_double_induction.rst @@ -0,0 +1,9 @@ +- **Removed:** + double induction tactic. Replace :n:`double induction @ident @ident` + with :n:`induction @ident; induction @ident` (or + :n:`induction @ident ; destruct @ident` depending on the exact needs). + Replace :n:`double induction @natural__1 @natural__2` with + :n:`induction @natural__1; induction natural__3` where :n:`natural__3` is the result + of :n:`natural__2 - natural__1` + (`#13762 <https://github.com/coq/coq/pull/13762>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13781-deprecate_micromega_options.rst b/doc/changelog/04-tactics/13781-deprecate_micromega_options.rst new file mode 100644 index 0000000000..e3375bd875 --- /dev/null +++ b/doc/changelog/04-tactics/13781-deprecate_micromega_options.rst @@ -0,0 +1,3 @@ +- **Deprecated:** + The micromega option :flag:`Simplex`, which is currently set by default + (`#13781 <https://github.com/coq/coq/pull/13781>`_, by Frédéric Besson). diff --git a/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst b/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst new file mode 100644 index 0000000000..cd1ac3a35a --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst @@ -0,0 +1,19 @@ +- **Added:** + :opt:`Debug` to control debug messages, functioning similarly to the warning system + (`#13202 <https://github.com/coq/coq/pull/13202>`_, + by Maxime Dénès and Gaëtan Gilbert). + The following flags have been converted (such that ``Set Flag`` becomes ``Set Debug "flag"``): + + - ``Debug Unification`` to ``unification`` + + - ``Debug HO Unification`` to ``ho-unification`` + + - ``Debug Tactic Unification`` to ``tactic-unification`` + + - ``Congruence Verbose`` to ``congruence`` + + - ``Debug Cbv`` to ``cbv`` + + - ``Debug RAKAM`` to ``RAKAM`` + + - ``Debug Ssreflect`` to ``ssreflect`` diff --git a/doc/changelog/07-vernac-commands-and-options/13758-remove_hide_obligations.rst b/doc/changelog/07-vernac-commands-and-options/13758-remove_hide_obligations.rst new file mode 100644 index 0000000000..84d6bdea89 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13758-remove_hide_obligations.rst @@ -0,0 +1,4 @@ +- **Removed:** + The Hide Obligations flag, deprecated in 8.12 + (`#13758 <https://github.com/coq/coq/pull/13758>`_, + by Jim Fehrle). diff --git a/doc/changelog/07-vernac-commands-and-options/13763-remove_searchhead.rst b/doc/changelog/07-vernac-commands-and-options/13763-remove_searchhead.rst new file mode 100644 index 0000000000..7f0650d8ee --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13763-remove_searchhead.rst @@ -0,0 +1,4 @@ +- **Removed:** + SearchHead command. Use the `headconcl:` clause of :cmd:`Search` instead + (`#13763 <https://github.com/coq/coq/pull/13763>`_, + by Jim Fehrle). diff --git a/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst b/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst new file mode 100644 index 0000000000..e3333f8a9a --- /dev/null +++ b/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst @@ -0,0 +1,4 @@ +- **Removed:** previously deprecated command line options + ``-sprop-cumulative`` and ``-input-state`` and its alias ``-is`` + (`#13822 <https://github.com/coq/coq/pull/13822>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/08-cli-tools/13876-coqc+no_multiple_files.rst b/doc/changelog/08-cli-tools/13876-coqc+no_multiple_files.rst new file mode 100644 index 0000000000..e48b772f01 --- /dev/null +++ b/doc/changelog/08-cli-tools/13876-coqc+no_multiple_files.rst @@ -0,0 +1,6 @@ +- **Changed:** + `coqc` now enforces that at most a single `.v` file can be passed in + the command line. Support for multiple `.v` files in the form of + `coqc f1.v f2.v` didn't properly work in 8.13, tho it was accepted. + (`#13876 <https://github.com/coq/coq/pull/13876>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst b/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst new file mode 100644 index 0000000000..e78280d91d --- /dev/null +++ b/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst @@ -0,0 +1,3 @@ +- **Added:** + Shift-return in the Find dialog now searches backwards (`#13810 <https://github.com/coq/coq/pull/13810>`_, + by slrnsc). diff --git a/doc/changelog/10-standard-library/13080-ascii.rst b/doc/changelog/10-standard-library/13080-ascii.rst new file mode 100644 index 0000000000..167002283e --- /dev/null +++ b/doc/changelog/10-standard-library/13080-ascii.rst @@ -0,0 +1,4 @@ +- **Added:** + ``leb`` and ``ltb`` functions for ``ascii`` + (`#13080 <https://github.com/coq/coq/pull/13080>`_, + by Yishuai Li). diff --git a/doc/changelog/10-standard-library/13559-primitive_integers.rst b/doc/changelog/10-standard-library/13559-primitive_integers.rst new file mode 100644 index 0000000000..c3cad79bd2 --- /dev/null +++ b/doc/changelog/10-standard-library/13559-primitive_integers.rst @@ -0,0 +1,5 @@ +- **Added:** + Library for signed primitive integers, Sint63. The following operations were added to the kernel: division, remainder, comparison functions, and arithmetic shift right. Everything else works the same for signed and unsigned ints. + (`#13559 <https://github.com/coq/coq/pull/13559>`_, + fixes `#12109 <https://github.com/coq/coq/issues/12109>`_, + by Ana Borges, Guillaume Melquiond and Pierre Roux). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12567-dune+split_stdlib.rst b/doc/changelog/11-infrastructure-and-dependencies/12567-dune+split_stdlib.rst new file mode 100644 index 0000000000..6fe6f62faa --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/12567-dune+split_stdlib.rst @@ -0,0 +1,14 @@ +- **Changed:** + Coq's configure script now requires absolute paths for the `-prefix` + option. + (`#12567 <https://github.com/coq/coq/pull/12567>`_, + by Emilio Jesus Gallego Arias). + +- **Changed:** + The regular Coq package has been split in two: coq-core, with + OCaml-based libraries and tools; and coq-stdlib, which contains the + Gallina-based standard library. The package Coq now depends on both + for compatiblity. + (`#12567 <https://github.com/coq/coq/pull/12567>`_, + by Emilio Jesus Gallego Arias, review by Vincent Laporte, Guillaume + Melquiond, Enrico Tassi, and Théo Zimmerman). @@ -13,7 +13,8 @@ ; + %{bin:coqdoc} etc... ; + config/coq_config.py ; + tools/coqdoc/coqdoc.css - (package coq) + (package coq-core) + (package coq-stdlib) (source_tree sphinx) (source_tree tools/coqrst) unreleased.rst @@ -26,7 +27,8 @@ ; Cannot use this deps alias because of ocaml/dune#3415 ; (deps (alias refman-deps)) (deps - (package coq) + (package coq-core) + (package coq-stdlib) (source_tree sphinx) (source_tree tools/coqrst) unreleased.rst @@ -41,7 +43,8 @@ ; Cannot use this deps alias because of ocaml/dune#3415 ; (deps (alias refman-deps)) (deps - (package coq) + (package coq-core) + (package coq-stdlib) (source_tree sphinx) (source_tree tools/coqrst) unreleased.rst diff --git a/doc/plugin_tutorial/tuto0/src/dune b/doc/plugin_tutorial/tuto0/src/dune index ab9b4dd531..c7ed997221 100644 --- a/doc/plugin_tutorial/tuto0/src/dune +++ b/doc/plugin_tutorial/tuto0/src/dune @@ -1,6 +1,6 @@ (library (name tuto0_plugin) - (public_name coq.plugins.tutorial.p0) - (libraries coq.plugins.ltac)) + (public_name coq-core.plugins.tutorial.p0) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto0)) diff --git a/doc/plugin_tutorial/tuto1/src/dune b/doc/plugin_tutorial/tuto1/src/dune index 054d5ecd26..bf87222e16 100644 --- a/doc/plugin_tutorial/tuto1/src/dune +++ b/doc/plugin_tutorial/tuto1/src/dune @@ -1,6 +1,6 @@ (library (name tuto1_plugin) - (public_name coq.plugins.tutorial.p1) - (libraries coq.plugins.ltac)) + (public_name coq-core.plugins.tutorial.p1) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto1)) diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune index 8c4b04b1ae..0797debccf 100644 --- a/doc/plugin_tutorial/tuto2/src/dune +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -1,6 +1,6 @@ (library (name tuto2_plugin) - (public_name coq.plugins.tutorial.p2) - (libraries coq.plugins.ltac)) + (public_name coq-core.plugins.tutorial.p2) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto2)) diff --git a/doc/plugin_tutorial/tuto3/src/dune b/doc/plugin_tutorial/tuto3/src/dune index 678dd71328..dcecf0852e 100644 --- a/doc/plugin_tutorial/tuto3/src/dune +++ b/doc/plugin_tutorial/tuto3/src/dune @@ -1,7 +1,7 @@ (library (name tuto3_plugin) - (public_name coq.plugins.tutorial.p3) + (public_name coq-core.plugins.tutorial.p3) (flags :standard -warn-error -3) - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto3)) diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 3bd85d29c8..5d471c695c 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -31,9 +31,11 @@ tactics for solving arithmetic goals over :math:`\mathbb{Q}`, .. flag:: Simplex + .. deprecated:: 8.14 + This flag (set by default) instructs the decision procedures to - use the Simplex method for solving linear goals. If it is not set, - the decision procedures are using Fourier elimination. + use the Simplex method for solving linear goals instead of the + deprecated Fourier elimination. .. opt:: Dump Arith diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 2b24ced8a1..8f2b51ccce 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -320,14 +320,6 @@ optional tactic is replaced by the default one if not specified. (the default), or if the system should infer which obligations can be declared opaque. -.. flag:: Hide Obligations - - .. deprecated:: 8.12 - - Controls whether obligations appearing in the - term should be hidden as implicit arguments of the special - constant ``Program.Tactics.obligation``. - The module :g:`Coq.Program.Tactics` defines the default tactic for solving obligations called :g:`program_simpl`. Importing :g:`Coq.Program.Program` also adds some useful notations, as documented in the file itself. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 7db54987d6..8fa1b97851 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -82,13 +82,13 @@ Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, Arnaud Spiwack, Matthieu Sozeau, Enrico Tassi, Laurent Théry, Anton Trunov, Li-yao Xia and Théo Zimmermann. -The 52 contributors to this version are Reynald Affeldt, Tanaka Akira, Frédéric +The 51 contributors to this version are Reynald Affeldt, Tanaka Akira, Frédéric Besson, Lasse Blaauwbroek, Clément Blaudeau, Martin Bodin, Ali Caglayan, Tej Chajed, Cyril Cohen, Julien Coolen, Matthew Dempsky, Maxime Dénès, Andres Erbsen, Jim Fehrle, Emilio Jesús Gallego Arias, Paolo G. Giarrusso, Attila Gáspár, Gaëtan Gilbert, Jason Gross, Benjamin Grégoire, Hugo Herbelin, Wolf Honore, Jasper Hugunin, Ignat Insarov, Ralf Jung, Fabian Kunze, Vincent Laporte, Olivier Laurent, Larry D. Lee Jr, -Thomas Letan, Yishuai Li, Xia Li-yao, James Lottes, Jean-Christophe Léchenet, +Thomas Letan, Yishuai Li, James Lottes, Jean-Christophe Léchenet, Kenji Maillard, Erik Martin-Dorel, Yusuke Matsushita, Guillaume Melquiond, Carl Patenaude-Poulin, Clément Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, Matthieu Sozeau, @@ -701,6 +701,27 @@ Commands and options (`#13556 <https://github.com/coq/coq/pull/13556>`_, by Simon Friis Vindum). +Changes in 8.13.1 +~~~~~~~~~~~~~~~~~ + +Kernel +^^^^^^ + +- **Fixed:** + Fix arities of VM opcodes for some floating-point operations + that could cause memory corruption + (`#13867 <https://github.com/coq/coq/pull/13867>`_, + by Guillaume Melquiond). + +CoqIDE +^^^^^^ + +- **Added:** + Option ``-v`` and ``--version`` to CoqIDE + (`#13870 <https://github.com/coq/coq/pull/13870>`_, + by Guillaume Melquiond). + + Version 8.12 ------------ @@ -1230,7 +1251,7 @@ Flags, options and attributes :attr:`universes(template)` and ``universes(notemplate)`` instead (`#11663 <https://github.com/coq/coq/pull/11663>`_, by Théo Zimmermann). - **Deprecated:** - :flag:`Hide Obligations` flag + `Hide Obligations` flag (`#11828 <https://github.com/coq/coq/pull/11828>`_, by Emilio Jesus Gallego Arias). - **Added:** Handle the :attr:`local` attribute in :cmd:`Canonical @@ -1301,7 +1322,7 @@ Commands Declaration of arbitrary terms as hints. Global references are now preferred (`#7791 <https://github.com/coq/coq/pull/7791>`_, by Pierre-Marie Pédrot). -- **Deprecated:** :cmd:`SearchHead` in favor of the new `headconcl:` +- **Deprecated:** `SearchHead` in favor of the new `headconcl:` clause of :cmd:`Search` (part of `#8855 <https://github.com/coq/coq/pull/8855>`_, by Théo Zimmermann). - **Added:** @@ -3191,7 +3212,7 @@ Other changes in 8.10+beta1 by Maxime Dénès, review by Pierre-Marie Pédrot). - New variant :tacn:`change_no_check` of :tacn:`change`, usable as a - documented replacement of :tacn:`convert_concl_no_check` + documented replacement of `convert_concl_no_check` (`#10012 <https://github.com/coq/coq/pull/10012>`_, `#10017 <https://github.com/coq/coq/pull/10017>`_, `#10053 <https://github.com/coq/coq/pull/10053>`_, and diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index 8dbc1626ba..7566996ef6 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -9,7 +9,7 @@ Binders .. insertprodn open_binders binder .. prodn:: - open_binders ::= {+ @name } : @term + open_binders ::= {+ @name } : @type | {+ @binder } name ::= _ | @ident diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 0a61c4ce22..2b50d4c420 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -523,31 +523,20 @@ they appear after a boldface label. They are listed in the Locality attributes supported by :cmd:`Set` and :cmd:`Unset` ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -The :cmd:`Set` and :cmd:`Unset` commands support the :attr:`local`, -:attr:`global` and :attr:`export` locality attributes: - -* no attribute: the original setting is *not* restored at the end of - the current module or section. -* :attr:`local` (or alternatively, the ``Local`` prefix): the setting - is applied within the current module or section. The original value - of the setting is restored at the end of the current module or - section. -* :attr:`export` (or alternatively, the ``Export`` prefix): similar to - :attr:`local`, the original value of the setting is restored at the - end of the current module or section. In addition, if the value is - set in a module, then :cmd:`Import`\-ing the module sets the option - or flag. -* :attr:`global` (or alternatively, the ``Global`` prefix): the - original setting is *not* restored at the end of the current module - or section. In addition, if the value is set in a file, then - :cmd:`Require`\-ing the file sets the option. +The :cmd:`Set` and :cmd:`Unset` commands support the mutually +exclusive :attr:`local`, :attr:`export` and :attr:`global` locality +attributes (or the ``Local``, ``Export`` or ``Global`` prefixes). + +If no attribute is specified, the original value of the flag or option +is restored at the end of the current module but it is *not* restored +at the end of the current section. Newly opened modules and sections inherit the current settings. .. note:: - We discourage using the :attr:`global` attribute with the :cmd:`Set` and - :cmd:`Unset` commands. If your goal is to define + We discourage using the :attr:`global` locality attribute with the + :cmd:`Set` and :cmd:`Unset` commands. If your goal is to define project-wide settings, you should rather use the command-line arguments ``-set`` and ``-unset`` for setting flags and options (see :ref:`command-line-options`). diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 93d70c773f..2e678c49d8 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -880,7 +880,7 @@ started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-opt .. _qualified-names: Qualified identifiers ---------------------- +~~~~~~~~~~~~~~~~~~~~~ .. insertprodn qualid field_ident @@ -1010,3 +1010,73 @@ subdirectories of path). See the command :cmd:`Declare ML Module` in See :ref:`command-line-options` for a more general view over the Coq command line options. + +.. _controlling-locality-of-commands: + +Controlling the scope of commands with locality attributes +---------------------------------------------------------- + +Many commands have effects that apply only within a specific scope, +typically the section or the module in which the command was +called. Locality :term:`attributes <attribute>` can alter the scope of +the effect. Below, we give the semantics of each locality attribute +while noting a few exceptional commands for which :attr:`local` and +:attr:`global` attributes are interpreted differently. + +.. attr:: local + + The :attr:`local` attribute limits the effect of the command to the + current scope (section or module). + + The ``Local`` prefix is an alternative syntax for the :attr:`local` + attribute (see :n:`@legacy_attr`). + + .. note:: + + - For some commands, this is the only locality supported within + sections (e.g., for :cmd:`Notation`, :cmd:`Ltac` and + :ref:`Hint <creating_hints>` commands). + + - For some commands, this is the default locality within + sections even though other locality attributes are supported + as well (e.g., for the :cmd:`Arguments` command). + + .. warning:: + + **Exception:** when :attr:`local` is applied to + :cmd:`Definition`, :cmd:`Theorem` or their variants, its + semantics are different: it makes the defined objects available + only through their fully-qualified names rather than their + unqualified names after an :cmd:`Import`. + +.. attr:: export + + The :attr:`export` attribute makes the effect of the command + persist when the section is closed and applies the effect when the + module containing the command is imported. + + Commands supporting this attribute include :cmd:`Set`, :cmd:`Unset` + and the :ref:`Hint <creating_hints>` commands, although the latter + don't support it within sections. + +.. attr:: global + + The :attr:`global` attribute makes the effect of the command + persist even when the current section or module is closed. Loading + the file containing the command (possibly transitively) applies the + effect of the command. + + The ``Global`` prefix is an alternative syntax for the + :attr:`global` attribute (see :n:`@legacy_attr`). + + .. warning:: + + **Exception:** for a few commands (like :cmd:`Notation` and + :cmd:`Ltac`), this attribute behaves like :attr:`export`. + + .. warning:: + + We strongly discourage using the :attr:`global` locality + attribute because the transitive nature of file loading gives + the user little control. We recommend using the :attr:`export` + locality attribute where it is supported. diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst index 4505fc4b4d..7211d00dd0 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -8,15 +8,20 @@ Primitive Integers The language of terms features 63-bit machine integers as values. The type of such a value is *axiomatized*; it is declared through the following sentence -(excerpt from the :g:`Int63` module): +(excerpt from the :g:`PrimInt63` module): .. coqdoc:: Primitive int := #int63_type. -This type is equipped with a few operators, that must be similarly declared. -For instance, equality of two primitive integers can be decided using the :g:`Int63.eqb` function, -declared and specified as follows: +This type can be understood as representing either unsigned or signed integers, +depending on which module is imported or, more generally, which scope is open. +:g:`Int63` and :g:`int63_scope` refer to the unsigned version, while :g:`Sint63` +and :g:`sint63_scope` refer to the signed one. + +The :g:`PrimInt63` module declares the available operators for this type. +For instance, equality of two unsigned primitive integers can be determined using +the :g:`Int63.eqb` function, declared and specified as follows: .. coqdoc:: @@ -25,7 +30,9 @@ declared and specified as follows: Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. -The complete set of such operators can be obtained looking at the :g:`Int63` module. +The complete set of such operators can be found in the :g:`PrimInt63` module. +The specifications and notations are in the :g:`Int63` and :g:`Sint63` +modules. These primitive declarations are regular axioms. As such, they must be trusted and are listed by the :g:`Print Assumptions` command, as in the following example. diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index dcc60195ed..e7237cf7eb 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -248,7 +248,7 @@ right arrow, or ``\>=`` for a greater than or equal sign. A larger number of latex tokens are supported by default. The full list is available here: -https://github.com/coq/coq/blob/master/ide/default_bindings_src.ml +https://github.com/coq/coq/blob/master/ide/coqide/default_bindings_src.ml Custom bindings may be added, as explained further on. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 766f7ab44e..071fcbee11 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -77,7 +77,7 @@ specified, the default selector is used. .. todo: fully describe selectors. At the moment, ltac has a fairly complete description .. todo: mention selectors can be applied to some commands, such as - Check, Search, SearchHead, SearchPattern, SearchRewrite. + Check, Search, SearchPattern, SearchRewrite. .. opt:: Default Goal Selector "@toplevel_selector" :name: Default Goal Selector @@ -498,10 +498,16 @@ one or more of its hypotheses. :n:`{? - } {+ @nat_or_var }` Selects the specified occurrences within a single goal or hypothesis. - Occurrences are numbered from left to right starting with 1 when the - goal is printed with the :flag:`Printing All` flag. (In particular, occurrences - in :ref:`implicit arguments <ImplicitArguments>` and - :ref:`coercions <Coercions>` are counted but not shown by default.) + Occurrences are numbered starting with 1 following a depth-first traversal + of the term's expression, including occurrences in + :ref:`implicit arguments <ImplicitArguments>` + and :ref:`coercions <Coercions>` that are not displayed by default. + (Set the :flag:`Printing All` flag to show those in the printed term.) + + For example, when matching the pattern `_ + _` in the term `(a + b) + c`, + occurrence 1 is `(...) + c` and + occurrence 2 is `(a + b)`. When matching that pattern with term `a + (b + c)`, + occurrence 1 is `a + (...)` and occurrence 2 is `b + c`. Specifying `-` includes all occurrences *except* the ones listed. @@ -669,10 +675,10 @@ Applying theorems :tacn:`notypeclasses refine`: it performs type checking without resolution of typeclasses, does not perform beta reductions or shelve the subgoals. - .. flag:: Debug Unification - - Enables printing traces of unification steps used during - elaboration/typechecking and the :tacn:`refine` tactic. + :opt:`Debug` ``"unification"`` enables printing traces of + unification steps used during elaboration/typechecking and the + :tacn:`refine` tactic. ``"ho-unification"`` prints information + about higher order heuristics. .. tacn:: apply @term :name: apply @@ -1034,10 +1040,9 @@ Applying theorems when the instantiation of a variable cannot be found (cf. :tacn:`eapply` and :tacn:`apply`). -.. flag:: Debug Tactic Unification - - Enables printing traces of unification steps in tactic unification. - Tactic unification is used in tactics such as :tacn:`apply` and :tacn:`rewrite`. +:opt:`Debug` ``"tactic-unification"`` enables printing traces of +unification steps in tactic unification. Tactic unification is used in +tactics such as :tacn:`apply` and :tacn:`rewrite`. .. _managingthelocalcontext: @@ -2067,19 +2072,6 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) is the name given by :n:`intros until @natural` to the :n:`@natural`-th non-dependent premise of the goal. -.. tacn:: double induction @ident @ident - :name: double induction - - This tactic is deprecated and should be replaced by - :n:`induction @ident; induction @ident` (or - :n:`induction @ident ; destruct @ident` depending on the exact needs). - -.. tacv:: double induction @natural__1 @natural__2 - - This tactic is deprecated and should be replaced by - :n:`induction num1; induction num3` where :n:`num3` is the result - of :n:`num2 - num1` - .. tacn:: dependent induction @ident :name: dependent induction diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 8e2f577f6b..37d605360d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -312,31 +312,6 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). Search is:Instance [ Reflexive | Symmetric ]. -.. cmd:: SearchHead @one_pattern {? {| inside | outside } {+ @qualid } } - - .. deprecated:: 8.12 - - Use the `headconcl:` clause of :cmd:`Search` instead. - - Displays the name and type of all hypotheses of the - selected goal (if any) and theorems of the current context that have the - form :n:`{? forall {* @binder }, } {* P__i -> } C` where :n:`@one_pattern` - matches a subterm of `C` in head position. For example, a :n:`@one_pattern` of `f _ b` - matches `f a b`, which is a subterm of `C` in head position when `C` is `f a b c`. - - See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. - - .. example:: :cmd:`SearchHead` examples - - .. coqtop:: none reset - - Add Search Blacklist "internal_". - - .. coqtop:: all warn - - SearchHead le. - SearchHead (@eq bool). - .. cmd:: SearchPattern @one_pattern {? {| inside | outside } {+ @qualid } } Displays the name and type of all hypotheses of the @@ -384,7 +359,7 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). .. table:: Search Blacklist @string Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, - :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose + :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose fully-qualified name contains any of the strings will be excluded from the search results. The default blacklisted substrings are ``_subterm``, ``_subproof`` and ``Private_``. @@ -395,7 +370,7 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). .. flag:: Search Output Name Only This flag restricts the output of search commands to identifier names; - turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, + turning it on causes invocations of :cmd:`Search`, :cmd:`SearchPattern`, :cmd:`SearchRewrite` etc. to omit types from their output, printing only identifiers. @@ -890,6 +865,14 @@ Controlling display interpreted from left to right, so in case of an overlap, the flags on the right have higher priority, meaning that `A,-A` is equivalent to `-A`. +.. opt:: Debug "{+, {? - } @ident }" + + Configures the display of debug messages. Each :n:`@ident` enables debug messages + for that component, while :n:`-@ident` disables messages for the component. + ``all`` activates or deactivates all other components. ``backtrace`` controls printing of + error backtraces. + + :cmd:`Test` `Debug` displays the list of components and their enabled/disabled state. .. opt:: Printing Width @natural This command sets which left-aligned part of the width of the screen is used @@ -1083,57 +1066,6 @@ described first. .. seealso:: :ref:`performingcomputations` -.. _controlling-locality-of-commands: - -Controlling the locality of commands ------------------------------------------ - -.. attr:: global - local - - Some commands support a :attr:`local` or :attr:`global` attribute - to control the scope of their effect. There is also a legacy (and - much more commonly used) syntax using the ``Local`` or ``Global`` - prefixes (see :n:`@legacy_attr`). There are four kinds of - commands: - - + Commands whose default is to extend their effect both outside the - section and the module or library file they occur in. For these - commands, the :attr:`local` attribute limits the effect of the command to the - current section or module it occurs in. As an example, the :cmd:`Coercion` - and :cmd:`Strategy` commands belong to this category. - + Commands whose default behavior is to stop their effect at the end - of the section they occur in but to extend their effect outside the module or - library file they occur in. For these commands, the :attr:`local` attribute limits the - effect of the command to the current module if the command does not occur in a - section and the :attr:`global` attribute extends the effect outside the current - sections and current module if the command occurs in a section. As an example, - the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong - to this category. Notice that a subclass of these commands do not support - extension of their scope outside sections at all and the :attr:`global` attribute is not - applicable to them. - + Commands whose default behavior is to stop their effect at the end - of the section or module they occur in. For these commands, the :attr:`global` - attribute extends their effect outside the sections and modules they - occur in. The :cmd:`Transparent` and :cmd:`Opaque` commands - belong to this category. - + Commands whose default behavior is to extend their effect outside - sections but not outside modules when they occur in a section and to - extend their effect outside the module or library file they occur in - when no section contains them. For these commands, the :attr:`local` attribute - limits the effect to the current section or module while the :attr:`global` - attribute extends the effect outside the module even when the command - occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this - category. - -.. attr:: export - - Some commands support an :attr:`export` attribute. The effect of - the attribute is to make the effect of the command available when - the module containing it is imported. It is supported in - particular by the :ref:`Hint <creating_hints>`, :cmd:`Set` and :cmd:`Unset` - commands. - .. _controlling-typing-flags: Controlling Typing Flags diff --git a/doc/sphinx/proofs/automatic-tactics/logic.rst b/doc/sphinx/proofs/automatic-tactics/logic.rst index 5aaded2726..3f1f5d46c5 100644 --- a/doc/sphinx/proofs/automatic-tactics/logic.rst +++ b/doc/sphinx/proofs/automatic-tactics/logic.rst @@ -194,9 +194,7 @@ Solvers for logic and equality additional arguments can be given to congruence by filling in the holes in the terms given in the error message, using the `with` clause. - .. flag:: Congruence Verbose - - Makes :tacn:`congruence` print debug information. + :opt:`Debug` ``"congruence"`` makes :tacn:`congruence` print debug information. .. tacn:: btauto diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 8c8c88c526..4f937ad727 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -44,11 +44,14 @@ Rewriting with Leibniz and setoid equality oriented_rewriter ::= {? {| -> | <- } } {? @natural } {? {| ? | ! } } @one_term_with_bindings one_term_with_bindings ::= {? > } @one_term {? with @bindings } - Rewrites terms based on equalities. The type of :n:`@one_term` must have the form: + Replaces subterms with other subterms that have been proven to be equal. + The type of :n:`@one_term` must have the form: :n:`{? forall {+ (x__i: A__i) } , } EQ @term__1 @term__2` - where :g:`EQ` is the Leibniz equality `eq` or a registered setoid equality. + .. todo :term:`Leibniz equality` does not work with Sphinx 2.3.1. It does with Sphinx 3.0.3. + + where :g:`EQ` is the Leibniz equality `eq` or a registered :term:`setoid equality`. Note that :n:`eq @term__1 @term__2` is typically written with the infix notation :n:`@term__1 = @term__2`. You must `Require Setoid` to use the tactic with a setoid equality or with :ref:`setoid rewriting <generalizedrewriting>`. @@ -61,7 +64,7 @@ Rewriting with Leibniz and setoid equality Some of the variables :g:`x`\ :sub:`i` are solved by unification, and some of the types :n:`A__1, ..., A__n` may become new subgoals. :tacn:`rewrite` won't find occurrences inside `forall` that refer - to variables bound by the `forall`; use :tacn:`setoid_rewrite` + to variables bound by the `forall`; use the more advanced :tacn:`setoid_rewrite` if you want to find such occurrences. :n:`{+, @oriented_rewriter }` @@ -90,12 +93,55 @@ Rewriting with Leibniz and setoid equality any of them can be rewritten. If not specified, only the first occurrence in the conclusion is replaced. - If :n:`at @occs_nums` is specified, rewriting is always done with - :ref:`setoid rewriting <generalizedrewriting>`, even for Leibniz’s equality. + .. note:: + + If :n:`at @occs_nums` is specified, rewriting is always done + with :ref:`setoid rewriting <generalizedrewriting>`, even for + Leibniz equality, which means that you must `Require + Setoid` to use that form. However, note that :tacn:`rewrite` + (even when using setoid rewriting) and :tacn:`setoid_rewrite` + don't behave identically (as is noted above and below). :n:`by @ltac_expr3` If specified, is used to resolve all side conditions generated by the tactic. + .. note:: + + For each selected hypothesis and/or the conclusion, + :tacn:`rewrite` finds the first matching subterm in + depth-first search order. Only subterms identical to + that first matched subterm are rewritten. If the `at` clause is specified, + only these subterms are considered when counting occurrences. + To select a different set of matching subterms, you can + specify how some or all of the free variables are bound by + using a `with` clause (see :n:`@one_term_with_bindings`). + + For instance, if we want to rewrite the right-hand side in the + following goal, this will not work: + + .. coqtop:: none + + Require Import Arith. + + .. coqtop:: out + + Lemma example x y : x + y = y + x. + + .. coqtop:: all fail + + rewrite Nat.add_comm at 2. + + One can explicitly specify how some variables are bound to match + a different subterm: + + .. coqtop:: all abort + + rewrite Nat.add_comm with (m := x). + + Note that the more advanced :tacn:`setoid_rewrite` tactic + behaves differently, and thus the number of occurrences + available to rewrite may differ between the two tactics. + .. exn:: Tactic failure: Setoid library not loaded. :undocumented: @@ -338,13 +384,6 @@ Rewriting with definitional equality exact H. Qed. - .. tacn:: convert_concl_no_check @one_term - - .. deprecated:: 8.11 - - Deprecated old name for :tacn:`change_no_check`. Does not support any of its - variants. - .. _performingcomputations: Performing computations @@ -520,9 +559,7 @@ the conversion in hypotheses :n:`{+ @ident}`. on the profile file to see the results. Consult the ``perf`` documentation for more details. -.. flag:: Debug Cbv - - This flag makes :tacn:`cbv` (and its derivative :tacn:`compute`) print + :opt:`Debug` ``"Cbv"`` makes :tacn:`cbv` (and its derivative :tacn:`compute`) print information about the constants it encounters and the unfolding decisions it makes. @@ -538,9 +575,6 @@ the conversion in hypotheses :n:`{+ @ident}`. definition (say :g:`t`) and then reduces :g:`(t t`:sub:`1` :g:`... t`:sub:`n` :g:`)` according to :math:`\beta`:math:`\iota`:math:`\zeta`-reduction rules. -.. exn:: Not reducible. - :undocumented: - .. exn:: No head constant to reduce. :undocumented: @@ -623,10 +657,8 @@ the conversion in hypotheses :n:`{+ @ident}`. This applies :tacn:`simpl` only to the :n:`{+ @natural}` applicative subterms whose head occurrence is :n:`@qualid` (or :n:`@string`). -.. flag:: Debug RAKAM - - This flag makes :tacn:`cbn` print various debugging information. - ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. +:opt:`Debug` ``"RAKAM"`` makes :tacn:`cbn` print various debugging information. +``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. .. tacn:: unfold @qualid :name: unfold diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 609884ce1d..557ef10555 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1726,12 +1726,6 @@ Number notations * :n:`@qualid__type -> Number.number` * :n:`@qualid__type -> option Number.number` - .. deprecated:: 8.12 - Number notations on :g:`Decimal.uint`, :g:`Decimal.int` and - :g:`Decimal.decimal` are replaced respectively by number - notations on :g:`Number.uint`, :g:`Number.int` and - :g:`Number.number`. - When parsing, the application of the parsing function :n:`@qualid__parse` to the number will be fully reduced, and universes of the resulting term will be refreshed. @@ -1741,6 +1735,12 @@ Number notations sorts, primitive integers, primitive floats, primitive arrays and type constants for primitive types) will be considered for printing. + .. note:: + For example, :n:`@qualid__type` can be :n:`PrimInt63.int`, + in which case :n:`@qualid__print` takes :n:`PrimInt63.int_wrapper` as input + instead of :n:`PrimInt63.int`. See below for an + :ref:`example <example-number-notation-primitive-int>`. + .. _number-string-via: :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` @@ -2066,6 +2066,23 @@ The following errors apply to both string and number notations: Check 3. +.. _example-number-notation-primitive-int: + +.. example:: Number Notation for primitive integers + + This shows the use of the primitive + integers :n:`PrimInt63.int` as :n:`@qualid__type`. It is the way + parsing and printing of primitive integers are actually implemented + in `PrimInt63.v`. + + .. coqtop:: in reset + + Require Import Int63. + Definition parser (x : pos_neg_int63) : option int := + match x with Pos p => Some p | Neg _ => None end. + Definition printer (x : int_wrapper) : pos_neg_int63 := Pos (int_wrap x). + Number Notation int parser printer : int63_scope. + .. _example-number-notation-non-inductive: .. example:: Number Notation for a non inductive type diff --git a/doc/stdlib/dune b/doc/stdlib/dune index 0b6ca5f178..6b51202f6e 100644 --- a/doc/stdlib/dune +++ b/doc/stdlib/dune @@ -22,7 +22,8 @@ (:header %{project_root}/doc/common/styles/html/coqremote/header.html) (:footer %{project_root}/doc/common/styles/html/coqremote/footer.html) ; For .glob files, should be gone when Coq Dune is smarter. - (package coq)) + (package coq-core) + (package coq-stdlib)) (action (progn (run mkdir -p html) diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 1bc0c1f6d7..b0f4e883be 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -286,6 +286,7 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/Cyclic/Int63/Cyclic63.v theories/Numbers/Cyclic/Int63/PrimInt63.v theories/Numbers/Cyclic/Int63/Int63.v + theories/Numbers/Cyclic/Int63/Sint63.v theories/Numbers/Cyclic/Int63/Ring63.v theories/Numbers/Cyclic/ZModulo/ZModulo.v </dd> diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 8aeb2e564d..27144fd1ad 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -447,7 +447,7 @@ binder: [ open_binders: [ | REPLACE name LIST0 name ":" lconstr -| WITH LIST1 name ":" lconstr +| WITH LIST1 name ":" type (* @Zimmi48: Special token .. is for use in the Notation command. (see bug_3304.v) *) | DELETE name ".." name | REPLACE name LIST0 name binders @@ -1510,8 +1510,6 @@ query_command: [ | WITH "Check" lconstr | REPLACE "About" smart_global OPT univ_name_list "." | WITH "About" smart_global OPT univ_name_list -| REPLACE "SearchHead" constr_pattern in_or_out_modules "." -| WITH "SearchHead" constr_pattern in_or_out_modules | REPLACE "SearchPattern" constr_pattern in_or_out_modules "." | WITH "SearchPattern" constr_pattern in_or_out_modules | REPLACE "SearchRewrite" constr_pattern in_or_out_modules "." diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 1c07d00d4f..4ba60ddd9f 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -1,6 +1,6 @@ (executable (name doc_grammar) - (libraries coq.clib coqpp)) + (libraries coq-core.clib coqpp)) (env (_ (binaries doc_grammar.exe))) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index ec23ffe83e..bc6b803bbb 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -687,17 +687,6 @@ command: [ | "Add" "Zify" "BinOpSpec" constr (* micromega plugin *) | "Add" "Zify" "UnOpSpec" constr (* micromega plugin *) | "Add" "Zify" "Saturate" constr (* micromega plugin *) -| "Add" "InjTyp" constr (* micromega plugin *) -| "Add" "BinOp" constr (* micromega plugin *) -| "Add" "UnOp" constr (* micromega plugin *) -| "Add" "CstOp" constr (* micromega plugin *) -| "Add" "BinRel" constr (* micromega plugin *) -| "Add" "PropOp" constr (* micromega plugin *) -| "Add" "PropBinOp" constr (* micromega plugin *) -| "Add" "PropUOp" constr (* micromega plugin *) -| "Add" "BinOpSpec" constr (* micromega plugin *) -| "Add" "UnOpSpec" constr (* micromega plugin *) -| "Add" "Saturate" constr (* micromega plugin *) | "Show" "Zify" "InjTyp" (* micromega plugin *) | "Show" "Zify" "BinOp" (* micromega plugin *) | "Show" "Zify" "UnOp" (* micromega plugin *) @@ -705,7 +694,6 @@ command: [ | "Show" "Zify" "BinRel" (* micromega plugin *) | "Show" "Zify" "UnOpSpec" (* micromega plugin *) | "Show" "Zify" "BinOpSpec" (* micromega plugin *) -| "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" constr OPT ring_mods (* ring plugin *) | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) @@ -1258,7 +1246,6 @@ query_command: [ | "Compute" lconstr "." | "Check" lconstr "." | "About" smart_global OPT univ_name_list "." -| "SearchHead" constr_pattern in_or_out_modules "." | "SearchPattern" constr_pattern in_or_out_modules "." | "SearchRewrite" constr_pattern in_or_out_modules "." | "Search" search_query search_queries "." @@ -1551,7 +1538,6 @@ simple_tactic: [ | "revert" LIST1 hyp | "simple" "induction" quantified_hypothesis | "simple" "destruct" quantified_hypothesis -| "double" "induction" quantified_hypothesis quantified_hypothesis | "admit" | "fix" ident natural | "cofix" ident @@ -1669,7 +1655,6 @@ simple_tactic: [ | "autounfold_one" hintbases | "unify" constr constr | "unify" constr constr "with" preident -| "convert_concl_no_check" constr | "typeclasses" "eauto" "bfs" OPT nat_or_var "with" LIST1 preident | "typeclasses" "eauto" OPT nat_or_var "with" LIST1 preident | "typeclasses" "eauto" "bfs" OPT nat_or_var diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 75b32a5800..a34e96ac16 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -493,7 +493,7 @@ term_forall_or_fun: [ ] open_binders: [ -| LIST1 name ":" term +| LIST1 name ":" type | LIST1 binder ] @@ -1001,18 +1001,6 @@ command: [ | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" OPT [ "CutOff" integer | string ] | "Show" "Lia" "Profile" (* micromega plugin *) -| "Add" "InjTyp" one_term (* micromega plugin *) -| "Add" "BinOp" one_term (* micromega plugin *) -| "Add" "UnOp" one_term (* micromega plugin *) -| "Add" "CstOp" one_term (* micromega plugin *) -| "Add" "BinRel" one_term (* micromega plugin *) -| "Add" "PropOp" one_term (* micromega plugin *) -| "Add" "PropBinOp" one_term (* micromega plugin *) -| "Add" "PropUOp" one_term (* micromega plugin *) -| "Add" "BinOpSpec" one_term (* micromega plugin *) -| "Add" "UnOpSpec" one_term (* micromega plugin *) -| "Add" "Saturate" one_term (* micromega plugin *) -| "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* ring plugin *) | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) @@ -1117,7 +1105,6 @@ command: [ | "Compute" term | "Check" term | "About" reference OPT univ_name_list -| "SearchHead" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchPattern" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) @@ -1626,7 +1613,6 @@ simple_tactic: [ | "revert" LIST1 ident | "simple" "induction" [ ident | natural ] | "simple" "destruct" [ ident | natural ] -| "double" "induction" [ ident | natural ] [ ident | natural ] | "admit" | "clear" LIST0 ident | "clear" "-" LIST1 ident @@ -1758,7 +1744,6 @@ simple_tactic: [ | "autounfold" OPT hintbases OPT occurrences | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) -| "convert_concl_no_check" one_term | "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 ident ) | "head_of_constr" ident one_term | "not_evar" one_term @@ -2420,7 +2405,6 @@ tac2mode: [ | "Compute" term | "Check" term | "About" reference OPT univ_name_list -| "SearchHead" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchPattern" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) @@ -20,7 +20,7 @@ (install (section lib) - (package coq) + (package coq-core) (files revision)) (rule diff --git a/dune-project b/dune-project index 1187c58449..251fbd92aa 100644 --- a/dune-project +++ b/dune-project @@ -22,13 +22,13 @@ ; Note that we use coq.opam.template to have dune add the correct opam ; prefix for configure (package - (name coq) + (name coq-core) (depends (ocaml (>= 4.05.0)) - (dune (>= 2.5.0)) (ocamlfind (>= 1.8.1)) - (zarith (>= 1.10))) - (synopsis "The Coq Proof Assistant") + (zarith (>= 1.10)) + (ounit2 :with-test)) + (synopsis "The Coq Proof Assistant -- Core Binaries and Tools") (description "Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an environment for @@ -38,13 +38,38 @@ Typical applications include the certification of properties of programming languages (e.g. the CompCert compiler certification project, or the Bedrock verified low-level programming library), the formalization of mathematics (e.g. the full formalization of the -Feit-Thompson theorem or homotopy type theory) and teaching.")) +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq core binaries, plugins, and tools, but +not the vernacular standard library. + +Note that in this setup, Coq needs to be started with the -boot and +-noinit options, as will otherwise fail to find the regular Coq +prelude, now living in the coq-stdlib package.")) + +(package + (name coq-stdlib) + (depends + (coq-core (= :version))) + (synopsis "The Coq Proof Assistant -- Standard Library") + (description "Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq Standard Library, that is to say, the +set of modules usually bound to the Coq.* namespace.")) (package (name coqide-server) (depends - (dune (>= 2.5.0)) - (coq (= :version))) + (coq-core (= :version))) (synopsis "The Coq Proof Assistant, XML protocol server") (description "Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable @@ -59,7 +84,6 @@ structured way.")) (package (name coqide) (depends - (dune (>= 2.5.0)) (coqide-server (= :version))) (synopsis "The Coq Proof Assistant --- GTK3 IDE") (description "Coq is a formal proof management system. It provides @@ -75,6 +99,7 @@ development of interactive proofs.")) (license "OPL-1.0") (depends (dune (and :build (>= 2.5.0))) + (conf-python-3 :build) (coq (and :build (= :version)))) (synopsis "The Coq Proof Assistant --- Reference Manual") (description "Coq is a formal proof management system. It provides @@ -84,3 +109,19 @@ semi-interactive development of machine-checked proofs. This package provides the Coq Reference Manual.")) +(package + (name coq) + (depends + (coq-core (= :version)) + (coq-stdlib (= :version))) + (synopsis "The Coq Proof Assistant") + (description "Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching.")) diff --git a/engine/dune b/engine/dune index e2b7ab9c87..00db94389b 100644 --- a/engine/dune +++ b/engine/dune @@ -1,6 +1,6 @@ (library (name engine) (synopsis "Coq's Tactic Engine") - (public_name coq.engine) + (public_name coq-core.engine) (wrapped false) (libraries library)) diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 0d038e9a67..162d189136 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -365,6 +365,8 @@ val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Cons val of_case_invert : Constr.case_invert -> case_invert +val of_constr_array : Constr.t array -> t array + (** {5 Unsafe operations} *) module Unsafe : diff --git a/gramlib/dune b/gramlib/dune index 8ca6aff25a..62c64b0c1a 100644 --- a/gramlib/dune +++ b/gramlib/dune @@ -1,4 +1,4 @@ (library (name gramlib) - (public_name coq.gramlib) - (libraries coq.lib)) + (public_name coq-core.gramlib) + (libraries coq-core.lib)) diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index b8228df2aa..20e9f0134f 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -13,13 +13,9 @@ open Preferences let ideslave_coqtop_flags = ref None -(** * Version and date *) +(** * Version *) -let get_version_date () = - let date = - if Glib.Utf8.validate Coq_config.date - then Coq_config.date - else "<date not printable>" in +let get_version () = try (* the following makes sense only when running with local layout *) let coqroot = Filename.concat @@ -29,21 +25,20 @@ let get_version_date () = let ch = open_in (Filename.concat coqroot "revision") in let ver = input_line ch in let rev = input_line ch in - (ver,rev) - with _ -> (Coq_config.version,date) + close_in ch; + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let short_version () = - let (ver,date) = get_version_date () in - Printf.sprintf "The Coq Proof Assistant, version %s (%s)\n" ver date + Printf.sprintf "The Coq Proof Assistant, version %s\n" (get_version ()) let version () = - let (ver,date) = get_version_date () in Printf.sprintf - "The Coq Proof Assistant, version %s (%s)\ + "The Coq Proof Assistant, version %s\ \nArchitecture %s running %s operating system\ \nGtk version is %s\ \nThis is %s \n" - ver date + (get_version ()) Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) (Filename.basename Sys.executable_name) diff --git a/ide/coqide/coq_commands.ml b/ide/coqide/coq_commands.ml index 711986c2b2..2d75ad9ff6 100644 --- a/ide/coqide/coq_commands.ml +++ b/ide/coqide/coq_commands.ml @@ -207,7 +207,6 @@ let state_preserving = [ "Recursive Extraction Library"; "Search"; - "SearchHead"; "SearchPattern"; "SearchRewrite"; diff --git a/ide/coqide/coqide.ml b/ide/coqide/coqide.ml index f9e6e74372..3fbfbd66d3 100644 --- a/ide/coqide/coqide.ml +++ b/ide/coqide/coqide.ml @@ -1374,8 +1374,7 @@ let main files = let read_coqide_args argv = let set_debug () = Minilib.debug := true; - Flags.debug := true; - Exninfo.record_backtrace true + CDebug.set_debug_all true in let rec filter_coqtop coqtop project_files bindings_files out = function |"-unicode-bindings" :: sfilenames :: args -> @@ -1405,6 +1404,9 @@ let read_coqide_args argv = |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; filter_coqtop coqtop project_files bindings_files out args + | ("-v" | "--version") :: _ -> + Printf.printf "CoqIDE, version %s\n" Coq_config.version; + exit 0 |arg::args when out = [] && CString.is_prefix "-psn_" arg -> (* argument added by MacOS during .app launch *) filter_coqtop coqtop project_files bindings_files out args diff --git a/ide/coqide/coqide_main.ml b/ide/coqide/coqide_main.ml index 0812e00960..a178e72806 100644 --- a/ide/coqide/coqide_main.ml +++ b/ide/coqide/coqide_main.ml @@ -35,7 +35,7 @@ let catch_gtk_messages () = let () = GToolbox.message_box ~title:"Error" (header ^ msg) in Coqide.crash_save 1 |`ERROR -> - if !Flags.debug then GToolbox.message_box ~title:"Error" (header ^ msg) + if CDebug.(get_flag misc) then GToolbox.message_box ~title:"Error" (header ^ msg) else Printf.eprintf "%s\n" (header ^ msg) |`DEBUG -> Minilib.log msg |level when Sys.os_type = "Win32" -> Minilib.log ~level msg diff --git a/ide/coqide/dune b/ide/coqide/dune index 12bad7ebc4..4bb4672cd4 100644 --- a/ide/coqide/dune +++ b/ide/coqide/dune @@ -6,7 +6,7 @@ (public_name coqide-server.core) (wrapped false) (modules document) - (libraries coq.lib)) + (libraries coq-core.lib)) (executable (name fake_ide) @@ -20,7 +20,7 @@ (public_name coqidetop.opt) (package coqide-server) (modules idetop) - (libraries coq.toplevel coqide-server.protocol) + (libraries coq-core.toplevel coqide-server.protocol) (modes native byte) (link_flags -linkall)) diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 528e2a756b..a6a7f7d742 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -35,11 +35,11 @@ let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s let pr_debug s = - if !Flags.debug then pr_with_pid s + if CDebug.(get_flag misc) then pr_with_pid s let pr_debug_call q = - if !Flags.debug then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q) + if CDebug.(get_flag misc) then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q) let pr_debug_answer q r = - if !Flags.debug then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r) + if CDebug.(get_flag misc) then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r) (** Categories of commands *) @@ -397,8 +397,8 @@ let set_options options = let about () = { Interface.coqtop_version = Coq_config.version; Interface.protocol_version = Xmlprotocol.protocol_version; - Interface.release_date = Coq_config.date; - Interface.compile_date = Coq_config.compile_date; + Interface.release_date = "n/a"; + Interface.compile_date = "n/a"; } let handle_exn (e, info) = @@ -513,9 +513,11 @@ let msg_format = ref (fun () -> (* The loop ignores the command line arguments as the current model delegates its handing to the toplevel container. *) -let loop run_mode ~opts:_ state = +let loop ( { Coqtop.run_mode; color_mode },_) ~opts:_ state = match run_mode with | Coqtop.Batch -> exit 0 + | Coqtop.(Query PrintTags) -> Coqtop.print_style_tags color_mode; exit 0 + | Coqtop.(Query _) -> Printf.eprintf "Unknown query"; exit 1 | Coqtop.Interactive -> let open Vernac.State in set_doc state.doc; @@ -580,32 +582,28 @@ coqidetop specific options:\n\ \n --help-XML-protocol print documentation of the Coq XML protocol\n" } -let islave_parse ~opts extra_args = +let islave_parse extra_args = let open Coqtop in - let run_mode, extra_args = coqtop_toplevel.parse_extra ~opts extra_args in + let ({ run_mode; color_mode }, stm_opts), extra_args = coqtop_toplevel.parse_extra extra_args in let extra_args = parse extra_args in (* One of the role of coqidetop is to find the name of buffers to open *) (* in the command line; Coqide is waiting these names on stdout *) (* (see filter_coq_opts in coq.ml), so we send them now *) print_string (String.concat "\n" extra_args); - run_mode, [] + ( { Coqtop.run_mode; color_mode }, stm_opts), [] -let islave_init run_mode ~opts = +let islave_init ( { Coqtop.run_mode; color_mode }, stm_opts) injections ~opts = if run_mode = Coqtop.Batch then Flags.quiet := true; - Coqtop.init_toploop opts + Coqtop.init_toploop opts stm_opts injections -let islave_default_opts = - Coqargs.{ default with - config = { default.config with - stm_flags = { default.config.stm_flags with - Stm.AsyncOpts.async_proofs_worker_priority = CoqworkmgrApi.High }}} +let islave_default_opts = Coqargs.default let () = let open Coqtop in let custom = { parse_extra = islave_parse ; - help = coqidetop_specific_usage; - init = islave_init; + usage = coqidetop_specific_usage; + init_extra = islave_init; run = loop; - opts = islave_default_opts } in + initial_args = islave_default_opts } in start_coq custom diff --git a/ide/coqide/microPG.ml b/ide/coqide/microPG.ml index 5a4871b70a..9908703cea 100644 --- a/ide/coqide/microPG.ml +++ b/ide/coqide/microPG.ml @@ -15,7 +15,7 @@ open GdkKeysyms open Printf let eprintf x = - if !Flags.debug then Printf.eprintf x else Printf.ifprintf stderr x + if CDebug.(get_flag misc) then Printf.eprintf x else Printf.ifprintf stderr x type gui = { notebook : session Wg_Notebook.typed_notebook; diff --git a/ide/coqide/protocol/dune b/ide/coqide/protocol/dune index 801ceb20ec..f48c7de0c4 100644 --- a/ide/coqide/protocol/dune +++ b/ide/coqide/protocol/dune @@ -2,6 +2,6 @@ (name protocol) (public_name coqide-server.protocol) (wrapped false) - (libraries coq.lib)) + (libraries coq-core.lib)) (ocamllex xml_lexer) diff --git a/ide/coqide/wg_Find.ml b/ide/coqide/wg_Find.ml index 7e89191bd1..7f30cc8c6c 100644 --- a/ide/coqide/wg_Find.ml +++ b/ide/coqide/wg_Find.ml @@ -219,16 +219,18 @@ class finder name (view : GText.view) = let _ = replace_all_button#connect#clicked ~callback:self#replace_all in (* Keypress interaction *) - let generic_cb esc_cb ret_cb ev = + let dispatch_key_cb esc_cb ret_cb shift_ret_cb ev = let ev_key = GdkEvent.Key.keyval ev in - let (return, _) = GtkData.AccelGroup.parse "Return" in - let (esc, _) = GtkData.AccelGroup.parse "Escape" in - if ev_key = return then (ret_cb (); true) - else if ev_key = esc then (esc_cb (); true) + let ev_modifiers = GdkEvent.Key.state ev in + if ev_key = GdkKeysyms._Return then + (if List.mem `SHIFT ev_modifiers then + shift_ret_cb () + else ret_cb (); true) + else if ev_key = GdkKeysyms._Escape then (esc_cb (); true) else false in - let find_cb = generic_cb self#hide self#find_forward in - let replace_cb = generic_cb self#hide self#replace in + let find_cb = dispatch_key_cb self#hide self#find_forward self#find_backward in + let replace_cb = dispatch_key_cb self#hide self#replace self#replace in let _ = find_entry#event#connect#key_press ~callback:find_cb in let _ = replace_entry#event#connect#key_press ~callback:replace_cb in diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 8138b4c6d9..4fb7861ca6 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -969,7 +969,13 @@ let rec extern inctx ?impargs scopes vars r = with No_match -> extern inctx scopes vars r') | None -> - try extern_notations inctx scopes vars None r + let r' = match DAst.get r with + | GInt i when Coqlib.has_ref "num.int63.wrap_int" -> + let wrap = Coqlib.lib_ref "num.int63.wrap_int" in + DAst.make (GApp (DAst.make (GRef (wrap, None)), [r])) + | _ -> r in + + try extern_notations inctx scopes vars None r' with No_match -> let loc = r.CAst.loc in @@ -1123,7 +1129,7 @@ let rec extern inctx ?impargs scopes vars r = | GInt i -> extern_prim_token_delimiter_if_required - (Number (NumTok.Signed.of_int_string (Uint63.to_string i))) + (Number NumTok.(Signed.of_bigint CHex (Z.of_int64 (Uint63.to_int64 i)))) "int63" "int63_scope" (snd scopes) | GFloat f -> extern_float f (snd scopes) diff --git a/interp/dune b/interp/dune index 6d73d5724c..793ce48ea3 100644 --- a/interp/dune +++ b/interp/dune @@ -1,6 +1,6 @@ (library (name interp) (synopsis "Coq's Syntactic Interpretation for AST [notations, implicits]") - (public_name coq.interp) + (public_name coq-core.interp) (wrapped false) (libraries zarith pretyping)) diff --git a/interp/notation.ml b/interp/notation.ml index d6002d71b5..4010c3487e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -548,15 +548,15 @@ type number_ty = hexadecimal : Names.inductive; number : Names.inductive } +type pos_neg_int63_ty = + { pos_neg_int63_ty : Names.inductive } + type target_kind = | Int of int_ty (* Coq.Init.Number.int + uint *) | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Int63 of pos_neg_int63_ty (* Coq.Numbers.Cyclic.Int63.PrimInt63.pos_neg_int63 *) | Number of number_ty (* Coq.Init.Number.number + uint + int *) - | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) - | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte @@ -869,30 +869,16 @@ let mkDecHex ind c n = match c with | CDec -> mkApp (mkConstruct (ind, 1), [|n|]) (* (UInt|Int|)Decimal *) | CHex -> mkApp (mkConstruct (ind, 2), [|n|]) (* (UInt|Int|)Hexadecimal *) -exception NonDecimal - -let decimal_coqnumber_of_rawnum inds n = - if NumTok.Signed.classify n <> CDec then raise NonDecimal; - coqnumber_of_rawnum inds CDec n - let coqnumber_of_rawnum inds n = let c = NumTok.Signed.classify n in let n = coqnumber_of_rawnum inds c n in mkDecHex inds.number c n -let decimal_coquint_of_rawnum inds n = - if NumTok.UnsignedNat.classify n <> CDec then raise NonDecimal; - coquint_of_rawnum inds CDec (Some n) - let coquint_of_rawnum inds n = let c = NumTok.UnsignedNat.classify n in let n = coquint_of_rawnum inds c (Some n) in mkDecHex inds.uint c n -let decimal_coqint_of_rawnum inds n = - if NumTok.SignedNat.classify n <> CDec then raise NonDecimal; - coqint_of_rawnum inds CDec n - let coqint_of_rawnum inds n = let c = NumTok.SignedNat.classify n in let n = coqint_of_rawnum inds c n in @@ -947,23 +933,14 @@ let destDecHex c = match Constr.kind c with | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken -let decimal_rawnum_of_coqnumber c = - rawnum_of_coqnumber CDec c - let rawnum_of_coqnumber c = let cl, c = destDecHex c in rawnum_of_coqnumber cl c -let decimal_rawnum_of_coquint c = - rawnum_of_coquint CDec c - let rawnum_of_coquint c = let cl, c = destDecHex c in rawnum_of_coquint cl c -let decimal_rawnum_of_coqint c = - rawnum_of_coqint CDec c - let rawnum_of_coqint c = let cl, c = destDecHex c in rawnum_of_coqint cl c @@ -1038,12 +1015,22 @@ let error_negative ?loc = let error_overflow ?loc n = CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Z.to_string n)) -let interp_int63 ?loc n = +let error_underflow ?loc n = + CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "underflow in int63 literal: " ++ str (Z.to_string n)) + +let coqpos_neg_int63_of_bigint ?loc ind (sign,n) = + let uint = int63_of_pos_bigint ?loc n in + let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in + mkApp (mkConstruct (ind, pos_neg), [|uint|]) + +let interp_int63 ?loc ind n = + let sign = if Z.(compare n zero >= 0) then SPlus else SMinus in + let n = Z.abs n in if Z.(leq zero n) then if Z.(lt n (pow z_two 63)) - then int63_of_pos_bigint ?loc n - else error_overflow ?loc n + then coqpos_neg_int63_of_bigint ?loc ind (sign,n) + else match sign with SPlus -> error_overflow ?loc n | SMinus -> error_underflow ?loc n else error_negative ?loc let bigint_of_int63 c = @@ -1051,6 +1038,15 @@ let bigint_of_int63 c = | Int i -> Z.of_int64 (Uint63.to_int64 i) | _ -> raise NotAValidPrimToken +let bigint_of_coqpos_neg_int63 c = + match Constr.kind c with + | App (c,[|c'|]) -> + (match Constr.kind c with + | Construct ((_,1), _) (* Pos *) -> bigint_of_int63 c' + | Construct ((_,2), _) (* Neg *) -> Z.neg (bigint_of_int63 c') + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken + let interp o ?loc n = begin match o.warning, n with | Warning threshold, n when NumTok.Signed.is_bigger_int_than n threshold -> @@ -1062,22 +1058,13 @@ let interp o ?loc n = coqint_of_rawnum int_ty n | UInt int_ty, Some (SPlus, n) -> coquint_of_rawnum int_ty n - | DecimalInt int_ty, Some n -> - (try decimal_coqint_of_rawnum int_ty n - with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) - | DecimalUInt int_ty, Some (SPlus, n) -> - (try decimal_coquint_of_rawnum int_ty n - with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) | Z z_pos_ty, Some n -> z_of_bigint z_pos_ty (NumTok.SignedNat.to_bigint n) - | Int63, Some n -> - interp_int63 ?loc (NumTok.SignedNat.to_bigint n) - | (Int _ | UInt _ | DecimalInt _ | DecimalUInt _ | Z _ | Int63), _ -> + | Int63 pos_neg_int63_ty, Some n -> + interp_int63 ?loc pos_neg_int63_ty.pos_neg_int63_ty (NumTok.SignedNat.to_bigint n) + | (Int _ | UInt _ | Z _ | Int63 _), _ -> no_such_prim_token "number" ?loc o.ty_name | Number number_ty, _ -> coqnumber_of_rawnum number_ty n - | Decimal number_ty, _ -> - (try decimal_coqnumber_of_rawnum number_ty n - with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) in let env = Global.env () in let sigma = Evd.from_env env in @@ -1100,11 +1087,8 @@ let uninterp o n = | (Int _, c) -> NumTok.Signed.of_int (rawnum_of_coqint c) | (UInt _, c) -> NumTok.Signed.of_nat (rawnum_of_coquint c) | (Z _, c) -> NumTok.Signed.of_bigint CDec (bigint_of_z c) - | (Int63, c) -> NumTok.Signed.of_bigint CDec (bigint_of_int63 c) + | (Int63 _, c) -> NumTok.Signed.of_bigint CDec (bigint_of_coqpos_neg_int63 c) | (Number _, c) -> rawnum_of_coqnumber c - | (DecimalInt _, c) -> NumTok.Signed.of_int (decimal_rawnum_of_coqint c) - | (DecimalUInt _, c) -> NumTok.Signed.of_nat (decimal_rawnum_of_coquint c) - | (Decimal _, c) -> decimal_rawnum_of_coqnumber c end o n end diff --git a/interp/notation.mli b/interp/notation.mli index 97955bf92e..195f2a4416 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -137,15 +137,15 @@ type number_ty = hexadecimal : Names.inductive; number : Names.inductive } +type pos_neg_int63_ty = + { pos_neg_int63_ty : Names.inductive } + type target_kind = | Int of int_ty (* Coq.Init.Number.int + uint *) | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Int63 of pos_neg_int63_ty (* Coq.Numbers.Cyclic.Int63.PrimInt63.pos_neg_int63 *) | Number of number_ty (* Coq.Init.Number.number + uint + int *) - | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) - | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte diff --git a/interp/numTok.ml b/interp/numTok.ml index 124a6cd249..12ef33717a 100644 --- a/interp/numTok.ml +++ b/interp/numTok.ml @@ -85,7 +85,7 @@ struct let string_of_nonneg_bigint c n = match c with | CDec -> Z.format "%d" n - | CHex -> Z.format "0x%x" n + | CHex -> Z.format "%#x" n let of_bigint c n = let sign, n = if Int.equal (-1) (Z.sign n) then (SMinus, Z.neg n) else (SPlus, n) in (sign, string_of_nonneg_bigint c n) diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 4bc6848ba7..20890a28dc 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -21,68 +21,12 @@ #include <caml/alloc.h> #include <caml/memory.h> #include "coq_instruct.h" +#include "coq_arity.h" #include "coq_fix_code.h" #ifdef THREADED_CODE char ** coq_instr_table; char * coq_instr_base; -int arity[STOP+1]; - -void init_arity () { - /* instruction with zero operand */ - arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= - arity[ACC6]=arity[ACC7]= - arity[PUSH]=arity[PUSHACC1]= - arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= - arity[PUSHACC6]=arity[PUSHACC7]= - arity[ENVACC0]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]= - arity[PUSHENVACC0]=arity[PUSHENVACC1]=arity[PUSHENVACC2]=arity[PUSHENVACC3]= - arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[APPLY4]=arity[RESTART]= - arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE1]= - arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE1]= - arity[GETFIELD0]=arity[GETFIELD1]= - arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= - arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]= - 0; - /* instruction with one operand */ - arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= - arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= - arity[APPTERM3]=arity[RETURN]=arity[GRAB]=arity[OFFSETCLOSURE]= - arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= - arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= - arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= - arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ENSURESTACKCAPACITY]= - arity[CHECKADDINT63]=arity[CHECKADDCINT63]=arity[CHECKADDCARRYCINT63]= - arity[CHECKSUBINT63]=arity[CHECKSUBCINT63]=arity[CHECKSUBCARRYCINT63]= - arity[CHECKMULINT63]=arity[CHECKMULCINT63]= - arity[CHECKDIVINT63]=arity[CHECKMODINT63]=arity[CHECKDIVEUCLINT63]= - arity[CHECKDIV21INT63]= - arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= - arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= - arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= - arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]= - arity[CHECKEQFLOAT]=arity[CHECKLTFLOAT]=arity[CHECKLEFLOAT]= - arity[CHECKOPPFLOAT]=arity[CHECKABSFLOAT]=arity[CHECKCOMPAREFLOAT]= - arity[CHECKCLASSIFYFLOAT]= - arity[CHECKADDFLOAT]=arity[CHECKSUBFLOAT]=arity[CHECKMULFLOAT]= - arity[CHECKDIVFLOAT]=arity[CHECKSQRTFLOAT]= - arity[CHECKFLOATOFINT63]=arity[CHECKFLOATNORMFRMANTISSA]= - arity[CHECKFRSHIFTEXP]=arity[CHECKLDSHIFTEXP]= - arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; - /* instruction with two operands */ - arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[CHECKCAMLCALL1]=arity[CHECKCAMLCALL2_1]= - arity[CHECKCAMLCALL2]=arity[CHECKCAMLCALL3_1]= - arity[PROJ]= - 2; - /* instruction with four operands */ - arity[MAKESWITCHBLOCK]=4; - /* instruction with arbitrary operands */ - arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0; -} - #endif /* THREADED_CODE */ @@ -164,9 +108,7 @@ value coq_tcode_of_code (value code) { opcode_t instr; COPY32(&instr,p); p++; - if (instr < 0 || instr > STOP){ - instr = STOP; - }; + if (instr < 0 || instr > STOP) abort(); *q++ = VALINSTR(instr); if (instr == SWITCH) { uint32_t i, sizes, const_size, block_size; @@ -183,8 +125,9 @@ value coq_tcode_of_code (value code) { q++; for(i=1; i<n; i++) { COPY32(q,p); p++; q++; }; } else { - uint32_t i, ar; + int i, ar; ar = arity[instr]; + if (ar < 0) abort(); for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } } diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 5a233e6178..916d9753a4 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -18,7 +18,6 @@ void * coq_stat_alloc (asize_t sz); #ifdef THREADED_CODE extern char ** coq_instr_table; extern char * coq_instr_base; -void init_arity(); #define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base)) #else #define VALINSTR(instr) instr diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a9ea6d9f46..704eb1ef98 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -547,7 +547,7 @@ value coq_interprete CHECK_STACK(0); /* We also check for signals */ #if OCAML_VERSION >= 41000 - { + if (caml_something_to_do) { value res = caml_process_pending_actions_exn(); if (Is_exception_result(res)) { /* If there is an asynchronous exception, we reset the vm */ @@ -1426,6 +1426,41 @@ value coq_interprete Next; } + Instruct(CHECKDIVSINT63) { + print_instr("CHEKDIVSINT63"); + CheckInt2(); + int b; + Uint63_eq0(b, *sp); + if (b) { + accu = *sp++; + } + else { + Uint63_eqm1(b, *sp); + if (b) { + Uint63_neg(accu); + sp++; + } + else { + Uint63_divs(accu, *sp++); + } + } + Next; + } + + Instruct(CHECKMODSINT63) { + print_instr("CHEKMODSINT63"); + CheckInt2(); + int b; + Uint63_eq0(b, *sp); + if (b) { + accu = *sp++; + } + else { + Uint63_mods(accu,*sp++); + } + Next; + } + Instruct (CHECKDIV21INT63) { print_instr("DIV21INT63"); CheckInt3(); @@ -1473,6 +1508,13 @@ value coq_interprete Next; } + Instruct(CHECKASRINT63) { + print_instr("CHECKASRINT63"); + CheckInt2(); + Uint63_asr(accu,*sp++); + Next; + } + Instruct (CHECKADDMULDIVINT63) { print_instr("CHECKADDMULDIVINT63"); CheckInt3(); @@ -1508,6 +1550,24 @@ value coq_interprete Next; } + Instruct (CHECKLTSINT63) { + print_instr("CHECKLTSINT63"); + CheckInt2(); + int b; + Uint63_lts(b,accu,*sp++); + accu = b ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLESINT63) { + print_instr("CHECKLESINT63"); + CheckInt2(); + int b; + Uint63_les(b,accu,*sp++); + accu = b ? coq_true : coq_false; + Next; + } + Instruct (CHECKCOMPAREINT63) { /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ /* assumes Inductive _ : _ := Eq | Lt | Gt */ @@ -1526,6 +1586,24 @@ value coq_interprete Next; } + Instruct (CHECKCOMPARESINT63) { + /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ + /* assumes Inductive _ : _ := Eq | Lt | Gt */ + print_instr("CHECKCOMPARESINT63"); + CheckInt2(); + int b; + Uint63_eq(b, accu, *sp); + if (b) { + accu = coq_Eq; + sp++; + } + else { + Uint63_lts(b, accu, *sp++); + accu = b ? coq_Lt : coq_Gt; + } + Next; + } + Instruct (CHECKHEAD0INT63) { print_instr("CHECKHEAD0INT63"); CheckInt1(); diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index fe076f8f04..a55ff57c8d 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -100,9 +100,6 @@ value init_coq_vm(value unit) /* ML */ fprintf(stderr,"already open \n");fflush(stderr);} else { drawinstr=0; -#ifdef THREADED_CODE - init_arity(); -#endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); /* Initialing the interpreter */ diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index dd9b9e55be..693716ee90 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -96,7 +96,10 @@ value uint63_##name##_ml(value x, value y, value z) { \ accu = uint63_return_value__; \ }while(0) +DECLARE_NULLOP(zero) DECLARE_NULLOP(one) +DECLARE_UNOP(neg) +#define Uint63_neg(x) CALL_UNOP(neg, x) DECLARE_BINOP(add) #define Uint63_add(x, y) CALL_BINOP(add, x, y) DECLARE_BINOP(addcarry) @@ -105,28 +108,40 @@ DECLARE_TEROP(addmuldiv) #define Uint63_addmuldiv(x, y, z) CALL_TEROP(addmuldiv, x, y, z) DECLARE_BINOP(div) #define Uint63_div(x, y) CALL_BINOP(div, x, y) +DECLARE_BINOP(divs) +#define Uint63_divs(x, y) CALL_BINOP(divs, x, y) DECLARE_BINOP(eq) #define Uint63_eq(r, x, y) CALL_RELATION(r, eq, x, y) DECLARE_UNOP(eq0) #define Uint63_eq0(r, x) CALL_PREDICATE(r, eq0, x) +DECLARE_UNOP(eqm1) +#define Uint63_eqm1(r, x) CALL_PREDICATE(r, eqm1, x) DECLARE_UNOP(head0) #define Uint63_head0(x) CALL_UNOP(head0, x) DECLARE_BINOP(land) #define Uint63_land(x, y) CALL_BINOP(land, x, y) DECLARE_BINOP(leq) #define Uint63_leq(r, x, y) CALL_RELATION(r, leq, x, y) +DECLARE_BINOP(les) +#define Uint63_les(r, x, y) CALL_RELATION(r, les, x, y) DECLARE_BINOP(lor) #define Uint63_lor(x, y) CALL_BINOP(lor, x, y) DECLARE_BINOP(lsl) #define Uint63_lsl(x, y) CALL_BINOP(lsl, x, y) DECLARE_BINOP(lsr) #define Uint63_lsr(x, y) CALL_BINOP(lsr, x, y) +DECLARE_BINOP(asr) +#define Uint63_asr(x, y) CALL_BINOP(asr, x, y) DECLARE_BINOP(lt) #define Uint63_lt(r, x, y) CALL_RELATION(r, lt, x, y) +DECLARE_BINOP(lts) +#define Uint63_lts(r, x, y) CALL_RELATION(r, lts, x, y) DECLARE_BINOP(lxor) #define Uint63_lxor(x, y) CALL_BINOP(lxor, x, y) DECLARE_BINOP(mod) #define Uint63_mod(x, y) CALL_BINOP(mod, x, y) +DECLARE_BINOP(mods) +#define Uint63_mods(x, y) CALL_BINOP(mods, x, y) DECLARE_BINOP(mul) #define Uint63_mul(x, y) CALL_BINOP(mul, x, y) DECLARE_BINOP(sub) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 731ae8f46e..da9ae7f147 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -12,21 +12,28 @@ #define uint_of_value(val) (((uint64_t)(val)) >> 1) #define uint63_of_value(val) ((uint64_t)(val) >> 1) +#define int63_of_value(val) ((int64_t)(val) >> 1) /* 2^63 * y + x as a value */ //#define Val_intint(x,y) ((value)(((uint64_t)(x)) << 1 + ((uint64_t)(y) << 64))) -#define uint63_zero ((value) 1) /* 2*0 + 1 */ +#define uint63_zero() ((value) 1) /* 2*0 + 1 */ #define uint63_one() ((value) 3) /* 2*1 + 1 */ #define uint63_eq(x,y) ((x) == (y)) #define Uint63_eq(r,x,y) ((r) = uint63_eq(x,y)) #define Uint63_eq0(r,x) ((r) = ((x) == (uint64_t)1)) +#define Uint63_eqm1(r,x) ((r) = ((x) == (uint64_t)(int64_t)(-1))) #define uint63_lt(x,y) ((uint64_t) (x) < (uint64_t) (y)) #define Uint63_lt(r,x,y) ((r) = uint63_lt(x,y)) #define uint63_leq(x,y) ((uint64_t) (x) <= (uint64_t) (y)) #define Uint63_leq(r,x,y) ((r) = uint63_leq(x,y)) +#define uint63_lts(x,y) ((int64_t) (x) < (int64_t) (y)) +#define Uint63_lts(r,x,y) ((r) = uint63_lts(x,y)) +#define uint63_les(x,y) ((int64_t) (x) <= (int64_t) (y)) +#define Uint63_les(r,x,y) ((r) = uint63_les(x,y)) +#define Uint63_neg(x) (accu = (value)(2 - (uint64_t) x)) #define Uint63_add(x,y) (accu = (value)((uint64_t) (x) + (uint64_t) (y) - 1)) #define Uint63_addcarry(x,y) (accu = (value)((uint64_t) (x) + (uint64_t) (y) + 1)) #define Uint63_sub(x,y) (accu = (value)((uint64_t) (x) - (uint64_t) (y) + 1)) @@ -34,6 +41,8 @@ #define Uint63_mul(x,y) (accu = Val_long(uint63_of_value(x) * uint63_of_value(y))) #define Uint63_div(x,y) (accu = Val_long(uint63_of_value(x) / uint63_of_value(y))) #define Uint63_mod(x,y) (accu = Val_long(uint63_of_value(x) % uint63_of_value(y))) +#define Uint63_divs(x,y) (accu = Val_long(int63_of_value(x) / int63_of_value(y))) +#define Uint63_mods(x,y) (accu = Val_long(int63_of_value(x) % int63_of_value(y))) #define Uint63_lxor(x,y) (accu = (value)(((uint64_t)(x) ^ (uint64_t)(y)) | 1)) #define Uint63_lor(x,y) (accu = (value)((uint64_t)(x) | (uint64_t)(y))) @@ -46,14 +55,21 @@ if (uint63_lsl_y__ < (uint64_t) 127) \ accu = (value)((((uint64_t)(x)-1) << uint63_of_value(uint63_lsl_y__)) | 1); \ else \ - accu = uint63_zero; \ + accu = uint63_zero(); \ }while(0) #define Uint63_lsr(x,y) do{ \ value uint63_lsl_y__ = (y); \ if (uint63_lsl_y__ < (uint64_t) 127) \ accu = (value)(((uint64_t)(x) >> uint63_of_value(uint63_lsl_y__)) | 1); \ else \ - accu = uint63_zero; \ + accu = uint63_zero(); \ + }while(0) +#define Uint63_asr(x,y) do{ \ + value uint63_asr_y__ = (y); \ + if (uint63_asr_y__ < (uint64_t) 127) \ + accu = (value)(((int64_t)(x) >> uint63_of_value(uint63_asr_y__)) | 1); \ + else \ + accu = uint63_zero(); \ }while(0) /* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index d3e2a2fa7f..b14ad5c558 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -1,7 +1,7 @@ (library (name byterun) (synopsis "Coq's Kernel Abstract Reduction Machine [C implementation]") - (public_name coq.vm) + (public_name coq-core.vm) (foreign_stubs (language c) (names coq_fix_code coq_float64 coq_memory coq_values coq_interp) @@ -14,3 +14,7 @@ (rule (targets coq_jumptbl.h) (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe jump)))) + +(rule + (targets coq_arity.h) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe arity)))) diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 5cd91b4e74..6ef0e9fa15 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -8,6 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* Note: don't forget to update v_primitive in checker/values.ml if the *) +(* number of primitives is changed. *) + open Univ type t = @@ -18,8 +21,11 @@ type t = | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -34,7 +40,10 @@ type t = | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq @@ -68,8 +77,11 @@ let parse = function | "int63_mul" -> Int63mul | "int63_div" -> Int63div | "int63_mod" -> Int63mod + | "int63_divs" -> Int63divs + | "int63_mods" -> Int63mods | "int63_lsr" -> Int63lsr | "int63_lsl" -> Int63lsl + | "int63_asr" -> Int63asr | "int63_land" -> Int63land | "int63_lor" -> Int63lor | "int63_lxor" -> Int63lxor @@ -84,7 +96,10 @@ let parse = function | "int63_eq" -> Int63eq | "int63_lt" -> Int63lt | "int63_le" -> Int63le + | "int63_lts" -> Int63lts + | "int63_les" -> Int63les | "int63_compare" -> Int63compare + | "int63_compares" -> Int63compares | "float64_opp" -> Float64opp | "float64_abs" -> Float64abs | "float64_eq" -> Float64eq @@ -163,6 +178,12 @@ let hash = function | Arrayset -> 46 | Arraycopy -> 47 | Arraylength -> 48 + | Int63lts -> 49 + | Int63les -> 50 + | Int63divs -> 51 + | Int63mods -> 52 + | Int63asr -> 53 + | Int63compares -> 54 (* Should match names in nativevalues.ml *) let to_string = function @@ -173,8 +194,11 @@ let to_string = function | Int63mul -> "mul" | Int63div -> "div" | Int63mod -> "rem" + | Int63divs -> "divs" + | Int63mods -> "rems" | Int63lsr -> "l_sr" | Int63lsl -> "l_sl" + | Int63asr -> "a_sr" | Int63land -> "l_and" | Int63lor -> "l_or" | Int63lxor -> "l_xor" @@ -189,7 +213,10 @@ let to_string = function | Int63eq -> "eq" | Int63lt -> "lt" | Int63le -> "le" + | Int63lts -> "lts" + | Int63les -> "les" | Int63compare -> "compare" + | Int63compares -> "compares" | Float64opp -> "fopp" | Float64abs -> "fabs" | Float64eq -> "feq" @@ -271,14 +298,15 @@ let types = | Int63head0 | Int63tail0 -> [int_ty; int_ty] | Int63add | Int63sub | Int63mul | Int63div | Int63mod - | Int63lsr | Int63lsl + | Int63divs | Int63mods + | Int63lsr | Int63lsl | Int63asr | Int63land | Int63lor | Int63lxor -> [int_ty; int_ty; int_ty] | Int63addc | Int63subc | Int63addCarryC | Int63subCarryC -> [int_ty; int_ty; PITT_ind (PIT_carry, int_ty)] | Int63mulc | Int63diveucl -> [int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] - | Int63eq | Int63lt | Int63le -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] - | Int63compare -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] + | Int63eq | Int63lt | Int63le | Int63lts | Int63les -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] + | Int63compare | Int63compares -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] | Int63div21 -> [int_ty; int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] | Int63addMulDiv -> [int_ty; int_ty; int_ty; int_ty] @@ -314,8 +342,11 @@ let params = function | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -330,7 +361,10 @@ let params = function | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq @@ -367,8 +401,11 @@ let univs = function | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -383,7 +420,10 @@ let univs = function | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index 0db643faf4..de90179726 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -16,8 +16,11 @@ type t = | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -32,7 +35,10 @@ type t = | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq diff --git a/kernel/dune b/kernel/dune index bd663974da..0bf51f80ec 100644 --- a/kernel/dune +++ b/kernel/dune @@ -1,7 +1,7 @@ (library (name kernel) (synopsis "The Coq Kernel") - (public_name coq.kernel) + (public_name coq-core.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_31 uint63_63 float64_31 float64_63)) (libraries lib byterun dynlink)) @@ -25,7 +25,7 @@ (action (copy# %{gen-file} %{targets}))) (documentation - (package coq)) + (package coq-core)) ; In dev profile, we check the kernel against a more strict set of ; warnings. diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index 0e1cd0c56a..20220dd9d2 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -10,192 +10,201 @@ (** List of opcodes. - It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and - [vmopcodes.ml] files. + It is used to generate the files [coq_instruct.h], [coq_jumptbl.h], + [coq_arity.h], and [vmopcodes.ml]. - If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c - with the arity of the instruction and maybe coq_tcode_of_code. + [STOP] needs to be the last opcode. + + Arity -1 designates opcodes that need special handling in [coq_fix_code.c]. *) let opcodes = [| - "ACC0"; - "ACC1"; - "ACC2"; - "ACC3"; - "ACC4"; - "ACC5"; - "ACC6"; - "ACC7"; - "ACC"; - "PUSH"; - "PUSHACC1"; - "PUSHACC2"; - "PUSHACC3"; - "PUSHACC4"; - "PUSHACC5"; - "PUSHACC6"; - "PUSHACC7"; - "PUSHACC"; - "POP"; - "ENVACC0"; - "ENVACC1"; - "ENVACC2"; - "ENVACC3"; - "ENVACC"; - "PUSHENVACC0"; - "PUSHENVACC1"; - "PUSHENVACC2"; - "PUSHENVACC3"; - "PUSHENVACC"; - "PUSH_RETADDR"; - "APPLY"; - "APPLY1"; - "APPLY2"; - "APPLY3"; - "APPLY4"; - "APPTERM"; - "APPTERM1"; - "APPTERM2"; - "APPTERM3"; - "RETURN"; - "RESTART"; - "GRAB"; - "GRABREC"; - "CLOSURE"; - "CLOSUREREC"; - "CLOSURECOFIX"; - "OFFSETCLOSURE0"; - "OFFSETCLOSURE1"; - "OFFSETCLOSURE"; - "PUSHOFFSETCLOSURE0"; - "PUSHOFFSETCLOSURE1"; - "PUSHOFFSETCLOSURE"; - "GETGLOBAL"; - "PUSHGETGLOBAL"; - "MAKEBLOCK"; - "MAKEBLOCK1"; - "MAKEBLOCK2"; - "MAKEBLOCK3"; - "MAKEBLOCK4"; - "SWITCH"; - "PUSHFIELDS"; - "GETFIELD0"; - "GETFIELD1"; - "GETFIELD"; - "SETFIELD"; - "PROJ"; - "ENSURESTACKCAPACITY"; - "CONST0"; - "CONST1"; - "CONST2"; - "CONST3"; - "CONSTINT"; - "PUSHCONST0"; - "PUSHCONST1"; - "PUSHCONST2"; - "PUSHCONST3"; - "PUSHCONSTINT"; - "ACCUMULATE"; - "MAKESWITCHBLOCK"; - "MAKEACCU"; - "BRANCH"; - "CHECKADDINT63"; - "CHECKADDCINT63"; - "CHECKADDCARRYCINT63"; - "CHECKSUBINT63"; - "CHECKSUBCINT63"; - "CHECKSUBCARRYCINT63"; - "CHECKMULINT63"; - "CHECKMULCINT63"; - "CHECKDIVINT63"; - "CHECKMODINT63"; - "CHECKDIVEUCLINT63"; - "CHECKDIV21INT63"; - "CHECKLXORINT63"; - "CHECKLORINT63"; - "CHECKLANDINT63"; - "CHECKLSLINT63"; - "CHECKLSRINT63"; - "CHECKADDMULDIVINT63"; - "CHECKEQINT63"; - "CHECKLTINT63"; - "CHECKLEINT63"; - "CHECKCOMPAREINT63"; - "CHECKHEAD0INT63"; - "CHECKTAIL0INT63"; - "CHECKOPPFLOAT"; - "CHECKABSFLOAT"; - "CHECKEQFLOAT"; - "CHECKLTFLOAT"; - "CHECKLEFLOAT"; - "CHECKCOMPAREFLOAT"; - "CHECKCLASSIFYFLOAT"; - "CHECKADDFLOAT"; - "CHECKSUBFLOAT"; - "CHECKMULFLOAT"; - "CHECKDIVFLOAT"; - "CHECKSQRTFLOAT"; - "CHECKFLOATOFINT63"; - "CHECKFLOATNORMFRMANTISSA"; - "CHECKFRSHIFTEXP"; - "CHECKLDSHIFTEXP"; - "CHECKNEXTUPFLOAT"; - "CHECKNEXTDOWNFLOAT"; - "CHECKNEXTUPFLOATINPLACE"; - "CHECKNEXTDOWNFLOATINPLACE"; - "CHECKCAMLCALL2_1"; - "CHECKCAMLCALL1"; - "CHECKCAMLCALL2"; - "CHECKCAMLCALL3_1"; - "STOP" + "ACC0", 0; + "ACC1", 0; + "ACC2", 0; + "ACC3", 0; + "ACC4", 0; + "ACC5", 0; + "ACC6", 0; + "ACC7", 0; + "ACC", 1; + "PUSH", 0; + "PUSHACC1", 0; + "PUSHACC2", 0; + "PUSHACC3", 0; + "PUSHACC4", 0; + "PUSHACC5", 0; + "PUSHACC6", 0; + "PUSHACC7", 0; + "PUSHACC", 1; + "POP", 1; + "ENVACC0", 0; + "ENVACC1", 0; + "ENVACC2", 0; + "ENVACC3", 0; + "ENVACC", 1; + "PUSHENVACC0", 0; + "PUSHENVACC1", 0; + "PUSHENVACC2", 0; + "PUSHENVACC3", 0; + "PUSHENVACC", 1; + "PUSH_RETADDR", 1; + "APPLY", 1; + "APPLY1", 0; + "APPLY2", 0; + "APPLY3", 0; + "APPLY4", 0; + "APPTERM", 2; + "APPTERM1", 1; + "APPTERM2", 1; + "APPTERM3", 1; + "RETURN", 1; + "RESTART", 0; + "GRAB", 1; + "GRABREC", 1; + "CLOSURE", 2; + "CLOSUREREC", -1; + "CLOSURECOFIX", -1; + "OFFSETCLOSURE0", 0; + "OFFSETCLOSURE1", 0; + "OFFSETCLOSURE", 1; + "PUSHOFFSETCLOSURE0", 0; + "PUSHOFFSETCLOSURE1", 0; + "PUSHOFFSETCLOSURE", 1; + "GETGLOBAL", 1; + "PUSHGETGLOBAL", 1; + "MAKEBLOCK", 2; + "MAKEBLOCK1", 1; + "MAKEBLOCK2", 1; + "MAKEBLOCK3", 1; + "MAKEBLOCK4", 1; + "SWITCH", -1; + "PUSHFIELDS", 1; + "GETFIELD0", 0; + "GETFIELD1", 0; + "GETFIELD", 1; + "SETFIELD", 1; + "PROJ", 2; + "ENSURESTACKCAPACITY", 1; + "CONST0", 0; + "CONST1", 0; + "CONST2", 0; + "CONST3", 0; + "CONSTINT", 1; + "PUSHCONST0", 0; + "PUSHCONST1", 0; + "PUSHCONST2", 0; + "PUSHCONST3", 0; + "PUSHCONSTINT", 1; + "ACCUMULATE", 0; + "MAKESWITCHBLOCK", 4; + "MAKEACCU", 1; + "BRANCH", 1; + "CHECKADDINT63", 1; + "CHECKADDCINT63", 1; + "CHECKADDCARRYCINT63", 1; + "CHECKSUBINT63", 1; + "CHECKSUBCINT63", 1; + "CHECKSUBCARRYCINT63", 1; + "CHECKMULINT63", 1; + "CHECKMULCINT63", 1; + "CHECKDIVINT63", 1; + "CHECKMODINT63", 1; + "CHECKDIVSINT63", 1; + "CHECKMODSINT63", 1; + "CHECKDIVEUCLINT63", 1; + "CHECKDIV21INT63", 1; + "CHECKLXORINT63", 1; + "CHECKLORINT63", 1; + "CHECKLANDINT63", 1; + "CHECKLSLINT63", 1; + "CHECKLSRINT63", 1; + "CHECKASRINT63", 1; + "CHECKADDMULDIVINT63", 1; + "CHECKEQINT63", 1; + "CHECKLTINT63", 1; + "CHECKLEINT63", 1; + "CHECKLTSINT63", 1; + "CHECKLESINT63", 1; + "CHECKCOMPAREINT63", 1; + "CHECKCOMPARESINT63", 1; + "CHECKHEAD0INT63", 1; + "CHECKTAIL0INT63", 1; + "CHECKOPPFLOAT", 1; + "CHECKABSFLOAT", 1; + "CHECKEQFLOAT", 1; + "CHECKLTFLOAT", 1; + "CHECKLEFLOAT", 1; + "CHECKCOMPAREFLOAT", 1; + "CHECKCLASSIFYFLOAT", 1; + "CHECKADDFLOAT", 1; + "CHECKSUBFLOAT", 1; + "CHECKMULFLOAT", 1; + "CHECKDIVFLOAT", 1; + "CHECKSQRTFLOAT", 1; + "CHECKFLOATOFINT63", 1; + "CHECKFLOATNORMFRMANTISSA", 1; + "CHECKFRSHIFTEXP", 1; + "CHECKLDSHIFTEXP", 1; + "CHECKNEXTUPFLOAT", 1; + "CHECKNEXTDOWNFLOAT", 1; + "CHECKNEXTUPFLOATINPLACE", 1; + "CHECKNEXTDOWNFLOATINPLACE", 1; + "CHECKCAMLCALL2_1", 2; + "CHECKCAMLCALL1", 2; + "CHECKCAMLCALL2", 2; + "CHECKCAMLCALL3_1", 2; + "STOP", 0 |] let pp_c_comment fmt = - Format.fprintf fmt "/* %a */" + Format.fprintf fmt "/* %s */" let pp_ocaml_comment fmt = - Format.fprintf fmt "(* %a *)" + Format.fprintf fmt "(* %s *)" let pp_header isOcaml fmt = Format.fprintf fmt "%a" - (fun fmt -> - (if isOcaml then pp_ocaml_comment else pp_c_comment) fmt - Format.pp_print_string) + (if isOcaml then pp_ocaml_comment else pp_c_comment) "DO NOT EDIT: automatically generated by kernel/genOpcodeFiles.ml" -let pp_with_commas fmt k = - Array.iteri (fun n s -> - Format.fprintf fmt " %a%s@." - k s - (if n + 1 < Array.length opcodes - then "," else "") - ) opcodes - let pp_coq_instruct_h fmt = - let line = Format.fprintf fmt "%s@." in pp_header false fmt; - line "#pragma once"; - line "enum instructions {"; - pp_with_commas fmt Format.pp_print_string; - line "};" + Format.fprintf fmt "#pragma once@.enum instructions {@."; + Array.iter (fun (name, _) -> + Format.fprintf fmt " %s,@." name + ) opcodes; + Format.fprintf fmt "};@." let pp_coq_jumptbl_h fmt = - pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") + pp_header false fmt; + Array.iter (fun (name, _) -> + Format.fprintf fmt " &&coq_lbl_%s,@." name + ) opcodes + +let pp_coq_arity_h fmt = + pp_header false fmt; + Format.fprintf fmt "static signed char arity[] = {@."; + Array.iter (fun (_, arity) -> + Format.fprintf fmt " %d,@." arity + ) opcodes; + Format.fprintf fmt "};@." let pp_vmopcodes_ml fmt = pp_header true fmt; Array.iteri (fun n s -> Format.fprintf fmt "let op%s = %d@.@." s n - ) opcodes + ) (Array.map fst opcodes) let usage () = - Format.eprintf "usage: %s [enum|jump|copml]@." Sys.argv.(0); + Format.eprintf "usage: %s [enum|jump|arity|copml]@." Sys.argv.(0); exit 1 let main () = match Sys.argv.(1) with | "enum" -> pp_coq_instruct_h Format.std_formatter | "jump" -> pp_coq_jumptbl_h Format.std_formatter + | "arity" -> pp_coq_arity_h Format.std_formatter | "copml" -> pp_vmopcodes_ml Format.std_formatter | _ -> usage () | exception Invalid_argument _ -> usage () diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index c19b883e3d..d517d215ed 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -24,6 +24,11 @@ open Environ compiler. mllambda represents a fragment of ML, and can easily be printed to OCaml code. *) +let debug_native_flag, debug_native_compiler = CDebug.create_full ~name:"native-compiler" () + +let keep_debug_files () = + CDebug.get_flag debug_native_flag + (** Local names **) (* The first component is there for debugging purposes only *) @@ -1939,7 +1944,7 @@ let compile_constant env sigma con cb = | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in - if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); + debug_native_compiler (fun () -> Pp.str "Generated lambda code"); let is_lazy = is_lazy t in let code = if is_lazy then mk_lazy code else code in let l = Constant.label con in @@ -1950,11 +1955,11 @@ let compile_constant env sigma con cb = let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in - if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); + debug_native_compiler (fun () -> Pp.str "Generated mllambda code"); let code = optimize_stk (Glet(Gconstant ("", con),code)::auxdefs) in - if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); + debug_native_compiler (fun () -> Pp.str "Optimized mllambda code"); code | _ -> let i = push_symbol (SymbConst con) in diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index aab6e1d4a0..90525a19b2 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -21,6 +21,10 @@ to OCaml code. *) type mllambda type global +val debug_native_compiler : CDebug.t + +val keep_debug_files : unit -> bool + val pp_global : Format.formatter -> global -> unit val mk_open : string -> global @@ -59,6 +63,8 @@ val empty_updates : code_location_updates val register_native_file : string -> unit +val is_loaded_native_file : string -> bool + val compile_constant_field : env -> string -> Constant.t -> global list -> 'a constant_body -> global list diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index d77ee759c6..f0ae5e2fbf 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Nativelib open Reduction open Util open Nativevalues @@ -151,22 +150,25 @@ let warn_no_native_compiler = strbrk " falling back to VM conversion test.") let native_conv_gen pb sigma env univs t1 t2 = - if not (typing_flags env).Declarations.enable_native_compiler then begin - warn_no_native_compiler (); - Vconv.vm_conv_gen pb env univs t1 t2 - end - else - let ml_filename, prefix = get_ml_filename () in + Nativelib.link_libraries (); + let ml_filename, prefix = Nativelib.get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in - let fn = compile ml_filename code ~profile:false in - if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); + let fn = Nativelib.compile ml_filename code ~profile:false in + debug_native_compiler (fun () -> Pp.str "Running test..."); let t0 = Sys.time () in - call_linker ~fatal:true ~prefix fn (Some upds); + let (rt1, rt2) = Nativelib.execute_library ~prefix fn upds in let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + debug_native_compiler (fun () -> Pp.str time_info); (* TODO change 0 when we can have de Bruijn *) - fst (conv_val env pb 0 !rt1 !rt2 univs) + fst (conv_val env pb 0 rt1 rt2 univs) + +let native_conv_gen pb sigma env univs t1 t2 = + if not (typing_flags env).Declarations.enable_native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else native_conv_gen pb sigma env univs t1 t2 (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 1e1085d5ff..73567e34cf 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -38,7 +38,7 @@ let ( / ) = Filename.concat let my_temp_dir = lazy (CUnix.mktemp_dir "Coq_native" "") let () = at_exit (fun () -> - if not !Flags.debug && Lazy.is_val my_temp_dir then + if not (keep_debug_files ()) && Lazy.is_val my_temp_dir then try let d = Lazy.force my_temp_dir in Array.iter (fun f -> Sys.remove (Filename.concat d f)) (Sys.readdir d); @@ -129,7 +129,7 @@ let call_compiler ?profile:(profile=false) ml_filename = ::"-w"::"a" ::include_dirs) @ ["-impl"; ml_filename] in - if !Flags.debug then Feedback.msg_debug (Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); + debug_native_compiler (fun () -> Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (Envars.ocamlfind ()) args in match res with @@ -142,7 +142,7 @@ let call_compiler ?profile:(profile=false) ml_filename = let compile fn code ~profile:profile = write_ml_code fn code; let r = call_compiler ~profile fn in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; + if (not (keep_debug_files ())) && Sys.file_exists fn then Sys.remove fn; r type native_library = Nativecode.global list * Nativevalues.symbols @@ -160,34 +160,43 @@ let compile_library (code, symb) fn = let fn = dirname / basename in write_ml_code fn ~header code; let _ = call_compiler fn in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn + if (not (keep_debug_files ())) && Sys.file_exists fn then Sys.remove fn -(* call_linker links dynamically the code for constants in environment or a *) -(* conversion test. *) -let call_linker ?(fatal=true) ~prefix f upds = +let execute_library ~prefix f upds = rt1 := dummy_value (); rt2 := dummy_value (); if not (Sys.file_exists f) then - begin - let msg = "Cannot find native compiler file " ^ f in - if fatal then CErrors.user_err Pp.(str msg) - else if !Flags.debug then Feedback.msg_debug (Pp.str msg) - end - else - (try - if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; - register_native_file prefix - with Dynlink.Error _ as exn -> - let exn = Exninfo.capture exn in - if fatal then Exninfo.iraise exn - else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); - match upds with Some upds -> update_locations upds | _ -> () - -let link_library ~prefix ~dirname ~basename = + CErrors.user_err Pp.(str "Cannot find native compiler file " ++ str f); + if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; + register_native_file prefix; + update_locations upds; + (!rt1, !rt2) + +let link_library dirname prefix = + let basename = Dynlink.adapt_filename (prefix ^ "cmo") in (* We try both [output_dir] and [.coq-native], unfortunately from [Require] we don't know if we are loading a library in the build dir or in the installed layout *) let install_location = dirname / dft_output_dir / basename in let build_location = dirname / !output_dir / basename in let f = if Sys.file_exists build_location then build_location else install_location in - call_linker ~fatal:false ~prefix f None + try + if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; + register_native_file prefix + with + | Dynlink.Error _ as exn -> + debug_native_compiler (fun () -> CErrors.iprint (Exninfo.capture exn)) + +let delayed_link = ref [] + +let link_libraries () = + let delayed = List.rev !delayed_link in + delayed_link := []; + List.iter (fun (dirname, libname) -> + let prefix = mod_uid_of_dirpath libname ^ "." in + if not (Nativecode.is_loaded_native_file prefix) then + link_library dirname prefix + ) delayed + +let enable_library dirname libname = + delayed_link := (dirname, libname) :: !delayed_link diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 0c0fe3acc9..ba04c28ab0 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -7,7 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Nativecode (** This file provides facilities to access OCaml compiler and dynamic linker, used by the native compiler. *) @@ -25,7 +24,7 @@ val get_ml_filename : unit -> string * string (** [compile file code ~profile] will compile native [code] to [file], and return the name of the object file; this name depends on whether are in byte mode or not; file is expected to be .ml file *) -val compile : string -> global list -> profile:bool -> string +val compile : string -> Nativecode.global list -> profile:bool -> string type native_library = Nativecode.global list * Nativevalues.symbols @@ -33,18 +32,19 @@ type native_library = Nativecode.global list * Nativevalues.symbols but will perform some extra tweaks to handle [code] as a Coq lib. *) val compile_library : native_library -> string -> unit -val call_linker - : ?fatal:bool - -> prefix:string - -> string - -> code_location_updates option - -> unit +(** [execute_library file upds] dynamically loads library [file], + updates the library locations [upds], and returns the values stored + in [rt1] and [rt2] *) +val execute_library : + prefix:string -> string -> Nativecode.code_location_updates -> + Nativevalues.t * Nativevalues.t -val link_library - : prefix:string - -> dirname:string - -> basename:string - -> unit +(** [enable_library] marks the given library for dynamic loading + the next time [link_libraries] is called. *) +val enable_library : string -> Names.DirPath.t -> unit +val link_libraries : unit -> unit + +(* used for communication with the loaded libraries *) val rt1 : Nativevalues.t ref val rt2 : Nativevalues.t ref diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index c95880dc36..2e27fe071e 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -28,35 +28,35 @@ and translate_field prefix mp env acc (l,x) = match x with | SFBconst cb -> let con = Constant.make2 mp l in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); compile_constant_field env prefix con acc cb | SFBmind mb -> - (if !Flags.debug then + (debug_native_compiler (fun () -> let id = mb.mind_packets.(0).mind_typename in let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); compile_mind_field mp l acc mb | SFBmodule md -> let mp = md.mod_mp in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); translate_mod prefix mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); translate_mod prefix mp env mdtyp.mod_type acc let dump_library mp dp env mod_expr = - if !Flags.debug then Feedback.msg_debug (Pp.str "Compiling library..."); + debug_native_compiler (fun () -> Pp.str "Compiling library..."); match mod_expr with | NoFunctor struc -> let env = add_structure mp struc empty_delta_resolver env in diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index bd6241ae67..c986cb473d 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -333,6 +333,22 @@ let rem accu x y = if is_int x && is_int y then no_check_rem x y else accu x y +let no_check_divs x y = + mk_uint (Uint63.divs (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let divs accu x y = + if is_int x && is_int y then no_check_divs x y + else accu x y + +let no_check_rems x y = + mk_uint (Uint63.rems (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let rems accu x y = + if is_int x && is_int y then no_check_rems x y + else accu x y + let no_check_l_sr x y = mk_uint (Uint63.l_sr (to_uint x) (to_uint y)) [@@ocaml.inline always] @@ -349,6 +365,14 @@ let l_sl accu x y = if is_int x && is_int y then no_check_l_sl x y else accu x y +let no_check_a_sr x y = + mk_uint (Uint63.a_sr (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let a_sr accu x y = + if is_int x && is_int y then no_check_a_sr x y + else accu x y + let no_check_l_and x y = mk_uint (Uint63.l_and (to_uint x) (to_uint y)) [@@ocaml.inline always] @@ -502,6 +526,22 @@ let le accu x y = if is_int x && is_int y then no_check_le x y else accu x y +let no_check_lts x y = + mk_bool (Uint63.lts (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let lts accu x y = + if is_int x && is_int y then no_check_lts x y + else accu x y + +let no_check_les x y = + mk_bool (Uint63.les (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let les accu x y = + if is_int x && is_int y then no_check_les x y + else accu x y + let no_check_compare x y = match Uint63.compare (to_uint x) (to_uint y) with | x when x < 0 -> (Obj.magic CmpLt:t) @@ -512,6 +552,16 @@ let compare accu x y = if is_int x && is_int y then no_check_compare x y else accu x y +let no_check_compares x y = + match Uint63.compares (to_uint x) (to_uint y) with + | x when x < 0 -> (Obj.magic CmpLt:t) + | 0 -> (Obj.magic CmpEq:t) + | _ -> (Obj.magic CmpGt:t) + +let compares accu x y = + if is_int x && is_int y then no_check_compares x y + else accu x y + let print x = Printf.fprintf stderr "%s" (Uint63.to_string (to_uint x)); flush stderr; diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index b9b75a9d7c..98cf4219a0 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -158,9 +158,12 @@ val sub : t -> t -> t -> t val mul : t -> t -> t -> t val div : t -> t -> t -> t val rem : t -> t -> t -> t +val divs : t -> t -> t -> t +val rems : t -> t -> t -> t val l_sr : t -> t -> t -> t val l_sl : t -> t -> t -> t +val a_sr : t -> t -> t -> t val l_and : t -> t -> t -> t val l_xor : t -> t -> t -> t val l_or : t -> t -> t -> t @@ -179,7 +182,10 @@ val addMulDiv : t -> t -> t -> t -> t val eq : t -> t -> t -> t val lt : t -> t -> t -> t val le : t -> t -> t -> t +val lts : t -> t -> t -> t +val les : t -> t -> t -> t val compare : t -> t -> t -> t +val compares : t -> t -> t -> t val print : t -> t @@ -205,12 +211,21 @@ val no_check_div : t -> t -> t val no_check_rem : t -> t -> t [@@ocaml.inline always] +val no_check_divs : t -> t -> t +[@@ocaml.inline always] + +val no_check_rems : t -> t -> t +[@@ocaml.inline always] + val no_check_l_sr : t -> t -> t [@@ocaml.inline always] val no_check_l_sl : t -> t -> t [@@ocaml.inline always] +val no_check_a_sr : t -> t -> t +[@@ocaml.inline always] + val no_check_l_and : t -> t -> t [@@ocaml.inline always] @@ -253,8 +268,16 @@ val no_check_lt : t -> t -> t val no_check_le : t -> t -> t [@@ocaml.inline always] +val no_check_lts : t -> t -> t +[@@ocaml.inline always] + +val no_check_les : t -> t -> t +[@@ocaml.inline always] + val no_check_compare : t -> t -> t +val no_check_compares : t -> t -> t + (** Support for machine floating point values *) val is_float : t -> bool diff --git a/kernel/primred.ml b/kernel/primred.ml index f0b4d6d362..23b7e13ab8 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -223,10 +223,16 @@ struct let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.div i1 i2) | Int63mod -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.rem i1 i2) + | Int63divs -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.divs i1 i2) + | Int63mods -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.rems i1 i2) | Int63lsr -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sr i1 i2) | Int63lsl -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sl i1 i2) + | Int63asr -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.a_sr i1 i2) | Int63land -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_and i1 i2) | Int63lor -> @@ -276,6 +282,12 @@ struct | Int63le -> let i1, i2 = get_int2 evd args in E.mkBool env (Uint63.le i1 i2) + | Int63lts -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.lts i1 i2) + | Int63les -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.les i1 i2) | Int63compare -> let i1, i2 = get_int2 evd args in begin match Uint63.compare i1 i2 with @@ -283,6 +295,13 @@ struct | 0 -> E.mkEq env | _ -> E.mkGt env end + | Int63compares -> + let i1, i2 = get_int2 evd args in + begin match Uint63.compares i1 i2 with + | x when x < 0 -> E.mkLt env + | 0 -> E.mkEq env + | _ -> E.mkGt env + end | Float64opp -> let f = get_float1 evd args in E.mkFloat env (Float64.opp f) | Float64abs -> diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 6b2519918a..ff8d1eefb7 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -48,6 +48,7 @@ val l_xor : t -> t -> t val l_or : t -> t -> t (* Arithmetic operations *) +val a_sr : t -> t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t @@ -56,6 +57,10 @@ val rem : t -> t -> t val diveucl : t -> t -> t * t + (* Signed arithmetic opeartions *) +val divs : t -> t -> t +val rems : t -> t -> t + (* Specific arithmetic operations *) val mulc : t -> t -> t * t val addmuldiv : t -> t -> t -> t @@ -71,6 +76,11 @@ val equal : t -> t -> bool val le : t -> t -> bool val compare : t -> t -> int + (* signed comparision *) +val lts : t -> t -> bool +val les : t -> t -> bool +val compares : t -> t -> int + (* head and tail *) val head0 : t -> t val tail0 : t -> t diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index 4f2cbc4262..9c8401105e 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -52,6 +52,15 @@ let lt x y = let le x y = Int64.compare x y <= 0 + (* signed comparison *) +(* We shift the arguments by 1 to the left so that the top-most bit is interpreted as a sign *) +(* The zero at the end doesn't change the order (it is stable by multiplication by 2) *) +let lts x y = + Int64.(compare (shift_left x 1) (shift_left y 1)) < 0 + +let les x y = + Int64.(compare (shift_left x 1) (shift_left y 1)) <= 0 + (* logical shift *) let l_sl x y = if le 0L y && lt y 63L then mask63 (Int64.shift_left x (Int64.to_int y)) else 0L @@ -59,6 +68,12 @@ let l_sl x y = let l_sr x y = if le 0L y && lt y 63L then Int64.shift_right x (Int64.to_int y) else 0L + (* arithmetic shift (for sint63) *) +let a_sr x y = + if les 0L y && lts y 63L then + mask63 (Int64.shift_right (Int64.shift_left x 1) ((Int64.to_int y) + 1)) + else 0L + let l_and x y = Int64.logand x y let l_or x y = Int64.logor x y let l_xor x y = Int64.logxor x y @@ -86,6 +101,15 @@ let rem x y = let diveucl x y = (div x y, rem x y) + (* signed division *) +let divs x y = + if y = 0L then 0L else mask63 Int64.(div (shift_left x 1) (shift_left y 1)) + + (* signed modulo *) +let rems x y = + if y = 0L then 0L else + Int64.shift_right_logical (Int64.(rem (shift_left x 1) (shift_left y 1))) 1 + let addmuldiv p x y = l_or (l_sl x p) (l_sr y Int64.(sub (of_int uint_size) p)) @@ -139,6 +163,8 @@ let equal (x : t) y = x = y let compare x y = Int64.compare x y +let compares x y = Int64.(compare (shift_left x 1) (shift_left y 1)) + (* Number of leading zeroes *) let head0 x = let r = ref 0 in @@ -198,22 +224,30 @@ let () = Callback.register "uint63 addcarry" addcarry; Callback.register "uint63 addmuldiv" addmuldiv; Callback.register "uint63 div" div; + Callback.register "uint63 divs" divs; Callback.register "uint63 div21_ml" div21; Callback.register "uint63 eq" equal; Callback.register "uint63 eq0" (equal Int64.zero); + Callback.register "uint63 eqm1" (equal (sub zero one)); Callback.register "uint63 head0" head0; Callback.register "uint63 land" l_and; Callback.register "uint63 leq" le; + Callback.register "uint63 les" les; Callback.register "uint63 lor" l_or; Callback.register "uint63 lsl" l_sl; Callback.register "uint63 lsr" l_sr; + Callback.register "uint63 asr" a_sr; Callback.register "uint63 lt" lt; + Callback.register "uint63 lts" lts; Callback.register "uint63 lxor" l_xor; Callback.register "uint63 mod" rem; + Callback.register "uint63 mods" rems; Callback.register "uint63 mul" mul; Callback.register "uint63 mulc_ml" mulc; + Callback.register "uint63 zero" zero; Callback.register "uint63 one" one; Callback.register "uint63 sub" sub; + Callback.register "uint63 neg" (sub zero); Callback.register "uint63 subcarry" subcarry; Callback.register "uint63 tail0" tail0; Callback.register "uint63 of_float" of_float; diff --git a/kernel/uint63_63.ml b/kernel/uint63_63.ml index 8d052d6593..d017dafd3c 100644 --- a/kernel/uint63_63.ml +++ b/kernel/uint63_63.ml @@ -53,6 +53,10 @@ let l_sl x y = let l_sr x y = if 0 <= y && y < 63 then x lsr y else 0 + (* arithmetic shift (for sint63) *) +let a_sr x y = + if 0 <= y && y < 63 then x asr y else 0 + let l_and x y = x land y [@@ocaml.inline always] @@ -84,6 +88,14 @@ let rem (x : int) (y : int) = let diveucl x y = (div x y, rem x y) + (* signed division *) +let divs (x : int) (y : int) = + if y = 0 then 0 else x / y + + (* modulo *) +let rems (x : int) (y : int) = + if y = 0 then 0 else x mod y + let addmuldiv p x y = l_or (l_sl x p) (l_sr y (uint_size - p)) @@ -96,6 +108,15 @@ let le (x : int) (y : int) = (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) [@@ocaml.inline always] + (* signed comparison *) +let lts (x : int) (y : int) = + x < y +[@@ocaml.inline always] + +let les (x : int) (y : int) = + x <= y +[@@ocaml.inline always] + let to_int_min n m = if lt n m then n else m [@@ocaml.inline always] @@ -175,9 +196,10 @@ let equal (x : int) (y : int) = x = y let compare (x:int) (y:int) = let x = x lxor 0x4000000000000000 in let y = y lxor 0x4000000000000000 in - if x > y then 1 - else if y > x then -1 - else 0 + Int.compare x y + +let compares (x : int) (y : int) = + Int.compare x y (* head tail *) diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index d3af8bf09b..caa263432e 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -226,8 +226,11 @@ let check_prim_op = function | Int63mul -> opCHECKMULINT63 | Int63div -> opCHECKDIVINT63 | Int63mod -> opCHECKMODINT63 + | Int63divs -> opCHECKDIVSINT63 + | Int63mods -> opCHECKMODSINT63 | Int63lsr -> opCHECKLSRINT63 | Int63lsl -> opCHECKLSLINT63 + | Int63asr -> opCHECKASRINT63 | Int63land -> opCHECKLANDINT63 | Int63lor -> opCHECKLORINT63 | Int63lxor -> opCHECKLXORINT63 @@ -242,7 +245,10 @@ let check_prim_op = function | Int63eq -> opCHECKEQINT63 | Int63lt -> opCHECKLTINT63 | Int63le -> opCHECKLEINT63 + | Int63lts -> opCHECKLTSINT63 + | Int63les -> opCHECKLESINT63 | Int63compare -> opCHECKCOMPAREINT63 + | Int63compares -> opCHECKCOMPARESINT63 | Float64opp -> opCHECKOPPFLOAT | Float64abs -> opCHECKABSFLOAT | Float64eq -> opCHECKEQFLOAT diff --git a/lib/cDebug.ml b/lib/cDebug.ml new file mode 100644 index 0000000000..efa7365b91 --- /dev/null +++ b/lib/cDebug.ml @@ -0,0 +1,92 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type flag = bool ref + +type t = (unit -> Pp.t) -> unit + +let debug = ref CString.Map.empty + +(* Used to remember level of Set Debug "all" for debugs created by + plugins dynlinked after the Set *) +let all_flag = ref false + +let set_debug_backtrace b = + Exninfo.record_backtrace b + +let set_debug_all b = + set_debug_backtrace b; + CString.Map.iter (fun _ flag -> flag := b) !debug; + all_flag := b + +let create_full ~name () = + let anomaly pp = CErrors.anomaly ~label:"CDebug.create" pp in + let () = match name with + | "all"|"backtrace" -> anomaly Pp.(str"The debug name \""++str name++str"\" is reserved.") + | _ -> + if CString.Map.mem name !debug then + anomaly Pp.(str "The debug name \"" ++ str name ++ str "\" is already used.") + in + let pp x = + Feedback.msg_debug Pp.(str "[" ++ str name ++ str "] " ++ x) + in + let flag = ref !all_flag in + debug := CString.Map.add name flag !debug; + let pp x = + if !flag + then pp (x ()) + in + flag, pp + +let create ~name () = + snd (create_full ~name ()) + +let get_flag flag = !flag + +let warn_unknown_debug = CWarnings.create ~name:"unknown-debug-flag" ~category:"option" + Pp.(fun name -> str "There is no debug flag \"" ++ str name ++ str "\".") + +let get_flags () = + let pp_flag name flag = if flag then name else "-"^name in + let flags = + CString.Map.fold + (fun name v acc -> pp_flag name !v :: acc) + !debug [] + in + let all = pp_flag "all" !all_flag in + let bt = pp_flag "backtrace" (Printexc.backtrace_status()) in + String.concat "," (all::bt::flags) + +exception Error + +let parse_flags s = + let parse_flag s = + if CString.is_empty s then raise Error + else if s.[0] = '-' + then String.sub s 1 (String.length s - 1), false + else s, true + in + try + Some (CList.map parse_flag @@ String.split_on_char ',' s) + with Error -> None + +let set_flags s = match parse_flags s with + | None -> CErrors.user_err Pp.(str "Syntax error in debug flags.") + | Some flags -> + let set_one_flag (name,b) = match name with + | "all" -> set_debug_all b + | "backtrace" -> set_debug_backtrace b + | _ -> match CString.Map.find_opt name !debug with + | None -> warn_unknown_debug name + | Some flag -> flag := b + in + List.iter set_one_flag flags + +let misc, pp_misc = create_full ~name:"misc" () diff --git a/lib/cDebug.mli b/lib/cDebug.mli new file mode 100644 index 0000000000..846c4b493b --- /dev/null +++ b/lib/cDebug.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type flag + +type t = (unit -> Pp.t) -> unit + +(** Creates a debug component, which may be used to print debug + messages. + + A debug component is named by the string [name]. It is either + active or inactive. + + The special component ["all"] may be used to control all components. + + There is also a special component ["backtrace"] to control + backtrace recording. +*) +val create : name:string -> unit -> t + +(** Useful when interacting with a component from code, typically when + doing something more complicated than printing. + + Note that the printer function prints some metadata compared to + [ fun pp -> if get_flag flag then Feedback.msg_debug (pp ()) ] + *) +val create_full : name:string -> unit -> flag * t + +val get_flag : flag -> bool + +(** [get_flags] and [set_flags] use the user syntax: a comma separated + list of activated "component" and "-component"s. [get_flags] starts + with "all" or "-all" and lists all components after it (even if redundant). *) +val get_flags : unit -> string + +(** Components not mentioned are not affected (use the "all" component + at the start if you want to reset everything). *) +val set_flags : string -> unit + +val set_debug_all : bool -> unit + +val misc : flag +val pp_misc : t diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 760c07783b..1baedb64c9 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -30,6 +30,7 @@ let anomaly ?loc ?info ?label pp = let info = Option.cata (Loc.add_loc info) info loc in Exninfo.iraise (Anomaly (label, pp), info) +(* TODO remove the option *) exception UserError of string option * Pp.t (* User errors *) let user_err ?loc ?info ?hdr strm = @@ -46,7 +47,7 @@ exception Timeout = Control.Timeout let where = function | None -> mt () | Some s -> - if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () + str "in " ++ str s ++ str ":" ++ spc () let raw_anomaly e = match e with | Anomaly (s, pps) -> @@ -133,7 +134,7 @@ let print_no_report e = iprint_no_report (e, Exninfo.info e) let _ = register_handler begin function | UserError(s, pps) -> - Some (where s ++ pps) + Some pps | _ -> None end diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index cc1fa647f9..ee7dab92bc 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -173,3 +173,9 @@ let create ~name ~category ?(default=Enabled) pp = | Disabled -> () | AsError -> CErrors.user_err ?loc (pp x) | Enabled -> Feedback.msg_warning ?loc (pp x) + +(* Remark: [warn] does not need to start with a comma, but if present + it won't hurt (",," is normalized into ","). *) +let with_warn warn (f:'b -> 'a) x = + let s = get_flags () in + Util.try_finally (fun x -> set_flags (s^","^warn);f x) x set_flags s diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index ded1f9be3b..b63eed09d0 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -19,3 +19,10 @@ val set_flags : string -> unit (** Cleans up a user provided warnings status string, e.g. removing unknown warnings (in which case a warning is emitted) or subsumed warnings . *) val normalize_flags_string : string -> string + +(** [with_warn "-xxx,+yyy..." f x] calls [f x] after setting the + warnings as specified in the string (keeping other previously set + warnings), and restores current warnings after [f()] returns or + raises an exception. If both f and restoring the warnings raise + exceptions, the latter is raised. *) +val with_warn: string -> ('b -> 'a) -> 'b -> 'a @@ -1,7 +1,7 @@ (library (name lib) (synopsis "Coq's Utility Library [coq-specific]") - (public_name coq.lib) + (public_name coq-core.lib) (wrapped false) (modules_without_implementation xml_datatype) - (libraries coq.clib coq.config)) + (libraries coq-core.clib coq-core.config)) diff --git a/lib/envars.ml b/lib/envars.ml index 1702b5d7a2..823d255f58 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -132,7 +132,9 @@ let guess_coqlib fail = if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / prelude) then Coq_config.coqlib else - fail "cannot guess a path for Coq libraries; please use -coqlib option") + fail "cannot guess a path for Coq libraries; please use -coqlib option \ + or ensure you have installed the package contaning Coq's stdlib (coq-stdlib in OPAM) \ + If you intend to use Coq without a standard library, the -boot -noinit options must be used.") ) let coqlib : string option ref = ref None @@ -205,6 +207,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = let open Printf in fprintf f "%sLOCAL=%s\n" prefix_var_name (if Coq_config.local then "1" else "0"); fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); + fprintf f "%sCOQCORELIB=%s/\n" prefix_var_name (if Coq_config.local then coqlib () else coqlib () / "../coq-core/"); fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; diff --git a/lib/flags.ml b/lib/flags.ml index 83733cf00d..57e879add7 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -46,7 +46,6 @@ let async_proofs_is_worker () = !async_proofs_worker_id <> "master" let load_vos_libraries = ref false -let debug = ref false let xml_debug = ref false let in_debugger = ref false diff --git a/lib/flags.mli b/lib/flags.mli index ebd23a4d20..e10e2c8cb8 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -40,7 +40,6 @@ val async_proofs_is_worker : unit -> bool val load_vos_libraries : bool ref (** Debug flags *) -val debug : bool ref val xml_debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref diff --git a/lib/lib.mllib b/lib/lib.mllib index 4e08e87084..bbc9966498 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -10,6 +10,7 @@ Loc Feedback CErrors CWarnings +CDebug AcyclicGraph Rtree diff --git a/lib/pp.mli b/lib/pp.mli index 12f1ba9bb2..b3c2301d34 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -10,30 +10,31 @@ (** Coq document type. *) -(** Pretty printing guidelines ******************************************) -(* *) -(* `Pp.t` is the main pretty printing document type *) -(* in the Coq system. Documents are composed laying out boxes, and *) -(* users can add arbitrary tag metadata that backends are free *) -(* to interpret. *) -(* *) -(* The datatype has a public view to allow serialization or advanced *) -(* uses, however regular users are _strongly_ warned against its use, *) -(* they should instead rely on the available functions below. *) -(* *) -(* Box order and number is indeed an important factor. Try to create *) -(* a proper amount of boxes. The `++` operator provides "efficient" *) -(* concatenation, but using the list constructors is usually preferred. *) -(* *) -(* That is to say, this: *) -(* *) -(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) -(* *) -(* is preferred to: *) -(* *) -(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) -(* *) -(************************************************************************) +(** +{4 Pretty printing guidelines} + +[Pp.t] is the main pretty printing document type +in the Coq system. Documents are composed laying out boxes, and +users can add arbitrary tag metadata that backends are free +to interpret. + +The datatype has a public view to allow serialization or advanced +uses, however regular users are _strongly_ warned against its use, +they should instead rely on the available functions below. + +Box order and number is indeed an important factor. Try to create +a proper amount of boxes. The [++] operator provides "efficient" +concatenation, but using the list constructors is usually preferred. + +That is to say, this: + +[hov [str "Term"; hov (pr_term t); str "is defined"]] + +is preferred to: + +[hov (str "Term" ++ hov (pr_term t) ++ str "is defined")] +*) + (* XXX: Improve and add attributes *) type pp_tag = string diff --git a/lib/spawn.ml b/lib/spawn.ml index 2fe7b31d04..27b4387b61 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -13,7 +13,7 @@ let prefer_sock = Sys.os_type = "Win32" let accept_timeout = 10.0 let pr_err s = Printf.eprintf "(Spawn ,%d) %s\n%!" (Unix.getpid ()) s -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if CDebug.(get_flag misc) then begin pr_err s end else () type req = ReqDie | Hello of int * int diff --git a/lib/stateid.ml b/lib/stateid.ml index a1328f156c..2a41cb7866 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -45,3 +45,6 @@ type ('a,'b) request = { name : string } +let is_valid_ref = ref (fun ~doc:_ (_ : t) -> true) +let is_valid ~doc id = !is_valid_ref ~doc id +let set_is_valid f = is_valid_ref := f diff --git a/lib/stateid.mli b/lib/stateid.mli index 9b2de9c894..00acc962a2 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -42,3 +42,10 @@ type ('a,'b) request = { name : string } +(* Asks the document manager if the given state is valid (or belongs to an + old version of the document) *) +val is_valid : doc:int -> t -> bool + +(* By default [is_valid] always answers true, but a document manager supporting + undo operations like the STM can override this. *) +val set_is_valid : (doc:int -> t -> bool) -> unit diff --git a/lib/util.ml b/lib/util.ml index 87cc30e557..e8aa0f3e48 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -135,6 +135,13 @@ type 'a delayed = unit -> 'a let delayed_force f = f () +(* finalize - Credit X.Leroy, D.Remy. *) +let try_finally f x finally y = + let res = try f x with exn -> finally y; raise exn in + finally y; + res + + (* Misc *) type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b diff --git a/lib/util.mli b/lib/util.mli index fe34525671..aefb015c38 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -112,6 +112,15 @@ type 'a delayed = unit -> 'a val delayed_force : 'a delayed -> 'a +(** [try_finally f x g y] applies the main code [f] to [x] and + returns the result after having applied the finalization + code [g] to [y]. If the main code raises the exception + [exn], the finalization code is executed and [exn] is raised. + If the finalization code itself fails, the exception + returned is always the one from the finalization code. + Credit X.Leroy, D.Remy. *) +val try_finally: ('a -> 'b) -> 'a -> ('c -> unit) -> 'c -> 'b + (** {6 Enriched exceptions} *) type iexn = Exninfo.iexn diff --git a/library/dune b/library/dune index 344fad5a75..bf90511ead 100644 --- a/library/dune +++ b/library/dune @@ -1,9 +1,9 @@ (library (name library) (synopsis "Coq's Loadable Libraries (vo) Support") - (public_name coq.library) + (public_name coq-core.library) (wrapped false) (libraries kernel)) (documentation - (package coq)) + (package coq-core)) diff --git a/library/nametab.ml b/library/nametab.ml index e94b696b60..bd96446f1c 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -574,7 +574,7 @@ let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as exn -> let exn, info = Exninfo.capture exn in - if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); + if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str "pr_global_env not found"); Exninfo.iraise (exn, info) let global_inductive qid = diff --git a/library/summary.ml b/library/summary.ml index 221ac868fa..572467ada3 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -131,28 +131,27 @@ let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x module Local = struct -type 'a local_ref = ('a CEphemeron.key * 'a Dyn.tag) ref +type 'a local_ref = 'a CEphemeron.key ref * 'a CEphemeron.key Dyn.tag -let set r v = r := (CEphemeron.create v, snd !r) +let set (r, tag) v = r := CEphemeron.create v -let get r = - let key, name = !r in - try CEphemeron.get key +let get (key, name) = + try CEphemeron.get !key with CEphemeron.InvalidKey -> let { init_function } = DynMap.find name !sum_map in init_function (); - CEphemeron.get (fst !r) + CEphemeron.get !key -let ref ?(freeze=fun x -> x) ~name init = +let ref (type a) ~name (init : a) : a local_ref = let () = check_name (mangle name) in - let tag : 'a Dyn.tag = Dyn.create (mangle name) in - let r = pervasives_ref (CEphemeron.create init, tag) in + let tag : a CEphemeron.key Dyn.tag = Dyn.create (mangle name) in + let r = pervasives_ref (CEphemeron.create init) in let () = sum_map := DynMap.add tag - { freeze_function = (fun ~marshallable -> freeze (get r)); - unfreeze_function = (set r); - init_function = (fun () -> set r init) } !sum_map + { freeze_function = (fun ~marshallable -> !r); + unfreeze_function = (fun v -> r := v); + init_function = (fun () -> r := CEphemeron.create init) } !sum_map in - r + (r, tag) let (!) = get let (:=) = set diff --git a/library/summary.mli b/library/summary.mli index 7c5e1bee6f..a6f94a49ae 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -53,7 +53,7 @@ val ref_tag : ?freeze:(marshallable:bool -> 'a -> 'a) -> name:string -> 'a -> 'a module Local : sig type 'a local_ref - val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref + val ref : name:string -> 'a -> 'a local_ref val (:=) : 'a local_ref -> 'a -> unit val (!) : 'a local_ref -> 'a @@ -1,6 +1,6 @@ (install (section man) - (package coq) + (package coq-core) (files coqc.1 coqtop.1 coqtop.byte.1 coqtop.opt.1 coqchk.1 coqdep.1 coqdoc.1 coq_makefile.1 coq-tex.1 coqwc.1)) (install diff --git a/parsing/dune b/parsing/dune index 8a31434101..17011d10de 100644 --- a/parsing/dune +++ b/parsing/dune @@ -1,7 +1,7 @@ (library (name parsing) - (public_name coq.parsing) + (public_name coq-core.parsing) (wrapped false) - (libraries coq.gramlib interp)) + (libraries coq-core.gramlib interp)) (coq.pp (modules g_prim g_constr)) diff --git a/plugins/btauto/dune b/plugins/btauto/dune index d2f5b65980..f7b3477460 100644 --- a/plugins/btauto/dune +++ b/plugins/btauto/dune @@ -1,7 +1,7 @@ (library (name btauto_plugin) - (public_name coq.plugins.btauto) + (public_name coq-core.plugins.btauto) (synopsis "Coq's btauto plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_btauto)) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 129b220680..6617f4726e 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -19,20 +19,12 @@ open Sorts open Constr open Context open Vars -open Goptions open Tacmach open Util let init_size=5 -let cc_verbose= - declare_bool_option_and_ref - ~depr:false - ~key:["Congruence";"Verbose"] - ~value:false - -let debug x = - if cc_verbose () then Feedback.msg_debug (x ()) +let debug_congruence = CDebug.create ~name:"congruence" () (* Signature table *) @@ -576,7 +568,7 @@ let add_inst state (inst,int_subst) = Control.check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then - debug (fun () -> str "discarding redundant (dis)equality") + debug_congruence (fun () -> str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; @@ -591,7 +583,7 @@ let add_inst state (inst,int_subst) = state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); @@ -599,7 +591,7 @@ let add_inst state (inst,int_subst) = end else begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); @@ -630,7 +622,7 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ + debug_congruence (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in @@ -670,7 +662,7 @@ let union state i1 i2 eq= | _,_ -> () let merge eq state = (* merge and no-merge *) - debug + debug_congruence (fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++ str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str "."); let uf=state.uf in @@ -683,7 +675,7 @@ let merge eq state = (* merge and no-merge *) union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug + debug_congruence (fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in @@ -745,7 +737,7 @@ let process_constructor_mark t i rep pac state = end let process_mark t m state = - debug + debug_congruence (fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in @@ -766,7 +758,7 @@ let check_disequalities state = if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis) else (str "No", check_aux q) in - let _ = debug + let _ = debug_congruence (fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++ pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in ans @@ -953,7 +945,7 @@ let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = - debug (fun () -> str "Running E-matching algorithm ... "); + debug_congruence (fun () -> str "Running E-matching algorithm ... "); try while true do Control.check_for_interrupt (); @@ -964,7 +956,7 @@ let find_instances state = !res let rec execute first_run state = - debug (fun () -> str "Executing ... "); + debug_congruence (fun () -> str "Executing ... "); try while Control.check_for_interrupt (); @@ -974,7 +966,7 @@ let rec execute first_run state = None -> if not(Int.Set.is_empty state.pa_classes) then begin - debug (fun () -> str "First run was incomplete, completing ... "); + debug_congruence (fun () -> str "First run was incomplete, completing ... "); complete state; execute false state end @@ -989,12 +981,12 @@ let rec execute first_run state = end else begin - debug (fun () -> str "Out of instances ... "); + debug_congruence (fun () -> str "Out of instances ... "); None end else begin - debug (fun () -> str "Out of depth ... "); + debug_congruence (fun () -> str "Out of depth ... "); None end | Some dis -> Some diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3270f74479..047756deef 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -121,7 +121,7 @@ val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : (unit -> Pp.t) -> unit +val debug_congruence : CDebug.t val forest : state -> forest diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 53d8c5bdd9..e7e0822916 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -95,13 +95,13 @@ let pinject p c n a = p_rule=Inject(p,c,n,a)} let rec equal_proof env sigma uf i j= - debug (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) and edge_proof env sigma uf ((i,j),eq)= - debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let pi=equal_proof env sigma uf i eq.lhs in let pj=psym (equal_proof env sigma uf j eq.rhs) in let pij= @@ -117,7 +117,7 @@ and edge_proof env sigma uf ((i,j),eq)= ptrans (ptrans pi pij) pj and constr_proof env sigma uf i ipac= - debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); + debug_congruence (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in let eq_it=equal_proof env sigma uf i t in if ipac.args=[] then @@ -130,20 +130,20 @@ and constr_proof env sigma uf i ipac= ptrans eq_it (pcongr p (prefl targ)) and path_proof env sigma uf i l= - debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ + debug_congruence (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) and congr_proof env sigma uf i j= - debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) and ind_proof env sigma uf i ipac j jpac= - debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let p=equal_proof env sigma uf i j and p1=constr_proof env sigma uf i ipac and p2=constr_proof env sigma uf j jpac in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 72f77508d8..341fde7b77 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,16 +420,16 @@ let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.(check_required_library logic_module_name); - let _ = debug (fun () -> Pp.str "Reading goal ...") in + let _ = debug_congruence (fun () -> Pp.str "Reading goal ...") in let state = make_prb gl depth additionnal_terms in - let _ = debug (fun () -> Pp.str "Problem built, solving ...") in + let _ = debug_congruence (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in - let _ = debug (fun () -> Pp.str "Computation completed.") in + let _ = debug_congruence (fun () -> Pp.str "Computation completed.") in let uf=forest state in match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); + debug_congruence (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in diff --git a/plugins/cc/dune b/plugins/cc/dune index f7fa3adb56..ee28148c5a 100644 --- a/plugins/cc/dune +++ b/plugins/cc/dune @@ -1,7 +1,7 @@ (library (name cc_plugin) - (public_name coq.plugins.cc) + (public_name coq-core.plugins.cc) (synopsis "Coq's congruence closure plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_congruence)) diff --git a/plugins/derive/dune b/plugins/derive/dune index 1931339471..d382031a58 100644 --- a/plugins/derive/dune +++ b/plugins/derive/dune @@ -1,7 +1,7 @@ (library (name derive_plugin) - (public_name coq.plugins.derive) + (public_name coq-core.plugins.derive) (synopsis "Coq's derive plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_derive)) diff --git a/plugins/extraction/dune b/plugins/extraction/dune index d9d675fe6a..7f2582f84e 100644 --- a/plugins/extraction/dune +++ b/plugins/extraction/dune @@ -1,7 +1,7 @@ (library (name extraction_plugin) - (public_name coq.plugins.extraction) + (public_name coq-core.plugins.extraction) (synopsis "Coq's extraction plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_extraction)) diff --git a/plugins/firstorder/dune b/plugins/firstorder/dune index 1b05452d8f..0299ca802f 100644 --- a/plugins/firstorder/dune +++ b/plugins/firstorder/dune @@ -1,7 +1,7 @@ (library (name ground_plugin) - (public_name coq.plugins.firstorder) + (public_name coq-core.plugins.firstorder) (synopsis "Coq's first order logic solver plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ground)) diff --git a/plugins/funind/dune b/plugins/funind/dune index e594ffbd02..42377f37f4 100644 --- a/plugins/funind/dune +++ b/plugins/funind/dune @@ -1,7 +1,7 @@ (library (name recdef_plugin) - (public_name coq.plugins.funind) + (public_name coq-core.plugins.funind) (synopsis "Coq's functional induction plugin") - (libraries coq.plugins.extraction)) + (libraries coq-core.plugins.extraction)) (coq.pp (modules g_indfun)) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index ca6ae150a7..15cf88f827 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -195,16 +195,29 @@ let is_interactive recsl = } +(* For usability we temporarily switch off some flags during the call + to Function. However this is not satisfactory: + + 1- Function should not warn "non-recursive" and call the Definition + mechanism instead of Fixpoint when needed + + 2- Only for automatically generated names should + unused-pattern-matching-variable be ignored. *) + VERNAC COMMAND EXTEND Function STATE CUSTOM | ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { - if is_interactive recsl then - Vernacextend.VtOpenProof (fun () -> - Gen_principle.do_generate_principle_interactive (List.map snd recsl)) - else - Vernacextend.VtDefault (fun () -> - Gen_principle.do_generate_principle (List.map snd recsl)) } + let warn = "-unused-pattern-matching-variable,-matching-variable,-non-recursive" in + if is_interactive recsl then + Vernacextend.VtOpenProof (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle_interactive (List.map snd recsl)) + else + Vernacextend.VtDefault (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle (List.map snd recsl)) + } END { diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index e39c066c95..b20c4d173d 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -259,13 +259,6 @@ TACTIC EXTEND simple_destruct | [ "simple" "destruct" quantified_hypothesis(h) ] -> { simple_destruct h } END -(** Double induction *) - -TACTIC EXTEND double_induction DEPRECATED { Deprecation.make () } -| [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> - { Elim.h_double_induction h1 h2 } -END - (* Admit *) TACTIC EXTEND admit diff --git a/plugins/ltac/dune b/plugins/ltac/dune index 6558ecbfe8..9ec2b10873 100644 --- a/plugins/ltac/dune +++ b/plugins/ltac/dune @@ -1,15 +1,15 @@ (library (name ltac_plugin) - (public_name coq.plugins.ltac) + (public_name coq-core.plugins.ltac) (synopsis "Coq's LTAC tactic language") (modules :standard \ tauto) - (libraries coq.stm)) + (libraries coq-core.stm)) (library (name tauto_plugin) - (public_name coq.plugins.tauto) + (public_name coq-core.plugins.tauto) (synopsis "Coq's tauto tactic") (modules tauto) - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules extratactics g_tactic g_rewrite g_eqdecide g_auto g_obligations g_ltac profile_ltac_tactics coretactics g_class extraargs)) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 069a342b2a..82b41e41bd 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -11,7 +11,6 @@ { open Pp -open Constr open Stdarg open Pcoq.Prim open Pcoq.Constr @@ -199,20 +198,6 @@ TACTIC EXTEND unify END { -let deprecated_convert_concl_no_check = - CWarnings.create - ~name:"convert_concl_no_check" ~category:"deprecated" - (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") -} - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { - deprecated_convert_concl_no_check (); - Tactics.convert_concl ~check:false x DEFAULTcast - } -END - -{ let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 6bf330c830..e7902d06eb 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -151,13 +151,13 @@ VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY STATE read_program -| [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } -| [ "Obligations" ] -> { show_obligations None } +| [ "Obligations" "of" ident(name) ] -> { fun ~stack:_ -> show_obligations (Some name) } +| [ "Obligations" ] -> { fun ~stack:_ -> show_obligations None } END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY STATE read_program -| [ "Preterm" "of" ident(name) ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } -| [ "Preterm" ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm None) } +| [ "Preterm" "of" ident(name) ] -> { fun ~stack:_ ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } +| [ "Preterm" ] -> { fun ~stack:_ ~pm -> Feedback.msg_notice (show_term ~pm None) } END { diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index aa2449d962..937d579012 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -436,11 +436,7 @@ let finish_timing ~prefix name = (* ******************** *) let print_results_filter ~cutoff ~filter = - (* The STM doesn't provide yet a proper document query and traversal - API, thus we need to re-check if some states are current anymore - (due to backtracking) using the `state_of_id` API. *) - let valid (did,id) _ = Stm.(state_of_id ~doc:(get_doc did) id) <> `Expired in - data := SM.filter valid !data; + data := SM.filter (fun (doc,id) _ -> Stateid.is_valid ~doc id) !data; let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 74d5374193..53aa619d10 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -28,7 +28,7 @@ open Q.Notations open Mutils let use_simplex = - Goptions.declare_bool_option_and_ref ~depr:false ~key:["Simplex"] ~value:true + Goptions.declare_bool_option_and_ref ~depr:true ~key:["Simplex"] ~value:true (* If set to some [file], arithmetic goals are dumped in [file].v *) @@ -223,6 +223,28 @@ let find_point l = let optimise v l = if use_simplex () then Simplex.optimise v l else Mfourier.Fourier.optimise v l +let output_cstr_sys o sys = + List.iter + (fun (c, wp) -> + Printf.fprintf o "%a by %a\n" output_cstr c ProofFormat.output_prf_rule wp) + sys + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let tr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_sys sys output_sys sys'; + sys' + +let tr_cstr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_cstr_sys sys + output_cstr_sys sys'; + sys' + let dual_raw_certificate l = if debug then begin Printf.printf "dual_raw_certificate\n"; @@ -375,25 +397,7 @@ let elim_simple_linear_equality sys0 = in iterate_until_stable elim sys0 -let output_sys o sys = - List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys - -let subst sys = - let sys' = WithProof.subst sys in - if debug then - Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys - sys'; - sys' - -let tr_sys str f sys = - let sys' = f sys in - if debug then ( - Printf.fprintf stdout "[%s\n" str; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - Printf.fprintf stdout "\n => \n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; - Printf.fprintf stdout "]\n" ); - sys' +let subst sys = tr_sys "subst" WithProof.subst sys (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. @@ -489,12 +493,10 @@ let nlinear_preprocess (sys : WithProof.t list) = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in let sys = sys @ all_pairs WithProof.product sys in - if debug then begin - Printf.fprintf stdout "Preprocessed\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys - end; List.map (WithProof.annot "P") sys +let nlinear_preprocess = tr_sys "nlinear_preprocess" nlinear_preprocess + let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in @@ -698,6 +700,15 @@ let pivot v (c1, p1) (c2, p2) = Some (xpivot cv1 cv2) else None +let pivot v c1 c2 = + let res = pivot v c1 c2 in + ( match res with + | None -> () + | Some (c, _) -> + if Vect.get v c.coeffs =/ Q.zero then () + else Printf.printf "pivot error %a\n" output_cstr c ); + res + (* op2 could be Eq ... this might happen *) let simpl_sys sys = @@ -762,6 +773,8 @@ let reduce_coprime psys = in Some (pivot_sys v (cstr, prf) ((c1, p1) :: sys)) +(*let pivot_sys v pc sys = tr_cstr_sys "pivot_sys" (pivot_sys v pc) sys*) + (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr, prf) = @@ -820,6 +833,8 @@ let reduction_equations psys = [reduce_unary; reduce_coprime; reduce_var_change (*; reduce_pivot*)]) psys +let reduction_equations = tr_cstr_sys "reduction_equations" reduction_equations + (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v, i) = @@ -891,11 +906,6 @@ let check_sys sys = open ProofFormat -let output_cstr_sys sys = - (pp_list ";" (fun o (c, wp) -> - Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) - sys - let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -1170,7 +1180,9 @@ let nlia enum prfdepth sys = No: if a wrong equation is chosen, the proof may fail. It would only be safe if the variable is linear... *) - let sys1 = elim_simple_linear_equality sys in + let sys1 = + elim_simple_linear_equality (WithProof.subst_constant true sys) + in let sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1 @ sys2) in let sys4 = make_cstr_system (*sys2@*) sys3 in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 5e138fa3d1..91f7e27911 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -38,14 +38,14 @@ let max_depth = max_int (* Search limit for provers over Q R *) let lra_proof_depth = - declare_int_option_and_ref ~depr:false ~key:["Lra"; "Depth"] ~value:max_depth + declare_int_option_and_ref ~depr:true ~key:["Lra"; "Depth"] ~value:max_depth (* Search limit for provers over Z *) let lia_enum = - declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Enum"] ~value:true + declare_bool_option_and_ref ~depr:true ~key:["Lia"; "Enum"] ~value:true let lia_proof_depth = - declare_int_option_and_ref ~depr:false ~key:["Lia"; "Depth"] ~value:max_depth + declare_int_option_and_ref ~depr:true ~key:["Lia"; "Depth"] ~value:max_depth let get_lia_option () = (Certificate.use_simplex (), lia_enum (), lia_proof_depth ()) diff --git a/plugins/micromega/dune b/plugins/micromega/dune index 204125ab56..41f894bce3 100644 --- a/plugins/micromega/dune +++ b/plugins/micromega/dune @@ -1,24 +1,24 @@ (library (name micromega_plugin) - (public_name coq.plugins.micromega) + (public_name coq-core.plugins.micromega) ; be careful not to link the executable to the plugin! (modules (:standard \ csdpcert g_zify zify)) (synopsis "Coq's micromega plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (executable (name csdpcert) (public_name csdpcert) - (package coq) + (package coq-core) (modules csdpcert) (flags :standard -open Micromega_plugin) - (libraries coq.plugins.micromega)) + (libraries coq-core.plugins.micromega)) (library (name zify_plugin) - (public_name coq.plugins.zify) + (public_name coq-core.plugins.zify) (modules g_zify zify) (synopsis "Coq's zify plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_micromega g_zify)) diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 7b29aa15f9..024fc6dade 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -485,7 +485,7 @@ module ProofFormat = struct let rec output_proof o = function | Done -> Printf.fprintf o "." | Step (i, p, pf) -> - Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + Printf.fprintf o "%i:= %a\n ; %a" i output_prf_rule p output_proof pf | Split (i, v, p1, p2) -> Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 output_proof p2 @@ -496,6 +496,48 @@ module ProofFormat = struct Printf.fprintf o "%i := %i = %i - %i ; %i := %i >= 0 ; %i := %i >= 0 ; %a" i x z t j z k t output_proof pr + module OrdPrfRule = struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1, x2) (y1, y2) = + match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i + + let rec compare p1 p2 = + match (p1, p2) with + | Annot (s1, p1), Annot (s2, p2) -> + if s1 = s2 then compare p1 p2 else String.compare s1 s2 + | Hyp i, Hyp j -> Int.compare i j + | Def i, Def j -> Int.compare i j + | Cst n, Cst m -> Q.compare n m + | Zero, Zero -> 0 + | Square v1, Square v2 -> Vect.compare v1 v2 + | MulC (v1, p1), MulC (v2, p2) -> + cmp_pair Vect.compare compare (v1, p1) (v2, p2) + | Gcd (b1, p1), Gcd (b2, p2) -> + cmp_pair Z.compare compare (b1, p1) (b2, p2) + | MulPrf (p1, q1), MulPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | CutPrf p, CutPrf p' -> compare p p' + | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) + end + + module PrfRuleMap = Map.Make (OrdPrfRule) + let rec pr_size = function | Annot (_, p) -> pr_size p | Zero | Square _ -> Q.zero @@ -537,33 +579,38 @@ module ProofFormat = struct (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. This is because the Coq proof format only accept they as a proof-step *) - let rec pr_rule_def_cut id = function - | Annot (_, p) -> pr_rule_def_cut id p - | MulC (p, prf) -> - let bds, id', prf' = pr_rule_def_cut id prf in - (bds, id', MulC (p, prf')) - | MulPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, MulPrf (p1, p2)) - | AddPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, AddPrf (p1, p2)) - | CutPrf p -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | Gcd (c, p) -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], id, x) + let pr_rule_def_cut m id p = + let rec pr_rule_def_cut m id = function + | Annot (_, p) -> pr_rule_def_cut m id p + | MulC (p, prf) -> + let bds, m, id', prf' = pr_rule_def_cut m id prf in + (bds, m, id', MulC (p, prf')) + | MulPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, MulPrf (p1, p2)) + | AddPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, AddPrf (p1, p2)) + | CutPrf p | Gcd (_, p) -> ( + let bds, m, id, p = pr_rule_def_cut m id p in + try + let id' = PrfRuleMap.find p m in + (bds, m, id, Def id') + with Not_found -> + let m = PrfRuleMap.add p id m in + ((id, p) :: bds, m, id + 1, Def id) ) + | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], m, id, x) + in + pr_rule_def_cut m id p (* Do not define top-level cuts *) - let pr_rule_def_cut id = function + let pr_rule_def_cut m id = function | CutPrf p -> - let bds, ids, p' = pr_rule_def_cut id p in - (bds, ids, CutPrf p') - | p -> pr_rule_def_cut id p + let bds, m, ids, p' = pr_rule_def_cut m id p in + (bds, m, ids, CutPrf p') + | p -> pr_rule_def_cut m id p let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p @@ -577,6 +624,69 @@ module ProofFormat = struct | MulPrf (p1, p2) | AddPrf (p1, p2) -> ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2) + let add_proof x y = + match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) + + let rec mul_cst_proof c p = + match p with + | Annot (s, p) -> Annot (s, mul_cst_proof c p) + | MulC (v, p') -> MulC (Vect.mul c v, p') + | _ -> ( + match Q.sign c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> + MulC (LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) + | _ -> assert false ) + + let sMulC v p = + let c, v' = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) + + let mul_proof p1 p2 = + match (p1, p2) with + | Zero, _ | _, Zero -> Zero + | Cst c, p | p, Cst c -> mul_cst_proof c p + | _, _ -> MulPrf (p1, p2) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + let rec dev_prf_rule p = + match p with + | Annot (s, p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> + PrfRuleMap.singleton p (LinPoly.constant Q.one) + | MulC (v, p) -> + PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf (p1, p2) -> + PrfRuleMap.merge + (fun k o1 o2 -> + match (o1, o2) with + | None, None -> None + | None, Some v | Some v, None -> Some v + | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) + (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf (p1, p2) -> ( + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) + ) + | Gcd (c, p) -> + PrfRuleMap.singleton + (Gcd (c, prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + | CutPrf p -> + PrfRuleMap.singleton + (CutPrf (prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + + let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) + (** [simplify_proof p] removes proof steps that are never re-used. *) let rec simplify_proof p = match p with @@ -618,7 +728,9 @@ module ProofFormat = struct | Done -> (id, Done) | Step (i, Gcd (c, p), Done) -> normalise_proof id (Step (i, p, Done)) | Step (i, p, prf) -> - let bds, id, p' = pr_rule_def_cut id p in + let bds, m, id, p' = + pr_rule_def_cut PrfRuleMap.empty id (simplify_prf_rule p) + in let id, prf = normalise_proof id prf in let prf = List.fold_left @@ -642,8 +754,10 @@ module ProofFormat = struct (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) - let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in + let bds1, m, id, p1' = + pr_rule_def_cut PrfRuleMap.empty id (implicit_cut p1) + in + let bds2, m, id, p2' = pr_rule_def_cut m id (implicit_cut p2) in let ids, prfs = List.split (List.map (normalise_proof id) pl) in ( List.fold_left max 0 ids , List.fold_left @@ -659,104 +773,6 @@ module ProofFormat = struct (snd res); res - module OrdPrfRule = struct - type t = prf_rule - - let id_of_constr = function - | Annot _ -> 0 - | Hyp _ -> 1 - | Def _ -> 2 - | Cst _ -> 3 - | Zero -> 4 - | Square _ -> 5 - | MulC _ -> 6 - | Gcd _ -> 7 - | MulPrf _ -> 8 - | AddPrf _ -> 9 - | CutPrf _ -> 10 - - let cmp_pair c1 c2 (x1, x2) (y1, y2) = - match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i - - let rec compare p1 p2 = - match (p1, p2) with - | Annot (s1, p1), Annot (s2, p2) -> - if s1 = s2 then compare p1 p2 else String.compare s1 s2 - | Hyp i, Hyp j -> Int.compare i j - | Def i, Def j -> Int.compare i j - | Cst n, Cst m -> Q.compare n m - | Zero, Zero -> 0 - | Square v1, Square v2 -> Vect.compare v1 v2 - | MulC (v1, p1), MulC (v2, p2) -> - cmp_pair Vect.compare compare (v1, p1) (v2, p2) - | Gcd (b1, p1), Gcd (b2, p2) -> - cmp_pair Z.compare compare (b1, p1) (b2, p2) - | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | AddPrf (p1, q1), AddPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | CutPrf p, CutPrf p' -> compare p p' - | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) - end - - let add_proof x y = - match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) - - let rec mul_cst_proof c p = - match p with - | Annot (s, p) -> Annot (s, mul_cst_proof c p) - | MulC (v, p') -> MulC (Vect.mul c v, p') - | _ -> ( - match Q.sign c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> - MulC (LinPoly.constant c, p) (* [p] should represent an equality *) - | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) - | _ -> assert false ) - - let sMulC v p = - let c, v' = Vect.decomp_cst v in - if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) - - let mul_proof p1 p2 = - match (p1, p2) with - | Zero, _ | _, Zero -> Zero - | Cst c, p | p, Cst c -> mul_cst_proof c p - | _, _ -> MulPrf (p1, p2) - - module PrfRuleMap = Map.Make (OrdPrfRule) - - let prf_rule_of_map m = - PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero - - let rec dev_prf_rule p = - match p with - | Annot (s, p) -> dev_prf_rule p - | Hyp _ | Def _ | Cst _ | Zero | Square _ -> - PrfRuleMap.singleton p (LinPoly.constant Q.one) - | MulC (v, p) -> - PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) - | AddPrf (p1, p2) -> - PrfRuleMap.merge - (fun k o1 o2 -> - match (o1, o2) with - | None, None -> None - | None, Some v | Some v, None -> Some v - | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) - (dev_prf_rule p1) (dev_prf_rule p2) - | MulPrf (p1, p2) -> ( - let p1' = dev_prf_rule p1 in - let p2' = dev_prf_rule p2 in - let p1'' = prf_rule_of_map p1' in - let p2'' = prf_rule_of_map p2' in - match p1'' with - | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' - | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) - ) - | _ -> PrfRuleMap.singleton p (LinPoly.constant Q.one) - - let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) - (* let mul_proof p1 p2 = let res = mul_proof p1 p2 in @@ -835,7 +851,8 @@ module ProofFormat = struct Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; raise x - let rec cmpl_proof env = function + let rec cmpl_proof env prf = + match prf with | Done -> Mc.DoneProof | Step (i, p, prf) -> ( match p with @@ -1097,15 +1114,33 @@ module WithProof = struct in List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) - let subst sys0 = + let iterate_pivot p sys0 = let elim sys = - let oeq, sys' = extract (is_substitution true) sys in + let oeq, sys' = extract p sys in match oeq with | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in iterate_until_stable elim (List.map snd (sort sys0)) + let subst_constant is_int sys = + let is_integer q = Q.(q =/ floor q) in + let is_constant ((c, o), p) = + match o with + | Ge | Gt -> None + | Eq -> ( + Vect.Bound.( + match of_vect c with + | None -> None + | Some b -> + if (not is_int) || is_integer (b.cst // b.coeff) then + Monomial.get_var (LinPoly.MonT.retrieve b.var) + else None) ) + in + iterate_pivot is_constant sys + + let subst sys0 = iterate_pivot (is_substitution true) sys0 + let saturate_subst b sys0 = let select = is_substitution b in let gen (v, pc) ((c, op), prf) = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 84b5421207..81c131fe78 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -393,6 +393,10 @@ module WithProof : sig val subst : t list -> t list + (** [subst_constant b sys] performs the equivalent of the 'subst' tactic of Coq + only if there is an equation a.x = c for a,c a constant and a divides c if b= true*) + val subst_constant : bool -> t list -> t list + (** [subst1 sys] performs a single substitution *) val subst1 : t list -> t list diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index d1403558ad..61966b60c0 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -14,7 +14,7 @@ open Pp open Lazy module NamedDecl = Context.Named.Declaration -let debug = false +let debug_zify = CDebug.create ~name:"zify" () (* The following [constr] are necessary for constructing the proof terms *) @@ -805,12 +805,11 @@ let pp_prf prf = let interp_prf evd inj source prf = let t, prf' = interp_prf evd inj source prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "interp_prf " ++ gl_pr_constr inj.EInjT.inj ++ str " " ++ gl_pr_constr source ++ str " = " ++ gl_pr_constr t ++ str " by " - ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ()); + ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ())); (t, prf') let mkvar evd inj e = @@ -888,13 +887,12 @@ let app_unop evd src unop arg prf = let app_unop evd src unop arg prf = let res = app_unop evd src unop arg prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "\napp_unop " ++ pp_prf evd unop.EUnOpT.inj1_t arg prf ++ str " => " - ++ pp_prf evd unop.EUnOpT.inj2_t src res); + ++ pp_prf evd unop.EUnOpT.inj2_t src res)); res let app_binop evd src binop arg1 prf1 arg2 prf2 = @@ -1066,8 +1064,7 @@ let match_operator env evd hd args (t, d) = let pp_trans_expr env evd e res = let {deriv = inj} = get_injection env evd e.typ in - if debug then - Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); + debug_zify (fun () -> Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res)); res let declared_term env evd hd args = @@ -1187,7 +1184,7 @@ let trans_binrel evd src rop a1 prf1 a2 prf2 = let trans_binrel evd src rop a1 prf1 a2 prf2 = let res = trans_binrel evd src rop a1 prf1 a2 prf2 in - if debug then Feedback.msg_debug Pp.(str "\ntrans_binrel " ++ pp_prfp res); + debug_zify (fun () -> Pp.(str "\ntrans_binrel " ++ pp_prfp res)); res let mkprf t p = @@ -1199,11 +1196,10 @@ let mkprf t p = let mkprf t p = let t', p = mkprf t p in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "mkprf " ++ gl_pr_constr t ++ str " <-> " ++ gl_pr_constr t' - ++ str " by " ++ gl_pr_constr p); + ++ str " by " ++ gl_pr_constr p)); (t', p) let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = @@ -1221,7 +1217,7 @@ let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let prf = trans_bin_prop op_constr op_iff t1 p1 t2 p2 in - if debug then Feedback.msg_debug (pp_prfp prf); + debug_zify (fun () -> pp_prfp prf); prf let trans_un_prop op_constr op_iff p1 prf1 = @@ -1285,8 +1281,7 @@ let trans_hyps env evd l = [] l let trans_hyp h t0 prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC (* Should detect before *) | CProof t' -> @@ -1313,8 +1308,7 @@ let trans_hyp h t0 prfp = (tclTHEN (Tactics.clear [h]) (Tactics.rename_hyp [(h', h)]))))) let trans_concl prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC | CProof t -> diff --git a/plugins/nsatz/dune b/plugins/nsatz/dune index 3b67ab3429..2aaeec2665 100644 --- a/plugins/nsatz/dune +++ b/plugins/nsatz/dune @@ -1,7 +1,7 @@ (library (name nsatz_plugin) - (public_name coq.plugins.nsatz) + (public_name coq-core.plugins.nsatz) (synopsis "Coq's nsatz solver plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_nsatz)) diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index 1caa042db6..19bdcbac58 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -1,9 +1,9 @@ (* Printing *) let pr x = - if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () + if CDebug.(get_flag misc) then (Format.printf "@[%s@]" x; flush(stdout);)else () let prt0 s = () (* print_string s;flush(stdout)*) -let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) -let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) +let sinfo s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str s) +let info s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str (s ())) diff --git a/plugins/omega/dune b/plugins/omega/dune index 0db71ed6fb..a3c9342322 100644 --- a/plugins/omega/dune +++ b/plugins/omega/dune @@ -1,7 +1,7 @@ (library (name omega_plugin) - (public_name coq.plugins.omega) + (public_name coq-core.plugins.omega) (synopsis "Coq's omega plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_omega)) diff --git a/plugins/ring/dune b/plugins/ring/dune index 080d8c672e..40f310831a 100644 --- a/plugins/ring/dune +++ b/plugins/ring/dune @@ -1,7 +1,7 @@ (library (name ring_plugin) - (public_name coq.plugins.ring) + (public_name coq-core.plugins.ring) (synopsis "Coq's ring plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ring)) diff --git a/plugins/rtauto/dune b/plugins/rtauto/dune index 43efa0eca5..a13f063550 100644 --- a/plugins/rtauto/dune +++ b/plugins/rtauto/dune @@ -1,7 +1,7 @@ (library (name rtauto_plugin) - (public_name coq.plugins.rtauto) + (public_name coq-core.plugins.rtauto) (synopsis "Coq's rtauto plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_rtauto)) diff --git a/plugins/ssr/dune b/plugins/ssr/dune index a117d09a16..4c28776bb7 100644 --- a/plugins/ssr/dune +++ b/plugins/ssr/dune @@ -1,9 +1,9 @@ (library (name ssreflect_plugin) - (public_name coq.plugins.ssreflect) + (public_name coq-core.plugins.ssreflect) (synopsis "Coq's ssreflect plugin") (modules_without_implementation ssrast) (flags :standard -open Gramlib) - (libraries coq.plugins.ssrmatching)) + (libraries coq-core.plugins.ssrmatching)) (coq.pp (modules ssrvernac ssrparser)) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 4d57abb465..41fd96ccb5 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -252,7 +252,7 @@ let interp_refine ist gl rc = in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) - ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); + debug_ssr (fun () -> str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c); (sigma, (sigma, c)) @@ -1207,7 +1207,7 @@ let gentac gen = Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux gl false gen in - ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); + debug_ssr (fun () -> str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c); let gl = pf_merge_uc ucst gl in if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 582c45cde1..78a59abda9 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -126,17 +126,17 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = fun (oc, orig_clr, occ, c_gen) -> pfLIFT begin fun gl -> let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in - ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); + debug_ssr (fun () -> (Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) | _ -> false in let match_pat env p occ h cl = let sigma0 = project orig_gl in - ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); + debug_ssr (fun () -> Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in - ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); + debug_ssr (fun () -> Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in @@ -212,10 +212,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let renamed_tys = Array.mapi (fun j (ctx, cty) -> let t = Term.it_mkProd_or_LetIn cty ctx in - ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); let t = Arguments_renaming.rename_type t (GlobRef.ConstructRef((kn,i),j+1)) in - ppdebug(lazy Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); t) tys in @@ -241,8 +241,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = in let () = let sigma = project gl in - ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); - ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in + debug_ssr (fun () -> Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + debug_ssr (fun () -> Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let open EConstr in let inf_deps_r = match kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) @@ -301,7 +301,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | Some (c, _, _,gl) -> Some(true, gl) | None -> None in first [try_c_last_arg;try_c_last_pattern] in - ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); + debug_ssr (fun () -> Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at @@ -321,7 +321,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); + debug_ssr (fun () -> Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -337,8 +337,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in head_p @ patterns, Util.List.uniquize clr, gl in - ppdebug(lazy Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); - ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); (* Predicate generation, and (if necessary) tactic to generalize the * equation asked by the user *) let elim_pred, gen_eq_tac, clr, gl = @@ -348,7 +348,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then - let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern env p)) in + let () = debug_ssr (fun () -> Pp.(str"postponing " ++ pp_pattern env p)) in cl, gl, post @ [h, p, inf_t, occ] else try let c, cl, ucst = match_pat env p occ h cl in @@ -420,8 +420,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else gl, concl in concl, gen_eq_tac, clr, gl in let gl, pty = pf_e_type_of gl elim_pred in - ppdebug(lazy Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); - ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); + debug_ssr (fun () -> Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); + debug_ssr (fun () -> Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); let gl = pf_unify_HO gl pred elim_pred in let elim = fire_subst gl elim in let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 0008d31ffd..92a481dd18 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -76,7 +76,7 @@ let simpltac s = Proofview.Goal.enter (fun _ -> simpltac s) (** The "congr" tactic *) let interp_congrarg_at ist gl n rf ty m = - ppdebug(lazy Pp.(str"===interp_congrarg_at===")); + debug_ssr (fun () -> Pp.(str"===interp_congrarg_at===")); let congrn, _ = mkSsrRRef "nary_congruence" in let args1 = mkRnat n :: mkRHoles n @ [ty] in let args2 = mkRHoles (3 * n) in @@ -84,7 +84,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); + debug_ssr (fun () -> Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -92,8 +92,8 @@ let interp_congrarg_at ist gl n rf ty m = let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = - ppdebug(lazy (Pp.str"===congr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); + debug_ssr (fun () -> (Pp.str"===congr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); let sigma, _ as it = interp_term (pf_env gl) (project gl) ist t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in @@ -124,8 +124,8 @@ let newssrcongrtac arg ist = Proofview.Goal.enter_one ~__LOC__ begin fun _g -> (Ssrcommon.tacMK_SSR_CONST "ssr_congr_arrow") end >>= fun arr -> Proofview.V82.tactic begin fun gl -> - ppdebug(lazy Pp.(str"===newcongr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); + debug_ssr (fun () -> Pp.(str"===newcongr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = @@ -385,8 +385,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) | e when CErrors.noncritical e -> raise (PRtype_error None) in - ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); - ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); try Proofview.V82.of_tactic (refine_with ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof)) gl with e when CErrors.noncritical e -> @@ -435,12 +435,12 @@ let rwcltac ?under ?map_redex cl rdx dir sr = let sigma0 = Evd.set_universe_context sigma0 ucst in let rdxt = Retyping.get_type_of env (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); + debug_ssr (fun () -> Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); let cvtac, rwtac, sigma0 = if EConstr.Vars.closed0 sigma0 r' then let sigma, c, c_eq = fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in - ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); + debug_ssr (fun () -> Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); let open EConstr in match kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> @@ -521,7 +521,7 @@ let rwprocess_rule env dir rule = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta env sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); + debug_ssr (fun () -> Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index f2c7f495b3..bc46c23761 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -296,8 +296,8 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave = | Some id -> if pats = [] then Tacticals.New.tclIDTAC else let args = Array.of_list args in - ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); - ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); + debug_ssr (fun () -> str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args))); + debug_ssr (fun () -> str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct); Tacticals.New.tclTHENS (basecuttac "ssr_have" ct) [Tactics.apply EConstr.(mkApp (mkVar id,args)); Tacticals.New.tclIDTAC] in "ssr_have", @@ -395,7 +395,7 @@ let intro_lock ipats = Array.length args = 3 && is_app_evar sigma args.(2) -> protect_subgoal env sigma hd args | _ -> - ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); + debug_ssr (fun () -> Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); Proofview.tclUNIT () end) @@ -468,13 +468,13 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = | Some l -> [IPatCase(Regular [l;[]])] in let map_redex env evar_map ~before:_ ~after:t = - ppdebug(lazy Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); + debug_ssr (fun () -> Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); let evar_map, ty = Typing.type_of env evar_map t in let new_t = (* pretty-rename the bound variables *) try begin match EConstr.destApp evar_map t with (f, ar) -> let lam = Array.last ar in - ppdebug(lazy Pp.(str"under: mapping:" ++ + debug_ssr(fun () -> Pp.(str"under: mapping:" ++ pr_econstr_env env evar_map lam)); let new_lam = pretty_rename evar_map lam varnames in let new_ar, len1 = Array.copy ar, pred (Array.length ar) in @@ -482,10 +482,10 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = EConstr.mkApp (f, new_ar) end with | DestKO -> - ppdebug(lazy Pp.(str"under: cannot pretty-rename bound variables with destApp")); + debug_ssr (fun () -> Pp.(str"under: cannot pretty-rename bound variables with destApp")); t in - ppdebug(lazy Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); + debug_ssr (fun () -> Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); evar_map, new_t in let undertacs = diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 1e940b5ad3..f8abed5482 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -324,7 +324,7 @@ end `tac`, where k is the size of `seeds` *) let tclSEED_SUBGOALS seeds tac = tclTHENin tac (fun i n -> - Ssrprinters.ppdebug (lazy Pp.(str"seeding")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"seeding")); (* eg [case: (H _ : nat)] generates 3 goals: - 1 for _ - 2 for the nat constructors *) @@ -416,11 +416,11 @@ let tclMK_ABSTRACT_VARS ids = (* Debugging *) let tclLOG p t = tclUNIT () >>= begin fun () -> - Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ pr_ipatop p)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "exec: " ++ pr_ipatop p)); tclUNIT () end <*> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str" on state:" ++ spc () ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str" on state:" ++ spc () ++ isPRINT g ++ str" goal:" ++ spc () ++ Printer.pr_goal (Goal.print g))); tclUNIT () @@ -429,7 +429,7 @@ let tclLOG p t = t p >>= fun ret -> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "done: " ++ isPRINT g)); tclUNIT () end >>= fun () -> tclUNIT ret @@ -579,10 +579,10 @@ let tclCompileIPats l = elab l ;; let tclCompileIPats l = - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats input: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats input: " ++ prlist_with_sep spc Ssrprinters.pr_ipat l)); let ops = tclCompileIPats l in - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats output: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats output: " ++ prlist_with_sep spc pr_ipatop ops)); ops @@ -597,11 +597,11 @@ let main ?eqtac ~first_case_is_dispatch iops = end (* }}} *) let tclIPAT_EQ eqtac ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~eqtac ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclIPATssr ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclCompileIPats = IpatMachine.tclCompileIPats diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 6ed68094dc..434568b554 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -15,7 +15,6 @@ open Names open Printer open Tacmach -open Ssrmatching_plugin open Ssrast let pr_spc () = str " " @@ -121,15 +120,4 @@ and pr_block = function (Prefix id) -> str"^" ++ Id.print id | (SuffixId id) -> str"^~" ++ Id.print id | (SuffixNum n) -> str"^~" ++ int n -(* 0 cost pp function. Active only if Debug Ssreflect is Set *) -let ppdebug_ref = ref (fun _ -> ()) -let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) -let () = - Goptions.(declare_bool_option - { optkey = ["Debug";"Ssreflect"]; - optdepr = false; - optread = (fun _ -> !ppdebug_ref == ssr_pp); - optwrite = (fun b -> - Ssrmatching.debug b; - if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) }) -let ppdebug s = !ppdebug_ref s +let debug_ssr = CDebug.create ~name:"ssreflect" () diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 21fb28038a..994577a0c9 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -51,5 +51,4 @@ val pr_guarded : val pr_occ : ssrocc -> Pp.t -val ppdebug : Pp.t Lazy.t -> unit - +val debug_ssr : CDebug.t diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 97926753f5..b3a9e71a3f 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -194,17 +194,17 @@ let mkGApp f args = let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> let env = Goal.env goal in let sigma = Goal.sigma goal in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env sigma glob)); try let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-out: " ++ Printer.pr_econstr_env env sigma term)); tclUNIT (env,sigma,term) with e -> (* XXX this is another catch all! *) let e, info = Exninfo.capture e in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env sigma glob)); tclZERO ~info e end @@ -217,7 +217,7 @@ end let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t let tclADD_CLEAR_IF_ID (env, ist, t) x = - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); let hd, args = EConstr.decompose_app ist t in match EConstr.kind ist hd with @@ -269,11 +269,11 @@ let interp_view ~clear_if_id ist v p = let p_id = DAst.make p_id in match DAst.get v with | Glob_term.GApp (hd, rargs) when is_specialize hd -> - Ssrprinters.ppdebug (lazy Pp.(str "specialize")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "specialize")); interp_glob ist (mkGApp p_id rargs) >>= tclKeepOpenConstr >>= tclPAIR [] | _ -> - Ssrprinters.ppdebug (lazy Pp.(str "view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "view")); (* We find out how to build (v p) eventually using an adaptor *) let adaptors = AdaptorDb.(get Forward) in Proofview.tclORELSE @@ -324,7 +324,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let rigid = rigid_of und0 in let n, p, to_prune, _ucst = pf_abs_evars2 s0 rigid (sigma, p) in let p = if simple_types then pf_abs_cterm s0 n p else p in - Ssrprinters.ppdebug (lazy Pp.(str"view@finalized: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str"view@finalized: " ++ Printer.pr_econstr_env env sigma p)); let sigma = List.fold_left Evd.remove sigma to_prune in Unsafe.tclEVARS sigma <*> @@ -349,26 +349,26 @@ let rec apply_all_views_aux ~clear_if_id vs finalization conclusion s0 = pose_proof name p <*> conclusion ~to_clear:name) <*> tclUNIT false) | v :: vs -> - Ssrprinters.ppdebug (lazy Pp.(str"piling...")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"piling...")); is_tac_in_term ~extra_scope:"ssripat" v >>= function | `Term v -> - Ssrprinters.ppdebug (lazy Pp.(str"..a term")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a term")); pile_up_view ~clear_if_id v <*> apply_all_views_aux ~clear_if_id vs finalization conclusion s0 | `Tac tac -> - Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a tactic")); finalization s0 (fun name p -> (match p with | None -> tclUNIT () | Some p -> pose_proof name p) <*> Tacinterp.eval_tactic tac <*> if vs = [] then begin - Ssrprinters.ppdebug (lazy Pp.(str"..was the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was the last view")); conclusion ~to_clear:name <*> tclUNIT true end else Tactics.clear name <*> tclINDEPENDENTL begin - Ssrprinters.ppdebug (lazy Pp.(str"..was NOT the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was NOT the last view")); Ssrcommon.tacSIGMA >>= apply_all_views_aux ~clear_if_id vs finalization conclusion end >>= reduce_or) diff --git a/plugins/ssrmatching/dune b/plugins/ssrmatching/dune index 629d723816..efaa09c939 100644 --- a/plugins/ssrmatching/dune +++ b/plugins/ssrmatching/dune @@ -1,7 +1,7 @@ (library (name ssrmatching_plugin) - (public_name coq.plugins.ssrmatching) + (public_name coq-core.plugins.ssrmatching) (synopsis "Coq ssrmatching plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ssrmatching)) diff --git a/plugins/ssrsearch/dune b/plugins/ssrsearch/dune index 2851835eae..a38bec496f 100644 --- a/plugins/ssrsearch/dune +++ b/plugins/ssrsearch/dune @@ -1,7 +1,7 @@ (library (name ssrsearch_plugin) - (public_name coq.plugins.ssrsearch) + (public_name coq-core.plugins.ssrsearch) (synopsis "Deprecated Search command from SSReflect") - (libraries coq.plugins.ssreflect)) + (libraries coq-core.plugins.ssreflect)) (coq.pp (modules g_search)) diff --git a/plugins/syntax/dune b/plugins/syntax/dune index f930fc265a..b00242be1a 100644 --- a/plugins/syntax/dune +++ b/plugins/syntax/dune @@ -1,22 +1,15 @@ (library (name number_string_notation_plugin) - (public_name coq.plugins.number_string_notation) + (public_name coq-core.plugins.number_string_notation) (synopsis "Coq number and string notation plugin") (modules g_number_string string_notation number) - (libraries coq.vernac)) - -(library - (name int63_syntax_plugin) - (public_name coq.plugins.int63_syntax) - (synopsis "Coq syntax plugin: int63") - (modules int63_syntax) - (libraries coq.vernac)) + (libraries coq-core.vernac)) (library (name float_syntax_plugin) - (public_name coq.plugins.float_syntax) + (public_name coq-core.plugins.float_syntax) (synopsis "Coq syntax plugin: float") (modules float_syntax) - (libraries coq.vernac)) + (libraries coq-core.vernac)) (coq.pp (modules g_number_string)) diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml deleted file mode 100644 index 110b26581f..0000000000 --- a/plugins/syntax/int63_syntax.ml +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "int63_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -(* digit-based syntax for int63 *) - -open Names -open Libnames - -(*** Constants for locating int63 constructors ***) - -let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.int" -let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.id_int" - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -(* int63 stuff *) -let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "PrimInt63"] -let int63_path = make_path int63_module "int" -let int63_scope = "int63_scope" - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -(* Actually declares the interpreter for int63 *) - -let _ = - let open Notation in - at_declare_ml_module - (fun () -> - let id_int63 = Nametab.locate q_id_int63 in - let o = { to_kind = Int63, Direct; - to_ty = id_int63; - to_post = [||]; - of_kind = Int63, Direct; - of_ty = id_int63; - ty_name = q_int63; - warning = Nop } in - enable_prim_token_interpretation - { pt_local = false; - pt_scope = int63_scope; - pt_interp_info = NumberNotation o; - pt_required = (int63_path, int63_module); - pt_refs = []; - pt_in_match = false }) - () diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml index 0e7640f430..551e2bac5d 100644 --- a/plugins/syntax/number.ml +++ b/plugins/syntax/number.ml @@ -106,10 +106,12 @@ let locate_number () = let locate_int63 () = let int63n = "num.int63.type" in - if Coqlib.has_ref int63n + let pos_neg_int63n = "num.int63.pos_neg_int63" in + if Coqlib.has_ref int63n && Coqlib.has_ref pos_neg_int63n then - let q_int63 = qualid_of_ref int63n in - Some (mkRefC q_int63) + let q_pos_neg_int63 = qualid_of_ref pos_neg_int63n in + Some ({pos_neg_int63_ty = unsafe_locate_ind q_pos_neg_int63}, + mkRefC q_pos_neg_int63) else None let has_type env sigma f ty = @@ -121,20 +123,13 @@ let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Number.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + fnl () ++ str "Instead of Number.int, the types Number.uint or Z or PrimInt63.pos_neg_int63 or Number.number could be used (you may need to require BinNums or Number or PrimInt63 first).") let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Number.int or (option Number.int)." ++ fnl () ++ - str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") - -let warn_deprecated_decimal = - CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Deprecated Number Notation for Decimal.uint, \ - Decimal.int or Decimal.decimal. Use Number.uint, \ - Number.int or Number.number respectively.") + str "Instead of Number.int, the types Number.uint or Z or PrimInt63.pos_neg_int63 or Number.number could be used (you may need to require BinNums or Number or PrimInt63 first).") let error_params ind = CErrors.user_err @@ -381,22 +376,37 @@ let elaborate_to_post_via env sigma ty_name ty_ind l = let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in to_post, pt_refs -let locate_global_inductive allow_params qid = - let locate_param_inductive qid = +type target_type = + | TargetInd of (inductive * GlobRef.t option list) + | TargetPrim of required_module + +let locate_global_inductive_with_params allow_params qid = + if not allow_params then raise Not_found else match Nametab.locate_extended qid with | Globnames.TrueGlobal _ -> raise Not_found | Globnames.SynDef kn -> match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) when allow_params -> + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) -> i, List.map (function | Notation_term.NRef (r,None) -> Some r | Notation_term.NHole _ -> None | _ -> raise Not_found) l - | _ -> raise Not_found in - try locate_param_inductive qid + | _ -> raise Not_found + +let locate_global_inductive allow_params qid = + try locate_global_inductive_with_params allow_params qid with Not_found -> Smartlocate.global_inductive_with_alias qid, [] +let locate_global_inductive_or_int63 allow_params qid = + try TargetInd (locate_global_inductive_with_params allow_params qid) + with Not_found -> + let int63n = "num.int63.type" in + if allow_params && Coqlib.has_ref int63n + && GlobRef.equal (Smartlocate.global_with_alias qid) (Coqlib.lib_ref int63n) + then TargetPrim (Nametab.path_of_global (Coqlib.lib_ref int63n), []) + else TargetInd (Smartlocate.global_inductive_with_alias qid, []) + let vernac_number_notation local ty f g opts scope = let rec parse_opts = function | [] -> None, Nop @@ -421,7 +431,7 @@ let vernac_number_notation local ty f g opts scope = let ty_name = ty in let ty, via = match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in - let tyc, params = locate_global_inductive (via = None) ty in + let tyc_params = locate_global_inductive_or_int63 (via = None) ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in let cty = mkRefC ty in @@ -439,23 +449,20 @@ let vernac_number_notation local ty f g opts scope = | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option + | Some (pos_neg_int63_ty, cint63) when has_type env sigma f (arrow cint63 cty) -> Int63 pos_neg_int63_ty, Direct + | Some (pos_neg_int63_ty, cint63) when has_type env sigma f (arrow cint63 (opt cty)) -> Int63 pos_neg_int63_ty, Option | _ -> type_error_to f ty in (* Check the type of g *) + let cty = match tyc_params with + | TargetPrim _ -> mkRefC (qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.int_wrapper") + | TargetInd _ -> cty in let of_kind = match num_ty with | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct @@ -464,30 +471,24 @@ let vernac_number_notation local ty f g opts scope = | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option + | Some (pos_neg_int63_ty, cint63) when has_type env sigma g (arrow cty cint63) -> Int63 pos_neg_int63_ty, Direct + | Some (pos_neg_int63_ty, cint63) when has_type env sigma g (arrow cty (opt cint63)) -> Int63 pos_neg_int63_ty, Option | _ -> type_error_of g ty in - (match to_kind, of_kind with - | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ - | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> - warn_deprecated_decimal () - | _ -> ()); - let to_post, pt_refs = match via with - | None -> elaborate_to_post_params env sigma tyc params - | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let to_post, pt_required, pt_refs = match tyc_params with + | TargetPrim path -> [||], path, [Coqlib.lib_ref "num.int63.wrap_int"] + | TargetInd (tyc, params) -> + let to_post, pt_refs = + match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + to_post, (Nametab.path_of_global (GlobRef.IndRef tyc), []), pt_refs in let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = opts } in @@ -498,7 +499,7 @@ let vernac_number_notation local ty f g opts scope = { pt_local = local; pt_scope = scope; pt_interp_info = NumberNotation o; - pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; + pt_required; pt_refs; pt_in_match = true } in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 7930c3d634..02fb347d08 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -201,10 +201,7 @@ let cofixp_reducible flgs _ stk = else false -let get_debug_cbv = Goptions.declare_bool_option_and_ref - ~depr:false - ~value:false - ~key:["Debug";"Cbv"] +let debug_cbv = CDebug.create ~name:"Cbv" () (* Reduction of primitives *) @@ -525,7 +522,7 @@ and norm_head_ref k info env stack normt t = if red_set_ref info.reds normt then match cbv_value_cache info normt with | Declarations.Def body -> - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Unfolding " ++ debug_pr_key normt)); strip_appl (shift_value k body) stack | Declarations.Primitive op -> let c = match normt with @@ -534,11 +531,11 @@ and norm_head_ref k info env stack normt t = in (PRIMITIVE(op,c,[||]),stack) | Declarations.OpaqueDef _ | Declarations.Undef _ -> - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Not unfolding " ++ debug_pr_key normt)); (VAL(0,make_constr_ref k normt t),stack) else begin - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Not unfolding " ++ debug_pr_key normt)); (VAL(0,make_constr_ref k normt t),stack) end diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index 8ddc576d83..ac89dfd747 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -156,8 +156,6 @@ let cl_fun_index = fst(class_info CL_FUN) let cl_sort_index = fst(class_info CL_SORT) -(* coercion_info : coe_typ -> coe_info_typ *) - let coercion_info coe = CoeTypMap.find coe !coercion_tab let coercion_exists coe = CoeTypMap.mem coe !coercion_tab diff --git a/pretyping/coercionops.mli b/pretyping/coercionops.mli index 31600dd17f..073500b155 100644 --- a/pretyping/coercionops.mli +++ b/pretyping/coercionops.mli @@ -92,6 +92,8 @@ val declare_coercion : env -> evar_map -> coercion -> unit (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool +val coercion_info : coe_typ -> coe_info_typ + (** {6 Lookup functions for coercion paths } *) (** @raise Not_found in the following functions when no path exists *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 722a0a2048..48f34e7c6b 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -744,9 +744,11 @@ let detype_level sigma l = UNamed (detype_level_name sigma l) let detype_instance sigma l = - let l = EInstance.kind sigma l in - if Univ.Instance.is_empty l then None - else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) + if not !print_universes then None + else + let l = EInstance.kind sigma l in + if Univ.Instance.is_empty l then None + else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) let delay (type a) (d : a delay) (f : a delay -> _ -> _ -> _ -> _ -> _ -> a glob_constr_r) flags env avoid sigma t : a glob_constr_g = match d with @@ -928,10 +930,12 @@ and detype_binder d flags bk avoid env sigma decl c = let c = detype d { flags with flg_isgoal = false } avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) let s = - (* It can fail if ty is an evar, or if run inside ocamldebug or the - OCaml toplevel since their printers don't have access to the proper sigma/env *) - try Retyping.get_sort_family_of (snd env) sigma ty - with Retyping.RetypeError _ -> InType + if !Flags.in_debugger then InType + else + (* It can fail if ty is an evar, or if run inside ocamldebug or the + OCaml toplevel since their printers don't have access to the proper sigma/env *) + try Retyping.get_sort_family_of (snd env) sigma ty + with Retyping.RetypeError _ -> InType in let t = if s != InProp && not !Flags.raw_print then None else Some (detype d { flags with flg_isgoal = false } avoid env sigma ty) in GLetIn (na', c, t, r) diff --git a/pretyping/dune b/pretyping/dune index 14bce92de1..d9b5609bd4 100644 --- a/pretyping/dune +++ b/pretyping/dune @@ -1,6 +1,6 @@ (library (name pretyping) (synopsis "Coq's Type Inference Component (Pretyper)") - (public_name coq.pretyping) + (public_name coq-core.pretyping) (wrapped false) (libraries engine)) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 990e84e5a7..e1d6fff3e4 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -47,17 +47,9 @@ let default_flags env = let ts = default_transparent_state env in default_flags_of ts -let debug_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"Unification"] - ~value:false - -let debug_ho_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"HO";"Unification"] - ~value:false +let debug_unification = CDebug.create ~name:"unification" () + +let debug_ho_unification = CDebug.create ~name:"ho-unification" () (*******************************************) (* Functions to deal with impossible cases *) @@ -808,9 +800,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) - let () = if debug_unification () then - let open Pp in - Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in + let () = debug_unification (fun () -> Pp.(v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ()))) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> @@ -1288,17 +1278,17 @@ let apply_on_subterm env evd fixed f test c t = (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else - (if debug_ho_unification () then - Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); + (debug_ho_unification (fun () -> + Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t)); let b, evd = try test env !evdref k c t with e when CErrors.noncritical e -> assert false in - if b then (if debug_ho_unification () then Feedback.msg_debug (Pp.str "succeeded"); + if b then (debug_ho_unification (fun () -> Pp.str "succeeded"); let evd', fixed, t' = f !evdref !fixedref k t in fixedref := fixed; evdref := evd'; t') else ( - if debug_ho_unification () then Feedback.msg_debug (Pp.str "failed"); + debug_ho_unification (fun () -> Pp.str "failed"); map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) @@ -1404,9 +1394,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let env_evar = evar_filtered_env env_rhs evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); - Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); + debug_ho_unification (fun () -> + Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs ++ fnl () ++ + str"env evars: " ++ Termops.Internal.print_env env_evar)); let args = List.map (nf_evar evd) args in let argsubst = List.map2 (fun decl c -> (NamedDecl.get_id decl, c)) ctxt args in let instance = evar_identity_subst evi in @@ -1439,17 +1429,17 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let rec set_holes env_rhs evd fixed rhs = function | (id,idty,c,cty,evsref,filter,occs)::subst -> let c = nf_evar evd c in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"set holes for: " ++ + debug_ho_unification (fun () -> + Pp.(str"set holes for: " ++ prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ prc env_rhs evd c ++ str" in " ++ - prc env_rhs evd rhs); + prc env_rhs evd rhs)); let occ = ref 1 in let set_var evd fixed k inst = let oc = !occ in - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"Found one occurrence"); - Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); + debug_ho_unification (fun () -> + Pp.(str"Found one occurrence" ++ fnl () ++ + str"cty: " ++ prc env_rhs evd c)); incr occ; match occs with | AtOccurrences occs -> @@ -1458,10 +1448,10 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | Unspecified prefer_abstraction -> let evd, fixed, evty = set_holes env_rhs evd fixed cty subst in let evty = nf_evar evd evty in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ - str" of type: " ++ prc env_evar evd evty ++ - str " for " ++ prc env_rhs evd c); + debug_ho_unification (fun () -> + Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ + str" of type: " ++ prc env_evar evd evty ++ + str " for " ++ prc env_rhs evd c)); let instance = Filter.filter_list filter instance in (* Allow any type lower than the variable's type as the abstracted subterm might have a smaller type, which could be @@ -1477,8 +1467,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = evd, fixed, mkEvar (evk, instance) in let evd, fixed, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); + debug_ho_unification (fun () -> + Pp.(str"abstracted: " ++ prc env_rhs evd rhs')); let () = check_selected_occs env_rhs evd c !occ occs in let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in set_holes env_rhs' evd fixed rhs' subst @@ -1491,9 +1481,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (* Thin evars making the term typable in env_evar *) let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); - Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + debug_ho_unification (fun () -> + Pp.(str"solve_evars on: " ++ prc env_evar evd rhs' ++ fnl () ++ + str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let evd,rhs' = try !solve_evars env_evar evd rhs' with e when Pretype_errors.precatchable_exception e -> @@ -1501,18 +1491,18 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = raise (TypingFailed evd) in let rhs' = nf_evar evd rhs' in (* We instantiate the evars of which the value is forced by typing *) - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); - Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + debug_ho_unification (fun () -> + Pp.(str"after solve_evars: " ++ prc env_evar evd rhs' ++ fnl () ++ + str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let rec abstract_free_holes evd = function | (id,idty,c,cty,evsref,_,_)::l -> let id = id.binder_name in let c = nf_evar evd c in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracting: " ++ - prc env_rhs evd (mkVar id) ++ spc () ++ - prc env_rhs evd c); + debug_ho_unification (fun () -> + Pp.(str"abstracting: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c)); let rec force_instantiation evd = function | (evk,evty,inst,abstract)::evs -> let evk = Option.default evk (Evarutil.advance evd evk) in @@ -1541,14 +1531,14 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = with IllTypedInstance _ (* from instantiate_evar *) | TypingFailed _ -> user_err (Pp.str "Cannot find an instance.") else - ((if debug_ho_unification () then + ((debug_ho_unification (fun () -> let evi = Evd.find evd evk in let env = Evd.evar_env env_rhs evi in - Feedback.msg_debug Pp.(str"evar is defined: " ++ + Pp.(str"evar is defined: " ++ int (Evar.repr evk) ++ spc () ++ prc env evd (match evar_body evi with Evar_defined c -> c | Evar_empty -> assert false))); - evd) + evd)) in force_instantiation evd evs | [] -> abstract_free_holes evd l in force_instantiation evd !evsref @@ -1556,27 +1546,27 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = if Evd.is_defined evd evk then (* Can happen due to dependencies: instantiating evars in the arguments of evk might instantiate evk itself. *) - (if debug_ho_unification () then + (debug_ho_unification (fun () -> begin let evi = Evd.find evd evk in let evenv = evar_env env_rhs evi in let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in - Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) - end; + Pp.(str"evar was defined already as: " ++ prc evenv evd body) + end); evd) else try let evi = Evd.find_undefined evd evk in let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ - prc evenv evd rhs'); + debug_ho_unification (fun () -> + Pp.(str"abstracted type before second solve_evars: " ++ + prc evenv evd rhs')); (* solve_evars is not commuting with nf_evar, because restricting an evar might provide a more specific type. *) let evd, _ = !solve_evars evenv evd rhs' in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); + debug_ho_unification (fun () -> + Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs'))); let flags = default_flags_of TransparentState.full in Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' with IllTypedInstance _ -> raise (TypingFailed evd) @@ -1629,11 +1619,10 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in - let () = if debug_unification () then - let open Pp in - Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ + let () = debug_unification (fun () -> + Pp.(v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ - Termops.Internal.print_constr_env env evd t2 ++ cut ())) in + 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/inductiveops.ml b/pretyping/inductiveops.ml index d02b015604..2e678f5700 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -347,37 +347,50 @@ let make_case_invert env (IndType (((ind,u),params),indices)) ci = then CaseInvert {indices=Array.of_list indices} else NoInvert +let make_project env sigma ind pred c branches ps = + let open EConstr in + assert(Array.length branches == 1); + let na, ty, t = destLambda sigma pred in + let () = + let mib, _ = Inductive.lookup_mind_specif env ind in + if (* dependent *) not (Vars.noccurn sigma 1 t) && + not (has_dependent_elim mib) then + user_err ~hdr:"make_case_or_project" + Pp.(str"Dependent case analysis not allowed" ++ + 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 + let n, len, ctx = + List.fold_right + (fun decl (i, j, ctx) -> + match decl with + | LocalAssum (na, ty) -> + let t = mkProj (Projection.make ps.(i) true, mkRel j) in + (i + 1, j + 1, LocalDef (na, t, Vars.liftn 1 j ty) :: ctx) + | LocalDef (na, b, ty) -> + (i, j + 1, LocalDef (na, Vars.liftn 1 j b, Vars.liftn 1 j ty) :: ctx)) + ctx (0, 1, []) + in + mkLetIn (na, c, ty, it_mkLambda_or_LetIn (Vars.liftn 1 (Array.length ps + 1) br) ctx) + +let simple_make_case_or_project env sigma ci pred invert c branches = + let open EConstr in + let ind = ci.ci_ind in + let projs = get_projections env ind in + match projs with + | None -> mkCase (EConstr.contract_case env sigma (ci, pred, invert, c, branches)) + | Some ps -> make_project env sigma ind pred c branches ps + let make_case_or_project env sigma indt ci pred c branches = let open EConstr in let IndType (((ind,_),_),_) = indt in let projs = get_projections env ind in match projs with - | None -> (mkCase (EConstr.contract_case env sigma (ci, pred, make_case_invert env indt ci, c, branches))) - | Some ps -> - assert(Array.length branches == 1); - let na, ty, t = destLambda sigma pred in - let () = - let mib, _ = Inductive.lookup_mind_specif env ind in - if (* dependent *) not (Vars.noccurn sigma 1 t) && - not (has_dependent_elim mib) then - user_err ~hdr:"make_case_or_project" - Pp.(str"Dependent case analysis not allowed" ++ - 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 - let n, len, ctx = - List.fold_right - (fun decl (i, j, ctx) -> - match decl with - | LocalAssum (na, ty) -> - let t = mkProj (Projection.make ps.(i) true, mkRel j) in - (i + 1, j + 1, LocalDef (na, t, Vars.liftn 1 j ty) :: ctx) - | LocalDef (na, b, ty) -> - (i, j + 1, LocalDef (na, Vars.liftn 1 j b, Vars.liftn 1 j ty) :: ctx)) - ctx (0, 1, []) - in - mkLetIn (na, c, ty, it_mkLambda_or_LetIn (Vars.liftn 1 (Array.length ps + 1) br) ctx) + | None -> + let invert = make_case_invert env indt ci in + mkCase (EConstr.contract_case env sigma (ci, pred, invert, c, branches)) + | Some ps -> make_project env sigma ind pred c branches ps (* substitution in a signature *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 8e83814fa0..59ef8e08e3 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -212,6 +212,12 @@ val make_case_or_project : env -> evar_map -> inductive_type -> case_info -> (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr +(** Sometimes [make_case_or_project] is nicer to call with a pre-built + [case_invert] than [inductive_type]. *) +val simple_make_case_or_project : + env -> evar_map -> case_info -> + (* pred *) EConstr.constr -> EConstr.case_invert -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr + val make_case_invert : env -> inductive_type -> case_info -> EConstr.case_invert diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 92e412a537..2c107502f4 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -469,15 +469,15 @@ let start_profiler_linux profile_fn = Unix.stdin dev_null dev_null in (* doesn't seem to be a way to test whether process creation succeeded *) - if !Flags.debug then - Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); + debug_native_compiler (fun () -> + Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); Some profiler_pid (* kill profiler via SIGINT *) let stop_profiler_linux m_pid = match m_pid with | Some pid -> ( - let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in + let _ = debug_native_compiler (fun () -> Pp.str "Stopping native code profiler") in try Unix.kill pid Sys.sigint; let _ = Unix.waitpid [] pid in () @@ -502,15 +502,9 @@ let stop_profiler m_pid = | _ -> () let native_norm env sigma c ty = + Nativelib.link_libraries (); let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in - if not (Flags.get_native_compiler ()) then - user_err Pp.(str "Native_compute reduction has been disabled.") - else - (* - Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); - Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); - *) let profile = get_profiling_enabled () in let print_timing = get_timing_enabled () in let ml_filename, prefix = Nativelib.get_ml_filename () in @@ -526,17 +520,22 @@ let native_norm env sigma c ty = if print_timing then Feedback.msg_info (Pp.str time_info); let profiler_pid = if profile then start_profiler () else None in let t0 = Unix.gettimeofday () in - Nativelib.call_linker ~fatal:true ~prefix fn (Some upd); + let (rt1, _) = Nativelib.execute_library ~prefix fn upd in let t1 = Unix.gettimeofday () in if profile then stop_profiler profiler_pid; let time_info = Format.sprintf "native_compute: Evaluation done in %.5f" (t1 -. t0) in if print_timing then Feedback.msg_info (Pp.str time_info); - let res = nf_val env sigma !Nativelib.rt1 ty in + let res = nf_val env sigma rt1 ty in let t2 = Unix.gettimeofday () in let time_info = Format.sprintf "native_compute: Reification done in %.5f" (t2 -. t1) in if print_timing then Feedback.msg_info (Pp.str time_info); EConstr.of_constr res +let native_norm env sigma c ty = + if not (Flags.get_native_compiler ()) then + user_err Pp.(str "Native_compute reduction has been disabled."); + native_norm env sigma c ty + let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 54a47a252d..4083d3bc23 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -686,11 +686,7 @@ module CredNative = RedNative(CNativeEntries) contract_* in any case . *) -let debug_RAKAM = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"RAKAM"] - ~value:false +let debug_RAKAM = CDebug.create ~name:"RAKAM" () let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = let args = Stack.tail ci.ci_npar args in @@ -709,18 +705,18 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = let rec whd_state_gen flags env sigma = let open Context.Named.Declaration in let rec whrec (x, stack) : state = - let () = if debug_RAKAM () then + let () = let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_debug + debug_RAKAM (fun () -> (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str ">>"))) in let c0 = EConstr.kind sigma x in let fold () = - let () = if debug_RAKAM () then - let open Pp in Feedback.msg_debug (str "<><><><><>") in + let () = debug_RAKAM (fun () -> + let open Pp in str "<><><><><>") in ((EConstr.of_kind c0, stack)) in match c0 with diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 41d16f1c3c..09bcc860d0 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -19,7 +19,7 @@ open Environ exception Elimconst -val debug_RAKAM : unit -> bool +val debug_RAKAM : CDebug.t module CredNative : Primred.RedNative with type elem = EConstr.t and type args = EConstr.t array and type evd = Evd.evar_map diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index a103699716..4e89018656 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -384,11 +384,6 @@ let x = Name default_dependent_ident do so that the reduction uses this extra information *) let dummy = mkProp -let vfx = Id.of_string "_expanded_fix_" -let vfun = Id.of_string "_eliminator_function_" -let venv = let open Context.Named.Declaration in - val_of_named_context [LocalAssum (make_annot vfx Sorts.Relevant, dummy); - LocalAssum (make_annot vfun Sorts.Relevant, dummy)] (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -403,10 +398,10 @@ let substl_with_function subst sigma constr = match v.(i-k-1) with | (fx, Some (min, ref)) -> let sigma = !evd in - let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in + let (sigma, evk) = Evarutil.new_pure_evar empty_named_context_val sigma dummy in evd := sigma; - minargs := Evar.Map.add evk min !minargs; - Vars.lift k (mkEvar (evk, [fx; ref])) + minargs := Evar.Map.add evk (min, fx, ref) !minargs; + mkEvar (evk, []) | (fx, None) -> Vars.lift k fx else mkRel (i - Array.length v) | _ -> @@ -419,14 +414,14 @@ exception Partial (* each problem variable that cannot be made totally applied even by reduction is solved by the expanded fix term. *) let solve_arity_problem env sigma fxminargs c = - let evm = ref sigma in - let set_fix i = evm := Evd.define i (mkVar vfx) !evm in + let set = ref Evar.Set.empty in + let set_fix i = set := Evar.Set.add i !set in let rec check strict c = let c' = whd_betaiotazeta env sigma c in let (h,rcargs) = decompose_app_vect sigma c' in match EConstr.kind sigma h with - Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> - let minargs = Evar.Map.find i fxminargs in + Evar(i,_) when Evar.Map.mem i fxminargs && not (Evar.Set.mem i !set) -> + let minargs, _, _ = Evar.Map.find i fxminargs in if Array.length rcargs < minargs then if strict then set_fix i else raise Partial; @@ -435,45 +430,95 @@ let solve_arity_problem env sigma fxminargs c = (let ev, u = destEvalRefU sigma h in match reference_opt_value env sigma ev u with | Some h' -> - let bak = !evm in + let bak = !set in (try Array.iter (check false) rcargs with Partial -> - evm := bak; + set := bak; check strict (mkApp(h',rcargs))) | None -> Array.iter (check strict) rcargs) | _ -> EConstr.iter sigma (check strict) c' in check true c; - !evm + !set let substl_checking_arity env subst sigma c = (* we initialize the problem: *) let body,sigma,minargs = substl_with_function subst sigma c in (* we collect arity constraints *) - let sigma' = solve_arity_problem env sigma minargs body in + let ans = solve_arity_problem env sigma minargs body in (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) - let rec nf_fix c = match EConstr.kind sigma c with - | Evar (i,[fx;f]) when Evar.Map.mem i minargs -> + let rec nf_fix k c = match EConstr.kind sigma c with + | Evar (i, []) -> (* FIXME: find a less hackish way of doing this *) - begin match EConstr.kind sigma' c with - | Evar _ -> f - | c -> EConstr.of_kind c + begin match Evar.Map.find i minargs with + | (_, fx, ref) -> + if Evar.Set.mem i ans then Vars.lift k fx + else Vars.lift k ref + | exception Not_found -> + (* An argumentless evar that was not generated by substl_with_function *) + c end - | _ -> EConstr.map sigma nf_fix c + | _ -> EConstr.map_with_binders sigma succ nf_fix k c in - nf_fix body + nf_fix 0 body type fix_reduction_result = NotReducible | Reduced of (constr * constr list) let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = + let (names, (nbfix, lv, n)), u, largs = f in + let lu = List.firstn n largs in + let p = List.length lv in + let lyi = List.map fst lv in + let la = + List.map_i (fun q aq -> + (* k from the comment is q+1 *) + try mkRel (p+1-(List.index Int.equal (n-q) lyi)) + with Not_found -> Vars.lift p aq) + 0 lu + in + let f i = match names.(i) with + | None -> None + | Some (minargs,ref) -> + let body = applist (mkEvalRef ref u, la) in + let g = + List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> + let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in + let tij' = Vars.substl (List.rev subst) tij in + let x = make_annot x Sorts.Relevant in (* TODO relevance *) + mkLambda (x,tij',c)) 1 body (List.rev lv) + in Some (minargs,g) + in let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = List.init nbodies make_Fi in - substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) + let c = substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) in + nf_beta env sigma c let contract_cofix_use_function env sigma f - (bodynum,(_names,_,bodies as typedbodies)) = + (bodynum,(names,_,bodies as typedbodies)) args = + let f = + if isConst sigma f then + let minargs = List.length args in + fun i -> + if Int.equal i bodynum then Some (minargs, f) + else match names.(i).binder_name with + | Anonymous -> None + | Name id -> + (* In case of a call to another component of a block of + mutual inductive, try to reuse the global name if + the block was indeed initially built as a global + definition *) + let (kn, u) = destConst sigma f in + let kn = Constant.change_label kn (Label.of_id id) in + let cst = (kn, EInstance.kind sigma u) in + try match constant_opt_value_in env cst with + | None -> None + (* TODO: check kn is correct *) + | Some _ -> Some (minargs,mkConstU (kn, u)) + with Not_found -> None + else + fun _ -> None in let nbodies = Array.length bodies in let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = List.init nbodies make_Fi in @@ -503,7 +548,7 @@ let reduce_mind_case env sigma mia = mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false -let reduce_mind_case_use_function func env sigma mia = +let reduce_mind_case_use_function f env sigma mia = match EConstr.kind sigma mia.mconstr with | Construct ((_, i as cstr),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in @@ -512,30 +557,8 @@ let reduce_mind_case_use_function func env sigma mia = let br = it_mkLambda_or_LetIn (snd br) ctx in applist (br, real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> - let build_cofix_name = - if isConst sigma func then - let minargs = List.length mia.mcargs in - fun i -> - if Int.equal i bodynum then Some (minargs,func) - else match names.(i).binder_name with - | Anonymous -> None - | Name id -> - (* In case of a call to another component of a block of - mutual inductive, try to reuse the global name if - the block was indeed initially built as a global - definition *) - let (kn, u) = destConst sigma func in - let kn = Constant.change_label kn (Label.of_id id) in - let cst = (kn, EInstance.kind sigma u) in - try match constant_opt_value_in env cst with - | None -> None - (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConstU (kn, u)) - with Not_found -> None - else - fun _ -> None in let cofix_def = - contract_cofix_use_function env sigma build_cofix_name cofix in + contract_cofix_use_function env sigma f cofix mia.mcargs in mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -686,7 +709,7 @@ let rec red_elim_const env sigma ref u largs = let f = ([|Some (minfxargs,ref)|],infos), u, largs in (match reduce_fix_use_function env sigma f (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) + | Reduced (c,rest) -> (c, rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend (ref,u) args = let c = reference_value env sigma ref u in @@ -700,7 +723,7 @@ let rec red_elim_const env sigma ref u largs = let f = refinfos, u, midargs in (match reduce_fix_use_function env sigma f (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) + | Reduced (c,rest) -> (c, rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in (whd_betaiotazeta env sigma (applist (c, largs)), []), nocase @@ -825,29 +848,6 @@ and reduce_fix_use_function env sigma f fix stack = let stack' = List.assign stack recargnum (applist recarg') in (match EConstr.kind sigma recarg'hd with | Construct _ -> - let (names, (nbfix, lv, n)), u, largs = f in - let lu = List.firstn n largs in - let p = List.length lv in - let lyi = List.map fst lv in - let la = - List.map_i (fun q aq -> - (* k from the comment is q+1 *) - try mkRel (p+1-(List.index Int.equal (n-q) lyi)) - with Not_found -> Vars.lift p aq) - 0 lu - in - let f i = match names.(i) with - | None -> None - | Some (minargs,ref) -> - let body = applist (mkEvalRef ref u, la) in - let g = - List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> - let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in - let tij' = Vars.substl (List.rev subst) tij in - let x = make_annot x Sorts.Relevant in (* TODO relevance *) - mkLambda (x,tij',c)) 1 body (List.rev lv) - in Some (minargs,g) - in Reduced (contract_fix_use_function env sigma f fix,stack') | _ -> NotReducible) @@ -1203,9 +1203,7 @@ let unfoldn loccname env sigma c = (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = - let rcom = - try red_product env sigma com - with Redelimination -> user_err Pp.(str "Not reducible.") in + let rcom = red_product env sigma com in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 83e46e3295..df0f49a033 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -49,11 +49,7 @@ let is_keyed_unification = ~key:["Keyed";"Unification"] ~value:false -let debug_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"Tactic";"Unification"] - ~value:false +let debug_tactic_unification = CDebug.create ~name:"tactic-unification" () (** Making this unification algorithm correct w.r.t. the evar-map abstraction breaks too much stuff. So we redefine incorrect functions here. *) @@ -713,8 +709,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in let () = - if debug_unification () then - Feedback.msg_debug ( + debug_tactic_unification (fun () -> Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ Termops.Internal.print_constr_env curenv sigma cN) in @@ -1138,7 +1133,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - if debug_unification () then Feedback.msg_debug (str "Starting unification"); + debug_tactic_unification (fun () -> str "Starting unification"); let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in try let res = @@ -1165,11 +1160,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let a = match res with | Some sigma -> sigma, ms, es | None -> unirec_rec (env,0) cv_pb opt subst (fst m) (fst n) in - if debug_unification () then Feedback.msg_debug (str "Leaving unification with success"); + debug_tactic_unification (fun () -> str "Leaving unification with success"); a with e -> let e = Exninfo.capture e in - if debug_unification () then Feedback.msg_debug (str "Leaving unification with failure"); + debug_tactic_unification (fun () -> str "Leaving unification with failure"); Exninfo.iraise e let unify_0 env sigma pb flags c1 c2 = diff --git a/printing/dune b/printing/dune index 3392342165..a24a7535eb 100644 --- a/printing/dune +++ b/printing/dune @@ -1,6 +1,6 @@ (library (name printing) (synopsis "Coq's Term Pretty Printing Library") - (public_name coq.printing) + (public_name coq-core.printing) (wrapped false) (libraries parsing proofs)) diff --git a/proofs/dune b/proofs/dune index 36e9799998..f8e7661997 100644 --- a/proofs/dune +++ b/proofs/dune @@ -1,6 +1,6 @@ (library (name proofs) (synopsis "Coq's Higher-level Refinement Proof Engine and Top-level Proof Structure") - (public_name coq.proofs) + (public_name coq-core.proofs) (wrapped false) (libraries pretyping)) diff --git a/proofs/refine.ml b/proofs/refine.ml index ac410a958f..ce04c35e11 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -129,7 +129,6 @@ let solve_constraints = tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Unsafe.tclEVARSADVANCE sigma - with e -> - (* XXX this is absorbing anomalies? *) + with e when CErrors.noncritical e -> let info = Exninfo.reify () in tclZERO ~info e diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 4c4c26f47e..dd80ff21aa 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -13,7 +13,7 @@ open Pp open Util let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.pp_with pp -let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () +let stm_prerr_endline s = if CDebug.(get_flag misc) then begin stm_pr_err (str s) end else () type cancel_switch = bool ref let async_proofs_flags_for_workers = ref [] @@ -1,6 +1,6 @@ (library (name stm) (synopsis "Coq's Document Manager and Proof Checking Scheduler") - (public_name coq.stm) + (public_name coq-core.stm) (wrapped false) - (libraries vernac)) + (libraries sysinit)) diff --git a/stm/spawned.ml b/stm/spawned.ml index 5cc8be78f5..ee9c8e9942 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -11,7 +11,7 @@ open Spawn let pr_err s = Printf.eprintf "(Spawned,%d) %s\n%!" (Unix.getpid ()) s -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if CDebug.(get_flag misc) then begin pr_err s end else () type chandescr = AnonPipe | Socket of string * int * int diff --git a/stm/stm.ml b/stm/stm.ml index 1c06c1efb7..5ed6adbd63 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -9,7 +9,7 @@ (************************************************************************) (* enable in case of stm problems *) -(* let stm_debug () = !Flags.debug *) +(* let stm_debug () = CDebug.(get_flag misc) *) let stm_debug = ref false let stm_pr_err s = Format.eprintf "%s] %s\n%!" (Spawned.process_id ()) s @@ -18,7 +18,7 @@ let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.p let stm_prerr_endline s = if !stm_debug then begin stm_pr_err (s ()) end else () let stm_pperr_endline s = if !stm_debug then begin stm_pp_err (s ()) end else () -let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () +let stm_prerr_debug s = if CDebug.(get_flag misc) then begin stm_pr_err (s ()) end else () open Pp open CErrors @@ -297,13 +297,11 @@ end (* }}} *) (*************************** THE DOCUMENT *************************************) (******************************************************************************) -type interactive_top = TopLogical of DirPath.t | TopPhysical of string - (* The main document type associated to a VCS *) type stm_doc_type = | VoDoc of string | VioDoc of string - | Interactive of interactive_top + | Interactive of Coqargs.top (* Dummy until we land the functional interp patch + fixed start_library *) type doc = int @@ -517,7 +515,7 @@ end = struct (* {{{ *) type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) - let doc_type = ref (Interactive (TopLogical (Names.DirPath.make []))) + let doc_type = ref (Interactive (Coqargs.TopLogical (Names.DirPath.make []))) let ldir = ref Names.DirPath.empty let init dt id ps = @@ -787,7 +785,7 @@ end = struct (* {{{ *) end let print ?(now=false) () = - if !Flags.debug then NB.command ~now (print_dag !vcs) + if CDebug.(get_flag misc) then NB.command ~now (print_dag !vcs) let backup () = !vcs let restore v = vcs := v @@ -801,6 +799,9 @@ let state_of_id ~doc id = | EmptyState | ParsingState _ -> `Valid None with VCS.Expired -> `Expired +let () = + Stateid.set_is_valid (fun ~doc id -> state_of_id ~doc id <> `Expired) + (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig @@ -1532,7 +1533,7 @@ end = struct (* {{{ *) when is_tac expr && Vernacstate.Stm.same_env o n -> (* A pure tactic *) Some (id, `ProofOnly (prev, Vernacstate.Stm.pstate n)) | Some _, Some s -> - if !Flags.debug then msg_debug (Pp.str "STM: sending back a fat state"); + if CDebug.(get_flag misc) then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function @@ -2305,34 +2306,13 @@ end (* }}} *) (** STM initialization options: *) -type option_command = OptionSet of string option | OptionUnset - -type injection_command = - | OptionInjection of (Goptions.option_name * option_command) - (** Set flags or options before the initial state is ready. *) - | RequireInjection of (string * string option * bool option) - (** Require libraries before the initial state is - ready. Parameters follow [Library], that is to say, - [lib,prefix,import_export] means require library [lib] from - optional [prefix] and [import_export] if [Some false/Some true] - is used. *) - (* -load-vernac-source interleaving is not supported yet *) - (* | LoadInjection of (string * bool) *) - type stm_init_options = { doc_type : stm_doc_type (** The STM does set some internal flags differently depending on the specified [doc_type]. This distinction should disappear at some some point. *) - ; ml_load_path : CUnix.physical_path list - (** OCaml load paths for the document. *) - - ; vo_load_path : Loadpath.vo_path list - (** [vo] load paths for the document. Usually extracted from -R - options / _CoqProject *) - - ; injections : injection_command list + ; injections : Coqargs.injection_command list (** Injects Require and Set/Unset commands before the initial state is ready *) @@ -2349,67 +2329,17 @@ let doc_type_module_name (std : stm_doc_type) = | Interactive mn -> Names.DirPath.to_string mn *) +let init_process stm_flags = + Spawned.init_channels (); + CoqworkmgrApi.(init stm_flags.AsyncOpts.async_proofs_worker_priority) + let init_core () = if !cur_opt.async_proofs_mode = APon then Control.enable_thread_delay := true; if !Flags.async_proofs_worker_id = "master" then Partac.enable_par ~nworkers:!cur_opt.async_proofs_n_tacworkers; State.register_root_state () -let dirpath_of_file f = - let ldir0 = - try - let lp = Loadpath.find_load_path (Filename.dirname f) in - Loadpath.logical lp - with Not_found -> Libnames.default_root_prefix - in - let f = try Filename.chop_extension (Filename.basename f) with Invalid_argument _ -> f in - let id = Id.of_string f in - let ldir = Libnames.add_dirpath_suffix ldir0 id in - ldir - -let new_doc { doc_type ; ml_load_path; vo_load_path; injections; stm_options } = - - let require_file (dir, from, exp) = - let mp = Libnames.qualid_of_string dir in - let mfrom = Option.map Libnames.qualid_of_string from in - Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in - - let interp_set_option opt v old = - let open Goptions in - let err expect = - let opt = String.concat " " opt in - let got = v in (* avoid colliding with Pp.v *) - CErrors.user_err - Pp.(str "-set: " ++ str opt ++ - str" expects " ++ str expect ++ - str" but got " ++ str got) - in - match old with - | BoolValue _ -> - let v = match String.trim v with - | "true" -> true - | "false" | "" -> false - | _ -> err "a boolean" - in - BoolValue v - | IntValue _ -> - let v = String.trim v in - let v = match int_of_string_opt v with - | Some _ as v -> v - | None -> if v = "" then None else err "an int" - in - IntValue v - | StringValue _ -> StringValue v - | StringOptValue _ -> StringOptValue (Some v) in - - let set_option = let open Goptions in function - | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt - | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true - | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v in - let handle_injection = function - | RequireInjection r -> require_file r - (* | LoadInjection l -> *) - | OptionInjection o -> set_option o in +let new_doc { doc_type ; injections; stm_options } = (* Set the options from the new documents *) AsyncOpts.cur_opt := stm_options; @@ -2419,37 +2349,27 @@ let new_doc { doc_type ; ml_load_path; vo_load_path; injections; stm_options } = let doc = VCS.init doc_type Stateid.initial (Vernacstate.Parser.init ()) in - (* Set load path; important, this has to happen before we declare - the library below as [Declaremods/Library] will infer the module - name by looking at the load path! *) - List.iter Mltop.add_ml_dir ml_load_path; - List.iter Loadpath.add_vo_path vo_load_path; - Safe_typing.allow_delayed_constants := !cur_opt.async_proofs_mode <> APoff; - begin match doc_type with - | Interactive ln -> - let dp = match ln with - | TopLogical dp -> dp - | TopPhysical f -> dirpath_of_file f - in - Declaremods.start_library dp + let top = + match doc_type with + | Interactive top -> Coqargs.dirpath_of_top top | VoDoc f -> - let ldir = dirpath_of_file f in - let () = Flags.verbosely Declaremods.start_library ldir in + let ldir = Coqargs.(dirpath_of_top (TopPhysical f)) in VCS.set_ldir ldir; - set_compilation_hints f + set_compilation_hints f; + ldir | VioDoc f -> - let ldir = dirpath_of_file f in - let () = Flags.verbosely Declaremods.start_library ldir in + let ldir = Coqargs.(dirpath_of_top (TopPhysical f)) in VCS.set_ldir ldir; - set_compilation_hints f - end; + set_compilation_hints f; + ldir + in - (* Import initial libraries. *) - List.iter handle_injection injections; + (* Start this library and import initial libraries. *) + Coqinit.start_library ~top injections; (* We record the state at this point! *) State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; diff --git a/stm/stm.mli b/stm/stm.mli index 097bcbe0ca..bd42359cea 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -42,29 +42,13 @@ module AsyncOpts : sig end -type interactive_top = TopLogical of DirPath.t | TopPhysical of string - (** The STM document type [stm_doc_type] determines some properties such as what uncompleted proofs are allowed and what gets recorded to aux files. *) type stm_doc_type = | VoDoc of string (* file path *) | VioDoc of string (* file path *) - | Interactive of interactive_top (* module path *) - -type option_command = OptionSet of string option | OptionUnset - -type injection_command = - | OptionInjection of (Goptions.option_name * option_command) - (** Set flags or options before the initial state is ready. *) - | RequireInjection of (string * string option * bool option) - (** Require libraries before the initial state is - ready. Parameters follow [Library], that is to say, - [lib,prefix,import_export] means require library [lib] from - optional [prefix] and [import_export] if [Some false/Some true] - is used. *) - (* -load-vernac-source interleaving is not supported yet *) - (* | LoadInjection of (string * bool) *) + | Interactive of Coqargs.top (* module path *) (** STM initialization options: *) type stm_init_options = @@ -73,14 +57,7 @@ type stm_init_options = the specified [doc_type]. This distinction should disappear at some some point. *) - ; ml_load_path : CUnix.physical_path list - (** OCaml load paths for the document. *) - - ; vo_load_path : Loadpath.vo_path list - (** [vo] load paths for the document. Usually extracted from -R - options / _CoqProject *) - - ; injections : injection_command list + ; injections : Coqargs.injection_command list (** Injects Require and Set/Unset commands before the initial state is ready *) @@ -91,8 +68,10 @@ type stm_init_options = (** The type of a STM document *) type doc -(** [init_core] performs some low-level initialization; should go away - in future releases. *) +(** [init_process] performs some low-level initialization, call early *) +val init_process : AsyncOpts.stm_opt -> unit + +(** [init_core] snapshorts the initial system state *) val init_core : unit -> unit (** [new_doc opt] Creates a new document with options [opt] *) diff --git a/stm/stm.mllib b/stm/stm.mllib index 831369625f..a77e0c79e7 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -3,10 +3,10 @@ Dag Vcs TQueue WorkerPool -Vernac_classifier CoqworkmgrApi AsyncTaskQueue Partac Stm +Stmargs ProofBlockDelimiter Vio_checking diff --git a/stm/stmargs.ml b/stm/stmargs.ml new file mode 100644 index 0000000000..e2c7649a8f --- /dev/null +++ b/stm/stmargs.ml @@ -0,0 +1,140 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let fatal_error exn = + Topfmt.(in_phase ~phase:ParsingCommandLine print_err_exn exn); + let exit_code = if (CErrors.is_anomaly exn) then 129 else 1 in + exit exit_code + +let set_worker_id opt s = + assert (s <> "master"); + Flags.async_proofs_worker_id := s + +let get_host_port opt s = + match String.split_on_char ':' s with + | [host; portr; portw] -> + Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) + | ["stdfds"] -> Some Spawned.AnonPipe + | _ -> + Coqargs.error_wrong_arg ("Error: host:portr:portw or stdfds expected after option "^opt) + +let get_error_resilience opt = function + | "on" | "all" | "yes" -> `All + | "off" | "no" -> `None + | s -> `Only (String.split_on_char ',' s) + +let get_priority opt s = + try CoqworkmgrApi.priority_of_string s + with Invalid_argument _ -> + Coqargs.error_wrong_arg ("Error: low/high expected after "^opt) + +let get_async_proofs_mode opt = let open Stm.AsyncOpts in function + | "no" | "off" -> APoff + | "yes" | "on" -> APon + | "lazy" -> APonLazy + | _ -> + Coqargs.error_wrong_arg ("Error: on/off/lazy expected after "^opt) + +let get_cache opt = function + | "force" -> Some Stm.AsyncOpts.Force + | _ -> + Coqargs.error_wrong_arg ("Error: force expected after "^opt) + +let parse_args ~init arglist : Stm.AsyncOpts.stm_opt * string list = + let args = ref arglist in + let extras = ref [] in + let rec parse oval = match !args with + | [] -> + (oval, List.rev !extras) + | opt :: rem -> + args := rem; + let next () = match !args with + | x::rem -> args := rem; x + | [] -> Coqargs.error_missing_arg opt + in + let noval = begin match opt with + + |"-async-proofs" -> + { oval with + Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next()) + } + |"-async-proofs-j" -> + { oval with + Stm.AsyncOpts.async_proofs_n_workers = (Coqargs.get_int ~opt (next ())) + } + |"-async-proofs-cache" -> + { oval with + Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ()) + } + + |"-async-proofs-tac-j" -> + let j = Coqargs.get_int ~opt (next ()) in + if j <= 0 then begin + Coqargs.error_wrong_arg ("Error: -async-proofs-tac-j only accepts values greater than or equal to 1") + end; + { oval with + Stm.AsyncOpts.async_proofs_n_tacworkers = j + } + + |"-async-proofs-worker-priority" -> + { oval with + Stm.AsyncOpts.async_proofs_worker_priority = get_priority opt (next ()) + } + + |"-async-proofs-private-flags" -> + { oval with + Stm.AsyncOpts.async_proofs_private_flags = Some (next ()); + } + + |"-async-proofs-tactic-error-resilience" -> + { oval with + Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ()) + } + + |"-async-proofs-command-error-resilience" -> + { oval with + Stm.AsyncOpts.async_proofs_cmd_error_resilience = Coqargs.get_bool ~opt (next ()) + } + + |"-async-proofs-delegation-threshold" -> + { oval with + Stm.AsyncOpts.async_proofs_delegation_threshold = Coqargs.get_float ~opt (next ()) + } + + |"-worker-id" -> set_worker_id opt (next ()); oval + + |"-main-channel" -> + Spawned.main_channel := get_host_port opt (next()); oval + + |"-control-channel" -> + Spawned.control_channel := get_host_port opt (next()); oval + + (* Options with zero arg *) + |"-async-queries-always-delegate" + |"-async-proofs-always-delegate" + |"-async-proofs-never-reopen-branch" -> + { oval with + Stm.AsyncOpts.async_proofs_never_reopen_branch = true + } + |"-stm-debug" -> Stm.stm_debug := true; oval + (* Unknown option *) + | s -> + extras := s :: !extras; + oval + end in + parse noval + in + try + parse init + with any -> fatal_error any + +let usage = "\ +\n -stm-debug STM debug mode (will trace every transaction)\ +" diff --git a/stm/stmargs.mli b/stm/stmargs.mli new file mode 100644 index 0000000000..f760afdc98 --- /dev/null +++ b/stm/stmargs.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val parse_args : init:Stm.AsyncOpts.stm_opt -> string list -> Stm.AsyncOpts.stm_opt * string list + +val usage : string diff --git a/toplevel/coqargs.ml b/sysinit/coqargs.ml index fbf3b4873b..8be73ca028 100644 --- a/toplevel/coqargs.ml +++ b/sysinit/coqargs.ml @@ -22,39 +22,37 @@ let error_missing_arg s = exit 1 (******************************************************************************) -(* Imperative effects! This must be fixed at some point. *) -(******************************************************************************) -let set_worker_id opt s = - assert (s <> "master"); - Flags.async_proofs_worker_id := s -let set_type_in_type () = - let typing_flags = Environ.typing_flags (Global.env ()) in - Global.set_typing_flags { typing_flags with Declarations.check_universes = false } +type native_compiler = Coq_config.native_compiler = + NativeOff | NativeOn of { ondemand : bool } -(******************************************************************************) +type top = TopLogical of Names.DirPath.t | TopPhysical of string -type color = [`ON | `AUTO | `EMACS | `OFF] +type option_command = + | OptionSet of string option + | OptionUnset + | OptionAppend of string -type native_compiler = Coq_config.native_compiler = - NativeOff | NativeOn of { ondemand : bool } +type injection_command = + | OptionInjection of (Goptions.option_name * option_command) + | RequireInjection of (string * string option * bool option) + | WarnNoNative of string type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; - toplevel_name : Stm.interactive_top; + type_in_type : bool; + toplevel_name : top; } type coqargs_config = { logic : coqargs_logic_config; rcfile : string option; coqlib : string option; - color : color; enable_VM : bool; native_compiler : native_compiler; native_output_dir : CUnix.physical_path; native_include_dirs : CUnix.physical_path list; - stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; time : bool; print_emacs : bool; @@ -69,13 +67,11 @@ type coqargs_pre = { vo_includes : Loadpath.vo_path list; load_vernacular_list : (string * bool) list; - injections : Stm.injection_command list; - - inputstate : string option; + injections : injection_command list; } type coqargs_query = - | PrintTags | PrintWhere | PrintConfig + | PrintWhere | PrintConfig | PrintVersion | PrintMachineReadableVersion | PrintHelp of Usage.specific_usage @@ -85,7 +81,6 @@ type coqargs_main = type coqargs_post = { memory_stat : bool; - output_context : bool; } type t = { @@ -102,19 +97,18 @@ let default_native = Coq_config.native_compiler let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; - toplevel_name = Stm.TopLogical default_toplevel; + type_in_type = false; + toplevel_name = TopLogical default_toplevel; } let default_config = { logic = default_logic_config; rcfile = None; coqlib = None; - color = `AUTO; enable_VM = true; native_compiler = default_native; native_output_dir = ".coq-native"; native_include_dirs = []; - stm_flags = Stm.AsyncOpts.default_opts; debug = false; time = false; print_emacs = false; @@ -130,14 +124,12 @@ let default_pre = { vo_includes = []; load_vernacular_list = []; injections = []; - inputstate = None; } let default_queries = [] let default_post = { memory_stat = false; - output_context = false; } let default = { @@ -160,105 +152,67 @@ let add_vo_include opts unix_path coq_path implicit = unix_path; coq_path; has_ml = false; implicit; recursive = true } :: opts.pre.vo_includes }} let add_vo_require opts d p export = - { opts with pre = { opts.pre with injections = Stm.RequireInjection (d, p, export) :: opts.pre.injections }} + { opts with pre = { opts.pre with injections = RequireInjection (d, p, export) :: opts.pre.injections }} let add_load_vernacular opts verb s = { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} let add_set_option opts opt_name value = - { opts with pre = { opts.pre with injections = Stm.OptionInjection (opt_name, value) :: opts.pre.injections }} + { opts with pre = { opts.pre with injections = OptionInjection (opt_name, value) :: opts.pre.injections }} + +let add_set_debug opts flags = + add_set_option opts ["Debug"] (OptionAppend flags) (** Options for proof general *) let set_emacs opts = - Goptions.set_bool_option_value Printer.print_goal_tag_opt_name true; - { opts with config = { opts.config with color = `EMACS; print_emacs = true }} + let opts = add_set_option opts Printer.print_goal_tag_opt_name (OptionSet None) in + { opts with config = { opts.config with print_emacs = true }} let set_logic f oval = { oval with config = { oval.config with logic = f oval.config.logic }} -let set_color opts = function - | "yes" | "on" -> { opts with config = { opts.config with color = `ON }} - | "no" | "off" -> { opts with config = { opts.config with color = `OFF }} - | "auto" -> { opts with config = { opts.config with color = `AUTO }} - | _ -> - error_wrong_arg ("Error: on/off/auto expected after option color") - let set_query opts q = { opts with main = match opts.main with | Run -> Queries (default_queries@[q]) | Queries queries -> Queries (queries@[q]) } -let warn_deprecated_sprop_cumul = - CWarnings.create ~name:"deprecated-spropcumul" ~category:"deprecated" - (fun () -> Pp.strbrk "Use the \"Cumulative StrictProp\" flag instead.") - -let warn_deprecated_inputstate = - CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" - (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") - -let set_inputstate opts s = - warn_deprecated_inputstate (); - { opts with pre = { opts.pre with inputstate = Some s }} - (******************************************************************************) (* Parsing helpers *) (******************************************************************************) -let get_bool opt = function +let get_bool ~opt = function | "yes" | "on" -> true | "no" | "off" -> false | _ -> error_wrong_arg ("Error: yes/no expected after option "^opt) -let get_int opt n = +let get_int ~opt n = try int_of_string n with Failure _ -> error_wrong_arg ("Error: integer expected after option "^opt) +let get_int_opt ~opt n = + if n = "" then None + else Some (get_int ~opt n) -let get_float opt n = +let get_float ~opt n = try float_of_string n with Failure _ -> error_wrong_arg ("Error: float expected after option "^opt) -let get_host_port opt s = - match String.split_on_char ':' s with - | [host; portr; portw] -> - Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) - | ["stdfds"] -> Some Spawned.AnonPipe - | _ -> - error_wrong_arg ("Error: host:portr:portw or stdfds expected after option "^opt) - -let get_error_resilience opt = function - | "on" | "all" | "yes" -> `All - | "off" | "no" -> `None - | s -> `Only (String.split_on_char ',' s) - -let get_priority opt s = - try CoqworkmgrApi.priority_of_string s - with Invalid_argument _ -> - error_wrong_arg ("Error: low/high expected after "^opt) - -let get_async_proofs_mode opt = let open Stm.AsyncOpts in function - | "no" | "off" -> APoff - | "yes" | "on" -> APon - | "lazy" -> APonLazy - | _ -> - error_wrong_arg ("Error: on/off/lazy expected after "^opt) - -let get_cache opt = function - | "force" -> Some Stm.AsyncOpts.Force - | _ -> - error_wrong_arg ("Error: force expected after "^opt) - - -let get_native_name s = - (* We ignore even critical errors because this mode has to be super silent *) - try - Filename.(List.fold_left concat (dirname s) - [ !Nativelib.output_dir - ; Library.native_name_from_filename s - ]) - with _ -> "" +let interp_set_option opt v old = + let open Goptions in + let opt = String.concat " " opt in + match old with + | BoolValue _ -> BoolValue (get_bool ~opt v) + | IntValue _ -> IntValue (get_int_opt ~opt v) + | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) + +let set_option = let open Goptions in function + | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt + | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true + | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v + | opt, OptionAppend v -> set_string_option_append_value_gen ~locality:OptLocal opt v let get_compat_file = function | "8.14" -> "Coq.Compat.Coq814" @@ -282,12 +236,6 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v -let warn_no_native_compiler = - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - Pp.(fun s -> strbrk "Native compiler is disabled," ++ - strbrk " -native-compiler " ++ strbrk s ++ - strbrk " option ignored.") - let get_native_compiler s = (* We use two boolean flags because the four states make sense, even if only three are accessible to the user at the moment. The selection of the @@ -301,15 +249,13 @@ let get_native_compiler s = | _ -> error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in if Coq_config.native_compiler = NativeOff && n <> NativeOff then - let () = warn_no_native_compiler s in - NativeOff - else - n + NativeOff, Some (WarnNoNative s) + else n, None (* Main parsing routine *) (*s Parsing of the command line *) -let parse_args ~help ~init arglist : t * string list = +let parse_args ~usage ~init arglist : t * string list = let args = ref arglist in let extras = ref [] in let rec parse oval = match !args with @@ -351,55 +297,6 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = { oval.config with coqlib = Some (next ()) }} - |"-async-proofs" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next()) - }}} - |"-async-proofs-j" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_n_workers = (get_int opt (next ())) - }}} - |"-async-proofs-cache" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ()) - }}} - - |"-async-proofs-tac-j" -> - let j = get_int opt (next ()) in - if j <= 0 then begin - error_wrong_arg ("Error: -async-proofs-tac-j only accepts values greater than or equal to 1") - end; - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_n_tacworkers = j - }}} - - |"-async-proofs-worker-priority" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_worker_priority = get_priority opt (next ()) - }}} - - |"-async-proofs-private-flags" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_private_flags = Some (next ()); - }}} - - |"-async-proofs-tactic-error-resilience" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ()) - }}} - - |"-async-proofs-command-error-resilience" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_cmd_error_resilience = get_bool opt (next ()) - }}} - - |"-async-proofs-delegation-threshold" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_delegation_threshold = get_float opt (next ()) - }}} - - |"-worker-id" -> set_worker_id opt (next ()); oval - |"-compat" -> add_vo_require oval (get_compat_file (next ())) None (Some false) @@ -409,9 +306,6 @@ let parse_args ~help ~init arglist : t * string list = |"-init-file" -> { oval with config = { oval.config with rcfile = Some (next ()); }} - |"-inputstate"|"-is" -> - set_inputstate oval (next ()) - |"-load-vernac-object" -> add_vo_require oval (next ()) None None @@ -422,16 +316,12 @@ let parse_args ~help ~init arglist : t * string list = add_load_vernacular oval true (next ()) |"-mangle-names" -> - Goptions.set_bool_option_value ["Mangle"; "Names"] true; - Goptions.set_string_option_value ["Mangle"; "Names"; "Prefix"] (next ()); - oval - - |"-print-mod-uid" -> - let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0 + let oval = add_set_option oval ["Mangle"; "Names"] (OptionSet None) in + add_set_option oval ["Mangle"; "Names"; "Prefix"] (OptionSet(Some(next ()))) |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; - Flags.profile_ltac_cutoff := get_float opt (next ()); + Flags.profile_ltac_cutoff := get_float ~opt (next ()); oval |"-rfrom" -> @@ -451,39 +341,30 @@ let parse_args ~help ~init arglist : t * string list = let topname = Libnames.dirpath_of_string (next ()) in if Names.DirPath.is_empty topname then CErrors.user_err Pp.(str "Need a non empty toplevel module name"); - { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = Stm.TopLogical topname }}} + { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = TopLogical topname }}} |"-topfile" -> - { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = Stm.TopPhysical (next()) }}} - - |"-main-channel" -> - Spawned.main_channel := get_host_port opt (next()); oval - - |"-control-channel" -> - Spawned.control_channel := get_host_port opt (next()); oval + { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = TopPhysical (next()) }}} |"-w" | "-W" -> let w = next () in - if w = "none" then - (CWarnings.set_flags w; oval) - else - let w = CWarnings.get_flags () ^ "," ^ w in - CWarnings.set_flags (CWarnings.normalize_flags_string w); - oval + if w = "none" then add_set_option oval ["Warnings"] (OptionSet(Some w)) + else add_set_option oval ["Warnings"] (OptionAppend w) |"-bytecode-compiler" -> - { oval with config = { oval.config with enable_VM = get_bool opt (next ()) }} + { oval with config = { oval.config with enable_VM = get_bool ~opt (next ()) }} |"-native-compiler" -> - let native_compiler = get_native_compiler (next ()) in - { oval with config = { oval.config with native_compiler }} + let native_compiler, warn = get_native_compiler (next ()) in + { oval with config = { oval.config with native_compiler }; + pre = { oval.pre with injections = Option.List.cons warn oval.pre.injections }} | "-set" -> let opt, v = parse_option_set @@ next() in - add_set_option oval opt (Stm.OptionSet v) + add_set_option oval opt (OptionSet v) | "-unset" -> - add_set_option oval (to_opt_key @@ next ()) Stm.OptionUnset + add_set_option oval (to_opt_key @@ next ()) OptionUnset |"-native-output-dir" -> let native_output_dir = next () in @@ -494,49 +375,41 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = {oval.config with native_include_dirs = include_dir :: oval.config.native_include_dirs } } (* Options with zero arg *) - |"-async-queries-always-delegate" - |"-async-proofs-always-delegate" - |"-async-proofs-never-reopen-branch" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_never_reopen_branch = true - }}} |"-test-mode" -> Vernacinterp.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-bt" -> Exninfo.record_backtrace true; oval - |"-color" -> set_color oval (next ()) + |"-bt" -> add_set_debug oval "backtrace" |"-config"|"--config" -> set_query oval PrintConfig - |"-debug" -> Coqinit.set_debug (); oval - |"-xml-debug" -> Flags.xml_debug := true; Coqinit.set_debug (); oval + + |"-debug" -> add_set_debug oval "all" + |"-d" | "-D" -> add_set_debug oval (next()) + + (* -xml-debug implies -debug. TODO don't be imperative here. *) + |"-xml-debug" -> Flags.xml_debug := true; add_set_debug oval "all" + |"-diffs" -> - add_set_option oval Proof_diffs.opt_name @@ Stm.OptionSet (Some (next ())) - |"-stm-debug" -> Stm.stm_debug := true; oval + add_set_option oval Proof_diffs.opt_name @@ OptionSet (Some (next ())) |"-emacs" -> set_emacs oval |"-impredicative-set" -> set_logic (fun o -> { o with impredicative_set = Declarations.ImpredicativeSet }) oval |"-allow-sprop" -> - add_set_option oval Vernacentries.allow_sprop_opt_name (Stm.OptionSet None) + add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) |"-disallow-sprop" -> - add_set_option oval Vernacentries.allow_sprop_opt_name Stm.OptionUnset - |"-sprop-cumulative" -> - warn_deprecated_sprop_cumul(); - add_set_option oval Vernacentries.cumul_sprop_opt_name (Stm.OptionSet None) + add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval - |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} + |"-m"|"--memory" -> { oval with post = { memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} |"-boot" -> { oval with pre = { oval.pre with boot = true }} - |"-output-context" -> { oval with post = { oval.post with output_context = true }} |"-profile-ltac" -> Flags.profile_ltac := true; oval |"-q" -> { oval with pre = { oval.pre with load_rcfile = false; }} |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false; oval - |"-list-tags" -> set_query oval PrintTags |"-time" -> { oval with config = { oval.config with time = true }} - |"-type-in-type" -> set_type_in_type (); oval + |"-type-in-type" -> set_logic (fun o -> { o with type_in_type = true }) oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> set_query oval PrintWhere - |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp help) + |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp usage) |"-v"|"--version" -> set_query oval PrintVersion |"-print-version"|"--print-version" -> set_query oval PrintMachineReadableVersion @@ -552,8 +425,8 @@ let parse_args ~help ~init arglist : t * string list = with any -> fatal_error any (* We need to reverse a few lists *) -let parse_args ~help ~init args = - let opts, extra = parse_args ~help ~init args in +let parse_args ~usage ~init args = + let opts, extra = parse_args ~usage ~init args in let opts = { opts with pre = { opts.pre with @@ -572,13 +445,29 @@ let parse_args ~help ~init args = let prelude_data = "Prelude", Some "Coq", Some false let injection_commands opts = - if opts.pre.load_init then Stm.RequireInjection prelude_data :: opts.pre.injections else opts.pre.injections + if opts.pre.load_init then RequireInjection prelude_data :: opts.pre.injections else opts.pre.injections let build_load_path opts = let ml_path, vo_path = if opts.pre.boot then [],[] else let coqlib = Envars.coqlib () in - Coqinit.libs_init_load_path ~coqlib in + Coqloadpath.init_load_path ~coqlib in ml_path @ opts.pre.ml_includes , vo_path @ opts.pre.vo_includes + +let dirpath_of_file f = + let ldir0 = + try + let lp = Loadpath.find_load_path (Filename.dirname f) in + Loadpath.logical lp + with Not_found -> Libnames.default_root_prefix + in + let f = try Filename.chop_extension (Filename.basename f) with Invalid_argument _ -> f in + let id = Names.Id.of_string f in + let ldir = Libnames.add_dirpath_suffix ldir0 id in + ldir + +let dirpath_of_top = function + | TopPhysical f -> dirpath_of_file f + | TopLogical dp -> dp diff --git a/toplevel/coqargs.mli b/sysinit/coqargs.mli index f6222e4ec4..9725a849a4 100644 --- a/toplevel/coqargs.mli +++ b/sysinit/coqargs.mli @@ -8,29 +8,48 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type color = [`ON | `AUTO | `EMACS | `OFF] - val default_toplevel : Names.DirPath.t type native_compiler = Coq_config.native_compiler = NativeOff | NativeOn of { ondemand : bool } +type top = TopLogical of Names.DirPath.t | TopPhysical of string + +type option_command = + | OptionSet of string option + | OptionUnset + | OptionAppend of string + +type injection_command = + | OptionInjection of (Goptions.option_name * option_command) + (** Set flags or options before the initial state is ready. *) + | RequireInjection of (string * string option * bool option) + (** Require libraries before the initial state is + ready. Parameters follow [Library], that is to say, + [lib,prefix,import_export] means require library [lib] from + optional [prefix] and [import_export] if [Some false/Some true] + is used. *) + | WarnNoNative of string + (** Used so that "-w -native-compiler-disabled -native-compiler yes" + does not cause a warning. The native option must be processed + before injections (because it affects require), so the + instruction to emit a message is separated. *) + type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; - toplevel_name : Stm.interactive_top; + type_in_type : bool; + toplevel_name : top; } type coqargs_config = { logic : coqargs_logic_config; rcfile : string option; coqlib : string option; - color : color; enable_VM : bool; native_compiler : native_compiler; native_output_dir : CUnix.physical_path; native_include_dirs : CUnix.physical_path list; - stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; time : bool; print_emacs : bool; @@ -45,13 +64,11 @@ type coqargs_pre = { vo_includes : Loadpath.vo_path list; load_vernacular_list : (string * bool) list; - injections : Stm.injection_command list; - - inputstate : string option; + injections : injection_command list; } type coqargs_query = - | PrintTags | PrintWhere | PrintConfig + | PrintWhere | PrintConfig | PrintVersion | PrintMachineReadableVersion | PrintHelp of Usage.specific_usage @@ -61,7 +78,6 @@ type coqargs_main = type coqargs_post = { memory_stat : bool; - output_context : bool; } type t = { @@ -74,8 +90,20 @@ type t = { (* Default options *) val default : t -val parse_args : help:Usage.specific_usage -> init:t -> string list -> t * string list -val error_wrong_arg : string -> unit +val parse_args : usage:Usage.specific_usage -> init:t -> string list -> t * string list -val injection_commands : t -> Stm.injection_command list +val injection_commands : t -> injection_command list val build_load_path : t -> CUnix.physical_path list * Loadpath.vo_path list + +val dirpath_of_top : top -> Names.DirPath.t + +(* Common utilities *) + +val get_int : opt:string -> string -> int +val get_int_opt : opt:string -> string -> int option +val get_bool : opt:string -> string -> bool +val get_float : opt:string -> string -> float +val error_missing_arg : string -> 'a +val error_wrong_arg : string -> 'a + +val set_option : Goptions.option_name * option_command -> unit diff --git a/sysinit/coqinit.ml b/sysinit/coqinit.ml new file mode 100644 index 0000000000..25da2c5302 --- /dev/null +++ b/sysinit/coqinit.ml @@ -0,0 +1,142 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** GC tweaking *) + +(** Coq is a heavy user of persistent data structures and symbolic ASTs, so the + minor heap is heavily solicited. Unfortunately, the default size is far too + small, so we enlarge it a lot (128 times larger). + + To better handle huge memory consumers, we also augment the default major + heap increment and the GC pressure coefficient. +*) + +let set_gc_policy () = + Gc.set { (Gc.get ()) with + Gc.minor_heap_size = 32*1024*1024 (* 32Mwords x 8 bytes/word = 256Mb *) + ; Gc.space_overhead = 120 + } + +let set_gc_best_fit () = + Gc.set { (Gc.get ()) with + Gc.allocation_policy = 2 (* best-fit *) + ; Gc.space_overhead = 200 + } + +let init_gc () = + try + (* OCAMLRUNPARAM environment variable is set. + * In that case, we let ocamlrun to use the values provided by the user. + *) + ignore (Sys.getenv "OCAMLRUNPARAM") + + with Not_found -> + (* OCAMLRUNPARAM environment variable is not set. + * In this case, we put in place our preferred configuration. + *) + set_gc_policy (); + if Coq_config.caml_version_nums >= [4;10;0] then set_gc_best_fit () else () + +let init_ocaml () = + CProfile.init_profile (); + init_gc (); + Sys.catch_break false (* Ctrl-C is fatal during the initialisation *) + +let init_coqlib opts = match opts.Coqargs.config.Coqargs.coqlib with + | None when opts.Coqargs.pre.Coqargs.boot -> () + | None -> + Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + | Some s -> + Envars.set_user_coqlib s + +let print_query opts = let open Coqargs in function + | PrintVersion -> Usage.version () + | PrintMachineReadableVersion -> Usage.machine_readable_version () + | PrintWhere -> + let () = init_coqlib opts in + print_endline (Envars.coqlib ()) + | PrintHelp h -> Usage.print_usage stderr h + | PrintConfig -> + let () = init_coqlib opts in + Envars.print_config stdout Coq_config.all_src_dirs + +let parse_arguments ~parse_extra ~usage ?(initial_args=Coqargs.default) () = + let opts, extras = + Coqargs.parse_args ~usage ~init:initial_args + (List.tl (Array.to_list Sys.argv)) in + let customopts, extras = parse_extra extras in + if not (CList.is_empty extras) then begin + prerr_endline ("Don't know what to do with "^String.concat " " extras); + prerr_endline "See -help for the list of supported options"; + exit 1 + end; + match opts.Coqargs.main with + | Coqargs.Queries q -> List.iter (print_query opts) q; exit 0 + | Coqargs.Run -> opts, customopts + +let print_memory_stat () = + let open Pp in + (* -m|--memory from the command-line *) + Feedback.msg_notice + (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); + (* operf-macro interface: + https://github.com/OCamlPro/operf-macro *) + try + let fn = Sys.getenv "OCAML_GC_STATS" in + let oc = open_out fn in + Gc.print_stat oc; + close_out oc + with _ -> () + +let init_runtime opts = + let open Coqargs in + Lib.init (); + init_coqlib opts; + if opts.post.memory_stat then at_exit print_memory_stat; + Mltop.init_known_plugins (); + + (* Configuration *) + Global.set_engagement opts.config.logic.impredicative_set; + Global.set_indices_matter opts.config.logic.indices_matter; + Global.set_check_universes (not opts.config.logic.type_in_type); + Global.set_VM opts.config.enable_VM; + Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); + Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); + + (* Native output dir *) + Nativelib.output_dir := opts.config.native_output_dir; + Nativelib.include_dirs := opts.config.native_include_dirs; + + (* Paths for loading stuff *) + let ml_load_path, vo_load_path = Coqargs.build_load_path opts in + List.iter Mltop.add_ml_dir ml_load_path; + List.iter Loadpath.add_vo_path vo_load_path; + + injection_commands opts + +let require_file (dir, from, exp) = + let mp = Libnames.qualid_of_string dir in + let mfrom = Option.map Libnames.qualid_of_string from in + Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] + +let warn_no_native_compiler = + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + Pp.(fun s -> strbrk "Native compiler is disabled," ++ + strbrk " -native-compiler " ++ strbrk s ++ + strbrk " option ignored.") + +let handle_injection = let open Coqargs in function + | RequireInjection r -> require_file r + | OptionInjection o -> set_option o + | WarnNoNative s -> warn_no_native_compiler s + +let start_library ~top injections = + Flags.verbosely Declaremods.start_library top; + List.iter handle_injection injections diff --git a/sysinit/coqinit.mli b/sysinit/coqinit.mli new file mode 100644 index 0000000000..bea2186d81 --- /dev/null +++ b/sysinit/coqinit.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Main etry point to the sysinit component, all other modules are private. + + The following API shoud be called in order, and the first 3 steps only once + since they initialize global data. On the contrary step 4 can be called + many times to init the compilation of a unit. +*) + +(** 1 initialization of OCaml's runtime + + Profiling, GC parameters and signals. Nothing specific to Coq per se, but + the defaults here are good for Coq. + This API should be called up very early, or not at all. *) +val init_ocaml : unit -> unit + +(** 2 parsing of Sys.argv + + This API parses command line options which are known by Coq components. + Ideally it is functional, but some values in the `Flags` modules are set + on the spot instead of being represented as "injection commands" (a field + of Coqargs.t). + + [parse_extra] and [usage] can be used to parse/document more options. *) +val parse_arguments : + parse_extra:(string list -> 'a * string list) -> + usage:Usage.specific_usage -> + ?initial_args:Coqargs.t -> + unit -> + Coqargs.t * 'a + +(** 3 initialization of global runtime data + + All global setup is done here, like COQLIB and the paths for native + compilation. If Coq is used to process multiple libraries, what is set up + here is really global and common to all of them. + + The returned injections are options (as in "Set This Thing" or "Require + that") as specified on the command line. + The prelude is one of these (unless "-nois" is passed). + + This API must be called, typically jsut after parsing arguments. *) +val init_runtime : Coqargs.t -> Coqargs.injection_command list + +(** 4 Start a library (sets options and loads objects like the prelude) + + Given the logical name [top] of the current library and the set of initial + options and required libraries, it starts its processing (see also + Declaremods.start_library) *) +val start_library : top:Names.DirPath.t -> Coqargs.injection_command list -> unit diff --git a/toplevel/coqinit.ml b/sysinit/coqloadpath.ml index 501047c520..95ae5da3de 100644 --- a/toplevel/coqinit.ml +++ b/sysinit/coqloadpath.ml @@ -13,44 +13,6 @@ open Pp let ( / ) s1 s2 = Filename.concat s1 s2 -let set_debug () = - let () = Exninfo.record_backtrace true in - Flags.debug := true - -(* Loading of the resource file. - rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one - does not exist. *) - -let rcdefaultname = "coqrc" - -let load_rcfile ~rcfile ~state = - try - match rcfile with - | Some rcfile -> - if CUnix.file_readable_p rcfile then - Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state rcfile - else raise (Sys_error ("Cannot read rcfile: "^ rcfile)) - | None -> - try - let warn x = Feedback.msg_warning (str x) in - let inferedrc = List.find CUnix.file_readable_p [ - Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; - Envars.xdg_config_home warn / rcdefaultname; - Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; - Envars.home ~warn / "."^rcdefaultname - ] in - Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state inferedrc - with Not_found -> state - (* - Flags.if_verbose - mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ - " found. Skipping rcfile loading.")) - *) - with reraise -> - let reraise = Exninfo.capture reraise in - let () = Feedback.msg_info (str"Load of rcfile failed.") in - Exninfo.iraise reraise - (* Recursively puts `.v` files in the LoadPath *) let build_stdlib_vo_path ~unix_path ~coq_path = let open Loadpath in @@ -73,7 +35,7 @@ let build_userlib_path ~unix_path = else [], [] (* LoadPath for Coq user libraries *) -let libs_init_load_path ~coqlib = +let init_load_path ~coqlib = let open Loadpath in let user_contrib = coqlib/"user-contrib" in @@ -82,8 +44,18 @@ let libs_init_load_path ~coqlib = let coq_path = Names.DirPath.make [Libnames.coq_root] in (* ML includes *) - let plugins_dirs = System.all_subdirs ~unix_path:(coqlib/"plugins") |> List.map fst in - + let unix_path = + (* Usually lib/coq-stdlib/../plugins ; this kind of hacks with the + ML path should go away once we use ocamlfind to load plugins *) + CPath.choose_existing + [ CPath.make [ coqlib ; "plugins" ] + ; CPath.make [ coqlib ; ".."; "coq-core"; "plugins" ] + ] |> function + | None -> + CErrors.user_err (Pp.str "Cannot find plugins directory") + | Some f -> (f :> string) + in + let plugins_dirs = System.all_subdirs ~unix_path |> List.map fst in let contrib_ml, contrib_vo = build_userlib_path ~unix_path:user_contrib in let misc_ml, misc_vo = diff --git a/toplevel/coqinit.mli b/sysinit/coqloadpath.mli index b96a0ef162..d853e9ea54 100644 --- a/toplevel/coqinit.mli +++ b/sysinit/coqloadpath.mli @@ -8,15 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Initialization. *) - -val set_debug : unit -> unit - -val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t - (** Standard LoadPath for Coq user libraries; in particular it includes (in-order) Coq's standard library, Coq's [user-contrib] folder, and directories specified in [COQPATH] and [XDG_DIRS] *) -val libs_init_load_path +val init_load_path : coqlib:CUnix.physical_path -> CUnix.physical_path list * Loadpath.vo_path list diff --git a/sysinit/dune b/sysinit/dune new file mode 100644 index 0000000000..f882f987ff --- /dev/null +++ b/sysinit/dune @@ -0,0 +1,6 @@ +(library + (name sysinit) + (public_name coq-core.sysinit) + (synopsis "Coq's initialization") + (wrapped false) + (libraries coq-core.vernac)) diff --git a/sysinit/sysinit.mllib b/sysinit/sysinit.mllib new file mode 100644 index 0000000000..6e86536648 --- /dev/null +++ b/sysinit/sysinit.mllib @@ -0,0 +1,4 @@ +Usage +Coqloadpath +Coqargs +Coqinit diff --git a/toplevel/usage.ml b/sysinit/usage.ml index 6fb5f821ee..d00b916f23 100644 --- a/toplevel/usage.ml +++ b/sysinit/usage.ml @@ -9,9 +9,8 @@ (************************************************************************) let version () = - Printf.printf "The Coq Proof Assistant, version %s (%s)\n" - Coq_config.version Coq_config.date; - Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version + Printf.printf "The Coq Proof Assistant, version %s\n" Coq_config.version; + Printf.printf "compiled with OCaml %s\n" Coq_config.caml_version let machine_readable_version () = Printf.printf "%s %s\n" @@ -74,13 +73,11 @@ let print_usage_common co command = \n -debug debug mode (implies -bt)\ \n -xml-debug debug mode and print XML messages to/from coqide\ \n -diffs (on|off|removed) highlight differences between proof steps\ -\n -stm-debug STM debug mode (will trace every transaction)\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ \n -allow-sprop allow using the proof irrelevant SProp sort\ \n -disallow-sprop forbid using the proof irrelevant SProp sort\ -\n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ diff --git a/toplevel/usage.mli b/sysinit/usage.mli index cbc3b4f7e8..2d1a8e94cc 100644 --- a/toplevel/usage.mli +++ b/sysinit/usage.mli @@ -26,4 +26,3 @@ type specific_usage = { given executable. } *) val print_usage : out_channel -> specific_usage -> unit - diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 6fb6cff04f..167f7d4026 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -562,19 +562,18 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in let open ReductionBehaviour in let rec whrec cst_l (x, stack) = - let () = if debug_RAKAM () then + let () = debug_RAKAM (fun () -> let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_debug (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str ">>"))) in let c0 = EConstr.kind sigma x in let fold () = - let () = if debug_RAKAM () then - let open Pp in Feedback.msg_debug (str "<><><><><>") in + let () = debug_RAKAM (fun () -> + Pp.(str "<><><><><>")) in ((EConstr.of_kind c0, stack),cst_l) in match c0 with diff --git a/tactics/dune b/tactics/dune index 908dde5253..29378f52d1 100644 --- a/tactics/dune +++ b/tactics/dune @@ -1,6 +1,6 @@ (library (name tactics) (synopsis "Coq's Core Tactics [ML implementation]") - (public_name coq.tactics) + (public_name coq-core.tactics) (wrapped false) (libraries printing)) diff --git a/tactics/elim.ml b/tactics/elim.ml index 9a55cabc86..9e7843b2bb 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -19,7 +19,6 @@ open Tacmach.New open Tacticals.New open Clenv open Tactics -open Proofview.Notations type branch_args = { branchnum : int; (* the branch number *) @@ -28,8 +27,6 @@ type branch_args = { true=assumption, false=let-in *) branchnames : Tactypes.intro_patterns} -module NamedDecl = Context.Named.Declaration - type elim_kind = Case of bool | Elim (* Find the right elimination suffix corresponding to the sort of the goal *) @@ -217,52 +214,3 @@ let h_decompose l c = decompose_these c l let h_decompose_or = decompose_or let h_decompose_and = decompose_and - -(* The tactic Double performs a double induction *) - -let induction_trailer abs_i abs_j bargs = - tclTHEN - (tclDO (abs_j - abs_i) intro) - (onLastHypId - (fun id -> - Proofview.Goal.enter begin fun gl -> - let idty = pf_get_type_of gl (mkVar id) in - let fvty = global_vars (pf_env gl) (project gl) idty in - let possible_bring_hyps = - (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs - in - let (hyps,_) = - List.fold_left - (fun (bring_ids,leave_ids) d -> - let cid = NamedDecl.get_id d in - if not (List.mem cid leave_ids) - then (d::bring_ids,leave_ids) - else (bring_ids,cid::leave_ids)) - ([],fvty) possible_bring_hyps - in - let ids = List.rev (ids_of_named_context hyps) in - (tclTHENLIST - [revert ids; elimination_then (fun _ -> tclIDTAC) id]) - end - )) - -let double_ind h1 h2 = - Proofview.Goal.enter begin fun gl -> - let abs_i = depth_of_quantified_hypothesis true h1 gl in - let abs_j = depth_of_quantified_hypothesis true h2 gl in - let abs = - if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else - if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else - let info = Exninfo.reify () in - tclZEROMSG ~info (Pp.str "Both hypotheses are the same.") in - abs >>= fun (abs_i,abs_j) -> - (tclTHEN (tclDO abs_i intro) - (onLastHypId - (fun id -> - elimination_then - (introElimAssumsThen (induction_trailer abs_i abs_j)) id))) - end - -let h_double_induction = double_ind - - diff --git a/tactics/elim.mli b/tactics/elim.mli index 01053502e4..a603b472f7 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -21,4 +21,3 @@ val case_tac : bool -> or_and_intro_pattern option -> val h_decompose : inductive list -> constr -> unit Proofview.tactic val h_decompose_or : constr -> unit Proofview.tactic val h_decompose_and : constr -> unit Proofview.tactic -val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic diff --git a/tactics/hints.ml b/tactics/hints.ml index 058602acfd..5e9c3baeb1 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1019,18 +1019,6 @@ let remove_hint dbname grs = let db' = Hint_db.remove_list env grs db in searchtable_add (dbname, db') -type hint_action = - | CreateDB of bool * TransparentState.t - | AddTransparency of { - superglobal : bool; - grefs : evaluable_global_reference hints_transparency_target; - state : bool; - } - | AddHints of { superglobal : bool; hints : hint_entry list } - | RemoveHints of { superglobal : bool; hints : GlobRef.t list } - | AddCut of { superglobal : bool; paths : hints_path } - | AddMode of { superglobal : bool; gref : GlobRef.t; mode : hint_mode array } - let add_cut dbname path = let db = get_db dbname in let db' = Hint_db.add_cut path db in @@ -1041,30 +1029,72 @@ let add_mode dbname l m = let db' = Hint_db.add_mode l m db in searchtable_add (dbname, db') +type db_obj = { + db_local : bool; + db_name : string; + db_use_dn : bool; + db_ts : TransparentState.t; +} + +let cache_db (_, {db_name=name; db_use_dn=b; db_ts=ts}) = + searchtable_add (name, Hint_db.empty ~name ts b) + +let load_db _ x = cache_db x + +let classify_db db = if db.db_local then Dispose else Substitute db + +let inDB : db_obj -> obj = + declare_object {(default_object "AUTOHINT_DB") with + cache_function = cache_db; + load_function = load_db; + subst_function = (fun (_,x) -> x); + classify_function = classify_db; } + +let create_hint_db l n ts b = + let hint = {db_local=l; db_name=n; db_use_dn=b; db_ts=ts} in + Lib.add_anonymous_leaf (inDB hint) + +type hint_action = + | AddTransparency of { + grefs : evaluable_global_reference hints_transparency_target; + state : bool; + } + | AddHints of hint_entry list + | RemoveHints of GlobRef.t list + | AddCut of hints_path + | AddMode of { gref : GlobRef.t; mode : hint_mode array } + +type hint_locality = Local | Export | SuperGlobal + type hint_obj = { - hint_local : bool; + hint_local : hint_locality; hint_name : string; hint_action : hint_action; } +let superglobal h = match h.hint_local with + | SuperGlobal -> true + | Local | Export -> false + let load_autohint _ (kn, h) = let name = h.hint_name in + let superglobal = superglobal h in match h.hint_action with - | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) - | AddTransparency { superglobal; grefs; state } -> + | AddTransparency { grefs; state } -> if superglobal then add_transparency name grefs state - | AddHints { superglobal; hints } -> + | AddHints hints -> if superglobal then add_hint name hints - | RemoveHints { superglobal; hints } -> + | RemoveHints hints -> if superglobal then remove_hint name hints - | AddCut { superglobal; paths } -> + | AddCut paths -> if superglobal then add_cut name paths - | AddMode { superglobal; gref; mode } -> + | AddMode { gref; mode } -> if superglobal then add_mode name gref mode let open_autohint i (kn, h) = + let superglobal = superglobal h in if Int.equal i 1 then match h.hint_action with - | AddHints { superglobal; hints } -> + | AddHints hints -> let () = if not superglobal then (* Import-bound hints must be declared when not imported yet *) @@ -1073,15 +1103,14 @@ let open_autohint i (kn, h) = in let add (_, hint) = statustable := KNmap.add hint.code.uid true !statustable in List.iter add hints - | AddCut { superglobal; paths } -> + | AddCut paths -> if not superglobal then add_cut h.hint_name paths - | AddTransparency { superglobal; grefs; state } -> + | AddTransparency { grefs; state } -> if not superglobal then add_transparency h.hint_name grefs state - | RemoveHints { superglobal; hints } -> + | RemoveHints hints -> if not superglobal then remove_hint h.hint_name hints - | AddMode { superglobal; gref; mode } -> + | AddMode { gref; mode } -> if not superglobal then add_mode h.hint_name gref mode - | CreateDB _ -> () let cache_autohint (kn, obj) = load_autohint 1 (kn, obj); open_autohint 1 (kn, obj) @@ -1137,8 +1166,7 @@ let subst_autohint (subst, obj) = if k' == k && data' == data then hint else (k',data') in let action = match obj.hint_action with - | CreateDB _ -> obj.hint_action - | AddTransparency { superglobal; grefs = target; state = b } -> + | AddTransparency { grefs = target; state = b } -> let target' = match target with | HintsVariables -> target @@ -1148,26 +1176,28 @@ let subst_autohint (subst, obj) = if grs == grs' then target else HintsReferences grs' in - if target' == target then obj.hint_action else AddTransparency { superglobal; grefs = target'; state = b } - | AddHints { superglobal; hints } -> + if target' == target then obj.hint_action else AddTransparency { grefs = target'; state = b } + | AddHints hints -> let hints' = List.Smart.map subst_hint hints in - if hints' == hints then obj.hint_action else AddHints { superglobal; hints = hints' } - | RemoveHints { superglobal; hints = grs } -> + if hints' == hints then obj.hint_action else AddHints hints' + | RemoveHints grs -> let grs' = List.Smart.map (subst_global_reference subst) grs in - if grs == grs' then obj.hint_action else RemoveHints { superglobal; hints = grs' } - | AddCut { superglobal; paths = path } -> + if grs == grs' then obj.hint_action else RemoveHints grs' + | AddCut path -> let path' = subst_hints_path subst path in - if path' == path then obj.hint_action else AddCut { superglobal; paths = path' } - | AddMode { superglobal; gref = l; mode = m } -> + if path' == path then obj.hint_action else AddCut path' + | AddMode { gref = l; mode = m } -> let l' = subst_global_reference subst l in - if l' == l then obj.hint_action else AddMode { superglobal; gref = l'; mode = m } + if l' == l then obj.hint_action else AddMode { gref = l'; mode = m } in if action == obj.hint_action then obj else { obj with hint_action = action } let classify_autohint obj = match obj.hint_action with - | AddHints { hints = [] } -> Dispose - | _ -> if obj.hint_local then Dispose else Substitute obj + | AddHints [] -> Dispose + | _ -> match obj.hint_local with + | Local -> Dispose + | Export | SuperGlobal -> Substitute obj let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with @@ -1177,16 +1207,12 @@ let inAutoHint : hint_obj -> obj = subst_function = subst_autohint; classify_function = classify_autohint; } -let make_hint ?(local = false) name action = { +let make_hint ~local name action = { hint_local = local; hint_name = name; hint_action = action; } -let create_hint_db l n st b = - let hint = make_hint ~local:l n (CreateDB (b, st)) in - Lib.add_anonymous_leaf (inAutoHint hint) - let warn_deprecated_hint_without_locality = CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" (fun () -> strbrk "The default value for hint locality is currently \ @@ -1210,16 +1236,16 @@ let check_hint_locality = let open Goptions in function | OptLocal -> () let interp_locality = function -| Goptions.OptDefault | Goptions.OptGlobal -> false, true -| Goptions.OptExport -> false, false -| Goptions.OptLocal -> true, false +| Goptions.OptDefault | Goptions.OptGlobal -> SuperGlobal +| Goptions.OptExport -> Export +| Goptions.OptLocal -> Local let remove_hints ~locality dbnames grs = - let local, superglobal = interp_locality locality in + let local = interp_locality locality in let dbnames = if List.is_empty dbnames then ["core"] else dbnames in List.iter (fun dbname -> - let hint = make_hint ~local dbname (RemoveHints { superglobal; hints = grs }) in + let hint = make_hint ~local dbname (RemoveHints grs) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1227,7 +1253,7 @@ let remove_hints ~locality dbnames grs = (* The "Hint" vernacular command *) (**************************************************************************) -let add_resolves env sigma clist ~local ~superglobal dbnames = +let add_resolves env sigma clist ~local dbnames = List.iter (fun dbname -> let r = @@ -1254,56 +1280,56 @@ let add_resolves env sigma clist ~local ~superglobal dbnames = | _ -> () in let () = if not !Flags.quiet then List.iter check r in - let hint = make_hint ~local dbname (AddHints { superglobal; hints = r }) in + let hint = make_hint ~local dbname (AddHints r) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_unfolds l ~local ~superglobal dbnames = +let add_unfolds l ~local dbnames = List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddHints { superglobal; hints = List.map make_unfold l }) in + let hint = make_hint ~local dbname (AddHints (List.map make_unfold l)) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_cuts l ~local ~superglobal dbnames = +let add_cuts l ~local dbnames = List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddCut { superglobal; paths = l }) in + let hint = make_hint ~local dbname (AddCut l) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_mode l m ~local ~superglobal dbnames = +let add_mode l m ~local dbnames = List.iter (fun dbname -> let m' = make_mode l m in - let hint = make_hint ~local dbname (AddMode { superglobal; gref = l; mode = m' }) in + let hint = make_hint ~local dbname (AddMode { gref = l; mode = m' }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_transparency l b ~local ~superglobal dbnames = +let add_transparency l b ~local dbnames = List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddTransparency { superglobal; grefs = l; state = b }) in + let hint = make_hint ~local dbname (AddTransparency { grefs = l; state = b }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_extern info tacast ~local ~superglobal dbname = +let add_extern info tacast ~local dbname = let pat = match info.hint_pattern with | None -> None | Some (_, pat) -> Some pat in let hint = make_hint ~local dbname - (AddHints { superglobal; hints = [make_extern (Option.get info.hint_priority) pat tacast] }) in + (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) -let add_externs info tacast ~local ~superglobal dbnames = - List.iter (add_extern info tacast ~local ~superglobal) dbnames +let add_externs info tacast ~local dbnames = + List.iter (add_extern info tacast ~local) dbnames -let add_trivials env sigma l ~local ~superglobal dbnames = +let add_trivials env sigma l ~local dbnames = List.iter (fun dbname -> let l = List.map (fun (name, c) -> make_trivial env sigma ~name c) l in - let hint = make_hint ~local dbname (AddHints { superglobal; hints = l }) in + let hint = make_hint ~local dbname (AddHints l) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1360,22 +1386,22 @@ let prepare_hint check env init (sigma,c) = (c', diff) let add_hints ~locality dbnames h = - let local, superglobal = interp_locality locality in + let local = interp_locality locality in if String.List.mem "nocore" dbnames then user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); assert (not (List.is_empty dbnames)); let env = Global.env() in let sigma = Evd.from_env env in match h with - | HintsResolveEntry lhints -> add_resolves env sigma lhints ~local ~superglobal dbnames - | HintsImmediateEntry lhints -> add_trivials env sigma lhints ~local ~superglobal dbnames - | HintsCutEntry lhints -> add_cuts lhints ~local ~superglobal dbnames - | HintsModeEntry (l,m) -> add_mode l m ~local ~superglobal dbnames - | HintsUnfoldEntry lhints -> add_unfolds lhints ~local ~superglobal dbnames + | HintsResolveEntry lhints -> add_resolves env sigma lhints ~local dbnames + | HintsImmediateEntry lhints -> add_trivials env sigma lhints ~local dbnames + | HintsCutEntry lhints -> add_cuts lhints ~local dbnames + | HintsModeEntry (l,m) -> add_mode l m ~local dbnames + | HintsUnfoldEntry lhints -> add_unfolds lhints ~local dbnames | HintsTransparencyEntry (lhints, b) -> - add_transparency lhints b ~local ~superglobal dbnames + add_transparency lhints b ~local dbnames | HintsExternEntry (info, tacexp) -> - add_externs info tacexp ~local ~superglobal dbnames + add_externs info tacexp ~local dbnames let hint_globref gr = IsGlobRef gr diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c64f583428..cbf12ac22f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -156,9 +156,6 @@ let convert_hyp ~check ~reorder d = end end -let convert_concl_no_check = convert_concl ~check:false -let convert_hyp_no_check = convert_hyp ~check:false ~reorder:false - let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with diff --git a/tactics/tactics.mli b/tactics/tactics.mli index a6471be549..c07073a91a 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -35,10 +35,6 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool val introduction : Id.t -> unit Proofview.tactic val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : check:bool -> reorder:bool -> named_declaration -> unit Proofview.tactic -val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic -[@@ocaml.deprecated "use [Tactics.convert_concl]"] -val convert_hyp_no_check : named_declaration -> unit Proofview.tactic -[@@ocaml.deprecated "use [Tactics.convert_hyp]"] val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t -> int -> unit Proofview.tactic @@ -81,11 +77,6 @@ val auto_intros_tac : Names.Name.t list -> unit Proofview.tactic val intros : unit Proofview.tactic -(** [depth_of_quantified_hypothesis b h g] returns the index of [h] in - the conclusion of goal [g], up to head-reduction if [b] is [true] *) -val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> Proofview.Goal.t -> int - val intros_until : quantified_hypothesis -> unit Proofview.tactic val intros_clearing : bool list -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index 245c717d42..2a2f62e23f 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -46,7 +46,11 @@ BIN := $(ROOT)/bin/ COQLIB?= ifeq ($(COQLIB),) + ifeq ($(LOCAL),true) COQLIB := $(shell ocaml ocaml_pwd.ml ..) + else + COQLIB := $(shell ocaml ocaml_pwd.ml $(COQLIBINSTALL)) + endif endif endif # exists ../_build export COQLIB @@ -320,7 +324,7 @@ unit-tests: $(UNIT_LOGFILES) # Build executable, run it to generate log file unit-tests/%.ml.log: unit-tests/%.ml unit-tests/src/$(UNIT_LINK) $(SHOW) 'TEST $<' - $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,ounit2 \ + $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq-core.toplevel,ounit2 \ -I unit-tests/src $(UNIT_LINK) $< -o $<.test; $(HIDE)./$<.test diff --git a/test-suite/bugs/closed/bug_13732.v b/test-suite/bugs/closed/bug_13732.v new file mode 100644 index 0000000000..24840abdf6 --- /dev/null +++ b/test-suite/bugs/closed/bug_13732.v @@ -0,0 +1,16 @@ +Module Sort. + Set Printing Universes. + + Implicit Types TT : Type. + + Check fun TT => nat. +End Sort. + +Module Ref. + Set Universe Polymorphism. + + Axiom tele : Type. + + Implicit Types TT : tele. + Check fun TT => nat. +End Ref. diff --git a/test-suite/bugs/closed/bug_13755.v b/test-suite/bugs/closed/bug_13755.v new file mode 100644 index 0000000000..cc25157b9b --- /dev/null +++ b/test-suite/bugs/closed/bug_13755.v @@ -0,0 +1,5 @@ +Module M1. +Lemma t1 : True. +Fail End M1. +Proof. exact I. Qed. +End M1. diff --git a/test-suite/bugs/closed/bug_4836.v b/test-suite/bugs/closed/bug_4836.v index 9aefb10172..62d39619b0 100644 --- a/test-suite/bugs/closed/bug_4836.v +++ b/test-suite/bugs/closed/bug_4836.v @@ -1 +1 @@ -(* -*- coq-prog-args: ("bugs/closed/PLACEHOLDER.v") -*- *) +(* Placeholder file for directory / file test *) diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in index 47d0e09e1a..258eb04271 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in @@ -744,7 +744,7 @@ CONTRIBUTING.md CREDITS INSTALL.md LICENSE -META.coq.in +META.coq-core.in Makefile Makefile.build Makefile.checker @@ -5626,4 +5626,4 @@ ValueError: too many values to unpack Makefile.ci:90: recipe for target 'ci-metacoq' failed make: *** [ci-metacoq] Error 1 section_end:1598965182:build_script
[0Ksection_start:1598965182:after_script
[0Ksection_end:1598965184:after_script
[0Ksection_start:1598965184:upload_artifacts_on_failure
[0Ksection_end:1598965189:upload_artifacts_on_failure
[0K[31;1mERROR: Job failed: exit code 1 -[0;m
\ No newline at end of file +[0;m diff --git a/test-suite/dune b/test-suite/dune index 1864153021..09597fc864 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -35,7 +35,8 @@ ; For the changelog test ../config/coq_config.py (source_tree doc/changelog) - (package coq) + (package coq-core) + (package coq-stdlib) ; For fake_ide (package coqide-server) (source_tree .)) diff --git a/test-suite/micromega/bug_13794.v b/test-suite/micromega/bug_13794.v new file mode 100644 index 0000000000..5e303a0b7f --- /dev/null +++ b/test-suite/micromega/bug_13794.v @@ -0,0 +1,39 @@ +From Coq Require Import Lia ZArith.ZArith NArith.NArith. +Unset Nia Cache. + +Open Scope N_scope. + + +Lemma over (n0 n1 n2 n3 n4 n5 n6 : N) + (e0 : 1 + 8 * n0 = n1 * n1 + n2) + (e1 : n1 - 1 = 2 * n3 + n4) + (e2 : n3 * (1 + n3) = 2 * n5) + (e3 : n2 + 2 * n4 * n1 - n4 = 8 * n6) + (o0 : n4 = 0 \/ n4 = 1) : + n6 = n0 - n5. +Proof. + Time nia. +Qed. + +Lemma over2 (n0 n1 n2 n3 n4 n5 n6 : N) + (e0 : 1 + 8 * n0 = n1 * n1 + n2) + (e1 : n1 + 1 = 2 * n3 + n4) + (e2 : n3 * (1 + n3) = 2 * n5) + (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n6) + (o0 : n4 = 0) : + n6 = n0 + n5. +Proof. + Fail nia. +Abort. + +Open Scope Z_scope. + +Lemma over3 (n1 n2 n3 n4 n5 : Z) + (e : 0 <= n1 /\ 0 <= n2 /\ 0 <= n3 /\ 0 <= n4 + /\ 0 <= n5) + (e1 : n1 + 1 = 20 * n3 + n4) + (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n5) : + n5 = 0. +Proof. +Time Fail nia. +Abort. diff --git a/test-suite/misc/coq_environment.sh b/test-suite/misc/coq_environment.sh index 667d11f89e..6f7b11c8f1 100755 --- a/test-suite/misc/coq_environment.sh +++ b/test-suite/misc/coq_environment.sh @@ -16,7 +16,7 @@ EOT cp $BIN/coqc . cp $BIN/coq_makefile . mkdir -p overridden/tools/ -cp $COQLIB/tools/CoqMakefile.in overridden/tools/ +cp $COQLIB/tools/CoqMakefile.in overridden/tools/ || cp $COQLIB/../coq-core/tools/CoqMakefile.in overridden/tools/ unset COQLIB N=`./coqc -config | grep COQLIB | grep /overridden | wc -l` diff --git a/test-suite/misc/coqtop_print-mod-uid.sh b/test-suite/misc/coqtop_print-mod-uid.sh new file mode 100755 index 0000000000..db1df4bb4b --- /dev/null +++ b/test-suite/misc/coqtop_print-mod-uid.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +[ "$(coqtop -print-mod-uid prerequisite/admit.vo)" = "prerequisite/.coq-native/NTestSuite_admit" ] diff --git a/test-suite/misc/non-marshalable-state.sh b/test-suite/misc/non-marshalable-state.sh new file mode 100755 index 0000000000..eef7786ebc --- /dev/null +++ b/test-suite/misc/non-marshalable-state.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash + +set -e + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +cd misc/non-marshalable-state/ + +coq_makefile -f _CoqProject -o Makefile + +make clean + +make src/evil_plugin.cmxs +make src/good_plugin.cmxs + +RC=1 +# must fail +coqc -async-proofs on -I src -Q theories Marshal theories/evil.v 2> log1 1>&2 || RC=0 +# for this reason +grep -q 'Marshalling error' log1 || RC=1 + +# must work +coqc -async-proofs off -I src -Q theories Marshal theories/evil.v + +# must work +coqc -async-proofs on -I src -Q theories Marshal theories/good.v + + +exit $RC diff --git a/test-suite/misc/non-marshalable-state/_CoqProject b/test-suite/misc/non-marshalable-state/_CoqProject new file mode 100644 index 0000000000..09e68d866c --- /dev/null +++ b/test-suite/misc/non-marshalable-state/_CoqProject @@ -0,0 +1,9 @@ +-Q theories Marshal +-I src + +src/evil.mlg +src/good.mlg +src/evil_plugin.mlpack +src/good_plugin.mlpack +theories/evil.v +theories/good.v diff --git a/test-suite/misc/non-marshalable-state/src/evil.mlg b/test-suite/misc/non-marshalable-state/src/evil.mlg new file mode 100644 index 0000000000..59b2b5a8ac --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/evil.mlg @@ -0,0 +1,15 @@ +DECLARE PLUGIN "evil_plugin" + +{ + +let state = Summary.ref + ~name:"elpi-compiler-cache" + None + +} + +VERNAC COMMAND EXTEND magic CLASSIFIED AS SIDEFF +| [ "magic" ] -> { + state := Some (fun () -> ()) +} +END diff --git a/test-suite/misc/non-marshalable-state/src/evil_plugin.mlpack b/test-suite/misc/non-marshalable-state/src/evil_plugin.mlpack new file mode 100644 index 0000000000..6382aa69e1 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/evil_plugin.mlpack @@ -0,0 +1 @@ +Evil diff --git a/test-suite/misc/non-marshalable-state/src/good.mlg b/test-suite/misc/non-marshalable-state/src/good.mlg new file mode 100644 index 0000000000..c6b9cbefd5 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/good.mlg @@ -0,0 +1,16 @@ +DECLARE PLUGIN "good_plugin" + +{ + +let state = Summary.Local.ref + ~name:"elpi-compiler-cache" + None + +} + +VERNAC COMMAND EXTEND magic CLASSIFIED AS SIDEFF +| [ "magic" ] -> { + let open Summary.Local in + state := Some (fun () -> ()) +} +END diff --git a/test-suite/misc/non-marshalable-state/src/good_plugin.mlpack b/test-suite/misc/non-marshalable-state/src/good_plugin.mlpack new file mode 100644 index 0000000000..cd9dd73b78 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/good_plugin.mlpack @@ -0,0 +1 @@ +Good diff --git a/test-suite/misc/non-marshalable-state/theories/evil.v b/test-suite/misc/non-marshalable-state/theories/evil.v new file mode 100644 index 0000000000..661482a975 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/theories/evil.v @@ -0,0 +1,5 @@ +Declare ML Module "evil_plugin". + +magic. + +Lemma x : True. Proof. trivial. Qed. diff --git a/test-suite/misc/non-marshalable-state/theories/good.v b/test-suite/misc/non-marshalable-state/theories/good.v new file mode 100644 index 0000000000..eab9a043e1 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/theories/good.v @@ -0,0 +1,5 @@ +Declare ML Module "good_plugin". + +magic. + +Lemma x : True. Proof. trivial. Qed. diff --git a/test-suite/output/DebugFlags.out b/test-suite/output/DebugFlags.out new file mode 100644 index 0000000000..0385413937 --- /dev/null +++ b/test-suite/output/DebugFlags.out @@ -0,0 +1,44 @@ +File "stdin", line 1, characters 0-16: +Warning: There is no debug flag "cbn". [unknown-debug-flag,option] +Debug: [RAKAM] <<forall A : Type, A -> A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<forall A : Type, A -> A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<?A -> ?A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<?A -> ?A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> Prop|>> +Debug: [RAKAM] <><><><><> +2 + 3 = 0 + : Prop diff --git a/test-suite/output/DebugFlags.v b/test-suite/output/DebugFlags.v new file mode 100644 index 0000000000..32c0f2d24b --- /dev/null +++ b/test-suite/output/DebugFlags.v @@ -0,0 +1,5 @@ +Set Debug "cbn". + +Set Debug "RAKAM". + +Check 2 + 3 = 0. diff --git a/test-suite/bugs/closed/PLACEHOLDER.v b/test-suite/output/Function.out index e69de29bb2..e69de29bb2 100644 --- a/test-suite/bugs/closed/PLACEHOLDER.v +++ b/test-suite/output/Function.out diff --git a/test-suite/output/Function.v b/test-suite/output/Function.v new file mode 100644 index 0000000000..b3e2a93895 --- /dev/null +++ b/test-suite/output/Function.v @@ -0,0 +1,31 @@ +Require Import FunInd List. + +(* Explanations: This kind of pattern matching displays a legitimate + unused variable warning in v8.13. + +Fixpoint f (l:list nat) : nat := + match l with + | nil => O + | S n :: nil => 1 + | x :: l' => f l' + end. +*) + +(* In v8.13 the same code with "Function" generates a lot more + warnings about variables created automatically by Function. These + are not legitimate. PR #13776 (post v8.13) removes all warnings + about pattern matching variables (and non truly recursive fixpoint) + for "Function". So this should not generate any warning. Note that + this PR removes also the legitimate warnings. It would be better if + this test generate the same warning as the Fixpoint above. This + test would then need to be updated. *) + +(* Ensuring the warning is a warning. *) +Set Warnings "matching-variable". +(* But no warning generated here. *) +Function f (l:list nat) : nat := + match l with + | nil => O + | S n :: nil => 1 + | n :: l' => f l' + end. diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out index 7ca4de1e46..96af456891 100644 --- a/test-suite/output/Int63Syntax.out +++ b/test-suite/output/Int63Syntax.out @@ -15,9 +15,9 @@ 427 : int The command has indeed failed with message: -Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.PrimInt63.int +Cannot interpret this number as a value of type int The command has indeed failed with message: -Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.PrimInt63.int +Cannot interpret this number as a value of type int 0 : int 0 @@ -33,9 +33,11 @@ The reference x was not found in the current environment. add 2 2 : int The command has indeed failed with message: -int63 are only non-negative numbers. +Cannot interpret this number as a value of type int The command has indeed failed with message: overflow in int63 literal: 9223372036854775808 +0x1 + : int 2 : nat 2%int63 diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v index 50910264f2..be0ee701af 100644 --- a/test-suite/output/Int63Syntax.v +++ b/test-suite/output/Int63Syntax.v @@ -20,6 +20,11 @@ Fail Check 0x. Check (PrimInt63.add 2 2). Fail Check -1. Fail Check 9223372036854775808. + +Set Printing All. +Check 1%int63. +Unset Printing All. + Open Scope nat_scope. Check 2. (* : nat *) Check 2%int63. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 3477a293e3..0b18981f4e 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -77,18 +77,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 184, characters 0-160: +File "stdin", line 187, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 197, characters 0-60: +File "stdin", line 200, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 201, characters 0-64: +File "stdin", line 204, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 206, characters 0-62: +File "stdin", line 209, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -97,10 +97,10 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 234, characters 0-61: +File "stdin", line 237, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 238, characters 0-63: +File "stdin", line 241, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] fun x : nat => U (S x) @@ -111,7 +111,7 @@ fun x : nat => V x : forall x : nat, nat * (?T -> ?T) where ?T : [x : nat x0 : ?T |- Type] (x0 cannot be used) -File "stdin", line 255, characters 0-30: +File "stdin", line 258, characters 0-30: Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] 0 :=: 0 : Prop diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index ebad12af88..a5ec92fe3c 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -103,7 +103,10 @@ Module NumberNotations. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. - Number Notation myint63 of_int to_int : test17_scope. + Definition parse x := + match x with Pos x => Some (of_int x) | Neg _ => None end. + Definition print x := Pos (to_int x). + Number Notation myint63 parse print : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. End NumberNotations. diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 60682edec8..df9b39389c 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -260,28 +260,28 @@ The command has indeed failed with message: add is not a constructor of an inductive type. The command has indeed failed with message: Missing mapping for constructor Iempty. -File "stdin", line 574, characters 56-61: +File "stdin", line 577, characters 56-61: Warning: Type of I'sum seems incompatible with the type of sum. Expected type is: (I' -> I' -> I') instead of (I -> I' -> I'). This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] -File "stdin", line 579, characters 32-33: +File "stdin", line 582, characters 32-33: Warning: I was already mapped to Set, mapping it also to nat might yield ill typed terms when using the notation. [via-type-remapping,numbers] -File "stdin", line 579, characters 37-42: +File "stdin", line 582, characters 37-42: Warning: Type of Iunit seems incompatible with the type of O. Expected type is: I instead of I. This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] The command has indeed failed with message: 'via' and 'abstract' cannot be used together. -File "stdin", line 659, characters 21-23: +File "stdin", line 662, characters 21-23: Warning: Type of I1 seems incompatible with the type of Fin.F1. Expected type is: (nat -> I) instead of I. This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] -File "stdin", line 659, characters 35-37: +File "stdin", line 662, characters 35-37: Warning: Type of IS seems incompatible with the type of Fin.FS. Expected type is: (nat -> I -> I) instead of (I -> I). This might yield ill typed terms when using the notation. diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index 718da13500..85400c2fd4 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -328,7 +328,10 @@ Module Test17. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. - Number Notation myint63 of_int to_int : test17_scope. + Definition parse x := + match x with Pos x => Some (of_int x) | Neg _ => None end. + Definition print x := Pos (to_int x). + Number Notation myint63 parse print : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. diff --git a/test-suite/output/SearchHead.v b/test-suite/output/SearchHead.v deleted file mode 100644 index 2ee8a0d184..0000000000 --- a/test-suite/output/SearchHead.v +++ /dev/null @@ -1,19 +0,0 @@ -(* Some tests of the Search command *) - -SearchHead le. (* app nodes *) -SearchHead bool. (* no apps *) -SearchHead (@eq nat). (* complex pattern *) - -Definition newdef := fun x:nat => x = x. - -Goal forall n:nat, newdef n -> False. - intros n h. - SearchHead newdef. (* search hypothesis *) -Abort. - - -Goal forall n (P:nat -> Prop), P n -> False. - intros n P h. - SearchHead P. (* search hypothesis also for patterns *) -Abort. - diff --git a/test-suite/output/SearchHead.out b/test-suite/output/Search_headconcl.out index 2f0d854ac6..24e2ee76af 100644 --- a/test-suite/output/SearchHead.out +++ b/test-suite/output/Search_headconcl.out @@ -1,17 +1,9 @@ -File "stdin", line 3, characters 0-14: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] le_n: forall n : nat, n <= n le_0_n: forall n : nat, 0 <= n le_S: forall n m : nat, n <= m -> n <= S m le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m le_n_S: forall n m : nat, n <= m -> S n <= S m le_S_n: forall n m : nat, S n <= S m -> n <= m -File "stdin", line 4, characters 0-16: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] false: bool true: bool negb: bool -> bool @@ -35,10 +27,6 @@ Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool Decimal.int_beq: Decimal.int -> Decimal.int -> bool Decimal.uint_beq: Decimal.uint -> Decimal.uint -> bool -File "stdin", line 5, characters 0-21: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] mult_n_O: forall n : nat, 0 = n * 0 plus_O_n: forall n : nat, 0 + n = n plus_n_O: forall n : nat, n = n + 0 @@ -57,13 +45,5 @@ f_equal2_plus: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 f_equal2_mult: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 -File "stdin", line 11, characters 2-20: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] h: newdef n -File "stdin", line 17, characters 2-15: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] h: P n diff --git a/test-suite/output/Search_headconcl.v b/test-suite/output/Search_headconcl.v new file mode 100644 index 0000000000..8b168dcd25 --- /dev/null +++ b/test-suite/output/Search_headconcl.v @@ -0,0 +1,18 @@ +(* Some tests of the Search command *) + +Search headconcl: le. (* app nodes *) +Search headconcl: bool. (* no apps *) +Search headconcl: (@eq nat). (* complex pattern *) + +Definition newdef := fun x:nat => x = x. + +Goal forall n:nat, newdef n -> False. + intros n h. + Search headconcl: newdef. (* search hypothesis *) +Abort. + + +Goal forall n (P:nat -> Prop), P n -> False. + intros n P h. + Search headconcl: P. (* search hypothesis also for patterns *) +Abort. diff --git a/test-suite/output/Sint63Syntax.out b/test-suite/output/Sint63Syntax.out new file mode 100644 index 0000000000..db14658307 --- /dev/null +++ b/test-suite/output/Sint63Syntax.out @@ -0,0 +1,66 @@ +2%sint63 + : int +2 + : int +-3 + : int +4611686018427387903 + : int +-4611686018427387904 + : int +427 + : int +427 + : int +427 + : int +427 + : int +427 + : int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +0 + : int +0 + : int +The command has indeed failed with message: +The reference xg was not found in the current environment. +The command has indeed failed with message: +The reference xG was not found in the current environment. +The command has indeed failed with message: +The reference x1 was not found in the current environment. +The command has indeed failed with message: +The reference x was not found in the current environment. +2 + 2 + : int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +0x1%int63 + : int +0x7fffffffffffffff%int63 + : int +2 + : nat +2%sint63 + : int +t = 2%si63 + : int +t = 2%si63 + : int +2 + : nat +2 + : int +(2 + 2)%sint63 + : int +2 + 2 + : int + = 4 + : int + = 37151199385380486 + : int diff --git a/test-suite/output/Sint63Syntax.v b/test-suite/output/Sint63Syntax.v new file mode 100644 index 0000000000..b9ed596537 --- /dev/null +++ b/test-suite/output/Sint63Syntax.v @@ -0,0 +1,49 @@ +Require Import Sint63. + +Check 2%sint63. +Open Scope sint63_scope. +Check 2. +Check -3. +Check 4611686018427387903. +Check -4611686018427387904. +Check 0x1ab. +Check 0X1ab. +Check 0x1Ab. +Check 0x1aB. +Check 0x1AB. +Fail Check 0x1ap5. (* exponents not implemented (yet?) *) +Fail Check 0x1aP5. +Check 0x0. +Check 0x000. +Fail Check 0xg. +Fail Check 0xG. +Fail Check 00x1. +Fail Check 0x. +Check (PrimInt63.add 2 2). +Fail Check 4611686018427387904. +Fail Check -4611686018427387905. + +Set Printing All. +Check 1%sint63. +Check (-1)%sint63. +Unset Printing All. + +Open Scope nat_scope. +Check 2. (* : nat *) +Check 2%sint63. +Delimit Scope sint63_scope with si63. +Definition t := 2%sint63. +Print t. +Delimit Scope nat_scope with sint63. +Print t. +Check 2. +Close Scope nat_scope. +Check 2. +Close Scope sint63_scope. +Delimit Scope sint63_scope with sint63. + +Check (2 + 2)%sint63. +Open Scope sint63_scope. +Check (2+2). +Eval vm_compute in 2+2. +Eval vm_compute in 65675757 * 565675998. diff --git a/test-suite/output/bug_13821_native_command_line_warn.out b/test-suite/output/bug_13821_native_command_line_warn.out new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/output/bug_13821_native_command_line_warn.out diff --git a/test-suite/output/bug_13821_native_command_line_warn.v b/test-suite/output/bug_13821_native_command_line_warn.v new file mode 100644 index 0000000000..a28210b6c2 --- /dev/null +++ b/test-suite/output/bug_13821_native_command_line_warn.v @@ -0,0 +1 @@ +(* -*- coq-prog-args: ("-w" "-native-compiler-disabled" "-native-compiler" "ondemand"); -*- *) diff --git a/test-suite/primitive/sint63/add.v b/test-suite/primitive/sint63/add.v new file mode 100644 index 0000000000..dcafd64181 --- /dev/null +++ b/test-suite/primitive/sint63/add.v @@ -0,0 +1,25 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 2 + 3 = 5). +Check (eq_refl 5 <: 2 + 3 = 5). +Check (eq_refl 5 <<: 2 + 3 = 5). +Definition compute1 := Eval compute in 2 + 3. +Check (eq_refl compute1 : 5 = 5). + +Check (eq_refl : 4611686018427387903 + 1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: + 4611686018427387903 + 1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: + 4611686018427387903 + 1 = -4611686018427387904). +Definition compute2 := Eval compute in 4611686018427387903 + 1. +Check (eq_refl compute2 : -4611686018427387904 = -4611686018427387904). + +Check (eq_refl : 2 - 3 = -1). +Check (eq_refl (-1) <: 2 - 3 = -1). +Check (eq_refl (-1) <<: 2 - 3 = -1). +Definition compute3 := Eval compute in 2 - 3. +Check (eq_refl compute3 : -1 = -1). diff --git a/test-suite/primitive/sint63/asr.v b/test-suite/primitive/sint63/asr.v new file mode 100644 index 0000000000..4524ae4e6f --- /dev/null +++ b/test-suite/primitive/sint63/asr.v @@ -0,0 +1,41 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : (-2305843009213693952) >> 61 = -1). +Check (eq_refl (-1) <: (-2305843009213693952) >> 61 = -1). +Check (eq_refl (-1) <<: (-2305843009213693952) >> 61 = -1). +Definition compute1 := Eval compute in (-2305843009213693952) >> 61. +Check (eq_refl compute1 : -1 = -1). + +Check (eq_refl : 2305843009213693952 >> 62 = 0). +Check (eq_refl 0 <: 2305843009213693952 >> 62 = 0). +Check (eq_refl 0 <<: 2305843009213693952 >> 62 = 0). +Definition compute2 := Eval compute in 2305843009213693952 >> 62. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 4611686018427387903 >> 63 = 0). +Check (eq_refl 0 <: 4611686018427387903 >> 63 = 0). +Check (eq_refl 0 <<: 4611686018427387903 >> 63 = 0). +Definition compute3 := Eval compute in 4611686018427387903 >> 63. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : (-1) >> 1 = -1). +Check (eq_refl (-1) <: (-1) >> 1 = -1). +Check (eq_refl (-1) <<: (-1) >> 1 = -1). +Definition compute4 := Eval compute in (-1) >> 1. +Check (eq_refl compute4 : -1 = -1). + +Check (eq_refl : (-1) >> (-1) = 0). +Check (eq_refl 0 <: (-1) >> (-1) = 0). +Check (eq_refl 0 <<: (-1) >> (-1) = 0). +Definition compute5 := Eval compute in (-1) >> (-1). +Check (eq_refl compute5 : 0 = 0). + +Check (eq_refl : 73 >> (-2) = 0). +Check (eq_refl 0 <: 73 >> (-2) = 0). +Check (eq_refl 0 <<: 73 >> (-2) = 0). +Definition compute6 := Eval compute in 73 >> (-2). +Check (eq_refl compute6 : 0 = 0). diff --git a/test-suite/primitive/sint63/compare.v b/test-suite/primitive/sint63/compare.v new file mode 100644 index 0000000000..7a9882f1c8 --- /dev/null +++ b/test-suite/primitive/sint63/compare.v @@ -0,0 +1,36 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 1 ?= 1 = Eq). +Check (eq_refl Eq <: 1 ?= 1 = Eq). +Check (eq_refl Eq <<: 1 ?= 1 = Eq). +Definition compute1 := Eval compute in 1 ?= 1. +Check (eq_refl compute1 : Eq = Eq). + +Check (eq_refl : 1 ?= 2 = Lt). +Check (eq_refl Lt <: 1 ?= 2 = Lt). +Check (eq_refl Lt <<: 1 ?= 2 = Lt). +Definition compute2 := Eval compute in 1 ?= 2. +Check (eq_refl compute2 : Lt = Lt). + +Check (eq_refl : 4611686018427387903 ?= 0 = Gt). +Check (eq_refl Gt <: 4611686018427387903 ?= 0 = Gt). +Check (eq_refl Gt <<: 4611686018427387903 ?= 0 = Gt). +Definition compute3 := Eval compute in 4611686018427387903 ?= 0. +Check (eq_refl compute3 : Gt = Gt). + +Check (eq_refl : -1 ?= 1 = Lt). +Check (eq_refl Lt <: -1 ?= 1 = Lt). +Check (eq_refl Lt <<: -1 ?= 1 = Lt). +Definition compute4 := Eval compute in -1 ?= 1. +Check (eq_refl compute4 : Lt = Lt). + +Check (eq_refl : 4611686018427387903 ?= -4611686018427387904 = Gt). +Check (eq_refl Gt <: 4611686018427387903 ?= -4611686018427387904 = Gt). +Check (eq_refl Gt <<: 4611686018427387903 ?= -4611686018427387904 = Gt). +Definition compute5 := + Eval compute in 4611686018427387903 ?= -4611686018427387904. +Check (eq_refl compute5 : Gt = Gt). diff --git a/test-suite/primitive/sint63/div.v b/test-suite/primitive/sint63/div.v new file mode 100644 index 0000000000..9da628ce1e --- /dev/null +++ b/test-suite/primitive/sint63/div.v @@ -0,0 +1,61 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 6 / 3 = 2). +Check (eq_refl 2 <: 6 / 3 = 2). +Check (eq_refl 2 <<: 6 / 3 = 2). +Definition compute1 := Eval compute in 6 / 3. +Check (eq_refl compute1 : 2 = 2). + +Check (eq_refl : -6 / 3 = -2). +Check (eq_refl (-2) <: -6 / 3 = -2). +Check (eq_refl (-2) <<: -6 / 3 = -2). +Definition compute2 := Eval compute in -6 / 3. +Check (eq_refl compute2 : -2 = -2). + +Check (eq_refl : 6 / -3 = -2). +Check (eq_refl (-2) <: 6 / -3 = -2). +Check (eq_refl (-2) <<: 6 / -3 = -2). +Definition compute3 := Eval compute in 6 / -3. +Check (eq_refl compute3 : -2 = -2). + +Check (eq_refl : -6 / -3 = 2). +Check (eq_refl 2 <: -6 / -3 = 2). +Check (eq_refl 2 <<: -6 / -3 = 2). +Definition compute4 := Eval compute in -6 / -3. +Check (eq_refl compute4 : 2 = 2). + +Check (eq_refl : 3 / 2 = 1). +Check (eq_refl 1 <: 3 / 2 = 1). +Check (eq_refl 1 <<: 3 / 2 = 1). +Definition compute5 := Eval compute in 3 / 2. +Check (eq_refl compute5 : 1 = 1). + +Check (eq_refl : -3 / 2 = -1). +Check (eq_refl (-1) <: -3 / 2 = -1). +Check (eq_refl (-1) <<: -3 / 2 = -1). +Definition compute6 := Eval compute in -3 / 2. +Check (eq_refl compute6 : -1 = -1). + +Check (eq_refl : 3 / -2 = -1). +Check (eq_refl (-1) <: 3 / -2 = -1). +Check (eq_refl (-1) <<: 3 / -2 = -1). +Definition compute7 := Eval compute in 3 / -2. +Check (eq_refl compute7 : -1 = -1). + +Check (eq_refl : -3 / -2 = 1). +Check (eq_refl 1 <: -3 / -2 = 1). +Check (eq_refl 1 <<: -3 / -2 = 1). +Definition compute8 := Eval compute in -3 / -2. +Check (eq_refl compute8 : 1 = 1). + +Check (eq_refl : -4611686018427387904 / -1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: + -4611686018427387904 / -1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: + -4611686018427387904 / -1 = -4611686018427387904). +Definition compute9 := Eval compute in -4611686018427387904 / -1. +Check (eq_refl compute9 : -4611686018427387904 = -4611686018427387904). diff --git a/test-suite/primitive/sint63/eqb.v b/test-suite/primitive/sint63/eqb.v new file mode 100644 index 0000000000..4d365acf54 --- /dev/null +++ b/test-suite/primitive/sint63/eqb.v @@ -0,0 +1,17 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 1 =? 1 = true). +Check (eq_refl true <: 1 =? 1 = true). +Check (eq_refl true <<: 1 =? 1 = true). +Definition compute1 := Eval compute in 1 =? 1. +Check (eq_refl compute1 : true = true). + +Check (eq_refl : 4611686018427387903 =? 0 = false). +Check (eq_refl false <: 4611686018427387903 =? 0 = false). +Check (eq_refl false <<: 4611686018427387903 =? 0 = false). +Definition compute2 := Eval compute in 4611686018427387903 =? 0. +Check (eq_refl compute2 : false = false). diff --git a/test-suite/primitive/sint63/isint.v b/test-suite/primitive/sint63/isint.v new file mode 100644 index 0000000000..f1c9c2cfd1 --- /dev/null +++ b/test-suite/primitive/sint63/isint.v @@ -0,0 +1,50 @@ +(* This file tests the check that arithmetic operations use to know if their +arguments are ground. The various test cases correspond to possible +optimizations of these tests made by the compiler. *) +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Section test. + +Variable m n : int. + +Check (eq_refl : (fun x => x + 3) m = m + 3). +Check (eq_refl (m + 3) <: (fun x => x + 3) m = m + 3). +Check (eq_refl (m + 3) <<: (fun x => x + 3) m = m + 3). +Definition compute1 := Eval compute in (fun x => x + 3) m. +Check (eq_refl compute1 : m + 3 = m + 3). + +Check (eq_refl : (fun x => 3 + x) m = 3 + m). +Check (eq_refl (3 + m) <: (fun x => 3 + x) m = 3 + m). +Check (eq_refl (3 + m) <<: (fun x => 3 + x) m = 3 + m). +Definition compute2 := Eval compute in (fun x => 3 + x) m. +Check (eq_refl compute2 : 3 + m = 3 + m). + +Check (eq_refl : (fun x y => x + y) m n = m + n). +Check (eq_refl (m + n) <: (fun x y => x + y) m n = m + n). +Check (eq_refl (m + n) <<: (fun x y => x + y) m n = m + n). +Definition compute3 := Eval compute in (fun x y => x + y) m n. +Check (eq_refl compute3 : m + n = m + n). + +Check (eq_refl : (fun x y => x + y) 2 3 = 5). +Check (eq_refl 5 <: (fun x y => x + y) 2 3 = 5). +Check (eq_refl 5 <<: (fun x y => x + y) 2 3 = 5). +Definition compute4 := Eval compute in (fun x y => x + y) 2 3. +Check (eq_refl compute4 : 5 = 5). + +Check (eq_refl : (fun x => x + x) m = m + m). +Check (eq_refl (m + m) <: (fun x => x + x) m = m + m). +Check (eq_refl (m + m) <<: (fun x => x + x) m = m + m). +Definition compute5 := Eval compute in (fun x => x + x) m. +Check (eq_refl compute5 : m + m = m + m). + +Check (eq_refl : (fun x => x + x) 2 = 4). +Check (eq_refl 4 <: (fun x => x + x) 2 = 4). +Check (eq_refl 4 <<: (fun x => x + x) 2 = 4). +Definition compute6 := Eval compute in (fun x => x + x) 2. +Check (eq_refl compute6 : 4 = 4). + +End test. diff --git a/test-suite/primitive/sint63/leb.v b/test-suite/primitive/sint63/leb.v new file mode 100644 index 0000000000..dbe958e41d --- /dev/null +++ b/test-suite/primitive/sint63/leb.v @@ -0,0 +1,29 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 1 <=? 1 = true). +Check (eq_refl true <: 1 <=? 1 = true). +Check (eq_refl true <<: 1 <=? 1 = true). +Definition compute1 := Eval compute in 1 <=? 1. +Check (eq_refl compute1 : true = true). + +Check (eq_refl : 1 <=? 2 = true). +Check (eq_refl true <: 1 <=? 2 = true). +Check (eq_refl true <<: 1 <=? 2 = true). +Definition compute2 := Eval compute in 1 <=? 2. +Check (eq_refl compute2 : true = true). + +Check (eq_refl : 4611686018427387903 <=? 0 = false). +Check (eq_refl false <: 4611686018427387903 <=? 0 = false). +Check (eq_refl false <<: 4611686018427387903 <=? 0 = false). +Definition compute3 := Eval compute in 4611686018427387903 <=? 0. +Check (eq_refl compute3 : false = false). + +Check (eq_refl : 1 <=? -1 = false). +Check (eq_refl false <: 1 <=? -1 = false). +Check (eq_refl false <<: 1 <=? -1 = false). +Definition compute4 := Eval compute in 1 <=? -1. +Check (eq_refl compute4 : false = false). diff --git a/test-suite/primitive/sint63/lsl.v b/test-suite/primitive/sint63/lsl.v new file mode 100644 index 0000000000..082c42979a --- /dev/null +++ b/test-suite/primitive/sint63/lsl.v @@ -0,0 +1,43 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 3 << 61 = -2305843009213693952). +Check (eq_refl (-2305843009213693952) <: 3 << 61 = -2305843009213693952). +Check (eq_refl (-2305843009213693952) <<: 3 << 61 = -2305843009213693952). +Definition compute1 := Eval compute in 3 << 61. +Check (eq_refl compute1 : -2305843009213693952 = -2305843009213693952). + +Check (eq_refl : 2 << 62 = 0). +Check (eq_refl 0 <: 2 << 62 = 0). +Check (eq_refl 0 <<: 2 << 62 = 0). +Definition compute2 := Eval compute in 2 << 62. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 4611686018427387903 << 63 = 0). +Check (eq_refl 0 <: 4611686018427387903 << 63 = 0). +Check (eq_refl 0 <<: 4611686018427387903 << 63 = 0). +Definition compute3 := Eval compute in 4611686018427387903 << 63. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : 4611686018427387903 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: + 4611686018427387903 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: + 4611686018427387903 << 62 = -4611686018427387904). +Definition compute4 := Eval compute in 4611686018427387903 << 62. +Check (eq_refl compute4 : -4611686018427387904 = -4611686018427387904). + +Check (eq_refl : 1 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: 1 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: 1 << 62 = -4611686018427387904). +Definition compute5 := Eval compute in 1 << 62. +Check (eq_refl compute5 : -4611686018427387904 = -4611686018427387904). + +Check (eq_refl : -1 << 1 = -2). +Check (eq_refl (-2) <: -1 << 1 = -2). +Check (eq_refl (-2) <<: -1 << 1 = -2). +Definition compute6 := Eval compute in -1 << 1. +Check (eq_refl compute6 : -2 = -2). diff --git a/test-suite/primitive/sint63/ltb.v b/test-suite/primitive/sint63/ltb.v new file mode 100644 index 0000000000..aa72e1d377 --- /dev/null +++ b/test-suite/primitive/sint63/ltb.v @@ -0,0 +1,29 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 1 <? 1 = false). +Check (eq_refl false <: 1 <? 1 = false). +Check (eq_refl false <<: 1 <? 1 = false). +Definition compute1 := Eval compute in 1 <? 1. +Check (eq_refl compute1 : false = false). + +Check (eq_refl : 1 <? 2 = true). +Check (eq_refl true <: 1 <? 2 = true). +Check (eq_refl true <<: 1 <? 2 = true). +Definition compute2 := Eval compute in 1 <? 2. +Check (eq_refl compute2 : true = true). + +Check (eq_refl : 4611686018427387903 <? 0 = false). +Check (eq_refl false <: 4611686018427387903 <? 0 = false). +Check (eq_refl false <<: 4611686018427387903 <? 0 = false). +Definition compute3 := Eval compute in 4611686018427387903 <? 0. +Check (eq_refl compute3 : false = false). + +Check (eq_refl : 1 <? -1 = false). +Check (eq_refl false <: 1 <? -1 = false). +Check (eq_refl false <<: 1 <? -1 = false). +Definition compute4 := Eval compute in 1 <? -1. +Check (eq_refl compute4 : false = false). diff --git a/test-suite/primitive/sint63/mod.v b/test-suite/primitive/sint63/mod.v new file mode 100644 index 0000000000..a4872b45f3 --- /dev/null +++ b/test-suite/primitive/sint63/mod.v @@ -0,0 +1,53 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 6 mod 3 = 0). +Check (eq_refl 0 <: 6 mod 3 = 0). +Check (eq_refl 0 <<: 6 mod 3 = 0). +Definition compute1 := Eval compute in 6 mod 3. +Check (eq_refl compute1 : 0 = 0). + +Check (eq_refl : -6 mod 3 = 0). +Check (eq_refl 0 <: -6 mod 3 = 0). +Check (eq_refl 0 <<: -6 mod 3 = 0). +Definition compute2 := Eval compute in -6 mod 3. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 6 mod -3 = 0). +Check (eq_refl 0 <: 6 mod -3 = 0). +Check (eq_refl 0 <<: 6 mod -3 = 0). +Definition compute3 := Eval compute in 6 mod -3. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : -6 mod -3 = 0). +Check (eq_refl 0 <: -6 mod -3 = 0). +Check (eq_refl 0 <<: -6 mod -3 = 0). +Definition compute4 := Eval compute in -6 mod -3. +Check (eq_refl compute4 : 0 = 0). + +Check (eq_refl : 5 mod 3 = 2). +Check (eq_refl 2 <: 5 mod 3 = 2). +Check (eq_refl 2 <<: 5 mod 3 = 2). +Definition compute5 := Eval compute in 5 mod 3. +Check (eq_refl compute5 : 2 = 2). + +Check (eq_refl : -5 mod 3 = -2). +Check (eq_refl (-2) <: -5 mod 3 = -2). +Check (eq_refl (-2) <<: -5 mod 3 = -2). +Definition compute6 := Eval compute in -5 mod 3. +Check (eq_refl compute6 : -2 = -2). + +Check (eq_refl : 5 mod -3 = 2). +Check (eq_refl 2 <: 5 mod -3 = 2). +Check (eq_refl 2 <<: 5 mod -3 = 2). +Definition compute7 := Eval compute in 5 mod -3. +Check (eq_refl compute7 : 2 = 2). + +Check (eq_refl : -5 mod -3 = -2). +Check (eq_refl (-2) <: -5 mod -3 = -2). +Check (eq_refl (-2) <<: -5 mod -3 = -2). +Definition compute8 := Eval compute in -5 mod -3. +Check (eq_refl compute8 : -2 = -2). diff --git a/test-suite/primitive/sint63/mul.v b/test-suite/primitive/sint63/mul.v new file mode 100644 index 0000000000..f72f643083 --- /dev/null +++ b/test-suite/primitive/sint63/mul.v @@ -0,0 +1,35 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 2 * 3 = 6). +Check (eq_refl 6 <: 2 * 3 = 6). +Check (eq_refl 6 <<: 2 * 3 = 6). +Definition compute1 := Eval compute in 2 * 3. +Check (eq_refl compute1 : 6 = 6). + +Check (eq_refl : -2 * 3 = -6). +Check (eq_refl (-6) <: -2 * 3 = -6). +Check (eq_refl (-6) <<: -2 * 3 = -6). +Definition compute2 := Eval compute in -2 * 3. +Check (eq_refl compute2 : -6 = -6). + +Check (eq_refl : 2 * -3 = -6). +Check (eq_refl (-6) <: 2 * -3 = -6). +Check (eq_refl (-6) <<: 2 * -3 = -6). +Definition compute3 := Eval compute in 2 * -3. +Check (eq_refl compute3 : -6 = -6). + +Check (eq_refl : -2 * -3 = 6). +Check (eq_refl 6 <: -2 * -3 = 6). +Check (eq_refl 6 <<: -2 * -3 = 6). +Definition compute4 := Eval compute in -2 * -3. +Check (eq_refl compute4 : 6 = 6). + +Check (eq_refl : 4611686018427387903 * 2 = -2). +Check (eq_refl (-2) <: 4611686018427387903 * 2 = -2). +Check (eq_refl (-2) <<: 4611686018427387903 * 2 = -2). +Definition compute5 := Eval compute in 4611686018427387903 * 2. +Check (eq_refl compute5 : -2 = -2). diff --git a/test-suite/primitive/sint63/signed.v b/test-suite/primitive/sint63/signed.v new file mode 100644 index 0000000000..d8333a8efb --- /dev/null +++ b/test-suite/primitive/sint63/signed.v @@ -0,0 +1,18 @@ +(* This file checks that operations over sint63 are signed. *) +Require Import Sint63. + +Open Scope sint63_scope. + +(* (0-1) must be negative 1 and not the maximum integer value *) + +Check (eq_refl : 1/(0-1) = -1). +Check (eq_refl (-1) <: 1/(0-1) = -1). +Check (eq_refl (-1) <<: 1/(0-1) = -1). +Definition compute1 := Eval compute in 1/(0-1). +Check (eq_refl compute1 : -1 = -1). + +Check (eq_refl : 3 mod (0-1) = 0). +Check (eq_refl 0 <: 3 mod (0-1) = 0). +Check (eq_refl 0 <<: 3 mod (0-1) = 0). +Definition compute2 := Eval compute in 3 mod (0-1). +Check (eq_refl compute2 : 0 = 0). diff --git a/test-suite/primitive/sint63/sub.v b/test-suite/primitive/sint63/sub.v new file mode 100644 index 0000000000..8504177286 --- /dev/null +++ b/test-suite/primitive/sint63/sub.v @@ -0,0 +1,25 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 3 - 2 = 1). +Check (eq_refl 1 <: 3 - 2 = 1). +Check (eq_refl 1 <<: 3 - 2 = 1). +Definition compute1 := Eval compute in 3 - 2. +Check (eq_refl compute1 : 1 = 1). + +Check (eq_refl : 0 - 1 = -1). +Check (eq_refl (-1) <: 0 - 1 = -1). +Check (eq_refl (-1) <<: 0 - 1 = -1). +Definition compute2 := Eval compute in 0 - 1. +Check (eq_refl compute2 : -1 = -1). + +Check (eq_refl : -4611686018427387904 - 1 = 4611686018427387903). +Check (eq_refl 4611686018427387903 <: + -4611686018427387904 - 1 = 4611686018427387903). +Check (eq_refl 4611686018427387903 <<: + -4611686018427387904 - 1 = 4611686018427387903). +Definition compute3 := Eval compute in -4611686018427387904 - 1. +Check (eq_refl compute3 : 4611686018427387903 = 4611686018427387903). diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 4983ee3c0d..615350c58c 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -154,50 +154,6 @@ induction H. change (0 = z -> True) in IHrepr''. Abort. -(* Test double induction *) - -(* This was failing in 8.5 and before because of a bug in the order of - hypotheses *) - -Set Warnings "-deprecated". - -Inductive I2 : Type := - C2 : forall x:nat, x=x -> I2. -Goal forall a b:I2, a = b. -double induction a b. -Abort. - -(* This was leaving useless hypotheses in 8.5 and before because of - the same bug. This is a change of compatibility. *) - -Inductive I3 : Prop := - C3 : forall x:nat, x=x -> I3. -Goal forall a b:I3, a = b. -double induction a b. -Fail clear H. (* H should have been erased *) -Abort. - -(* This one had quantification in reverse order in 8.5 and before *) -(* This is a change of compatibility. *) - -Goal forall m n, le m n -> le n m -> n=m. -intros m n. double induction 1 2. -3:destruct 1. (* Should be "S m0 <= m0" *) -Abort. - -(* Idem *) - -Goal forall m n p q, le m n -> le p q -> n+p=m+q. -intros *. double induction 1 2. -3:clear H2. (* H2 should have been erased *) -Abort. - -(* This is unchanged *) - -Goal forall m n:nat, n=m. -double induction m n. -Abort. - (* Mentioned as part of bug #12944 *) Inductive test : Set := cons : forall (IHv : nat) (v : test), test. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 7bb725538b..a3ebe67325 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -205,6 +205,7 @@ Qed. Corollary to_Z_bounded : forall x, (0 <= φ x < wB)%Z. Proof. apply to_Z_rec_bounded. Qed. + (* =================================================== *) Local Open Scope Z_scope. (* General arithmetic results *) @@ -1904,6 +1905,22 @@ Qed. Lemma lxor0_r i : i lxor 0 = i. Proof. rewrite lxorC; exact (lxor0 i). Qed. +Lemma opp_to_Z_opp (x : int) : + φ x mod wB <> 0 -> + (- φ (- x)) mod wB = (φ x) mod wB. +Proof. + intros neqx0. + rewrite opp_spec. + rewrite (Z_mod_nz_opp_full (φ x%int63)) by assumption. + rewrite (Z.mod_small (φ x%int63)) by apply to_Z_bounded. + rewrite <- Z.add_opp_l. + rewrite Z.opp_add_distr, Z.opp_involutive. + replace (- wB) with (-1 * wB) by easy. + rewrite Z_mod_plus by easy. + now rewrite Z.mod_small by apply to_Z_bounded. +Qed. + + Module Export Int63Notations. Local Open Scope int63_scope. #[deprecated(since="8.13",note="use infix mod instead")] diff --git a/theories/Numbers/Cyclic/Int63/PrimInt63.v b/theories/Numbers/Cyclic/Int63/PrimInt63.v index 64c1b862c7..98127ef0ac 100644 --- a/theories/Numbers/Cyclic/Int63/PrimInt63.v +++ b/theories/Numbers/Cyclic/Int63/PrimInt63.v @@ -17,11 +17,21 @@ Register comparison as kernel.ind_cmp. Primitive int := #int63_type. Register int as num.int63.type. +Variant pos_neg_int63 := Pos (d:int) | Neg (d:int). +Register pos_neg_int63 as num.int63.pos_neg_int63. Declare Scope int63_scope. Definition id_int : int -> int := fun x => x. -Declare ML Module "int63_syntax_plugin". - -Module Export Int63NotationsInternalA. +Record int_wrapper := wrap_int {int_wrap : int}. +Register wrap_int as num.int63.wrap_int. +Definition printer (x : int_wrapper) : pos_neg_int63 := Pos (int_wrap x). +Definition parser (x : pos_neg_int63) : option int := + match x with + | Pos p => Some p + | Neg _ => None + end. +Number Notation int parser printer : int63_scope. + +Module Import Int63NotationsInternalA. Delimit Scope int63_scope with int63. Bind Scope int63_scope with int. End Int63NotationsInternalA. @@ -37,6 +47,9 @@ Primitive lor := #int63_lor. Primitive lxor := #int63_lxor. + +Primitive asr := #int63_asr. + (* Arithmetic modulo operations *) Primitive add := #int63_add. @@ -50,6 +63,10 @@ Primitive div := #int63_div. Primitive mod := #int63_mod. +Primitive divs := #int63_divs. + +Primitive mods := #int63_mods. + (* Comparisons *) Primitive eqb := #int63_eq. @@ -57,6 +74,10 @@ Primitive ltb := #int63_lt. Primitive leb := #int63_le. +Primitive ltsb := #int63_lts. + +Primitive lesb := #int63_les. + (** Exact arithmetic operations *) Primitive addc := #int63_addc. @@ -76,7 +97,13 @@ Primitive addmuldiv := #int63_addmuldiv. (** Comparison *) Primitive compare := #int63_compare. +Primitive compares := #int63_compares. + (** Exotic operations *) Primitive head0 := #int63_head0. Primitive tail0 := #int63_tail0. + +Module Export PrimInt63Notations. + Export Int63NotationsInternalA. +End PrimInt63Notations. diff --git a/theories/Numbers/Cyclic/Int63/Sint63.v b/theories/Numbers/Cyclic/Int63/Sint63.v new file mode 100644 index 0000000000..c0239ae3db --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Sint63.v @@ -0,0 +1,407 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZArith. +Import Znumtheory. +Require Export Int63. +Require Import Lia. + +Declare Scope sint63_scope. +Definition printer (x : int_wrapper) : pos_neg_int63 := + if (int_wrap x <? 4611686018427387904)%int63 then (* 2^62 *) + Pos (int_wrap x) + else + Neg ((int_wrap x) lxor max_int + 1)%int63. +Definition parser (x : pos_neg_int63) : option int := + match x with + | Pos p => if (p <? 4611686018427387904)%int63 then Some p else None + | Neg n => if (n <=? 4611686018427387904)%int63 + then Some ((n - 1) lxor max_int)%int63 else None + end. +Number Notation int parser printer : sint63_scope. + + +Module Import Sint63NotationsInternalA. +Delimit Scope sint63_scope with sint63. +Bind Scope sint63_scope with int. +End Sint63NotationsInternalA. + + +Module Import Sint63NotationsInternalB. +Infix "<<" := Int63.lsl (at level 30, no associativity) : sint63_scope. +(* TODO do we want >> to be asr or lsr? And is there a notation for the other one? *) +Infix ">>" := asr (at level 30, no associativity) : sint63_scope. +Infix "land" := Int63.land (at level 40, left associativity) : sint63_scope. +Infix "lor" := Int63.lor (at level 40, left associativity) : sint63_scope. +Infix "lxor" := Int63.lxor (at level 40, left associativity) : sint63_scope. +Infix "+" := Int63.add : sint63_scope. +Infix "-" := Int63.sub : sint63_scope. +Infix "*" := Int63.mul : sint63_scope. +Infix "/" := divs : sint63_scope. +Infix "mod" := mods (at level 40, no associativity) : sint63_scope. +Infix "=?" := Int63.eqb (at level 70, no associativity) : sint63_scope. +Infix "<?" := ltsb (at level 70, no associativity) : sint63_scope. +Infix "<=?" := lesb (at level 70, no associativity) : sint63_scope. +Infix "≤?" := lesb (at level 70, no associativity) : sint63_scope. +Notation "- x" := (opp x) : sint63_scope. +Notation "n ?= m" := (compares n m) (at level 70, no associativity) : sint63_scope. +End Sint63NotationsInternalB. + +Definition min_int := Eval vm_compute in (lsl 1 62). +Definition max_int := Eval vm_compute in (min_int - 1)%sint63. + +(** Translation to and from Z *) +Definition to_Z (i:int) := + if (i <? min_int)%int63 then + φ i%int63 + else + (- φ (- i)%int63)%Z. + +Lemma to_Z_0 : to_Z 0 = 0. +Proof. easy. Qed. + +Lemma to_Z_min : to_Z min_int = - (wB / 2). +Proof. easy. Qed. + +Lemma to_Z_max : to_Z max_int = wB / 2 - 1. +Proof. easy. Qed. + +Lemma to_Z_bounded : forall x, (to_Z min_int <= to_Z x <= to_Z max_int)%Z. +Proof. + intros x; unfold to_Z. + case ltbP; [> lia | intros _]. + case (ltbP max_int); [> intros _ | now intros H; exfalso; apply H]. + rewrite opp_spec. + rewrite Z_mod_nz_opp_full by easy. + rewrite Z.mod_small by apply Int63.to_Z_bounded. + case ltbP. + - intros ltxmin; split. + + now transitivity 0%Z; [>| now apply Int63.to_Z_bounded]. + + replace (φ min_int%int63) with (φ max_int%int63 + 1)%Z in ltxmin. + * lia. + * now compute. + - rewrite Z.nlt_ge; intros leminx. + rewrite opp_spec. + rewrite Z_mod_nz_opp_full. + + rewrite Z.mod_small by apply Int63.to_Z_bounded. + split. + * rewrite <- Z.opp_le_mono. + now rewrite <- Z.sub_le_mono_l. + * transitivity 0%Z; [>| now apply Int63.to_Z_bounded]. + rewrite Z.opp_nonpos_nonneg. + apply Zle_minus_le_0. + apply Z.lt_le_incl. + now apply Int63.to_Z_bounded. + + rewrite Z.mod_small by apply Int63.to_Z_bounded. + now intros eqx0; rewrite eqx0 in leminx. +Qed. + +Lemma of_to_Z : forall x, of_Z (to_Z x) = x. +Proof. + unfold to_Z, of_Z. + intros x. + generalize (Int63.to_Z_bounded x). + case ltbP. + - intros ltxmin [leq0x _]. + generalize (Int63.of_to_Z x). + destruct (φ x%int63). + + now intros <-. + + now intros <-; unfold Int63.of_Z. + + now intros _. + - intros nltxmin leq0xltwB. + rewrite (opp_spec x). + rewrite Z_mod_nz_opp_full. + + rewrite Zmod_small by easy. + destruct (wB - φ x%int63) eqn: iswbmx. + * lia. + * simpl. + apply to_Z_inj. + rewrite opp_spec. + generalize (of_Z_spec (Z.pos p)). + simpl Int63.of_Z; intros ->. + rewrite <- iswbmx. + rewrite <- Z.sub_0_l. + rewrite <- (Zmod_0_l wB). + rewrite <- Zminus_mod. + replace (0 - _) with (φ x%int63 - wB) by ring. + rewrite <- Zminus_mod_idemp_r. + rewrite Z_mod_same_full. + rewrite Z.sub_0_r. + now rewrite Z.mod_small. + * lia. + + rewrite Z.mod_small by easy. + intros eqx0; revert nltxmin; rewrite eqx0. + now compute. +Qed. + +Lemma to_Z_inj (x y : int) : to_Z x = to_Z y -> x = y. +Proof. exact (fun e => can_inj of_to_Z e). Qed. + +Lemma to_Z_mod_Int63to_Z (x : int) : to_Z x mod wB = φ x%int63. +Proof. + unfold to_Z. + case ltbP; [> now rewrite Z.mod_small by now apply Int63.to_Z_bounded |]. + rewrite Z.nlt_ge; intros gexmin. + rewrite opp_to_Z_opp; rewrite Z.mod_small by now apply Int63.to_Z_bounded. + - easy. + - now intros neqx0; rewrite neqx0 in gexmin. +Qed. + + +(** Centered modulo *) +Definition cmod (x d : Z) : Z := + (x + d / 2) mod d - (d / 2). + +Lemma cmod_mod (x d : Z) : + cmod (x mod d) d = cmod x d. +Proof. + now unfold cmod; rewrite Zplus_mod_idemp_l. +Qed. + +Lemma cmod_small (x d : Z) : + - (d / 2) <= x < d / 2 -> cmod x d = x. +Proof. + intros bound. + unfold cmod. + rewrite Zmod_small; [> lia |]. + split; [> lia |]. + rewrite Z.lt_add_lt_sub_r. + apply (Z.lt_le_trans _ (d / 2)); [> easy |]. + now rewrite <- Z.le_add_le_sub_r, Z.add_diag, Z.mul_div_le. +Qed. + +Lemma to_Z_cmodwB (x : int) : + to_Z x = cmod (φ x%int63) wB. +Proof. + unfold to_Z, cmod. + case ltbP; change φ (min_int)%int63 with (wB / 2). + - intros ltxmin. + rewrite Z.mod_small; [> lia |]. + split. + + now apply Z.add_nonneg_nonneg; try apply Int63.to_Z_bounded. + + change wB with (wB / 2 + wB / 2) at 2; lia. + - rewrite Z.nlt_ge; intros gexmin. + rewrite Int63.opp_spec. + rewrite Z_mod_nz_opp_full. + + rewrite Z.mod_small by apply Int63.to_Z_bounded. + rewrite <- (Z_mod_plus_full _ (-1)). + change (-1 * wB) with (- (wB / 2) - wB / 2). + rewrite <- Z.add_assoc, Zplus_minus. + rewrite Z.mod_small. + * change wB with (wB / 2 + wB / 2) at 1; lia. + * split; [> lia |]. + apply Z.lt_sub_lt_add_r. + transitivity wB; [>| easy]. + now apply Int63.to_Z_bounded. + + rewrite Z.mod_small by now apply Int63.to_Z_bounded. + now intros not0; rewrite not0 in gexmin. +Qed. + +Lemma of_Z_spec (z : Z) : to_Z (of_Z z) = cmod z wB. +Proof. now rewrite to_Z_cmodwB, Int63.of_Z_spec, cmod_mod. Qed. + +Lemma of_Z_cmod (z : Z) : of_Z (cmod z wB) = of_Z z. +Proof. now rewrite <- of_Z_spec, of_to_Z. Qed. + +Lemma is_int (z : Z) : + to_Z min_int <= z <= to_Z max_int -> + z = to_Z (of_Z z). +Proof. + rewrite to_Z_min, to_Z_max. + intros bound; rewrite of_Z_spec, cmod_small; lia. +Qed. + +(** Specification of operations that differ on signed and unsigned ints *) + +Axiom asr_spec : forall x p, to_Z (x >> p) = (to_Z x) / 2 ^ (to_Z p). + +Axiom div_spec : forall x y, + to_Z x <> to_Z min_int \/ to_Z y <> (-1)%Z -> + to_Z (x / y) = Z.quot (to_Z x) (to_Z y). + +Axiom mod_spec : forall x y, to_Z (x mod y) = Z.rem (to_Z x) (to_Z y). + +Axiom ltb_spec : forall x y, (x <? y)%sint63 = true <-> to_Z x < to_Z y. + +Axiom leb_spec : forall x y, (x <=? y)%sint63 = true <-> to_Z x <= to_Z y. + +Axiom compare_spec : forall x y, (x ?= y)%sint63 = (to_Z x ?= to_Z y). + +(** Specification of operations that coincide on signed and unsigned ints *) + +Lemma add_spec (x y : int) : + to_Z (x + y)%sint63 = cmod (to_Z x + to_Z y) wB. +Proof. + rewrite to_Z_cmodwB, Int63.add_spec. + rewrite <- 2!to_Z_mod_Int63to_Z, <- Z.add_mod by easy. + now rewrite cmod_mod. +Qed. + +Lemma sub_spec (x y : int) : + to_Z (x - y)%sint63 = cmod (to_Z x - to_Z y) wB. +Proof. + rewrite to_Z_cmodwB, Int63.sub_spec. + rewrite <- 2!to_Z_mod_Int63to_Z, <- Zminus_mod by easy. + now rewrite cmod_mod. +Qed. + +Lemma mul_spec (x y : int) : + to_Z (x * y)%sint63 = cmod (to_Z x * to_Z y) wB. +Proof. + rewrite to_Z_cmodwB, Int63.mul_spec. + rewrite <- 2!to_Z_mod_Int63to_Z, <- Zmult_mod by easy. + now rewrite cmod_mod. +Qed. + +Lemma succ_spec (x : int) : + to_Z (succ x)%sint63 = cmod (to_Z x + 1) wB. +Proof. now unfold succ; rewrite add_spec. Qed. + +Lemma pred_spec (x : int) : + to_Z (pred x)%sint63 = cmod (to_Z x - 1) wB. +Proof. now unfold pred; rewrite sub_spec. Qed. + +Lemma opp_spec (x : int) : + to_Z (- x)%sint63 = cmod (- to_Z x) wB. +Proof. + rewrite to_Z_cmodwB, Int63.opp_spec. + rewrite <- Z.sub_0_l, <- to_Z_mod_Int63to_Z, Zminus_mod_idemp_r. + now rewrite cmod_mod. +Qed. + +(** Behaviour when there is no under or overflow *) + +Lemma add_bounded (x y : int) : + to_Z min_int <= to_Z x + to_Z y <= to_Z max_int -> + to_Z (x + y) = to_Z x + to_Z y. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite add_spec, cmod_small; [>| lia]. +Qed. + +Lemma sub_bounded (x y : int) : + to_Z min_int <= to_Z x - to_Z y <= to_Z max_int -> + to_Z (x - y) = to_Z x - to_Z y. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite sub_spec, cmod_small; [>| lia]. +Qed. + +Lemma mul_bounded (x y : int) : + to_Z min_int <= to_Z x * to_Z y <= to_Z max_int -> + to_Z (x * y) = to_Z x * to_Z y. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite mul_spec, cmod_small; [>| lia]. +Qed. + +Lemma succ_bounded (x : int) : + to_Z min_int <= to_Z x + 1 <= to_Z max_int -> + to_Z (succ x) = to_Z x + 1. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite succ_spec, cmod_small; [>| lia]. +Qed. + +Lemma pred_bounded (x : int) : + to_Z min_int <= to_Z x - 1 <= to_Z max_int -> + to_Z (pred x) = to_Z x - 1. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite pred_spec, cmod_small; [>| lia]. +Qed. + +Lemma opp_bounded (x : int) : + to_Z min_int <= - to_Z x <= to_Z max_int -> + to_Z (- x) = - to_Z x. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite opp_spec, cmod_small; [>| lia]. +Qed. + +(** Relationship with of_Z *) + +Lemma add_of_Z (x y : int) : + (x + y)%sint63 = of_Z (to_Z x + to_Z y). +Proof. now rewrite <- of_Z_cmod, <- add_spec, of_to_Z. Qed. + +Lemma sub_of_Z (x y : int) : + (x - y)%sint63 = of_Z (to_Z x - to_Z y). +Proof. now rewrite <- of_Z_cmod, <- sub_spec, of_to_Z. Qed. + +Lemma mul_of_Z (x y : int) : + (x * y)%sint63 = of_Z (to_Z x * to_Z y). +Proof. now rewrite <- of_Z_cmod, <- mul_spec, of_to_Z. Qed. + +Lemma succ_of_Z (x : int) : + (succ x)%sint63 = of_Z (to_Z x + 1). +Proof. now rewrite <- of_Z_cmod, <- succ_spec, of_to_Z. Qed. + +Lemma pred_of_Z (x : int) : + (pred x)%sint63 = of_Z (to_Z x - 1). +Proof. now rewrite <- of_Z_cmod, <- pred_spec, of_to_Z. Qed. + +Lemma opp_of_Z (x : int) : + (- x)%sint63 = of_Z (- to_Z x). +Proof. now rewrite <- of_Z_cmod, <- opp_spec, of_to_Z. Qed. + +(** Comparison *) +Import Bool. + +Lemma eqbP x y : reflect (to_Z x = to_Z y) (x =? y)%sint63. +Proof. + apply iff_reflect; rewrite Int63.eqb_spec. + now split; [> apply to_Z_inj | apply f_equal]. +Qed. + +Lemma ltbP x y : reflect (to_Z x < to_Z y) (x <? y)%sint63. +Proof. now apply iff_reflect; symmetry; apply ltb_spec. Qed. + +Lemma lebP x y : reflect (to_Z x <= to_Z y) (x ≤? y)%sint63. +Proof. now apply iff_reflect; symmetry; apply leb_spec. Qed. + +(** ASR *) +Lemma asr_0 (i : int) : (0 >> i)%sint63 = 0%sint63. +Proof. now apply to_Z_inj; rewrite asr_spec. Qed. + +Lemma asr_0_r (i : int) : (i >> 0)%sint63 = i. +Proof. now apply to_Z_inj; rewrite asr_spec, Zdiv_1_r. Qed. + +Lemma asr_neg_r (i n : int) : to_Z n < 0 -> (i >> n)%sint63 = 0%sint63. +Proof. + intros ltn0. + apply to_Z_inj. + rewrite asr_spec, Z.pow_neg_r by assumption. + now rewrite Zdiv_0_r. +Qed. + +Lemma asr_1 (n : int) : (1 >> n)%sint63 = (n =? 0)%sint63. +Proof. + apply to_Z_inj; rewrite asr_spec. + case eqbP; [> now intros -> | intros neqn0]. + case (lebP 0 n). + - intros le0n. + apply Z.div_1_l; apply Z.pow_gt_1; [> easy |]. + rewrite to_Z_0 in *; lia. + - rewrite Z.nle_gt; intros ltn0. + now rewrite Z.pow_neg_r. +Qed. + +Notation asr := asr (only parsing). +Notation div := divs (only parsing). +Notation rem := mods (only parsing). +Notation ltb := ltsb (only parsing). +Notation leb := lesb (only parsing). +Notation compare := compares (only parsing). + +Module Export Sint63Notations. + Export Sint63NotationsInternalA. + Export Sint63NotationsInternalB. +End Sint63Notations. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index fce69437d7..d852ad24fe 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -319,7 +319,3 @@ Create HintDb program discriminated. Ltac program_simpl := program_simplify ; try typeclasses eauto 10 with program ; try program_solve_wf. Obligation Tactic := program_simpl. - -Definition obligation (A : Type) {a : A} := a. - -Register obligation as program.tactics.obligation. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v index 60fad8795a..5a599587d0 100644 --- a/theories/Reals/Abstract/ConstructiveReals.v +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -285,14 +285,14 @@ Lemma CRlt_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), Proof. intros. apply (CRlt_le_trans _ y _ H). apply CRlt_asym. exact H0. -Defined. +Qed. Lemma CRlt_trans_flip : forall {R : ConstructiveReals} (x y z : CRcarrier R), y < z -> x < y -> x < z. Proof. intros. apply (CRlt_le_trans _ y). exact H0. apply CRlt_asym. exact H. -Defined. +Qed. Lemma CReq_refl : forall {R : ConstructiveReals} (x : CRcarrier R), x == x. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v index 53b5aca38c..6ed5845440 100644 --- a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -232,7 +232,7 @@ Proof. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CRle_refl. apply CR_of_Q_lt. exact H. -Defined. +Qed. Lemma CRplus_neg_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 069a1292cd..9a00408de3 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -112,7 +112,7 @@ Proof. pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; apply H | apply H1 ]. -Defined. +Qed. Lemma Alembert_C2 : forall An:nat -> R, @@ -330,7 +330,7 @@ Proof. rewrite <- Rabs_Ropp; apply RRle_abs. rewrite double; pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H. -Defined. +Qed. Lemma AlembertC3_step1 : forall (An:nat -> R) (x:R), @@ -374,7 +374,7 @@ Proof. [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ]. intro; unfold Bn; apply prod_neq_R0; [ apply H0 | apply pow_nonzero; assumption ]. -Defined. +Qed. Lemma AlembertC3_step2 : forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }. @@ -405,7 +405,7 @@ Proof. cut (x <> 0). intro; apply AlembertC3_step1; assumption. red; intro; rewrite H1 in Hgt; elim (Rlt_irrefl _ Hgt). -Defined. +Qed. Lemma Alembert_C4 : forall (An:nat -> R) (k:R), diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 8a11c155ce..4fb3846abc 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -320,7 +320,6 @@ Proof. - contradiction. - exact Hxltz. Qed. -(* Todo: this was Defined. Why *) Lemma CReal_lt_le_trans : forall x y z : CReal, x < y -> y <= z -> x < z. @@ -330,7 +329,6 @@ Proof. - exact Hxltz. - contradiction. Qed. -(* Todo: this was Defined. Why *) Lemma CReal_le_trans : forall x y z : CReal, x <= y -> y <= z -> x <= z. @@ -347,7 +345,6 @@ Proof. apply (CReal_lt_le_trans _ y _ Hxlty). apply CRealLt_asym; exact Hyltz. Qed. -(* Todo: this was Defined. Why *) Lemma CRealEq_trans : forall x y z : CReal, CRealEq x y -> CRealEq y z -> CRealEq x z. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index a180e13444..bc45868244 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -733,13 +733,11 @@ Definition CReal_inv_pos (x : CReal) (Hxpos : 0 < x) : CReal := bound := CReal_inv_pos_bound x Hxpos |}. -(* ToDo: make this more obviously computing *) - Definition CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x. Proof. intros x [n nmaj]. exists n. - apply (Qlt_le_trans _ _ _ nmaj). destruct x. simpl. - unfold Qminus. rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl. + simpl in *. unfold CReal_opp_seq, Qminus. + abstract now rewrite Qplus_0_r, <- (Qplus_0_l (- seq x n)). Defined. Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 70d2861d17..c2b60e6478 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -75,7 +75,7 @@ Proof. rewrite inject_Q_plus, (opp_inject_Q 2). ring_simplify. exact H. rewrite Qinv_plus_distr. reflexivity. -Defined. +Qed. (* ToDo: Move to ConstructiveCauchyAbs.v *) Lemma Qabs_Rabs : forall q : Q, @@ -688,21 +688,7 @@ Proof. exact (a i j H0 H1). exists l. intros p. destruct (cv p). exists x. exact c. -Defined. - -(* ToDO: Belongs into sumbool.v *) -Section connectives. - - Variables A B : Prop. - - Hypothesis H1 : {A} + {~A}. - Hypothesis H2 : {B} + {~B}. - - Definition sumbool_or_not_or : {A \/ B} + {~(A \/ B)}. - case H1; case H2; tauto. - Defined. - -End connectives. +Qed. Lemma Qnot_le_iff_lt: forall x y : Q, ~ (x <= y)%Q <-> (y < x)%Q. @@ -740,13 +726,11 @@ Proof. clear maj. right. exists n. apply H0. - clear H0 H. intro n. - apply sumbool_or_not_or. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q). - * left; assumption. - * right; apply Qle_not_lt; assumption. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q). - * left; assumption. - * right; apply Qle_not_lt; assumption. + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q) as [H1|H1]. + + now left; left. + + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q) as [H2|H2]. + * now left; right. + * now right; intros [H3|H3]; apply Qle_not_lt with (2 := H3). Qed. Definition CRealConstructive : ConstructiveReals diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v index 500838ed26..0736b09761 100644 --- a/theories/Reals/ClassicalDedekindReals.v +++ b/theories/Reals/ClassicalDedekindReals.v @@ -233,17 +233,12 @@ Qed. (** *** Conversion from CReal to DReal *) -Definition DRealAbstr : CReal -> DReal. +Lemma DRealAbstr_aux : + forall x H, + isLowerCut (fun q : Q => + if sig_forall_dec (fun n : nat => seq x (- Z.of_nat n) <= q + 2 ^ (- Z.of_nat n)) (H q) + then true else false). Proof. - intro x. - assert (forall (q : Q) (n : nat), - {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + - {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). - { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). - right. apply (Qlt_not_le _ _ q0). left. exact q0. } - - exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) - then true else false). repeat split. - intros. destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q) @@ -303,6 +298,20 @@ Proof. apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0. apply (Qplus_le_l _ _ (-seq x (-Z.of_nat n))) in q0. ring_simplify in q0. contradiction. reflexivity. +Qed. + +Definition DRealAbstr : CReal -> DReal. +Proof. + intro x. + assert (forall (q : Q) (n : nat), + {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + + {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). + { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). + right. apply (Qlt_not_le _ _ q0). left. exact q0. } + + exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) + then true else false). + apply DRealAbstr_aux. Defined. (** *** Conversion from DReal to CReal *) diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 6692119738..6107775003 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -170,7 +170,7 @@ Proof. reg. exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. assumption. -Defined. +Qed. (**********) Lemma antiderivative_P1 : diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 7f5a859c81..2004f40f00 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -41,9 +41,13 @@ Proof. red; intro; rewrite H0 in H; elim (lt_irrefl _ H). Qed. -Lemma exist_exp0 : { l:R | exp_in 0 l }. +(* Value of [exp 0] *) +Lemma exp_0 : exp 0 = 1. Proof. - exists 1. + cut (exp_in 0 1). + cut (exp_in 0 (exp 0)). + apply uniqueness_sum. + exact (proj2_sig (exist_exp 0)). unfold exp_in; unfold infinite_sum; intros. exists 0%nat. intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1. @@ -56,18 +60,6 @@ Proof. simpl. ring. unfold ge; apply le_O_n. -Defined. - -(* Value of [exp 0] *) -Lemma exp_0 : exp 0 = 1. -Proof. - cut (exp_in 0 (exp 0)). - cut (exp_in 0 1). - unfold exp_in; intros; eapply uniqueness_sum. - apply H0. - apply H. - exact (proj2_sig exist_exp0). - exact (proj2_sig (exist_exp 0)). Qed. (*****************************************) @@ -384,9 +376,14 @@ Proof. intros; ring. Qed. -Lemma exist_cos0 : { l:R | cos_in 0 l }. +(* Value of [cos 0] *) +Lemma cos_0 : cos 0 = 1. Proof. - exists 1. + cut (cos_in 0 1). + cut (cos_in 0 (cos 0)). + apply uniqueness_sum. + rewrite <- Rsqr_0 at 1. + exact (proj2_sig (exist_cos (Rsqr 0))). unfold cos_in; unfold infinite_sum; intros; exists 0%nat. intros. unfold R_dist. @@ -400,17 +397,4 @@ Proof. rewrite Rplus_0_r. apply Hrecn; unfold ge; apply le_O_n. simpl; ring. -Defined. - -(* Value of [cos 0] *) -Lemma cos_0 : cos 0 = 1. -Proof. - cut (cos_in 0 (cos 0)). - cut (cos_in 0 1). - unfold cos_in; intros; eapply uniqueness_sum. - apply H0. - apply H. - exact (proj2_sig exist_cos0). - assert (H := proj2_sig (exist_cos (Rsqr 0))); unfold cos; - pattern 0 at 1; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ]. Qed. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 06b02ab211..37d30a282c 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -173,6 +173,14 @@ Proof. apply N_ascii_bounded. Qed. +Definition ltb (a b : ascii) : bool := + (N_of_ascii a <? N_of_ascii b)%N. + +Definition leb (a b : ascii) : bool := + (N_of_ascii a <=? N_of_ascii b)%N. + +Infix "<?" := ltb : char_scope. +Infix "<=?" := leb : char_scope. (** * Concrete syntax *) diff --git a/theories/dune b/theories/dune index 18e000cfe1..1cd3d8c119 100644 --- a/theories/dune +++ b/theories/dune @@ -1,6 +1,6 @@ (coq.theory (name Coq) - (package coq) + (package coq-stdlib) (synopsis "Coq's Standard Library") (flags -q) ; (mode native) @@ -8,30 +8,29 @@ ; (per_file ; (Init/*.v -> -boot)) (libraries - coq.plugins.ltac - coq.plugins.tauto + coq-core.plugins.ltac + coq-core.plugins.tauto - coq.plugins.cc - coq.plugins.firstorder + coq-core.plugins.cc + coq-core.plugins.firstorder - coq.plugins.number_string_notation - coq.plugins.int63_syntax - coq.plugins.float_syntax + coq-core.plugins.number_string_notation + coq-core.plugins.float_syntax - coq.plugins.btauto - coq.plugins.rtauto + coq-core.plugins.btauto + coq-core.plugins.rtauto - coq.plugins.ring - coq.plugins.nsatz - coq.plugins.omega + coq-core.plugins.ring + coq-core.plugins.nsatz + coq-core.plugins.omega - coq.plugins.zify - coq.plugins.micromega + coq-core.plugins.zify + coq-core.plugins.micromega - coq.plugins.funind + coq-core.plugins.funind - coq.plugins.ssreflect - coq.plugins.ssrsearch - coq.plugins.derive)) + coq-core.plugins.ssreflect + coq-core.plugins.ssrsearch + coq-core.plugins.derive)) (include_subdirs qualified) diff --git a/theories/extraction/ExtrOCamlInt63.v b/theories/extraction/ExtrOCamlInt63.v index 7f7b4af98d..1949a1a9d8 100644 --- a/theories/extraction/ExtrOCamlInt63.v +++ b/theories/extraction/ExtrOCamlInt63.v @@ -10,7 +10,7 @@ (** Extraction to OCaml of native 63-bit machine integers. *) -From Coq Require Int63 Extraction. +From Coq Require Int63 Sint63 Extraction. (** Basic data types used by some primitive operators. *) @@ -26,6 +26,7 @@ Extraction Inline Int63.int. Extract Constant Int63.lsl => "Uint63.l_sl". Extract Constant Int63.lsr => "Uint63.l_sr". +Extract Constant Sint63.asr => "Uint63.a_sr". Extract Constant Int63.land => "Uint63.l_and". Extract Constant Int63.lor => "Uint63.l_or". Extract Constant Int63.lxor => "Uint63.l_xor". @@ -36,10 +37,15 @@ Extract Constant Int63.mul => "Uint63.mul". Extract Constant Int63.mulc => "Uint63.mulc". Extract Constant Int63.div => "Uint63.div". Extract Constant Int63.mod => "Uint63.rem". +Extract Constant Sint63.div => "Uint63.divs". +Extract Constant Sint63.rem => "Uint63.rems". + Extract Constant Int63.eqb => "Uint63.equal". Extract Constant Int63.ltb => "Uint63.lt". Extract Constant Int63.leb => "Uint63.le". +Extract Constant Sint63.ltb => "Uint63.lts". +Extract Constant Sint63.leb => "Uint63.les". Extract Constant Int63.addc => "Uint63.addc". Extract Constant Int63.addcarryc => "Uint63.addcarryc". @@ -51,6 +57,7 @@ Extract Constant Int63.diveucl_21 => "Uint63.div21". Extract Constant Int63.addmuldiv => "Uint63.addmuldiv". Extract Constant Int63.compare => "Uint63.compare". +Extract Constant Sint63.compare => "Uint63.compares". Extract Constant Int63.head0 => "Uint63.head0". Extract Constant Int63.tail0 => "Uint63.tail0". diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 0ebb97d0bf..f2f2111fae 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -37,6 +37,7 @@ COQLIBS_NOML := $(COQMF_COQLIBS_NOML) CMDLINE_COQLIBS := $(COQMF_CMDLINE_COQLIBS) LOCAL := $(COQMF_LOCAL) COQLIB := $(COQMF_COQLIB) +COQCORELIB := $(COQMF_COQCORELIB) DOCDIR := $(COQMF_DOCDIR) OCAMLFIND := $(COQMF_OCAMLFIND) CAMLFLAGS := $(COQMF_CAMLFLAGS) @@ -97,9 +98,9 @@ COQMKFILE ?= "$(COQBIN)coq_makefile" OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" # Timing scripts -COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" -COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" -COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" +COQMAKE_ONE_TIME_FILE ?= "$(COQCORELIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQCORELIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing-files.py" BEFORE ?= AFTER ?= @@ -220,7 +221,7 @@ COQDOCLIBS?=$(COQLIBS_NOML) COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) COQMAKEFILE_VERSION:=@COQ_VERSION@ -COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQCORELIB)/$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) # ocamldoc fails with unknown argument otherwise @@ -822,6 +823,7 @@ printenv:: $(warning write extensions in @LOCAL_FILE@ or include @CONF_FILE@) @echo 'LOCAL = $(LOCAL)' @echo 'COQLIB = $(COQLIB)' + @echo 'COQCORELIB = $(COQCORELIB)' @echo 'DOCDIR = $(DOCDIR)' @echo 'OCAMLFIND = $(OCAMLFIND)' @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' @@ -840,12 +842,12 @@ printenv:: .merlin: $(SHOW)'FILL .merlin' $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin - $(HIDE)echo 'B $(COQLIB)' >> .merlin - $(HIDE)echo 'S $(COQLIB)' >> .merlin + $(HIDE)echo 'B $(COQCORELIB)' >> .merlin + $(HIDE)echo 'S $(COQCORELIB)' >> .merlin $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ - echo 'B $(COQLIB)$(d)' >> .merlin;) + echo 'B $(COQCORELIB)$(d)' >> .merlin;) $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ - echo 'S $(COQLIB)$(d)' >> .merlin;) + echo 'S $(COQCORELIB)$(d)' >> .merlin;) $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 07550b67e3..cddb840693 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -125,8 +125,17 @@ let quote s = if String.contains s ' ' || CString.is_empty s then "'" ^ s ^ "'" let generate_makefile oc conf_file local_file dep_file args project = let coqlib = Envars.coqlib () in let makefile_template = - let template = Filename.concat "tools" "CoqMakefile.in" in - Filename.concat coqlib template in + CPath.choose_existing + [ CPath.make [ coqlib; "tools"; "CoqMakefile.in" ] + ; CPath.make [ coqlib; ".."; "coq-core"; "tools"; "CoqMakefile.in" ] + ] + in + let makefile_template = match makefile_template with + | None -> + Format.eprintf "Error: cannot find CoqMakefile.in"; + exit 1 + | Some v -> (v :> string) + in let s = read_whole_file makefile_template in let s = List.fold_left (* We use global_substitute to avoid running into backslash issues due to \1 etc. *) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 2177da0c75..f1dbac889b 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -97,8 +97,16 @@ let coqdep () = if not !option_boot then begin Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); let coqlib = Envars.coqlib () in + let coq_plugins_dir = CPath.choose_existing + [ CPath.make [ coqlib; "plugins" ] + ; CPath.make [ coqlib; ".."; "coq-core"; "plugins" ] + ] |> function + | None -> + CErrors.user_err (Pp.str "coqdep: cannot find plugins directory\n"); + | Some f -> (f :> string) + in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_rec_dir_import add_coqlib_known (coq_plugins_dir) ["Coq"]; let user = coqlib//"user-contrib" in if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune index e3c792f277..cc888a959f 100644 --- a/tools/coqdoc/dune +++ b/tools/coqdoc/dune @@ -1,6 +1,6 @@ (install (section lib) - (package coq) + (package coq-core) (files (coqdoc.css as tools/coqdoc/coqdoc.css) (coqdoc.sty as tools/coqdoc/coqdoc.sty))) @@ -8,7 +8,7 @@ (executable (name main) (public_name coqdoc) - (package coq) - (libraries str coq.config coq.clib)) + (package coq-core) + (libraries str coq-core.config coq-core.clib)) (ocamllex cpretty) diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 6ebf9b71d6..c95d1ee7db 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -87,8 +87,7 @@ let obsolete s = course). *) let banner () = - eprintf "This is coqdoc version %s, compiled on %s\n" - Coq_config.version Coq_config.compile_date; + eprintf "This is coqdoc version %s\n" Coq_config.version; flush stderr let target_full_name f = @@ -472,9 +471,17 @@ let index_module = function | Latex_file _ -> () let copy_style_file file = - let src = - List.fold_left - Filename.concat !Cdglobals.coqlib_path ["tools";"coqdoc";file] in + (* We give preference to coqlib in case it is overriden *) + let src_dir = CPath.choose_existing + [ CPath.make [ !Cdglobals.coqlib_path; "tools"; "coqdoc" ] + ; CPath.make [ !Cdglobals.coqlib_path; ".."; "coq-core"; "tools"; "coqdoc" ] + ] |> function + | None -> + eprintf "coqdoc: cannot find coqdoc style files\n"; + exit 1 + | Some f -> f + in + let src = (CPath.relative src_dir file :> string) in let dst = coqdoc_out file in if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 50aa658128..9cb3baf92c 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -42,7 +42,7 @@ let is_keyword = "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; - "Search"; "SearchHead"; "SearchPattern"; "SearchRewrite"; + "Search"; "SearchPattern"; "SearchRewrite"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; diff --git a/tools/dune b/tools/dune index d591bb0c37..703342b15c 100644 --- a/tools/dune +++ b/tools/dune @@ -1,6 +1,6 @@ (install (section lib) - (package coq) + (package coq-core) (files (CoqMakefile.in as tools/CoqMakefile.in) (TimeFileMaker.py as tools/TimeFileMaker.py) @@ -11,30 +11,30 @@ (executable (name coq_makefile) (public_name coq_makefile) - (package coq) + (package coq-core) (modules coq_makefile) - (libraries coq.lib)) + (libraries coq-core.lib)) (executable (name coqworkmgr) (public_name coqworkmgr) - (package coq) + (package coq-core) (modules coqworkmgr) - (libraries coq.stm)) + (libraries coq-core.stm)) (executable (name coqdep) (public_name coqdep) - (package coq) + (package coq-core) (modules coqdep_lexer coqdep_common coqdep) - (libraries coq.lib)) + (libraries coq-core.lib)) ; Bare-bones mllib/mlpack parser (executable (name ocamllibdep) (public_name ocamllibdep) (modules ocamllibdep) - (package coq) + (package coq-core) (libraries unix)) (ocamllex coqdep_lexer ocamllibdep) @@ -42,7 +42,7 @@ (executable (name coqwc) (public_name coqwc) - (package coq) + (package coq-core) (modules coqwc) (libraries)) @@ -51,6 +51,6 @@ (executables (names coq_tex) (public_names coq-tex) - (package coq) + (package coq-core) (modules coq_tex) (libraries str)) diff --git a/topbin/dune b/topbin/dune index 46052c81e5..5fcb3415f0 100644 --- a/topbin/dune +++ b/topbin/dune @@ -1,31 +1,31 @@ (install (section bin) - (package coq) + (package coq-core) (files (coqtop_bin.exe as coqtop))) (executable (name coqtop_bin) (public_name coqtop.opt) - (package coq) + (package coq-core) (modules coqtop_bin) - (libraries coq.toplevel) + (libraries coq-core.toplevel) (link_flags -linkall)) (executable (name coqtop_byte_bin) (public_name coqtop.byte) - (package coq) + (package coq-core) (modules coqtop_byte_bin) - (libraries compiler-libs.toplevel coq.toplevel) + (libraries compiler-libs.toplevel coq-core.toplevel) (modes byte) (link_flags -linkall)) (executable (name coqc_bin) (public_name coqc) - (package coq) + (package coq-core) (modules coqc_bin) - (libraries coq.toplevel) + (libraries coq-core.toplevel) (modes native byte) ; Adding -ccopt -flto to links options could be interesting, however, ; it doesn't work on Windows @@ -33,16 +33,16 @@ (install (section bin) - (package coq) + (package coq-core) (files (coqc_bin.bc as coqc.byte))) ; Workers (executables (names coqqueryworker_bin coqtacticworker_bin coqproofworker_bin) (public_names coqqueryworker.opt coqtacticworker.opt coqproofworker.opt) - (package coq) + (package coq-core) (modules :standard \ coqtop_byte_bin coqtop_bin coqc_bin) - (libraries coq.toplevel) + (libraries coq-core.toplevel) (link_flags -linkall)) ; Workers installed targets diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index b75a4199ea..041097d2d3 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -24,7 +24,7 @@ let fatal_error msg = let load_init_file opts ~state = if opts.pre.load_rcfile then Topfmt.(in_phase ~phase:LoadingRcFile) (fun () -> - Coqinit.load_rcfile ~rcfile:opts.config.rcfile ~state) () + Coqrc.load_rcfile ~rcfile:opts.config.rcfile ~state) () else begin Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); state @@ -93,7 +93,7 @@ let create_empty_file filename = close_out f (* Compile a vernac file *) -let compile opts copts ~echo ~f_in ~f_out = +let compile opts stm_options injections copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = let pfs = Vernacstate.Declare.get_all_proof_names () [@ocaml.warning "-3"] in @@ -104,9 +104,6 @@ let compile opts copts ~echo ~f_in ~f_out = |> prlist_with_sep pr_comma Names.Id.print) ++ str ".") in - let ml_load_path, vo_load_path = build_load_path opts in - let injections = injection_commands opts in - let stm_options = opts.config.stm_flags in let output_native_objects = match opts.config.native_compiler with | NativeOff -> false | NativeOn {ondemand} -> not ondemand in @@ -129,9 +126,7 @@ let compile opts copts ~echo ~f_in ~f_out = | BuildVo | BuildVok -> let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VoDoc long_f_dot_out; ml_load_path; - vo_load_path; injections; stm_options; - } in + Stm.{ doc_type = VoDoc long_f_dot_out; injections; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in @@ -181,8 +176,7 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VioDoc long_f_dot_out; ml_load_path; - vo_load_path; injections; stm_options; + Stm.{ doc_type = VioDoc long_f_dot_out; injections; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in @@ -209,22 +203,21 @@ let compile opts copts ~echo ~f_in ~f_out = dump_empty_vos(); create_empty_file (long_f_dot_out ^ "k") -let compile opts copts ~echo ~f_in ~f_out = +let compile opts stm_opts copts injections ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile opts copts ~echo ~f_in ~f_out; + compile opts stm_opts injections copts ~echo ~f_in ~f_out; CoqworkmgrApi.giveback 1 -let compile_file opts copts (f_in, echo) = +let compile_file opts stm_opts copts injections (f_in, echo) = let f_out = copts.compilation_output_name in if !Flags.beautify then Flags.with_option Flags.beautify_file - (fun f_in -> compile opts copts ~echo ~f_in ~f_out) f_in + (fun f_in -> compile opts stm_opts copts injections ~echo ~f_in ~f_out) f_in else - compile opts copts ~echo ~f_in ~f_out + compile opts stm_opts copts injections ~echo ~f_in ~f_out -let compile_files opts copts = - let compile_list = copts.compile_list in - List.iter (compile_file opts copts) compile_list +let compile_file opts stm_opts copts injections = + Option.iter (compile_file opts stm_opts copts injections) copts.compile_file (******************************************************************************) (* VIO Dispatching *) @@ -248,14 +241,7 @@ let schedule_vio copts = else Vio_checking.schedule_vio_compilation copts.vio_files_j l -let do_vio opts copts = - (* We must initialize the loadpath here as the vio scheduling - process happens outside of the STM *) - if copts.vio_files <> [] || copts.vio_tasks <> [] then - let ml_lp, vo_lp = build_load_path opts in - List.iter Mltop.add_ml_dir ml_lp; - List.iter Loadpath.add_vo_path vo_lp; - +let do_vio opts copts _injections = (* Vio compile pass *) if copts.vio_files <> [] then schedule_vio copts; (* Vio task pass *) diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index 8c154488d0..e9e83af3ad 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -12,8 +12,8 @@ the init (rc) file *) val load_init_vernaculars : Coqargs.t -> state:Vernac.State.t-> Vernac.State.t -(** [compile_files opts] compile files specified in [opts] *) -val compile_files : Coqargs.t -> Coqcargs.t -> unit +(** [compile_file opts] compile file specified in [opts] *) +val compile_file : Coqargs.t -> Stm.AsyncOpts.stm_opt -> Coqcargs.t -> Coqargs.injection_command list -> unit (** [do_vio opts] process [.vio] files in [opts] *) -val do_vio : Coqargs.t -> Coqcargs.t -> unit +val do_vio : Coqargs.t -> Coqcargs.t -> Coqargs.injection_command list -> unit diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 03c53d6991..b7af66b2ee 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -13,10 +13,11 @@ let outputstate opts = let fname = CUnix.make_suffix ostate_file ".coq" in Vernacstate.System.dump fname) opts.Coqcargs.outputstate -let coqc_init _copts ~opts = +let coqc_init ((_,color_mode),_) injections ~opts = Flags.quiet := true; System.trust_file_cache := true; - Coqtop.init_color opts.Coqargs.config + Coqtop.init_color (if opts.Coqargs.config.Coqargs.print_emacs then `EMACS else color_mode); + injections let coqc_specific_usage = Usage.{ executable_name = "coqc"; @@ -41,30 +42,30 @@ coqc specific options:\ \n" } -let coqc_main copts ~opts = +let coqc_main ((copts,_),stm_opts) injections ~opts = Topfmt.(in_phase ~phase:CompilationPhase) - Ccompile.compile_files opts copts; + Ccompile.compile_file opts stm_opts copts injections; (* Careful this will modify the load-path and state so after this point some stuff may not be safe anymore. *) Topfmt.(in_phase ~phase:CompilationPhase) - Ccompile.do_vio opts copts; + Ccompile.do_vio opts copts injections; (* Allow the user to output an arbitrary state *) outputstate copts; flush_all(); - if opts.Coqargs.post.Coqargs.output_context then begin + if copts.Coqcargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () -let coqc_run copts ~opts () = +let coqc_run copts ~opts injections = let _feeder = Feedback.add_feeder Coqloop.coqloop_feed in try - coqc_main ~opts copts; + coqc_main ~opts copts injections; exit 0 with exn -> flush_all(); @@ -73,12 +74,17 @@ let coqc_run copts ~opts () = let exit_code = if (CErrors.is_anomaly exn) then 129 else 1 in exit exit_code -let custom_coqc = Coqtop.{ - parse_extra = (fun ~opts extras -> Coqcargs.parse extras, []); - help = coqc_specific_usage; - init = coqc_init; +let custom_coqc : ((Coqcargs.t * Coqtop.color) * Stm.AsyncOpts.stm_opt, 'b) Coqtop.custom_toplevel + = Coqtop.{ + parse_extra = (fun extras -> + let color_mode, extras = Coqtop.parse_extra_colors extras in + let stm_opts, extras = Stmargs.parse_args ~init:Stm.AsyncOpts.default_opts extras in + let coqc_opts = Coqcargs.parse extras in + ((coqc_opts, color_mode), stm_opts), []); + usage = coqc_specific_usage; + init_extra = coqc_init; run = coqc_run; - opts = Coqargs.default; + initial_args = Coqargs.default; } let main () = diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 402a4d83c9..efd8a79e18 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -13,7 +13,7 @@ type compilation_mode = BuildVo | BuildVio | Vio2Vo | BuildVos | BuildVok type t = { compilation_mode : compilation_mode - ; compile_list: (string * bool) list (* bool is verbosity *) + ; compile_file: (string * bool) option (* bool is verbosity *) ; compilation_output_name : string option ; vio_checking : bool @@ -25,12 +25,14 @@ type t = ; outputstate : string option ; glob_out : Dumpglob.glob_output + + ; output_context : bool } let default = { compilation_mode = BuildVo - ; compile_list = [] + ; compile_file = None ; compilation_output_name = None ; vio_checking = false @@ -42,6 +44,8 @@ let default = ; outputstate = None ; glob_out = Dumpglob.MultFiles + + ; output_context = false } let depr opt = @@ -58,17 +62,13 @@ let error_missing_arg s = prerr_endline "See -help for the syntax of supported options"; exit 1 -let check_compilation_output_name_consistency args = - match args.compilation_output_name, args.compile_list with - | Some _, _::_::_ -> - prerr_endline ("Error: option -o is not valid when more than one"); - prerr_endline ("file have to be compiled") - | _ -> () +let arg_error msg = CErrors.user_err msg let is_dash_argument s = String.length s > 0 && s.[0] = '-' let add_compile ?echo copts s = - if is_dash_argument s then (prerr_endline ("Unknown option " ^ s); exit 1); + if is_dash_argument s then + arg_error Pp.(str "Unknown option " ++ str s); (* make the file name explicit; needed not to break up Coq loadpath stuff. *) let echo = Option.default copts.echo echo in let s = @@ -77,7 +77,14 @@ let add_compile ?echo copts s = then concat current_dir_name s else s in - { copts with compile_list = (s,echo) :: copts.compile_list } + { copts with compile_file = Some (s,echo) } + +let add_compile ?echo copts v_file = + match copts.compile_file with + | Some _ -> + arg_error Pp.(str "More than one file to compile: " ++ str v_file) + | None -> + add_compile ?echo copts v_file let add_vio_task opts f = { opts with vio_tasks = f :: opts.vio_tasks } @@ -162,6 +169,10 @@ let parse arglist : t = depr opt; let _ = next () in oval + + (* Non deprecated options *) + | "-output-context" -> + { oval with output_context = true } (* Verbose == echo mode *) | "-verbose" -> echo := true; @@ -222,14 +233,12 @@ let parse arglist : t = try let opts, extra = parse default in let args = List.fold_left add_compile opts extra in - check_compilation_output_name_consistency args; args with any -> fatal_error any let parse args = let opts = parse args in { opts with - compile_list = List.rev opts.compile_list - ; vio_tasks = List.rev opts.vio_tasks + vio_tasks = List.rev opts.vio_tasks ; vio_files = List.rev opts.vio_files } diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli index a9fc27b1b4..96895568ea 100644 --- a/toplevel/coqcargs.mli +++ b/toplevel/coqcargs.mli @@ -27,7 +27,7 @@ type compilation_mode = BuildVo | BuildVio | Vio2Vo | BuildVos | BuildVok type t = { compilation_mode : compilation_mode - ; compile_list: (string * bool) list (* bool is verbosity *) + ; compile_file: (string * bool) option (* bool is verbosity *) ; compilation_output_name : string option ; vio_checking : bool @@ -39,6 +39,8 @@ type t = ; outputstate : string option ; glob_out : Dumpglob.glob_output + + ; output_context : bool } val default : t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 6460378edc..4faecd2e62 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -480,6 +480,11 @@ let drop_args = ref None (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path ~coqlib = + let coqlib : string = + if Sys.file_exists (CPath.make [coqlib; "plugins"] :> string) + then coqlib + else (CPath.make [ coqlib ; ".."; "coq-core" ] :> string) + in let add_subdir dl = Mltop.add_ml_dir (Filename.concat coqlib dl) in List.iter add_subdir ("dev" :: Coq_config.all_src_dirs) diff --git a/toplevel/coqrc.ml b/toplevel/coqrc.ml new file mode 100644 index 0000000000..e074e621da --- /dev/null +++ b/toplevel/coqrc.ml @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let ( / ) s1 s2 = Filename.concat s1 s2 + +(* Loading of the resource file. + rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one + does not exist. *) + +let rcdefaultname = "coqrc" + +let load_rcfile ~rcfile ~state = + try + match rcfile with + | Some rcfile -> + if CUnix.file_readable_p rcfile then + Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state rcfile + else raise (Sys_error ("Cannot read rcfile: "^ rcfile)) + | None -> + try + let warn x = Feedback.msg_warning (Pp.str x) in + let inferedrc = List.find CUnix.file_readable_p [ + Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; + Envars.xdg_config_home warn / rcdefaultname; + Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; + Envars.home ~warn / "."^rcdefaultname + ] in + Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state inferedrc + with Not_found -> state + (* + Flags.if_verbose + mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ + " found. Skipping rcfile loading.")) + *) + with reraise -> + let reraise = Exninfo.capture reraise in + let () = Feedback.msg_info (Pp.str"Load of rcfile failed.") in + Exninfo.iraise reraise diff --git a/toplevel/coqrc.mli b/toplevel/coqrc.mli new file mode 100644 index 0000000000..3b8a31b2a5 --- /dev/null +++ b/toplevel/coqrc.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index d0d50aee70..bb44d9cdee 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -18,41 +18,19 @@ let () = at_exit flush_all let ( / ) = Filename.concat -let get_version_date () = +let get_version () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in - (ver,rev) - with e when CErrors.noncritical e -> - (Coq_config.version,Coq_config.date) + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let print_header () = - let (ver,rev) = get_version_date () in - Feedback.msg_info (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); + Feedback.msg_info (str "Welcome to Coq " ++ str (get_version ())); flush_all () -let print_memory_stat () = - (* -m|--memory from the command-line *) - Feedback.msg_notice - (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); - (* operf-macro interface: - https://github.com/OCamlPro/operf-macro *) - try - let fn = Sys.getenv "OCAML_GC_STATS" in - let oc = open_out fn in - Gc.print_stat oc; - close_out oc - with _ -> () - -(******************************************************************************) -(* Input/Output State *) -(******************************************************************************) -let inputstate opts = - Option.iter (fun istate_file -> - let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in - Vernacstate.System.load fname) opts.inputstate (******************************************************************************) (* Fatal Errors *) @@ -68,11 +46,44 @@ let fatal_error_exn exn = in exit exit_code -(******************************************************************************) -(* Color Options *) -(******************************************************************************) +type ('a,'b) custom_toplevel = + { parse_extra : string list -> 'a * string list + ; usage : Usage.specific_usage + ; init_extra : 'a -> Coqargs.injection_command list -> opts:Coqargs.t -> 'b + ; initial_args : Coqargs.t + ; run : 'a -> opts:Coqargs.t -> 'b -> unit + } + +(** Main init routine *) +let init_toplevel { parse_extra; init_extra; usage; initial_args } = + Coqinit.init_ocaml (); + let opts, customopts = Coqinit.parse_arguments ~parse_extra ~usage ~initial_args () in + Stm.init_process (snd customopts); + let injections = Coqinit.init_runtime opts in + (* This state will be shared by all the documents *) + Stm.init_core (); + let customstate = init_extra ~opts customopts injections in + opts, customopts, customstate + +let start_coq custom = + let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in + (* Init phase *) + let opts, custom_opts, state = + try init_toplevel custom + with any -> + flush_all(); + fatal_error_exn any in + Feedback.del_feeder init_feeder; + (* Run phase *) + custom.run ~opts custom_opts state + +(** ****************************************) +(** Specific support for coqtop executable *) + +type color = [`ON | `AUTO | `EMACS | `OFF] + let init_color opts = - let has_color = match opts.color with + let has_color = match opts with | `OFF -> false | `EMACS -> false | `ON -> true @@ -95,7 +106,7 @@ let init_color opts = Topfmt.default_styles (); false (* textual markers, no color *) end in - if opts.color = `EMACS then + if opts = `EMACS then Topfmt.set_emacs_print_strings () else if not term_color then begin Proof_diffs.write_color_enabled term_color; @@ -120,131 +131,15 @@ let print_style_tags opts = let () = List.iter iter tags in flush_all () -let init_coqlib opts = match opts.config.coqlib with - | None when opts.pre.boot -> () - | None -> - Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - | Some s -> - Envars.set_user_coqlib s - -let print_query opts = function - | PrintVersion -> Usage.version () - | PrintMachineReadableVersion -> Usage.machine_readable_version () - | PrintWhere -> - let () = init_coqlib opts in - print_endline (Envars.coqlib ()) - | PrintHelp h -> Usage.print_usage stderr h - | PrintConfig -> - let () = init_coqlib opts in - Envars.print_config stdout Coq_config.all_src_dirs - | PrintTags -> print_style_tags opts.config - -(** GC tweaking *) - -(** Coq is a heavy user of persistent data structures and symbolic ASTs, so the - minor heap is heavily solicited. Unfortunately, the default size is far too - small, so we enlarge it a lot (128 times larger). +type query = PrintTags | PrintModUid of string list +type run_mode = Interactive | Batch | Query of query - To better handle huge memory consumers, we also augment the default major - heap increment and the GC pressure coefficient. -*) - -let set_gc_policy () = - Gc.set { (Gc.get ()) with - Gc.minor_heap_size = 32*1024*1024 (* 32Mwords x 8 bytes/word = 256Mb *) - ; Gc.space_overhead = 120 - } - -let set_gc_best_fit () = - Gc.set { (Gc.get ()) with - Gc.allocation_policy = 2 (* best-fit *) - ; Gc.space_overhead = 200 - } - -let init_gc () = - try - (* OCAMLRUNPARAM environment variable is set. - * In that case, we let ocamlrun to use the values provided by the user. - *) - ignore (Sys.getenv "OCAMLRUNPARAM") - - with Not_found -> - (* OCAMLRUNPARAM environment variable is not set. - * In this case, we put in place our preferred configuration. - *) - set_gc_policy (); - if Coq_config.caml_version_nums >= [4;10;0] then set_gc_best_fit () else () - -let init_process () = - (* Coq's init process, phase 1: - OCaml parameters, basic structures, and IO - *) - CProfile.init_profile (); - init_gc (); - Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - Lib.init () - -let init_parse parse_extra help init_opts = - let opts, extras = - parse_args ~help:help ~init:init_opts - (List.tl (Array.to_list Sys.argv)) in - let customopts, extras = parse_extra ~opts extras in - if not (CList.is_empty extras) then begin - prerr_endline ("Don't know what to do with "^String.concat " " extras); - prerr_endline "See -help for the list of supported options"; - exit 1 - end; - opts, customopts - -(** Coq's init process, phase 2: Basic Coq environment, plugins. *) -let init_execution opts custom_init = - (* If we have been spawned by the Spawn module, this has to be done - * early since the master waits us to connect back *) - Spawned.init_channels (); - if opts.post.memory_stat then at_exit print_memory_stat; - CoqworkmgrApi.(init opts.config.stm_flags.Stm.AsyncOpts.async_proofs_worker_priority); - Mltop.init_known_plugins (); - (* Configuration *) - Global.set_engagement opts.config.logic.impredicative_set; - Global.set_indices_matter opts.config.logic.indices_matter; - Global.set_VM opts.config.enable_VM; - Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - - (* Native output dir *) - Nativelib.output_dir := opts.config.native_output_dir; - Nativelib.include_dirs := opts.config.native_include_dirs; - - (* Allow the user to load an arbitrary state here *) - inputstate opts.pre; - - (* This state will be shared by all the documents *) - Stm.init_core (); - custom_init ~opts - -type 'a extra_args_fn = opts:Coqargs.t -> string list -> 'a * string list - -type ('a,'b) custom_toplevel = - { parse_extra : 'a extra_args_fn - ; help : Usage.specific_usage - ; init : 'a -> opts:Coqargs.t -> 'b - ; run : 'a -> opts:Coqargs.t -> 'b -> unit - ; opts : Coqargs.t - } - -(** Main init routine *) -let init_toplevel custom = - let () = init_process () in - let opts, customopts = init_parse custom.parse_extra custom.help custom.opts in - (* Querying or running? *) - match opts.main with - | Queries q -> List.iter (print_query opts) q; exit 0 - | Run -> - let () = init_coqlib opts in - let customstate = init_execution opts (custom.init customopts) in - opts, customopts, customstate +type toplevel_options = { + run_mode : run_mode; + color_mode : color; +} -let init_document opts = +let init_document opts stm_options injections = (* Coq init process, phase 3: Stm initialization, backtracking state. It is essential that the module system is in a consistent @@ -253,57 +148,70 @@ let init_document opts = *) (* Next line allows loading .vos files when in interactive mode *) Flags.load_vos_libraries := true; - let ml_load_path, vo_load_path = build_load_path opts in - let injections = injection_commands opts in - let stm_options = opts.config.stm_flags in let open Vernac.State in let doc, sid = Stm.(new_doc { doc_type = Interactive opts.config.logic.toplevel_name; - ml_load_path; vo_load_path; injections; stm_options; + injections; stm_options; }) in { doc; sid; proof = None; time = opts.config.time } -let start_coq custom = - let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in - (* Init phase *) - let opts, custom_opts, state = - try init_toplevel custom - with any -> - flush_all(); - fatal_error_exn any in - Feedback.del_feeder init_feeder; - (* Run phase *) - custom.run ~opts custom_opts state - -(** ****************************************) -(** Specific support for coqtop executable *) - -type run_mode = Interactive | Batch - -let init_toploop opts = - let state = init_document opts in +let init_toploop opts stm_opts injections = + let state = init_document opts stm_opts injections in let state = Ccompile.load_init_vernaculars opts ~state in state -let coqtop_init run_mode ~opts = - if run_mode = Batch then Flags.quiet := true; - init_color opts.config; +let coqtop_init ({ run_mode; color_mode }, async_opts) injections ~opts = + if run_mode != Interactive then Flags.quiet := true; + init_color (if opts.config.print_emacs then `EMACS else color_mode); Flags.if_verbose print_header (); - init_toploop opts - -let coqtop_parse_extra ~opts extras = - let rec parse_extra run_mode = function - | "-batch" :: rest -> parse_extra Batch rest + init_toploop opts async_opts injections + +let set_color = function + | "yes" | "on" -> `ON + | "no" | "off" -> `OFF + | "auto" ->`AUTO + | _ -> + error_wrong_arg ("Error: on/off/auto expected after option color") + +let parse_extra_colors extras = + let rec parse_extra color_mode = function + | "-color" :: next :: rest -> parse_extra (set_color next) rest + | "-list-tags" :: rest -> parse_extra color_mode rest | x :: rest -> + let color_mode, rest = parse_extra color_mode rest in color_mode, x :: rest + | [] -> color_mode, [] in + parse_extra `AUTO extras + +let coqtop_parse_extra extras = + let rec parse_extra run_mode = function + | "-batch" :: rest -> parse_extra Batch rest + | "-print-mod-uid" :: rest -> Query (PrintModUid rest), [] + | x :: rest -> let run_mode, rest = parse_extra run_mode rest in run_mode, x :: rest | [] -> run_mode, [] in let run_mode, extras = parse_extra Interactive extras in - run_mode, extras + let color_mode, extras = parse_extra_colors extras in + let async_opts, extras = Stmargs.parse_args ~init:Stm.AsyncOpts.default_opts extras in + ({ run_mode; color_mode}, async_opts), extras + +let get_native_name s = + (* We ignore even critical errors because this mode has to be super silent *) + try + Filename.(List.fold_left concat (dirname s) + [ !Nativelib.output_dir + ; Library.native_name_from_filename s + ]) + with _ -> "" -let coqtop_run run_mode ~opts state = +let coqtop_run ({ run_mode; color_mode },_) ~opts state = match run_mode with | Interactive -> Coqloop.loop ~opts ~state; + | Query PrintTags -> print_style_tags color_mode; exit 0 + | Query (PrintModUid sl) -> + let s = String.concat " " (List.map get_native_name sl) in + print_endline s; + exit 0 | Batch -> exit 0 let coqtop_specific_usage = Usage.{ @@ -317,8 +225,8 @@ coqtop specific options:\n\ let coqtop_toplevel = { parse_extra = coqtop_parse_extra - ; help = coqtop_specific_usage - ; init = coqtop_init + ; usage = coqtop_specific_usage + ; init_extra = coqtop_init ; run = coqtop_run - ; opts = Coqargs.default + ; initial_args = Coqargs.default } diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index e535c19252..c675c6adec 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -9,18 +9,16 @@ (************************************************************************) (** Definition of custom toplevels. - [init] is used to do custom command line argument parsing. + [init_extra] is used to do custom initialization [run] launches a custom toplevel. *) -type 'a extra_args_fn = opts:Coqargs.t -> string list -> 'a * string list - type ('a,'b) custom_toplevel = - { parse_extra : 'a extra_args_fn - ; help : Usage.specific_usage - ; init : 'a -> opts:Coqargs.t -> 'b + { parse_extra : string list -> 'a * string list + ; usage : Usage.specific_usage + ; init_extra : 'a -> Coqargs.injection_command list -> opts:Coqargs.t -> 'b + ; initial_args : Coqargs.t ; run : 'a -> opts:Coqargs.t -> 'b -> unit - ; opts : Coqargs.t } (** The generic Coq main module. [start custom] will parse the command line, @@ -28,18 +26,28 @@ type ('a,'b) custom_toplevel = load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [custom.run]. *) -val start_coq : ('a,'b) custom_toplevel -> unit +val start_coq : ('a * Stm.AsyncOpts.stm_opt,'b) custom_toplevel -> unit (** Initializer color for output *) -val init_color : Coqargs.coqargs_config -> unit +type color = [`ON | `AUTO | `EMACS | `OFF] + +val init_color : color -> unit +val parse_extra_colors : string list -> color * string list +val print_style_tags : color -> unit (** Prepare state for interactive loop *) -val init_toploop : Coqargs.t -> Vernac.State.t +val init_toploop : Coqargs.t -> Stm.AsyncOpts.stm_opt -> Coqargs.injection_command list -> Vernac.State.t (** The specific characterization of the coqtop_toplevel *) -type run_mode = Interactive | Batch +type query = PrintTags | PrintModUid of string list +type run_mode = Interactive | Batch | Query of query + +type toplevel_options = { + run_mode : run_mode; + color_mode : color; +} -val coqtop_toplevel : (run_mode,Vernac.State.t) custom_toplevel +val coqtop_toplevel : (toplevel_options * Stm.AsyncOpts.stm_opt,Vernac.State.t) custom_toplevel diff --git a/toplevel/dune b/toplevel/dune index 98f4ba2edf..9d5a08dde7 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -1,9 +1,9 @@ (library (name toplevel) - (public_name coq.toplevel) + (public_name coq-core.toplevel) (synopsis "Coq's Interactive Shell [terminal-based]") (wrapped false) - (libraries coq.stm)) + (libraries coq-core.stm)) ; Interp provides the `zarith` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index ddd11fd160..90f8fb9686 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -1,7 +1,5 @@ Vernac -Usage -Coqinit -Coqargs +Coqrc Coqcargs G_toplevel Coqloop diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index 59e10b09a0..e72940d189 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -8,10 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let worker_parse_extra ~opts extra_args = - (), extra_args +let worker_parse_extra extra_args = + let stm_opts, extra_args = Stmargs.parse_args ~init:Stm.AsyncOpts.default_opts extra_args in + ((),stm_opts), extra_args -let worker_init init () ~opts = +let worker_init init ((),_) _injections ~opts = Flags.quiet := true; init (); Coqtop.init_toploop opts @@ -27,9 +28,9 @@ let start ~init ~loop name = let open Coqtop in let custom = { parse_extra = worker_parse_extra; - help = worker_specific_usage name; - opts = Coqargs.default; - init = worker_init init; - run = (fun () ~opts:_ _state (* why is state not used *) -> loop ()); + usage = worker_specific_usage name; + initial_args = Coqargs.default; + init_extra = worker_init init; + run = (fun ((),_) ~opts:_ _state (* why is state not used *) -> loop ()); } in start_coq custom diff --git a/user-contrib/Ltac2/dune b/user-contrib/Ltac2/dune index 90869a46a0..b90bae10a3 100644 --- a/user-contrib/Ltac2/dune +++ b/user-contrib/Ltac2/dune @@ -1,14 +1,14 @@ (coq.theory (name Ltac2) - (package coq) + (package coq-stdlib) (synopsis "Ltac2 tactic language") - (libraries coq.plugins.ltac2)) + (libraries coq-core.plugins.ltac2)) (library (name ltac2_plugin) - (public_name coq.plugins.ltac2) + (public_name coq-core.plugins.ltac2) (synopsis "Ltac2 plugin") (modules_without_implementation tac2expr tac2qexpr tac2types) - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ltac2)) diff --git a/user-contrib/Ltac2/plugin_base.dune b/user-contrib/Ltac2/plugin_base.dune deleted file mode 100644 index 711e9b95d3..0000000000 --- a/user-contrib/Ltac2/plugin_base.dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name ltac2_plugin) - (public_name coq.plugins.ltac2) - (synopsis "Coq's Ltac2 plugin") - (modules_without_implementation tac2expr tac2qexpr tac2types) - (libraries coq.plugins.ltac)) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index cc59a96834..f600432c80 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -193,48 +193,48 @@ let build_beq_scheme mode kn = let create_input c = let myArrow u v = mkArrow u Sorts.Relevant (lift 1 v) and eqName = function - | Name s -> Id.of_string ("eq_"^(Id.to_string s)) - | Anonymous -> Id.of_string "eq_A" + | Name s -> Id.of_string ("eq_"^(Id.to_string s)) + | Anonymous -> Id.of_string "eq_A" in let ext_rel_list = Context.Rel.to_extended_list mkRel 0 lnamesparrec in - let lift_cnt = ref 0 in - let eqs_typ = List.map (fun aa -> - let a = lift !lift_cnt aa in - incr lift_cnt; - myArrow a (myArrow a (bb ())) - ) ext_rel_list in - - let eq_input = List.fold_left2 - ( fun a b decl -> (* mkLambda(n,b,a) ) *) - (* here I leave the Naming thingy so that the type of + let lift_cnt = ref 0 in + let eqs_typ = List.map (fun aa -> + let a = lift !lift_cnt aa in + incr lift_cnt; + myArrow a (myArrow a (bb ())) + ) ext_rel_list in + + let eq_input = List.fold_left2 + ( fun a b decl -> (* mkLambda(n,b,a) ) *) + (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (map_annot eqName (RelDecl.get_annot decl)) b a ) - c (List.rev eqs_typ) lnamesparrec - in - List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) - (* Same here , hoping the auto renaming will do something good ;) *) - let x = map_annot - (function Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_annot decl) - in - mkNamedLambda x (RelDecl.get_type decl) a) eq_input lnamesparrec - in - let make_one_eq cur = - let u = Univ.Instance.empty in - let ind = (kn,cur),u (* FIXME *) in - (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd (fst ind)) in - (* Inductive toto : [rettyp] := *) - let rettyp = Inductive.type_of_inductive ((mib,cur_packet),u) in - (* split rettyp in a list without the non rec params and the last -> + mkNamedLambda (map_annot eqName (RelDecl.get_annot decl)) b a ) + c (List.rev eqs_typ) lnamesparrec + in + List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) + (* Same here , hoping the auto renaming will do something good ;) *) + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedLambda x (RelDecl.get_type decl) a) eq_input lnamesparrec + in + let make_one_eq cur = + let u = Univ.Instance.empty in + let ind = (kn,cur),u (* FIXME *) in + (* current inductive we are working on *) + let cur_packet = mib.mind_packets.(snd (fst ind)) in + (* Inductive toto : [rettyp] := *) + let rettyp = Inductive.type_of_inductive ((mib,cur_packet),u) in + (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) - let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in + let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in (* give a type A, this function tries to find the equality on A declared previously *) (* nlist = the number of args (A , B , ... ) eqA = the de Bruijn index of the first eq param ndx = how much to translate due to the 2nd Case - *) + *) let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in let rec aux c = @@ -243,47 +243,47 @@ let build_beq_scheme mode kn = match Constr.kind c with | Rel x -> mkRel (x-nlist+ndx) | 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) - with Not_found -> raise (ParameterWithoutEquality (GlobRef.VarRef x)) - in - mkVar eid + (* 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) + with Not_found -> raise (ParameterWithoutEquality (GlobRef.VarRef x)) + in + mkVar eid | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if Environ.QMutInd.equal env kn kn' then mkRel(eqA-nlist-i+nb_ind-1) - else begin - try - let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with - | Some c -> mkConst c - | None -> assert false - in - let eqa = Array.of_list @@ List.map aux a in - let args = - Array.append - (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in - if Int.equal (Array.length args) 0 then eq - else mkApp (eq, args) - with Not_found -> raise(EqNotFound (ind', fst ind)) - end + if Environ.QMutInd.equal env kn kn' then mkRel(eqA-nlist-i+nb_ind-1) + else begin + try + let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with + | Some c -> mkConst c + | None -> assert false + in + let eqa = Array.of_list @@ List.map aux a in + let args = + Array.append + (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in + if Int.equal (Array.length args) 0 then eq + else mkApp (eq, args) + with Not_found -> raise(EqNotFound (ind', fst ind)) + end | Sort _ -> raise InductiveWithSort | Prod _ -> raise InductiveWithProduct | Lambda _-> raise (EqUnknown "abstraction") | LetIn _ -> raise (EqUnknown "let-in") | Const (kn, u) -> - (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 - if Environ.mem_constant kneq env then - let _ = Environ.constant_opt_value_in env (kneq, u) in - Term.applist (mkConst kneq,a) - else raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) + (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 + if Environ.mem_constant kneq env then + let _ = Environ.constant_opt_value_in env (kneq, u) in + Term.applist (mkConst kneq,a) + else raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -293,100 +293,112 @@ let build_beq_scheme mode kn = | Evar _ -> raise (EqUnknown "existential variable") | Int _ -> raise (EqUnknown "int") | Float _ -> raise (EqUnknown "float") - | Array _ -> raise (EqUnknown "array") - in + | Array _ -> raise (EqUnknown "array") + in aux t - in - (* construct the predicate for the Case part*) - let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(make_annot Anonymous Sorts.Relevant,b,a)) - (mkLambda (make_annot Anonymous Sorts.Relevant, - mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - (bb ()))) - (List.rev rettyp_l) in - (* make_one_eq *) - (* do the [| C1 ... => match Y with ... end + in + (* construct the predicate for the Case part*) + let do_predicate rel_list n = + List.fold_left (fun a b -> mkLambda(make_annot Anonymous Sorts.Relevant,b,a)) + (mkLambda (make_annot Anonymous Sorts.Relevant, + mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), + (bb ()))) + (List.rev rettyp_l) in + (* make_one_eq *) + (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info env (fst ind) rci MatchStyle in - let constrs n = get_constructors env (make_ind_family (ind, - Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt)) in + let constrs n = + let params = Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt in + get_constructors env (make_ind_family (ind, params)) + in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.make n (ff ()) in - for i=0 to n-1 do - let nb_cstr_args = List.length constrsi.(i).cs_args in - let ar2 = Array.make n (ff ()) in - let constrsj = constrs (3+nparrec+nb_cstr_args) in - for j=0 to n-1 do - if Int.equal i j then - ar2.(j) <- let cc = (match nb_cstr_args with - | 0 -> tt () - | _ -> let eqs = Array.make nb_cstr_args (tt ()) in - for ndx = 0 to nb_cstr_args-1 do - let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in - let eqA = compute_A_equality rel_list - nparrec - (nparrec+3+2*nb_cstr_args) - (nb_cstr_args+ndx+1) - cc - in - Array.set eqs ndx - (mkApp (eqA, - [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] - )) - done; - Array.fold_left - (fun a b -> mkApp (andb(),[|b;a|])) - (eqs.(0)) - (Array.sub eqs 1 (nb_cstr_args - 1)) - ) - in - (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) cc - (constrsj.(j).cs_args) - ) - else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) - done; - - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (Inductive.contract_case env ((ci,do_predicate rel_list nb_cstr_args, - NoInvert, mkVar (Id.of_string "Y") ,ar2)))) - (constrsi.(i).cs_args)) - done; - mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( - mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (Inductive.contract_case env (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar)))) - in (* build_beq_scheme *) - let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and - types = Array.make nb_ind mkSet and - cores = Array.make nb_ind mkSet in - let u = Univ.Instance.empty in - for i=0 to (nb_ind-1) do - names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; - types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant - (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); - let c = make_one_eq i in - cores.(i) <- c; - done; - (Array.init nb_ind (fun i -> - let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in - if not (Sorts.family_leq InSet kelim) then - raise (NonSingletonProp (kn,i)); - let fix = match mib.mind_finite with - | CoFinite -> - raise NoDecidabilityCoInductive; - | Finite -> - mkFix (((Array.make nb_ind 0),i),(names,types,cores)) - | BiFinite -> - (* If the inductive type is not recursive, the fixpoint is + let ar = Array.init n (fun i -> + let nb_cstr_args = List.length constrsi.(i).cs_args in + let constrsj = constrs (3+nparrec+nb_cstr_args) in + let ar2 = Array.init n (fun j -> + if Int.equal i j then + let cc = match nb_cstr_args with + | 0 -> tt () + | _ -> + let eqs = Array.init nb_cstr_args (fun ndx -> + let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in + let eqA = compute_A_equality rel_list + nparrec + (nparrec+3+2*nb_cstr_args) + (nb_cstr_args+ndx+1) + cc + in + mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|])) + in + Array.fold_left + (fun a b -> mkApp (andb(),[|b;a|])) + eqs.(0) + (Array.sub eqs 1 (nb_cstr_args - 1)) + in + List.fold_left (fun a decl -> + mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) + cc + constrsj.(j).cs_args + else + List.fold_left (fun a decl -> + mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) + (ff ()) + (constrsj.(j).cs_args)) + in + let pred = EConstr.of_constr (do_predicate rel_list nb_cstr_args) in + let case = + simple_make_case_or_project env (Evd.from_env env) + ci pred NoInvert (EConstr.mkVar (Id.of_string "Y")) + (EConstr.of_constr_array ar2) + in + List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) + (EConstr.Unsafe.to_constr case) + (constrsi.(i).cs_args)) + in + let pred = EConstr.of_constr (do_predicate rel_list 0) in + let case = + simple_make_case_or_project env (Evd.from_env env) + ci pred NoInvert (EConstr.mkVar (Id.of_string "X")) + (EConstr.of_constr_array ar) + in + mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( + mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( + (EConstr.Unsafe.to_constr case))) + in (* build_beq_scheme *) + + let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and + types = Array.make nb_ind mkSet and + cores = Array.make nb_ind mkSet in + let u = Univ.Instance.empty in + for i=0 to (nb_ind-1) do + names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant + (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); + let c = make_one_eq i in + cores.(i) <- c; + done; + let res = Array.init nb_ind (fun i -> + let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in + if not (Sorts.family_leq InSet kelim) then + raise (NonSingletonProp (kn,i)); + let fix = match mib.mind_finite with + | CoFinite -> + raise NoDecidabilityCoInductive; + | Finite -> + mkFix (((Array.make nb_ind 0),i),(names,types,cores)) + | BiFinite -> + (* If the inductive type is not recursive, the fixpoint is not used, so let's replace it with garbage *) - let subst = List.init nb_ind (fun _ -> mkProp) in - Vars.substl subst cores.(i) - in - create_input fix), - UState.from_env (Global.env ())) + let subst = List.init nb_ind (fun _ -> mkProp) in + Vars.substl subst cores.(i) + in + create_input fix) + in + res, UState.from_env (Global.env ()) let beq_scheme_kind = declare_mutual_scheme_object "_beq" diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index b3ffb864f2..2e48313630 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -111,6 +111,10 @@ let interp_definition ~program_mode env evd impl_env bl red_option c ctypopt = let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in evd, (c, tyopt), imps +let definition_using env evd ~body ~types ~using = + let terms = Option.List.cons types [body] in + Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using + let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl red_option c ctypopt = let program_mode = false in let env = Global.env() in @@ -120,11 +124,7 @@ let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl r let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in - let using = using |> Option.map (fun expr -> - let terms = body :: match types with Some x -> [x] | None -> [] in - let l = Proof_using.process_expr (Global.env()) evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let using = definition_using env evd ~body ~types ~using in let kind = Decls.IsDefinition kind in let cinfo = Declare.CInfo.make ~name ~impargs ~typ:types ?using () in let info = Declare.Info.make ~scope ~kind ?hook ~udecl ~poly ?typing_flags () in @@ -141,11 +141,7 @@ let do_definition_program ?hook ~pm ~name ~scope ~poly ?typing_flags ~kind ?usin let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in - let using = using |> Option.map (fun expr -> - let terms = body :: match types with Some x -> [x] | None -> [] in - let l = Proof_using.process_expr (Global.env()) evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let using = definition_using env evd ~body ~types ~using in let term, typ, uctx, obls = Declare.Obls.prepare_obligation ~name ~body ~types evd in let pm, _ = let cinfo = Declare.CInfo.make ~name ~typ ~impargs ?using () in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 0cf0b07822..0f817ffbd1 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -259,13 +259,10 @@ let build_recthms ~indexes ?using fixnames fixtypes fiximps = in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - let using = using |> Option.map (fun expr -> - let terms = [EConstr.of_constr typ] in - let env = Global.env() in - let sigma = Evd.from_env env in - let l = Proof_using.process_expr env sigma expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let env = Global.env() in + let evd = Evd.from_env env in + let terms = [EConstr.of_constr typ] in + let using = Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using in let args = List.map Context.Rel.Declaration.get_name ctx in Declare.CInfo.make ~name ~typ ~args ~impargs ?using () ) fixnames fixtypes fiximps diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3c4a651cf5..0651f3330e 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -259,10 +259,9 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?typing_flags ?using r let evars, _, evars_def, evars_typ = RetrieveObl.retrieve_obligations env recname sigma 0 def typ in - let using = using |> Option.map (fun expr -> + let using = let terms = List.map EConstr.of_constr [evars_def; evars_typ] in - let l = Proof_using.process_expr env sigma expr terms in - Names.Id.Set.(List.fold_right add l empty)) + Option.map (fun using -> Proof_using.definition_using env sigma ~using ~terms) using in let uctx = Evd.evar_universe_context sigma in let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ ?using () in @@ -294,11 +293,8 @@ let do_program_recursive ~pm ~scope ~poly ?typing_flags ?using fixkind fixl = let evd = nf_evar_map_undefined evd in let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) - let using = using |> Option.map (fun expr -> - let terms = [def; typ] in - let l = Proof_using.process_expr env evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let terms = [def; typ] in + let using = Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using in let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml index af51f4fafb..1b811f3db7 100644 --- a/vernac/comSearch.ml +++ b/vernac/comSearch.ml @@ -105,12 +105,6 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let deprecated_searchhead = - CWarnings.create - ~name:"deprecated-searchhead" - ~category:"deprecated" - (fun () -> Pp.str("SearchHead is deprecated. Use the headconcl: clause of Search instead.")) - let interp_search env sigma s r = let r = interp_search_restriction r in let get_pattern c = snd (Constrintern.intern_constr_pattern env sigma c) in @@ -138,9 +132,6 @@ let interp_search env sigma s r = (Search.search_pattern env sigma (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> (Search.search_rewrite env sigma (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchHead c -> - deprecated_searchhead (); - (Search.search_by_head env sigma (get_pattern c) r |> Search.prioritize_search) pr_search | Search sl -> (Search.search env sigma (List.map (interp_search_request env Evd.(from_env env)) sl) r |> Search.prioritize_search) pr_search); diff --git a/vernac/declare.ml b/vernac/declare.ml index c715304419..607ba18a95 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -57,7 +57,7 @@ module CInfo = struct (** Names to pre-introduce *) ; impargs : Impargs.manual_implicits (** Explicitily declared implicit arguments *) - ; using : Names.Id.Set.t option + ; using : Proof_using.t option (** Explicit declaration of section variables used by the constant *) } @@ -889,13 +889,6 @@ let add_hint local prg cst = let locality = if local then Goptions.OptLocal else Goptions.OptExport in Hints.add_hints ~locality [Id.to_string prg.prg_cinfo.CInfo.name] (unfold_entry cst) -(* true = hide obligations *) -let get_hide_obligations = - Goptions.declare_bool_option_and_ref - ~depr:true - ~key:["Hide"; "Obligations"] - ~value:false - let declare_obligation prg obl ~uctx ~types ~body = let poly = prg.prg_info.Info.poly in let univs = UState.univ_entry ~poly uctx in @@ -1046,51 +1039,10 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let hide_obligation () = - Coqlib.check_required_library ["Coq"; "Program"; "Tactics"]; - UnivGen.constr_of_monomorphic_global - (Coqlib.lib_ref "program.tactics.obligation") - -(* XXX: Is this the right place? *) -let rec prod_app t n = - match - Constr.kind - (EConstr.Unsafe.to_constr - (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) - (* FIXME *) - with - | Prod (_, _, b) -> Vars.subst1 n b - | LetIn (_, b, t, b') -> prod_app (Vars.subst1 b b') n - | _ -> - CErrors.user_err ~hdr:"prod_app" - Pp.(str "Needed a product, but didn't find one" ++ fnl ()) - -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL - -let replace_appvars subst = - let rec aux c = - let f, l = decompose_app c in - if isVar f then - try - let c' = List.map (Constr.map aux) l in - let t, b = Id.List.assoc (destVar f) subst in - mkApp - ( delayed_force hide_obligation - , [|prod_applist t c'; Term.applistc b c'|] ) - with Not_found -> Constr.map aux c - else Constr.map aux c - in - Constr.map aux - let subst_prog subst prg = - if get_hide_obligations () then - ( replace_appvars subst prg.prg_body - , replace_appvars subst (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) - else - let subst' = List.map (fun (n, (_, b)) -> (n, b)) subst in - ( Vars.replace_vars subst' prg.prg_body - , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) + let subst' = List.map (fun (n, (_, b)) -> (n, b)) subst in + ( Vars.replace_vars subst' prg.prg_body + , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) let declare_definition ~pm prg = let varsubst = obligation_substitution true prg in @@ -1526,11 +1478,10 @@ let start_mutual_with_initialization ~info ~cinfo ~mutual_info sigma snl = let get_used_variables pf = pf.using let get_universe_decl pf = pf.pinfo.Proof_info.info.Info.udecl -let set_used_variables ps l = +let set_used_variables ps ~using = let open Context.Named.Declaration in let env = Global.env () in - let ids = List.fold_right Id.Set.add l Id.Set.empty in - let ctx = Environ.keep_hyps env ids in + let ctx = Environ.keep_hyps env using in let ctx_set = List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in diff --git a/vernac/declare.mli b/vernac/declare.mli index 37a61cc4f0..81558e6f6b 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -79,7 +79,7 @@ module CInfo : sig -> typ:'constr -> ?args:Name.t list -> ?impargs:Impargs.manual_implicits - -> ?using:Names.Id.Set.t + -> ?using:Proof_using.t -> unit -> 'constr t @@ -244,7 +244,7 @@ module Proof : sig (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) *) - val set_used_variables : t -> Names.Id.t list -> Constr.named_context * t + val set_used_variables : t -> using:Proof_using.t -> Constr.named_context * t (** Gets the set of variables declared to be used by the proof. None means no "Proof using" or #[using] was given *) diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index d2eeebc246..15e6d4ef37 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -301,7 +301,10 @@ and load_keep i ((sp,kn),kobjs) = let mark_object f obj (exports,acc) = (exports, (f,obj)::acc) -let rec collect_module_objects (f,mp) acc = +let rec collect_modules mpl acc = + List.fold_left (fun acc fmp -> collect_module fmp acc) acc (List.rev mpl) + +and collect_module (f,mp) acc = (* May raise Not_found for unknown module and for functors *) let modobjs = ModObjs.get mp in let prefix = modobjs.module_prefix in @@ -310,14 +313,16 @@ let rec collect_module_objects (f,mp) acc = and collect_object f i (name, obj as o) acc = match obj with - | ExportObject { mpl } -> collect_export f i mpl acc + | ExportObject { mpl } -> collect_exports f i mpl acc | AtomicObject _ | IncludeObject _ | KeepObject _ | ModuleObject _ | ModuleTypeObject _ -> mark_object f o acc and collect_objects f i prefix objs acc = - List.fold_right (fun (id, obj) acc -> collect_object f i (Lib.make_oname prefix id, obj) acc) objs acc + List.fold_left (fun acc (id, obj) -> + collect_object f i (Lib.make_oname prefix id, obj) acc + ) acc (List.rev objs) -and collect_one_export f (f',mp) (exports,objs as acc) = +and collect_export f (f',mp) (exports,objs as acc) = match filter_and f f' with | None -> acc | Some f -> @@ -334,12 +339,12 @@ and collect_one_export f (f',mp) (exports,objs as acc) = *) if exports == exports' then acc else - collect_module_objects (f,mp) (exports', objs) + collect_module (f,mp) (exports', objs) -and collect_export f i mpl acc = +and collect_exports f i mpl acc = if Int.equal i 1 then - List.fold_right (collect_one_export f) mpl acc + List.fold_left (fun acc fmp -> collect_export f fmp acc) acc (List.rev mpl) else acc let open_modtype i ((sp,kn),_) = @@ -388,7 +393,7 @@ and open_include f i ((sp,kn), aobjs) = open_objects f i prefix o and open_export f i mpl = - let _,objs = collect_export f i mpl (MPmap.empty, []) in + let _,objs = collect_exports f i mpl (MPmap.empty, []) in List.iter (fun (f,o) -> open_object f 1 o) objs and open_keep f i ((sp,kn),kobjs) = @@ -1056,7 +1061,7 @@ let end_library ?except ~output_native_objects dir = cenv,(substitute,keep),ast let import_modules ~export mpl = - let _,objs = List.fold_right collect_module_objects mpl (MPmap.empty, []) in + let _,objs = collect_modules mpl (MPmap.empty, []) in List.iter (fun (f,o) -> open_object f 1 o) objs; if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) diff --git a/vernac/dune b/vernac/dune index ba361b1377..7319b1353c 100644 --- a/vernac/dune +++ b/vernac/dune @@ -1,7 +1,7 @@ (library (name vernac) (synopsis "Coq's Vernacular Language") - (public_name coq.vernac) + (public_name coq-core.vernac) (wrapped false) (libraries tactics parsing)) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 5c329f60a9..f8a28332b1 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -965,8 +965,6 @@ GRAMMAR EXTEND Gram (* Searching the environment *) | IDENT "About"; qid = smart_global; l = OPT univ_name_list; "." -> { fun g -> VernacPrint (PrintAbout (qid,l,g)) } - | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchHead c,g, l) } | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules; "." -> { fun g -> VernacSearch (SearchPattern c,g, l) } | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." -> diff --git a/vernac/library.ml b/vernac/library.ml index 8a9b1fd68d..cc9e3c3c44 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -155,17 +155,13 @@ let library_is_loaded dir = let register_loaded_library m = let libname = m.libsum_name in - let link () = - let dirname = Filename.dirname (library_full_filename libname) in - let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in - let f = prefix ^ "cmo" in - let f = Dynlink.adapt_filename f in - Nativelib.link_library ~prefix ~dirname ~basename:f - in let rec aux = function | [] -> - let () = if Flags.get_native_compiler () then link () in - [libname] + if Flags.get_native_compiler () then begin + let dirname = Filename.dirname (library_full_filename libname) in + Nativelib.enable_library dirname libname + end; + [libname] | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index ff4365c8d3..8e5942440b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -242,7 +242,6 @@ let pr_search a gopt b pr_p = pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt ++ match a with - | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b | Search sl -> diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index bdb0cabacf..01e7b7cc3d 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -64,6 +64,12 @@ let process_expr env sigma e ty = let s = Id.Set.union v_ty (process_expr env sigma e v_ty) in Id.Set.elements s +type t = Names.Id.Set.t + +let definition_using env evd ~using ~terms = + let l = process_expr env evd using terms in + Names.Id.Set.(List.fold_right add l empty) + let name_set id expr = known_names := (id,expr) :: !known_names let minimize_hyps env ids = @@ -91,13 +97,14 @@ let remove_ids_and_lets env s ids = let record_proof_using expr = Aux_file.record_in_aux "suggest_proof_using" expr +let debug_proof_using = CDebug.create ~name:"proof-using" () + (* Variables in [skip] come from after the definition, so don't count for "All". Used in the variable case since the env contains the variable itself. *) let suggest_common env ppid used ids_typ skip = let module S = Id.Set in let open Pp in - let print x = Feedback.msg_debug x in let pr_set parens s = let wrap ppcmds = if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" @@ -111,13 +118,13 @@ let suggest_common env ppid used ids_typ skip = in let all = S.diff all skip in let fwd_typ = close_fwd env (Evd.from_env env) ids_typ in - if !Flags.debug then begin - print (str "All " ++ pr_set false all); - print (str "Type " ++ pr_set false ids_typ); - print (str "needed " ++ pr_set false needed); - print (str "all_needed " ++ pr_set false all_needed); - print (str "Type* " ++ pr_set false fwd_typ); - end; + let () = debug_proof_using (fun () -> + str "All " ++ pr_set false all ++ fnl() ++ + str "Type " ++ pr_set false ids_typ ++ fnl() ++ + str "needed " ++ pr_set false needed ++ fnl() ++ + str "all_needed " ++ pr_set false all_needed ++ fnl() ++ + str "Type* " ++ pr_set false fwd_typ) + in let valid_exprs = ref [] in let valid e = valid_exprs := e :: !valid_exprs in if S.is_empty needed then valid (str "Type"); diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index 93dbd33ae4..60db4d60e6 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -10,10 +10,17 @@ (** Utility code for section variables handling in Proof using... *) -val process_expr : - Environ.env -> Evd.evar_map -> - Vernacexpr.section_subset_expr -> EConstr.types list -> - Names.Id.t list +(** At some point it would be good to make this abstract *) +type t = Names.Id.Set.t + +(** Process a [using] expression in definitions to provide the list of + used terms *) +val definition_using + : Environ.env + -> Evd.evar_map + -> using:Vernacexpr.section_subset_expr + -> terms:EConstr.constr list + -> t val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit diff --git a/vernac/search.ml b/vernac/search.ml index 501e5b1a91..98e231de19 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -185,14 +185,6 @@ let rec pattern_filter pat ref env sigma typ = | LetIn (_, _, _, typ) -> pattern_filter pat ref env sigma typ | _ -> false -let rec head_filter pat ref env sigma typ = - let typ = Termops.strip_outer_cast sigma typ in - if Constr_matching.is_matching_head env sigma pat typ then true - else match EConstr.kind sigma typ with - | Prod (_, _, typ) - | LetIn (_, _, _, typ) -> head_filter pat ref env sigma typ - | _ -> false - let full_name_of_reference ref = let (dir,id) = repr_path (Nametab.path_of_global ref) in DirPath.to_string dir ^ "." ^ Id.to_string id @@ -274,19 +266,6 @@ let search_rewrite env sigma pat mods pr_search = (** Search *) -let search_by_head env sigma pat mods pr_search = - let filter ref kind env typ = - module_filter mods ref kind env sigma typ && - head_filter pat ref env sigma (EConstr.of_constr typ) && - blacklist_filter ref kind env sigma typ - in - let iter ref kind env typ = - if filter ref kind env typ then pr_search ref kind env typ - in - generic_search env iter - -(** Search *) - let search env sigma items mods pr_search = let filter ref kind env typ = let eqb b1 b2 = if b1 then b2 else not b2 in diff --git a/vernac/search.mli b/vernac/search.mli index 09847f4e03..6557aa5986 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -47,8 +47,6 @@ val search_filter : glob_search_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool - -> display_function -> unit val search_rewrite : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool -> display_function -> unit val search_pattern : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index cd0dd5e9a6..007a3b05fc 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -45,3 +45,4 @@ ComArguments Vernacentries ComTactic Vernacinterp +Vernac_classifier diff --git a/stm/vernac_classifier.ml b/vernac/vernac_classifier.ml index ffae2866c0..ffae2866c0 100644 --- a/stm/vernac_classifier.ml +++ b/vernac/vernac_classifier.ml diff --git a/stm/vernac_classifier.mli b/vernac/vernac_classifier.mli index 61bf3a503a..61bf3a503a 100644 --- a/stm/vernac_classifier.mli +++ b/vernac/vernac_classifier.mli diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 1c774a35bf..38ca836b32 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -563,19 +563,19 @@ let program_inference_hook env sigma ev = user_err Pp.(str "The statement obligations could not be resolved \ automatically, write a statement definition first.") -let vernac_set_used_variables ~pstate e : Declare.Proof.t = +let vernac_set_used_variables ~pstate using : Declare.Proof.t = let env = Global.env () in let sigma, _ = Declare.Proof.get_current_context pstate in let initial_goals pf = Proofview.initial_goals Proof.((data pf).entry) in - let tys = List.map snd (initial_goals (Declare.Proof.get pstate)) in - let l = Proof_using.process_expr env sigma e tys in + let terms = List.map snd (initial_goals (Declare.Proof.get pstate)) in + let using = Proof_using.definition_using env sigma ~using ~terms in let vars = Environ.named_context env in - List.iter (fun id -> - if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then - user_err ~hdr:"vernac_set_used_variables" - (str "Unknown variable: " ++ Id.print id)) - l; - let _, pstate = Declare.Proof.set_used_variables pstate l in + Names.Id.Set.iter (fun id -> + if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" + (str "Unknown variable: " ++ Id.print id)) + using; + let _, pstate = Declare.Proof.set_used_variables pstate ~using in pstate let vernac_set_used_variables_opt ?using pstate = @@ -1215,9 +1215,11 @@ let msg_of_subsection ss id = in Pp.str kind ++ spc () ++ Id.print id -let vernac_end_segment ~pm ({v=id} as lid) = +let vernac_end_segment ~pm ~stack ({v=id} as lid) = let ss = Lib.find_opening_node id in let what_for = msg_of_subsection ss lid.v in + if Option.has_some stack then + CErrors.user_err (Pp.str "Command not supported (Open proofs remain)"); Declare.Obls.check_solved_obligations ~pm ~what_for; match ss with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid @@ -1436,7 +1438,10 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) t in + let t = Flags.without_option Detyping.print_universes (fun () -> + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) t) + () + in let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1640,6 +1645,13 @@ let () = optwrite = CWarnings.set_flags } let () = + declare_string_option + { optdepr = false; + optkey = ["Debug"]; + optread = CDebug.get_flags; + optwrite = CDebug.set_flags } + +let () = declare_bool_option { optdepr = false; optkey = ["Guard"; "Checking"]; @@ -1705,9 +1717,9 @@ let vernac_set_append_option ~locality key s = let vernac_set_option ~locality table v = match v with | OptionSetString s -> - (* We make a special case for warnings because appending is their - natural semantics *) - if CString.List.equal table ["Warnings"] then + (* We make a special case for warnings and debug flags because appending is + their natural semantics *) + if CString.List.equal table ["Warnings"] || CString.List.equal table ["Debug"] then vernac_set_append_option ~locality table s else let (last, prefix) = List.sep_last table in @@ -2062,7 +2074,7 @@ let vernac_check_guard ~pstate = (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) -let translate_vernac ~atts v = let open Vernacextend in match v with +let translate_vernac ?loc ~atts v = let open Vernacextend in match v with | VernacAbortAll | VernacRestart | VernacUndo _ @@ -2173,9 +2185,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtNoProof(fun () -> vernac_begin_section ~poly:(only_polymorphism atts) lid) | VernacEndSegment lid -> - VtReadProgram(fun ~pm -> + VtReadProgram(fun ~stack ~pm -> unsupported_attributes atts; - vernac_end_segment ~pm lid) + vernac_end_segment ~pm ~stack lid) | VernacNameSectionHypSet (lid, set) -> VtDefault(fun () -> unsupported_attributes atts; @@ -2387,4 +2399,4 @@ let translate_vernac ~atts v = let open Vernacextend in match v with (* Extensions *) | VernacExtend (opn,args) -> - Vernacextend.type_vernac ~atts opn args + Vernacextend.type_vernac ?loc ~atts opn args diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index cf233248d7..b30bbc3ce7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -10,7 +10,8 @@ (** Vernac Translation into the Vernac DSL *) val translate_vernac - : atts:Attributes.vernac_flags + : ?loc:Loc.t + -> atts:Attributes.vernac_flags -> Vernacexpr.vernac_expr -> Vernacextend.typed_vernac @@ -26,4 +27,3 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr val command_focus : unit Proof.focus_kind val allow_sprop_opt_name : string list -val cumul_sprop_opt_name : string list diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 2e360cf969..46acaf7264 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -75,7 +75,6 @@ type search_request = type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr - | SearchHead of constr_pattern_expr | Search of (bool * search_request) list type locatable = diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index ed63332861..df82382041 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -59,12 +59,12 @@ type typed_vernac = | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) | VtReadProof of (pstate:Declare.Proof.t -> unit) - | VtReadProgram of (pm:Declare.OblState.t -> unit) + | VtReadProgram of (stack:Vernacstate.LemmaStack.t option -> pm:Declare.OblState.t -> unit) | VtModifyProgram of (pm:Declare.OblState.t -> Declare.OblState.t) | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) -type vernac_command = atts:Attributes.vernac_flags -> typed_vernac +type vernac_command = ?loc:Loc.t -> atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list @@ -94,7 +94,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let type_vernac opn converted_args ~atts = +let type_vernac opn converted_args ?loc ~atts = let depr, callback = vinterp_map opn in let () = if depr then let rules = Egramml.get_extend_vernac_rule opn in @@ -106,7 +106,7 @@ let type_vernac opn converted_args ~atts = warn_deprecated_command pr; in let hunk = callback converted_args in - hunk ~atts + hunk ?loc ~atts (** VERNAC EXTEND registering *) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index e1e3b4cfe5..27f6930dec 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -77,12 +77,12 @@ type typed_vernac = | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) | VtReadProof of (pstate:Declare.Proof.t -> unit) - | VtReadProgram of (pm:Declare.OblState.t -> unit) + | VtReadProgram of (stack:Vernacstate.LemmaStack.t option -> pm:Declare.OblState.t -> unit) | VtModifyProgram of (pm:Declare.OblState.t -> Declare.OblState.t) | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) -type vernac_command = atts:Attributes.vernac_flags -> typed_vernac +type vernac_command = ?loc:Loc.t -> atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 3a8a80d25a..4098401bf0 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -48,7 +48,7 @@ let interp_typed_vernac c ~pm ~stack = vernac_require_open_lemma ~stack (Vernacstate.LemmaStack.with_top ~f:(fun pstate -> f ~pstate)); stack, pm - | VtReadProgram f -> f ~pm; stack, pm + | VtReadProgram f -> f ~stack ~pm; stack, pm | VtModifyProgram f -> let pm = f ~pm in stack, pm | VtDeclareProgram f -> @@ -151,7 +151,7 @@ let interp_control_flag ~time_header (f : control_flag) ~st * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let rec interp_expr ~atts ~st c = +let rec interp_expr ?loc ~atts ~st c = let stack = st.Vernacstate.lemmas in let program = st.Vernacstate.program in vernac_pperr_endline Pp.(fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); @@ -174,7 +174,7 @@ let rec interp_expr ~atts ~st c = Attributes.unsupported_attributes atts; vernac_load ~verbosely fname | v -> - let fv = Vernacentries.translate_vernac ~atts v in + let fv = Vernacentries.translate_vernac ?loc ~atts v in interp_typed_vernac ~pm:program ~stack fv and vernac_load ~verbosely fname = @@ -206,13 +206,13 @@ and vernac_load ~verbosely fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); stack, pm -and interp_control ~st ({ CAst.v = cmd } as vernac) = +and interp_control ~st ({ CAst.v = cmd; loc } as vernac) = let time_header = mk_time_header vernac in List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) cmd.control (fun ~st -> let before_univs = Global.universes () in - let pstack, pm = interp_expr ~atts:cmd.attrs ~st cmd.expr in + let pstack, pm = interp_expr ?loc ~atts:cmd.attrs ~st cmd.expr in let after_univs = Global.universes () in if before_univs == after_univs then pstack, pm else |