diff options
268 files changed, 2623 insertions, 5349 deletions
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7ec3ba1bd7..744fe1c743 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -74,18 +74,3 @@ jobs: make -j "$NJOBS" test-suite PRINT_LOGS=1 env: NJOBS: "2" - - - name: Create the dmg bundle - run: | - eval $(opam env) - export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - export OUTDIR="$(pwd)/_install_ci" - ./dev/build/osx/make-macos-dmg.sh - env: - MACOSX_DEPLOYMENT_TARGET: "10.11" - NJOBS: "2" - - - uses: actions/upload-artifact@v2 - with: - name: coq-macOS-installer - path: _build/*.dmg diff --git a/.gitignore b/.gitignore index bf7430cc2e..1abead3c67 100644 --- a/.gitignore +++ b/.gitignore @@ -115,6 +115,9 @@ doc/stdlib/index-body.html doc/stdlib/index-list.html doc/tools/docgram/editedGrammar doc/tools/docgram/prodnGrammar +doc/tools/docgram/prodnCommands +doc/tools/docgram/prodnTactics +doc/tools/docgram/updated_rsts doc/unreleased.rst # .mll files diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ce6be777f3..52b03e455b 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-V2021-02-11-b601de5a7b" + CACHEKEY: "bionic_coq-V2021-04-14-802aebab96" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" diff --git a/META.coq-core.in b/META.coq-core.in index c58513979d..bc56b7b66e 100644 --- a/META.coq-core.in +++ b/META.coq-core.in @@ -320,21 +320,6 @@ package "plugins" ( plugin(native) = "tauto_plugin.cmxs" ) - package "omega" ( - - description = "Coq omega plugin" - version = "8.14" - - requires = "coq-core.plugins.ltac" - directory = "omega" - - archive(byte) = "omega_plugin.cmo" - archive(native) = "omega_plugin.cmx" - - plugin(byte) = "omega_plugin.cmo" - plugin(native) = "omega_plugin.cmxs" - ) - package "micromega" ( description = "Coq micromega plugin" diff --git a/Makefile.build b/Makefile.build index d619fd3c85..2b626506a3 100644 --- a/Makefile.build +++ b/Makefile.build @@ -256,17 +256,6 @@ BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) DEPFLAGS=$(LOCALINCLUDES) -map gramlib/.pack/gramlib.ml $(if $(filter plugins/% user-contrib/%,$@),, -I ide/coqide -I ide/coqide/protocol) -# On MacOS, the binaries are signed, except our private ones -ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) -LINKMETADATA=$(if $(filter $(PRIVATEBINARIES),$@),,-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist") -CODESIGN=$(if $(filter $(PRIVATEBINARIES),$@),true,codesign -s -) -CODESIGN_HIDE=$(CODESIGN) -else -LINKMETADATA= -CODESIGN=true -CODESIGN_HIDE=$(HIDE)true -endif - ifeq ($(STRIP),true) STRIP_HIDE=$(HIDE)true else @@ -293,7 +282,7 @@ endef define bestocaml $(if $(OPT),\ -$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ -linkpkg $(1) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ +$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -o $@ -linkpkg $(1) $^ && $(STRIP) $@,\ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^) endef @@ -431,9 +420,8 @@ bin/%.opt$(EXE): topbin/%_bin.ml $(LINKCMX) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) \ $(SYSMOD) \ - $(LINKCMX) $(OPTFLAGS) $(LINKMETADATA) $< -o $@ + $(LINKCMX) $(OPTFLAGS) $< -o $@ $(STRIP_HIDE) $@ - $(CODESIGN_HIDE) $@ bin/%.byte$(EXE): topbin/%_bin.ml $(LINKCMO) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' @@ -893,7 +881,7 @@ PLUGININCLUDES=$(addprefix -I plugins/, $(PLUGINDIRS)) $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEPBOOT) -vos -boot $(DYNDEP) -R theories Coq -R plugins Coq -Q user-contrib "" $(PLUGININCLUDES) $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) + $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) -R theories Coq -R plugins Coq -Q user-contrib "" $(PLUGININCLUDES) $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.checker b/Makefile.checker index ad296e0e88..320b03fea7 100644 --- a/Makefile.checker +++ b/Makefile.checker @@ -38,9 +38,8 @@ ifeq ($(BEST),opt) $(CHICKEN): config/config.cmxa clib/clib.cmxa lib/lib.cmxa kernel/kernel.cmxa \ checker/check.cmxa $(LIBCOQRUN) checker/coqchk.mli checker/coqchk.ml $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) -linkpkg $(SYSMOD) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -o $@ $^ + $(HIDE)$(OCAMLOPT) -linkpkg $(SYSMOD) $(CHKLIBS) $(OPTFLAGS) -o $@ $^ $(STRIP_HIDE) $@ - $(CODESIGN_HIDE) $@ else $(CHICKEN): $(CHICKENBYTE) rm -f $@ && cp $< $@ diff --git a/Makefile.common b/Makefile.common index dc40413078..a21e974ed5 100644 --- a/Makefile.common +++ b/Makefile.common @@ -102,7 +102,7 @@ CORESRCDIRS:=\ tactics vernac stm sysinit toplevel PLUGINDIRS:=\ - omega micromega \ + micromega \ ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ @@ -138,7 +138,6 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l # plugins object files ########################################################################### -OMEGACMO:=plugins/omega/omega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo RINGCMO:=plugins/ring/ring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo @@ -159,7 +158,7 @@ SSRSEARCHCMO=plugins/ssrsearch/ssrsearch_plugin.cmo LTAC2CMO:=user-contrib/Ltac2/ltac2_plugin.cmo ZIFYCMO:=plugins/micromega/zify_plugin.cmo -PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ +PLUGINSCMO:=$(LTACCMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ diff --git a/Makefile.dev b/Makefile.dev index cfb02b6d80..c573fccf95 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -141,7 +141,6 @@ noreal: unicode logic arith bool zarith qarith lists sets fsets \ ### 4) plugins ################ -OMEGAVO:=$(filter theories/omega/%, $(THEORIESVO)) MICROMEGAVO:=$(filter theories/micromega/%, $(THEORIESVO)) RINGVO:=$(filter theories/setoid_ring/%, $(THEORIESVO)) NSATZVO:=$(filter theories/nsatz/%, $(THEORIESVO)) @@ -153,7 +152,6 @@ CCVO:= DERIVEVO:=$(filter theories/derive/%, $(THEORIESVO)) LTACVO:=$(filter theories/ltac/%, $(THEORIESVO)) -omega: $(OMEGAVO) $(OMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) @@ -164,7 +162,7 @@ rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) ltac: $(LTACVO) $(LTACCMO) -.PHONY: omega micromega ring nsatz extraction +.PHONY: micromega ring nsatz extraction .PHONY: funind cc rtauto btauto ltac # For emacs: diff --git a/Makefile.dune b/Makefile.dune index c338405f2c..1313ef5eac 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -18,7 +18,7 @@ help: @echo " - world: build all public binaries and libraries" @echo " - watch: build all public binaries and libraries [continuous build]" @echo " - check: build all ML files as fast as possible" - @echo " - test-suite: run Coq's test suite" + @echo " - test-suite: run Coq's test suite [env NJOBS=N to set job parallelism]" @echo "" @echo " Note: running ./configure is not recommended," @echo " see dev/doc/build-system.dune.md for more info" diff --git a/Makefile.ide b/Makefile.ide index 6e3713c7bf..e721e90628 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -28,8 +28,6 @@ COQIDEBYTE:=bin/coqide.byte$(EXE) COQIDE:=bin/coqide$(EXE) -COQIDEAPP:=bin/CoqIDE_$(VERSION).app -COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide ## CoqIDE source directory and files @@ -154,9 +152,8 @@ $(IDETOP): ide/coqide/idetop.ml $(LINKCMX) $(LIBCOQRUN) $(IDETOPCMX) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) -I ide/coqide -I ide/coqide/protocol/ \ $(SYSMOD) \ - $(LINKCMX) $(IDETOPCMX) $(OPTFLAGS) $(LINKMETADATA) $< -o $@ + $(LINKCMX) $(IDETOPCMX) $(OPTFLAGS) $< -o $@ $(STRIP_HIDE) $@ - $(CODESIGN_HIDE) $@ $(IDETOPBYTE): ide/coqide/idetop.ml $(LINKCMO) $(LIBCOQRUN) $(IDETOPCMA) $(SHOW)'COQMKTOP -o $@' @@ -217,7 +214,7 @@ ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a) endif -install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time +install-ide-files: $(MKDIR) $(FULLDATADIR) $(INSTALLLIB) ide/coqide/coq.png ide/coqide/*.lang ide/coqide/coq_style.xml $(IDEBINDINGS) $(FULLDATADIR) $(MKDIR) $(FULLCONFIGDIR) @@ -227,76 +224,6 @@ install-ide-info: $(INSTALLLIB) ide/coqide/FAQ $(FULLDOCDIR)/FAQ-CoqIde ########################################################################### -# CoqIde MacOS special targets -########################################################################### - -.PHONY: $(COQIDEAPP)/Contents - -$(COQIDEAPP)/Contents: - $(MKDIR) $@ - sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/coqide/MacOS/Info.plist.template > $@/Info.plist - $(MKDIR) "$@/MacOS" - -$(COQIDEINAPP): ide/coqide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents - $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,threads,lablgtk3-sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ - $(STRIP_HIDE) $@ - -$(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents - $(MKDIR) $@/coq/ - $(INSTALLLIB) ide/coqide/coq.png ide/coqide/*.lang ide/coqide/coq_style.xml $(IDEBINDINGS) $@/coq/ - $(MKDIR) $@/gtksourceview-3.0/{language-specs,styles} - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-3.0/language-specs/ - $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/styles/{styles.rng,classic.xml} $@/gtksourceview-3.0/styles/ - cp -R "$(GTKSHARE)/"locale $@ - cp -R "$(GTKSHARE)/"themes $@ - $(MKDIR) $@/glib-2.0/schemas - glib-compile-schemas --targetdir=$@/glib-2.0/schemas "$(GTKSHARE)/"glib-2.0/schemas/ - cp -R "$(ADWAITASHARE)/"icons $@ - -$(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents - $(MKDIR) $@ - $(INSTALLLIB) $$("$(PIXBUFBIN)/gdk-pixbuf-query-loaders" | sed -n -e '5 s!.*= \(.*\)$$!\1!p')/libpixbufloader-png.so $@ - -$(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents - $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.dylib $@ || $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.so $@ - - -$(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib - $(MKDIR) $@/xdg/coq - $(MKDIR) $@/gtk-3.0 - { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ - sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-3.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.{dylib,so} |\ - sed -e "s!/.*\(/immodules/.*.dylib\)!@executable_path/../Resources/\1!" |\ - sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ - sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-3.0/gtk-immodules.loaders - $(MKDIR) $@/pango - echo "[Pango]" > $@/pango/pangorc - -$(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) - $(MKDIR) $@ - macpack -d ../Resources/lib $(COQIDEINAPP) - for i in $@/../bin/*; \ - do \ - macpack -d ../lib $$i; \ - done - for i in $@/../loaders/*.so $@/../immodules/*.{dylib,so}; \ - do \ - macpack -d ../lib $$i; \ - done - -$(COQIDEAPP)/Contents/Resources:$(COQIDEAPP)/Contents/Resources/etc $(COQIDEAPP)/Contents/Resources/share - $(INSTALLLIB) ide/coqide/MacOS/*.icns $@ - -$(COQIDEAPP):$(COQIDEAPP)/Contents/Resources - $(CODESIGN_HIDE) $@ - -########################################################################### # CoqIde for Windows special targets ########################################################################### diff --git a/Makefile.make b/Makefile.make index 9f0e06dffc..dc123820ee 100644 --- a/Makefile.make +++ b/Makefile.make @@ -277,7 +277,7 @@ cacheclean: 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 + rm -f config/Makefile config/coq_config.ml dev/ocamldebug-coq distclean: clean cleanconfig cacheclean timingclean diff --git a/checker/values.ml b/checker/values.ml index f7a367b986..1353435181 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -87,7 +87,7 @@ let v_cons = v_tuple "constructor" [|v_ind;Int|] (** kernel/univ *) -let v_level_global = v_tuple "Level.Global.t" [|v_dp;Int|] +let v_level_global = v_tuple "Level.Global.t" [|v_dp;String;Int|] let v_raw_level = v_sum "raw_level" 3 (* SProp, Prop, Set *) [|(*Level*)[|v_level_global|]; (*Var*)[|Int|]|] let v_level = v_tuple "level" [|Int;v_raw_level|] diff --git a/clib/cThread.ml b/clib/cThread.ml index 89ca2f7d83..3796fdf788 100644 --- a/clib/cThread.ml +++ b/clib/cThread.ml @@ -107,3 +107,22 @@ let mask_sigalrm f x = let create f x = Thread.create (mask_sigalrm f) x + +(* + Atomic mutex lock taken from https://gitlab.com/gadmm/memprof-limits/-/blob/master/src/thread_map.ml#L23-34 + Critical sections : + - Mutex.lock does not poll on leaving the blocking section + since 4.12. + - Never inline, to avoid theoretically-possible reorderings with + flambda. + (workaround to the lack of masking) +*) + +(* We inline the call to Mutex.unlock to avoid polling in bytecode mode *) +external unlock: Mutex.t -> unit = "caml_mutex_unlock" + +let[@inline never] with_lock m ~scope = + let () = Mutex.lock m (* BEGIN ATOMIC *) in + match (* END ATOMIC *) scope () with + | (* BEGIN ATOMIC *) x -> unlock m ; (* END ATOMIC *) x + | (* BEGIN ATOMIC *) exception e -> unlock m ; (* END ATOMIC *) raise e diff --git a/clib/cThread.mli b/clib/cThread.mli index 87889f3356..d974135d43 100644 --- a/clib/cThread.mli +++ b/clib/cThread.mli @@ -29,3 +29,8 @@ val thread_friendly_really_read_line : thread_ic -> string (* Wrapper around Thread.create that blocks signals such as Sys.sigalrm (used * for Timeout *) val create : ('a -> 'b) -> 'a -> Thread.t + +(* + Atomic mutex lock taken from https://gitlab.com/gadmm/memprof-limits/-/blob/master/src/thread_map.ml#L23-34 +*) +val with_lock : Mutex.t -> scope:(unit -> 'a) -> 'a diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 07b7f47529..4c1f47df30 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -71,10 +71,9 @@ let record_backtrace b = let get_backtrace e = get e backtrace_info let iraise (e,i) = - let () = Mutex.lock lock in - let id = Thread.id (Thread.self ()) in - let () = current := (id, (e,i)) :: remove_assoc id !current in - let () = Mutex.unlock lock in + CThread.with_lock lock ~scope:(fun () -> + let id = Thread.id (Thread.self ()) in + current := (id, (e,i)) :: remove_assoc id !current); match get i backtrace_info with | None -> raise e @@ -82,12 +81,11 @@ let iraise (e,i) = Printexc.raise_with_backtrace e bt let find_and_remove () = - let () = Mutex.lock lock in - let id = Thread.id (Thread.self ()) in - let (v, l) = find_and_remove_assoc id !current in - let () = current := l in - let () = Mutex.unlock lock in - v + CThread.with_lock lock ~scope:(fun () -> + let id = Thread.id (Thread.self ()) in + let (v, l) = find_and_remove_assoc id !current in + let () = current := l in + v) let info e = let (src, data) = find_and_remove () in diff --git a/configure.ml b/configure.ml index abea59bd60..68e4621cd5 100644 --- a/configure.ml +++ b/configure.ml @@ -13,15 +13,9 @@ open Printf let coq_version = "8.14+alpha" -let coq_macos_version = "8.13.90" (** "[...] should be a string comprised of -three non-negative, period-separated integers [...]" *) let vo_magic = 81391 let state_magic = 581391 let is_a_released_version = false -let distributed_exec = - ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; - "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep";"votour"] - let verbose = ref false (* for debugging this script *) let red, yellow, reset = @@ -1159,7 +1153,6 @@ let write_makefile f = List.iter (fun (v,_,dir,_) -> pr "%s=%S\n" v dir) install_dirs; pr "\n# Coq version\n"; pr "VERSION=%s\n" coq_version; - pr "VERSION4MACOS=%s\n\n" coq_macos_version; pr "# Objective-Caml compile command\n"; pr "OCAML=%S\n" camlexec.top; pr "OCAMLFIND=%S\n" camlexec.find; @@ -1235,33 +1228,6 @@ let write_dune_c_flags f = let _ = write_dune_c_flags "config/dune.c_flags" -let write_macos_metadata exec = - let f = "config/Info-"^exec^".plist" in - let () = safe_remove f in - let o = open_out f in - let pr s = fprintf o s in - pr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"; - pr "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">\n"; - pr "<plist version=\"1.0\">\n"; - pr "<dict>\n"; - pr " <key>CFBundleIdentifier</key>\n"; - pr " <string>fr.inria.coq.%s</string>\n" exec; - pr " <key>CFBundleName</key>\n"; - pr " <string>%s</string>\n" exec; - pr " <key>CFBundleVersion</key>\n"; - pr " <string>%s</string>\n" coq_macos_version; - pr " <key>CFBundleShortVersionString</key>\n"; - pr " <string>%s</string>\n" coq_macos_version; - pr " <key>CFBundleInfoDictionaryVersion</key>\n"; - pr " <string>6.0</string>\n"; - pr "</dict>\n"; - pr "</plist>\n"; - let () = close_out o in - Unix.chmod f 0o444 - -let () = - if arch = "Darwin" then List.iter write_macos_metadata distributed_exec - let write_configpy f = safe_remove f; let o = open_out f in diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 2de103a2ff..748f50b54b 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -615,12 +615,29 @@ let pr_ast fmt = function | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac | ArgumentExt arg -> fprintf fmt "%a@\n" ArgumentExt.print_ast arg -let () = +let help () = + Format.eprintf "Usage: coqpp file.mlg@\n%!"; + exit 1 + +let parse () = let () = - if Array.length Sys.argv <> 2 then fatal "Expected exactly one command line argument" + if Array.length Sys.argv <> 2 + then help () in - let file = Sys.argv.(1) in - let output = Filename.chop_extension file ^ ".ml" in + match Sys.argv.(1) with + | "-help" | "--help" -> help () + | file -> file + +let output_name file = + try + Filename.chop_extension file ^ ".ml" + with + | Invalid_argument _ -> + fatal "Input file must have an extension for coqpp [input.ext -> input.ml]" + +let () = + let file = parse () in + let output = output_name file in let ast = parse_file file in let chan = open_out output in let fmt = formatter_of_out_channel chan in diff --git a/dev/base_include b/dev/base_include index 061bf1f3e1..b761924b46 100644 --- a/dev/base_include +++ b/dev/base_include @@ -68,7 +68,7 @@ open Constr_matching open Glob_term open Glob_ops open Coercion -open Recordops +open Structures open Detyping open Reductionops open Evarconv diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh deleted file mode 100755 index 2550cbb31c..0000000000 --- a/dev/build/osx/make-macos-dmg.sh +++ /dev/null @@ -1,37 +0,0 @@ -#!/bin/bash - -# Fail on first error -set -e - -# Configuration setup -DMGDIR=$PWD/_dmg -VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) -APP=bin/CoqIDE_${VERSION}.app - -# Install Coq into the .app file -make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources" install-coq install-ide-toploop - -# Fill .app file with metadata and other .app specific stuff (like non-system .so) -make PRIVATEBINARIES="$APP" -j 1 -l2 "$APP" VERBOSE=1 - -# Create the dmg bundle -mkdir -p "$DMGDIR" -ln -sf /Applications "$DMGDIR/Applications" -cp -r "$APP" "$DMGDIR" - -mkdir -p _build - -# Temporary countermeasure to hdiutil error 5341 -# head -c9703424 /dev/urandom > $DMGDIR/.padding - -hdi_opts=(-volname "coq-$VERSION-installer-macos" - -srcfolder "$DMGDIR" - -ov # overwrite existing file - -format UDZO - -imagekey "zlib-level=9" - - # needed for backward compat since macOS 10.14 which uses APFS by default - # see discussion in #11803 - -fs hfs+ - ) -hdiutil create "${hdi_opts[@]}" "_build/coq-$VERSION-installer-macos.dmg" diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 67555da0a2..0093b5fca2 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -139,7 +139,8 @@ project compcert "https://github.com/AbsInt/CompCert" "master" ######################################################################## # VST ######################################################################## -project vst "https://github.com/PrincetonUniversity/VST" "master" +# todo: 2021 03 11: switch back to master once vst merges the compcert3.9 branch +project vst "https://github.com/PrincetonUniversity/VST" "compcert3.9" ######################################################################## # cross-crypto @@ -247,7 +248,7 @@ project reduction_effects "https://github.com/coq-community/reduction-effects" " # menhirlib ######################################################################## # Note: menhirlib is now in subfolder coq-menhirlib of menhir -project menhirlib "https://gitlab.inria.fr/fpottier/menhir" "20201122" +project menhirlib "https://gitlab.inria.fr/fpottier/menhir" "20210310" ######################################################################## # aac_tactics diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 006565df5c..6d1e6d788a 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -138,8 +138,8 @@ make() if [ -z "${MAKEFLAGS+x}" ] && [ -n "${NJOBS}" ]; then # Not submake and parallel make requested - command make --output-sync -j "$NJOBS" "$@" + command make -j "$NJOBS" "$@" else - command make --output-sync "$@" + command make "$@" fi } diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index cb6c3e6452..01723e5b5c 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -5,4 +5,10 @@ ci_dir="$(dirname "$0")" git_download flocq -( cd "${CI_BUILD_DIR}/flocq" && ( if [ ! -x ./configure ]; then autoconf && ./configure; fi ) && ./remake "-j${NJOBS}" && ./remake install ) +( cd "${CI_BUILD_DIR}/flocq" + ( if [ ! -x ./configure ]; then + autoconf + ./configure COQEXTRAFLAGS="-compat 8.13"; + fi ) + ./remake "-j${NJOBS}" + ./remake install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 8f14625c63..00729cd168 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -24,7 +24,7 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ texlive-science tipa # More dependencies of the sphinx doc, pytest for coqtail -RUN pip3 install sphinx==2.3.1 sphinx_rtd_theme==0.4.3 \ +RUN pip3 install docutils==0.16 sphinx==2.3.1 sphinx_rtd_theme==0.4.3 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.2 \ pytest==5.4.3 @@ -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.13.0" + BASE_ONLY_OPAM="elpi.1.13.1" # 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/13958-gares-recordops-api.sh b/dev/ci/user-overlays/13958-gares-recordops-api.sh new file mode 100644 index 0000000000..0ec50a1dda --- /dev/null +++ b/dev/ci/user-overlays/13958-gares-recordops-api.sh @@ -0,0 +1,6 @@ +overlay metacoq https://github.com/gares/metacoq recordops-api 13958 +overlay mtac2 https://github.com/gares/Mtac2 recordops-api 13958 +overlay elpi https://github.com/gares/coq-elpi recordops-api 13958 +overlay unicoq https://github.com/gares/unicoq recordops-api 13958 +overlay equations https://github.com/gares/Coq-Equations recordops-api 13958 +overlay hierarchy_builder https://github.com/gares/hierarchy-builder coq-master 13958 diff --git a/dev/ci/user-overlays/14050-SkySkimmer-no-remote-counter-alt.sh b/dev/ci/user-overlays/14050-SkySkimmer-no-remote-counter-alt.sh new file mode 100644 index 0000000000..d1606711dc --- /dev/null +++ b/dev/ci/user-overlays/14050-SkySkimmer-no-remote-counter-alt.sh @@ -0,0 +1 @@ +overlay metacoq https://github.com/SkySkimmer/metacoq no-remote-counter-alt 14050 diff --git a/dev/ci/user-overlays/14111-gares-update-elpi.sh b/dev/ci/user-overlays/14111-gares-update-elpi.sh new file mode 100644 index 0000000000..8827127a38 --- /dev/null +++ b/dev/ci/user-overlays/14111-gares-update-elpi.sh @@ -0,0 +1,2 @@ +overlay elpi https://github.com/LPCIC/coq-elpi coq-master+1.9.5 14111 +overlay hierarchy_builder https://github.com/math-comp/hierarchy-builder coq-master+1.1.0 14111 diff --git a/dev/core_dune.dbg b/dev/core_dune.dbg index da3022644d..db51dc08b6 100644 --- a/dev/core_dune.dbg +++ b/dev/core_dune.dbg @@ -6,7 +6,7 @@ load_printer clib.cma load_printer dynlink.cma load_printer lib.cma load_printer gramlib.cma -load_printer byterun.cma +load_printer coqrun.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index de3d5a3d15..8ebd6b5073 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -10,17 +10,23 @@ Coq can now be built using [Dune](https://github.com/ocaml/dune). ## Quick Start -Usually, using the latest version of Dune is recommended, see -`dune-project` for the minimum required version; type `dune build` to -build the base Coq libraries. No call to `./configure` is needed. +Usually, using the latest version of Dune is recommended, see the +first line of the `dune-project` file for the minimum required +version. + +It is strongly recommended that you use the helper targets available +in `Makefile.dune`, `make -f Makefile.dune` will display help. Note +that dune will call configure for you if needed, so no need to call +`./configure` in the regular development workflow. + +`dune build @install` will build all the public Coq artifacts; `dune +build` will build all the targets in the workspace, including tests +and documentations. Dune will get confused if it finds leftovers of in-tree compilation, so please be sure your tree is clean from objects files generated by the make-based system. -More helper targets are available in `Makefile.dune`, `make -f -Makefile.dune` will display some help. - Dune places build artifacts in a separate directory `_build`; it will also generate an `.install` file so files can be properly installed by package managers. @@ -84,7 +90,11 @@ builds, please see below. ## Documentation and testing targets -Coq's test-suite can be run with `dune runtest`. +Coq's test-suite can be run with `dune runtest`; given that `dune` +still invokes the test-suite makefile, the environment variable +`NJOBS` will control the value of the `-j` option that is passed to +make; common call `NJOBS=8 dune runtest`. This will be resolved in the +future once the test suite is ported to Dune rules. There is preliminary support to build the API documentation and reference manual in HTML format, use `dune build {@doc,@refman-html}` @@ -229,3 +239,17 @@ useful to Coq, some examples are: implicitly loaded plugins / vo files. See the "Running binaries [coqtop / coqide]" section above as to how to correctly call Coq's binaries. + +## Dune cheat sheet + +- `dune build` build all targets in the current workspace +- `dune build @check` build all ML targets as fast as possible, setup merlin +- `dune utop $dir` open a shell for libraries in `$dir` +- `dune exec -- $file` build and execute binary `$file`, can be in path or be an specific name +- `dune build _build/$context/$foo` build target `$foo$` in `$context`, with build dir layout +- `dune build _build/install/$context/foo` build target `$foo$` in `$context`, with install dir layout + +### packaging: + +- `dune subst` generate metadata for a package to be installed / distributed, necessary for opam +- `dune build -p $pkg` build a package in release mode diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 4452baf513..5c8b8944a7 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -344,6 +344,16 @@ Conversion machines noticeable if activated by chance, since it usually breaks control-flow integrity + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: arbitrary code execution on irreducible PArray.set + introduced: 8.13 + impacted released versions: 8.13.0, 8.13.1 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.2 + found by: Melquiond + GH issue number: #13998 + risk: none, unless using primitive array operations; systematic otherwise + Side-effects component: side-effects @@ -21,8 +21,8 @@ %{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.vm:coqrun.cma} + %{lib:coq-core.vm:../../stublibs/dllcoqrun_stubs.so} %{lib:coq-core.library:library.cma} %{lib:coq-core.engine:engine.cma} %{lib:coq-core.pretyping:pretyping.cma} diff --git a/dev/dune_db_408 b/dev/dune_db_408 index bc86020d56..dff9b1e9e6 100644 --- a/dev/dune_db_408 +++ b/dev/dune_db_408 @@ -6,7 +6,7 @@ load_printer clib.cma load_printer dynlink.cma load_printer lib.cma load_printer gramlib.cma -load_printer byterun.cma +load_printer coqrun.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/dune_db_409 b/dev/dune_db_409 index adb1f76872..6c9f701b65 100644 --- a/dev/dune_db_409 +++ b/dev/dune_db_409 @@ -5,7 +5,7 @@ load_printer config.cma load_printer clib.cma load_printer lib.cma load_printer gramlib.cma -load_printer byterun.cma +load_printer coqrun.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma diff --git a/dev/shim/dune b/dev/shim/dune index e4cc7699f0..2c7f9c3fa9 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -26,7 +26,7 @@ (targets coqbyte-prelude) (deps %{bin:coqtop.byte} - %{lib:coq-core.kernel:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.kernel:../../stublibs/dllcoqrun_stubs.so} %{project_root}/theories/Init/Prelude.vo) (action (with-stdout-to %{targets} diff --git a/doc/changelog/04-tactics/13741-remove_omega.rst b/doc/changelog/04-tactics/13741-remove_omega.rst new file mode 100644 index 0000000000..0b25c01958 --- /dev/null +++ b/doc/changelog/04-tactics/13741-remove_omega.rst @@ -0,0 +1,7 @@ +- **Removed:** + Removed the `omega` tactic (deprecated in 8.12) and 4 `* Omega *` flags. + Use `lia` instead. + (`#13741 <https://github.com/coq/coq/pull/13741>`_, + by Jim Fehrle, who addressed the final details, building on much work by + Frédéric Besson, who greatly improved :tacn:`lia`, Maxime Dénès, + Vincent Laporte and with the help of many package maintainers, among others). diff --git a/doc/changelog/04-tactics/14033-fix-14009.rst b/doc/changelog/04-tactics/14033-fix-14009.rst new file mode 100644 index 0000000000..3b58e193cb --- /dev/null +++ b/doc/changelog/04-tactics/14033-fix-14009.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Properly expand projection parameters in hint discrimination + nets. (`#14033 <https://github.com/coq/coq/pull/14033>`_, + fixes `#9000 <https://github.com/coq/coq/issues/9000>`_, + `#14009 <https://github.com/coq/coq/issues/14009>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/14089-ltac2_unify.rst b/doc/changelog/04-tactics/14089-ltac2_unify.rst new file mode 100644 index 0000000000..5887781db9 --- /dev/null +++ b/doc/changelog/04-tactics/14089-ltac2_unify.rst @@ -0,0 +1,5 @@ +- **Added:** + Ltac2 now has a `unify` tactic + (`#14089 <https://github.com/coq/coq/pull/14089>`_, + fixes `#14083 <https://github.com/coq/coq/issues/14083>`_, + by Samuel Gruetter). diff --git a/doc/changelog/05-tactic-language/13939-ltac2-open-constr-scope.rst b/doc/changelog/05-tactic-language/13939-ltac2-open-constr-scope.rst new file mode 100644 index 0000000000..9753ce915b --- /dev/null +++ b/doc/changelog/05-tactic-language/13939-ltac2-open-constr-scope.rst @@ -0,0 +1,5 @@ +- **Added:** + Allow scope delimiters in Ltac2 open_constr:(...) quotation + (`#13939 <https://github.com/coq/coq/pull/13939>`_, + fixes `#12806 <https://github.com/coq/coq/issues/12806>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13997-ltac2-ident-ffi.rst b/doc/changelog/05-tactic-language/13997-ltac2-ident-ffi.rst new file mode 100644 index 0000000000..b5b63455c9 --- /dev/null +++ b/doc/changelog/05-tactic-language/13997-ltac2-ident-ffi.rst @@ -0,0 +1,5 @@ +- **Added:** + Added a FFI to convert between Ltac1 and Ltac2 identifiers + (`#13997 <https://github.com/coq/coq/pull/13997>`_, + fixes `#13996 <https://github.com/coq/coq/issues/13996>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-vernac-commands-and-options/14093-fix-14092.rst b/doc/changelog/07-vernac-commands-and-options/14093-fix-14092.rst new file mode 100644 index 0000000000..7831d10392 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/14093-fix-14092.rst @@ -0,0 +1,6 @@ +- **Added:** + The Ltac2 grammar can now be printed using the + Print Grammar ltac2 command + (`#14093 <https://github.com/coq/coq/pull/14093>`_, + fixes `#14092 <https://github.com/coq/coq/issues/14092>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/08-cli-tools/13624-master+fix13581-extraction-letin-in-ind-arity.rst b/doc/changelog/08-cli-tools/13624-master+fix13581-extraction-letin-in-ind-arity.rst new file mode 100644 index 0000000000..6a34f5a70e --- /dev/null +++ b/doc/changelog/08-cli-tools/13624-master+fix13581-extraction-letin-in-ind-arity.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Failure of extraction in the presence of inductive types with local + definitions in parameters + (`#13624 <https://github.com/coq/coq/pull/13624>`_, + fixes `#13581 <https://github.com/coq/coq/issues/13581>`_, + by Hugo Herbelin). diff --git a/doc/changelog/08-cli-tools/14024-coqdep-errors.rst b/doc/changelog/08-cli-tools/14024-coqdep-errors.rst new file mode 100644 index 0000000000..355c0bd7b7 --- /dev/null +++ b/doc/changelog/08-cli-tools/14024-coqdep-errors.rst @@ -0,0 +1,8 @@ +- **Changed:** + ``coqdep`` now reports an error if files specified on the + command line don't exist or if it encounters unreadable files. + Unknown options now generate a warning. Previously these + conditions were ignored. + (`#14024 <https://github.com/coq/coq/pull/14024>`_, + fixes `#14023 <https://github.com/coq/coq/issues/14023>`_, + by Hendrik Tews). diff --git a/doc/changelog/10-standard-library/13955-List_lemmas1.rst b/doc/changelog/10-standard-library/13955-List_lemmas1.rst new file mode 100644 index 0000000000..73eb9a78d9 --- /dev/null +++ b/doc/changelog/10-standard-library/13955-List_lemmas1.rst @@ -0,0 +1,4 @@ +- **Added:** + Lemmas to ``List``: ``Exists_map``, ``Exists_concat``, ``Exists_flat_map``, ``Forall_map``, ``Forall_concat``, ``Forall_flat_map``, ``nth_error_map``, ``nth_repeat``, ``nth_error_repeat`` + (`#13955 <https://github.com/coq/coq/pull/13955>`_, + by Andrej Dudenhefner, with help from Olivier Laurent). diff --git a/doc/changelog/10-standard-library/13986-clean-List-imports.rst b/doc/changelog/10-standard-library/13986-clean-List-imports.rst new file mode 100644 index 0000000000..02e7b9cc97 --- /dev/null +++ b/doc/changelog/10-standard-library/13986-clean-List-imports.rst @@ -0,0 +1,4 @@ +- **Removed:** + from ``List.v`` deprecated/unexpected dependencies ``Setoid``, ``Le``, ``Gt``, ``Minus``, ``Lt`` + (`#13986 <https://github.com/coq/coq/pull/13986>`_, + by Andrej Dudenhefner). diff --git a/doc/changelog/10-standard-library/14008-Cantor-pairing.rst b/doc/changelog/10-standard-library/14008-Cantor-pairing.rst new file mode 100644 index 0000000000..4c217f3fb0 --- /dev/null +++ b/doc/changelog/10-standard-library/14008-Cantor-pairing.rst @@ -0,0 +1,6 @@ +- **Added:** + ``Cantor.v`` containing the Cantor pairing function and its inverse. + ``Cantor.to_nat : nat * nat -> nat`` and ``Cantor.of_nat : nat -> nat * nat`` + are the respective bijections between ``nat * nat`` and ``nat``. + (`#14008 <https://github.com/coq/coq/pull/14008>`_, + by Andrej Dudenhefner). @@ -63,3 +63,6 @@ (files (refman-html as html/refman) (refman-pdf as pdf/refman)) (section doc) (package coq-doc)) + +(documentation + (package coq-doc)) diff --git a/doc/index.mld b/doc/index.mld new file mode 100644 index 0000000000..3a1979bc62 --- /dev/null +++ b/doc/index.mld @@ -0,0 +1,3 @@ +{0 coq-doc } + +The coq-doc package only contains user documentation on the Coq proof assistant and no OCaml library. diff --git a/doc/sphinx/_static/ansi.css b/doc/sphinx/_static/ansi.css index 2a618f68d2..a4850a738b 100644 --- a/doc/sphinx/_static/ansi.css +++ b/doc/sphinx/_static/ansi.css @@ -69,7 +69,7 @@ } .ansi-fg-white { - color: #2e3436; + color: #ffffff; } .ansi-fg-light-black { diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index abb08d98cc..e262a9305d 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -267,6 +267,11 @@ code span.error { color: inherit !important; } + +.coqdoc-comment { + color: #808080 !important +} + /* make the error message index readable */ .indextable code { white-space: inherit; /* break long lines */ diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 5d471c695c..24e35dd85a 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -159,7 +159,6 @@ and checked to be :math:`-1`. This tactic solves linear goals over :g:`Z` by searching for *linear* refutations and cutting planes. :tacn:`lia` provides support for :g:`Z`, :g:`nat`, :g:`positive` and :g:`N` by pre-processing via the :tacn:`zify` tactic. - High level view of `lia` ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -296,7 +295,7 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. The :tacn:`zify` tactic can be extended with new types and operators by declaring and registering new typeclass instances using the following commands. The typeclass declarations can be found in the module ``ZifyClasses`` and the default instances can be found in the module ``ZifyInst``. -.. cmd:: Add Zify @add_zify @one_term +.. cmd:: Add Zify @add_zify @qualid .. insertprodn add_zify add_zify @@ -305,6 +304,9 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. | {| PropOp | PropBinOp | PropUOp | Saturate } Registers an instance of the specified typeclass. + The typeclass type (e.g. :g:`BinOp Z.mul` or :g:`BinRel (@eq Z)`) has the additional constraint that + the non-implicit argument (here, :g:`Z.mul` or :g:`(@eq Z)`) + is either a :n:`@reference` (here, :g:`Z.mul`) or the application of a :n:`@reference` (here, :g:`@eq`) to a sequence of :n:`@one_term`. .. cmd:: Show Zify @show_zify diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst deleted file mode 100644 index 86bb0502c6..0000000000 --- a/doc/sphinx/addendum/omega.rst +++ /dev/null @@ -1,210 +0,0 @@ -.. _omega_chapter: - -Omega: a (deprecated) solver for arithmetic -===================================================================== - -:Author: Pierre Crégut - -.. warning:: - - The :tacn:`omega` tactic is deprecated in favor of the :tacn:`lia` - tactic. The goal is to consolidate the arithmetic solving - capabilities of Coq into a single engine; moreover, :tacn:`lia` is - in general more powerful than :tacn:`omega` (it is a complete - Presburger arithmetic solver while :tacn:`omega` was known to be - incomplete). - - It is recommended to switch from :tacn:`omega` to :tacn:`lia` in existing - projects. We also ask that you report (in our `bug tracker - <https://github.com/coq/coq/issues>`_) any issue you encounter, especially - if the issue was not present in :tacn:`omega`. If no new issues are - reported, :tacn:`omega` will be removed soon. - - Note that replacing :tacn:`omega` with :tacn:`lia` can break - non-robust proof scripts which rely on incompleteness bugs of - :tacn:`omega` (e.g. using the pattern :g:`; try omega`). - -Description of ``omega`` ------------------------- - -.. tacn:: omega - - .. deprecated:: 8.12 - - Use :tacn:`lia` instead. - - :tacn:`omega` is a tactic for solving goals in Presburger arithmetic, - i.e. for proving formulas made of equations and inequalities over the - type ``nat`` of natural numbers or the type ``Z`` of binary-encoded integers. - Formulas on ``nat`` are automatically injected into ``Z``. The procedure - may use any hypothesis of the current proof session to solve the goal. - - Multiplication is handled by :tacn:`omega` but only goals where at - least one of the two multiplicands of products is a constant are - solvable. This is the restriction meant by "Presburger arithmetic". - - If the tactic cannot solve the goal, it fails with an error message. - In any case, the computation eventually stops. - -Arithmetical goals recognized by ``omega`` ------------------------------------------- - -:tacn:`omega` applies only to quantifier-free formulas built from the connectives:: - - /\ \/ ~ -> - -on atomic formulas. Atomic formulas are built from the predicates:: - - = < <= > >= - -on ``nat`` or ``Z``. In expressions of type ``nat``, :tacn:`omega` recognizes:: - - + - * S O pred - -and in expressions of type ``Z``, :tacn:`omega` recognizes numeral constants and:: - - + - * Z.succ Z.pred - -All expressions of type ``nat`` or ``Z`` not built on these -operators are considered abstractly as if they -were arbitrary variables of type ``nat`` or ``Z``. - -Messages from ``omega`` ------------------------ - -When :tacn:`omega` does not solve the goal, one of the following errors -is generated: - -.. exn:: omega can't solve this system. - - This may happen if your goal is not quantifier-free (if it is - universally quantified, try :tacn:`intros` first; if it contains - existentials quantifiers too, :tacn:`omega` is not strong enough to solve your - goal). This may happen also if your goal contains arithmetical - operators not recognized by :tacn:`omega`. Finally, your goal may be simply - not true! - -.. exn:: omega: Not a quantifier-free goal. - - If your goal is universally quantified, you should first apply - :tacn:`intro` as many times as needed. - -.. exn:: omega: Unrecognized predicate or connective: @ident. - :undocumented: - -.. exn:: omega: Unrecognized atomic proposition: ... - :undocumented: - -.. exn:: omega: Can't solve a goal with proposition variables. - :undocumented: - -.. exn:: omega: Unrecognized proposition. - :undocumented: - -.. exn:: omega: Can't solve a goal with non-linear products. - :undocumented: - -.. exn:: omega: Can't solve a goal with equality on type ... - :undocumented: - - -Using ``omega`` ---------------- - -The ``omega`` tactic does not belong to the core system. It should be -loaded by - -.. coqtop:: in - - Require Import Omega. - -.. example:: - - .. coqtop:: all warn - - Require Import Omega. - - Open Scope Z_scope. - - Goal forall m n:Z, 1 + 2 * m <> 2 * n. - intros; omega. - Abort. - - Goal forall z:Z, z > 0 -> 2 * z + 1 > z. - intro; omega. - Abort. - - -Options -------- - -.. flag:: Stable Omega - - .. deprecated:: 8.5 - - This deprecated flag (on by default) is for compatibility with Coq pre 8.5. It - resets internal name counters to make executions of :tacn:`omega` independent. - -.. flag:: Omega UseLocalDefs - - This flag (on by default) allows :tacn:`omega` to use the :term:`bodies <body>` of local - variables. - -.. flag:: Omega System - - This flag (off by default) activate the printing of debug information - -.. flag:: Omega Action - - This flag (off by default) activate the printing of debug information - -Technical data --------------- - -Overview of the tactic -~~~~~~~~~~~~~~~~~~~~~~ - - * The goal is negated twice and the first negation is introduced as a hypothesis. - * Hypotheses are decomposed in simple equations or inequalities. Multiple - goals may result from this phase. - * Equations and inequalities over ``nat`` are translated over - ``Z``, multiple goals may result from the translation of subtraction. - * Equations and inequalities are normalized. - * Goals are solved by the OMEGA decision procedure. - * The script of the solution is replayed. - -Overview of the OMEGA decision procedure -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The OMEGA decision procedure involved in the :tacn:`omega` tactic uses -a small subset of the decision procedure presented in :cite:`TheOmegaPaper` -Here is an overview, refer to the original paper for more information. - - * Equations and inequalities are normalized by division by the GCD of their - coefficients. - * Equations are eliminated, using the Banerjee test to get a coefficient - equal to one. - * Note that each inequality cuts the Euclidean space in half. - * Inequalities are solved by projecting on the hyperspace - defined by cancelling one of the variables. They are partitioned - according to the sign of the coefficient of the eliminated - variable. Pairs of inequalities from different classes define a - new edge in the projection. - * Redundant inequalities are eliminated or merged in new - equations that can be eliminated by the Banerjee test. - * The last two steps are iterated until a contradiction is reached - (success) or there is no more variable to eliminate (failure). - -It may happen that there is a real solution and no integer one. The last -steps of the Omega procedure are not implemented, so the -decision procedure is only partial. - -Bugs ----- - - * The simplification procedure is very dumb and this results in - many redundant cases to explore. - - * Much too slow. - - * Certainly other bugs! You can report them to https://coq.inria.fr/bugs/. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 4f3ee2dcaf..f8d6b35226 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -721,6 +721,33 @@ CoqIDE (`#13870 <https://github.com/coq/coq/pull/13870>`_, by Guillaume Melquiond). +Changes in 8.13.2 +~~~~~~~~~~~~~~~~~ + +Kernel +^^^^^^ + +- **Fixed:** + Crash when using :tacn:`vm_compute` on an irreducible ``PArray.set`` + (`#14005 <https://github.com/coq/coq/pull/14005>`_, + fixes `#13998 <https://github.com/coq/coq/issues/13998>`_, + by Guillaume Melquiond). +- **Fixed:** + Never store persistent arrays as VM / native structured values. + This could be used to make vo marshalling crash, and probably + breaking some other invariants of the kernel + (`#14007 <https://github.com/coq/coq/pull/14007>`_, + fixes `#14006 <https://github.com/coq/coq/issues/14006>`_, + by Pierre-Marie Pédrot). + +Tactic language +^^^^^^^^^^^^^^^^ + +- **Fixed:** + Ltac2 ``Array.init`` no longer incurs exponential overhead when used + recursively (`#14012 <https://github.com/coq/coq/pull/14012>`_, fixes `#14011 + <https://github.com/coq/coq/issues/14011>`_, by Jason Gross). + Version 8.12 ------------ @@ -751,10 +778,8 @@ The main changes include: of chapters along with updated syntax descriptions that match Coq's grammar in most but not all chapters. -Additionally, the :tacn:`omega` tactic is deprecated in this version of Coq, -and we recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter -<omega_chapter>`). +Additionally, the `omega` tactic is deprecated in this version of Coq, +and we recommend users to switch to :tacn:`lia` in new proof scripts. See the `Changes in 8.12+beta1`_ section and following sections for the detailed list of changes, including potentially breaking changes marked @@ -1019,7 +1044,7 @@ Tactics <https://github.com/coq/coq/pull/10760>`_, by Jason Gross). - **Changed:** The :g:`auto with zarith` tactic and variations (including - :tacn:`intuition`) may now call :tacn:`lia` instead of :tacn:`omega` + :tacn:`intuition`) may now call :tacn:`lia` instead of `omega` (when the `Omega` module is loaded); more goals may be automatically solved, fewer section variables will be captured spuriously (`#11018 <https://github.com/coq/coq/pull/11018>`_, @@ -1115,7 +1140,7 @@ Tactics (`#11883 <https://github.com/coq/coq/pull/11883>`_, by Attila Gáspár). - **Deprecated:** - The :tacn:`omega` tactic is deprecated; + The `omega` tactic is deprecated; use :tacn:`lia` from the :ref:`Micromega <micromega>` plugin instead (`#11976 <https://github.com/coq/coq/pull/11976>`_, by Vincent Laporte). @@ -2102,11 +2127,9 @@ The main changes brought by Coq version 8.11 are: - :ref:`Revision<811Reals>` of the :g:`Coq.Reals` library, its axiomatisation and instances of the constructive and classical real numbers. -Additionally, while the :tacn:`omega` tactic is not yet deprecated in +Additionally, while the `omega` tactic is not yet deprecated in this version of Coq, it should soon be the case and we already -recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter -<omega_chapter>`). +recommend users to switch to :tacn:`lia` in new proof scripts. The ``dev/doc/critical-bugs`` file documents the known critical bugs of Coq and affected releases. See the `Changes in 8.11+beta1`_ diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 9f097b4fe9..abe928fa26 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -5,7 +5,7 @@ The underlying formal language of Coq is a :gdef:`Calculus of Inductive Constructions` (|Cic|) whose inference rules are presented in this chapter. The history of this formalism as well as pointers to related -work are provided in a separate chapter; see *Credits*. +work are provided in a separate chapter; see :ref:`history`. .. _The-terms: diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 06b6c61ea9..e53e6ea1cb 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -4,10 +4,80 @@ Conversion rules ---------------- Coq has conversion rules that can be used to determine if two -terms are equal by definition, or :term:`convertible`. +terms are equal by definition in |CiC|, or :term:`convertible`. Conversion rules consist of reduction rules and expansion rules. -See :ref:`applyingconversionrules`, -which describes tactics that apply these conversion rules. +Equality is determined by +converting both terms to a normal form, then verifying they are syntactically +equal (ignoring differences in the names of bound variables by +:term:`alpha-conversion <alpha-convertible>`). + +.. seealso:: :ref:`applyingconversionrules`, which describes tactics that apply these conversion rules. + +:gdef:`Reductions <reduction>` convert terms to something that is incrementally +closer to its normal form. For example, :term:`zeta-reduction` removes +:n:`let @ident := @term__1 in @term__2` constructs from a term by replacing +:n:`@ident` with :n:`@term__1` wherever :n:`@ident` appears in :n:`@term__2`. +The resulting term may be longer or shorter than the original. + +.. coqtop:: all + + Eval cbv zeta in let i := 1 in i + i. + +:gdef:`Expansions <expansion>` are reductions applied in the opposite direction, +for example expanding `2 + 2` to `let i := 2 in i + i`. While applying +reductions gives a unique result, the associated +expansion may not be unique. For example, `2 + 2` could also be +expanded to `let i := 2 in i + 2`. Reductions that have a unique inverse +expansion are also referred to as :gdef:`contractions <contraction>`. + +The normal form is defined as the result of applying a particular +set of conversion rules (beta-, delta-, iota- and zeta-reduction and eta-expansion) +repeatedly until it's no longer possible to apply any of them. + +Sometimes the result of a reduction tactic will be a simple value, for example reducing +`2*3+4` with `cbv beta delta iota` to `10`, which requires applying several +reduction rules repeatedly. In other cases, it may yield an expression containing +variables, axioms or opaque contants that can't be reduced. + +The useful conversion rules are shown below. All of them except for eta-expansion +can be applied with conversion tactics such as :tacn:`cbv`: + + .. list-table:: + :header-rows: 1 + + * - Conversion name + - Description + + * - beta-reduction + - eliminates `fun` + + * - delta-reduction + - replaces a defined variable or constant with its definition + + * - zeta-reduction + - eliminates `let` + + * - eta-expansion + - replaces a term `f` of type `forall a : A, B` with `fun x : A => f x` + + * - match-reduction + - eliminates `match` + + * - fix-reduction + - replaces a `fix` with a :term:`beta-redex`; + recursive calls to the symbol are replaced with the `fix` term + + * - cofix-reduction + - replaces a `cofix` with a :term:`beta-redex`; + recursive calls to the symbol are replaced with the `cofix` term + + * - iota-reduction + - match-, fix- and cofix-reduction together + +:ref:`applyingconversionrules` +describes tactics that only apply conversion rules. +(Other tactics may use conversion rules in addition +to other changes to the proof state.) α-conversion ~~~~~~~~~~~~ @@ -123,7 +193,7 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. .. math:: λ x:T.~(t~x)~\not\triangleright_η~t - This is because, in general, the type of :math:`t` need not to be convertible + This is because, in general, the type of :math:`t` need not be convertible to the type of :math:`λ x:T.~(t~x)`. E.g., if we take :math:`f` such that: .. math:: @@ -142,6 +212,30 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. +Examples +~~~~~~~~ + + .. example:: Simple delta, fix, beta and match reductions + + ``+`` is a :ref:`notation <Notations>` for ``Nat.add``, which is defined + with a :cmd:`Fixpoint`. + + .. coqtop:: all abort + + Print Nat.add. + Goal 1 + 1 = 2. + cbv delta. + cbv fix. + cbv beta. + cbv match. + + The term can be fully reduced with `cbv`: + + .. coqtop:: all abort + + Goal 1 + 1 = 2. + cbv. + .. _proof-irrelevance: Proof Irrelevance diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 5d36ec3cf9..49c2c6b785 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -515,6 +515,11 @@ To build, say, two targets foo.vo and bar.vo in parallel one can use + ``-extra-phony`` and ``-extra`` are deprecated. To provide additional target (``.PHONY`` or not) please use ``CoqMakefile.local``. +.. note:: + + Due to limitations with the compilation chain, makefiles generated + by ``coq_makefile`` won't correctly compile OCaml plugins with OCaml + < 4.07.0 when using more than one job (``-j N`` for ``N > 1``). Precompiling for ``native_compute`` +++++++++++++++++++++++++++++++++++ diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b1759bf71b..88fca93547 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1666,7 +1666,7 @@ Proving a subgoal as a separate lemma: abstract is chosen to get a fresh name. If the proof is closed with :cmd:`Qed`, the auxiliary lemma is inlined in the final proof term. - This is useful with tactics such as :tacn:`omega` or + This is useful with tactics such as :tacn:`discriminate` that generate huge proof terms with many intermediate goals. It can significantly reduce peak memory use. In most cases it doesn't have a significant impact on run time. One case in which it can reduce run time @@ -2317,11 +2317,10 @@ performance issue. .. coqtop:: reset in - Set Warnings "-omega-is-deprecated". - Require Import Coq.omega.Omega. + Require Import Lia. Ltac mytauto := tauto. - Ltac tac := intros; repeat split; omega || mytauto. + Ltac tac := intros; repeat split; lia || mytauto. Notation max x y := (x + (y - x)) (only parsing). @@ -2340,7 +2339,7 @@ performance issue. Set Ltac Profiling. tac. Show Ltac Profile. - Show Ltac Profile "omega". + Show Ltac Profile "lia". .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 294c56ef06..25ac72069b 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -1375,8 +1375,9 @@ table further down lists the classes that that are handled plainly. the term (as described in :ref:`LocalInterpretationRulesForNotations`). The last :token:`scope_key` is the top of the scope stack that's applied to the :token:`term`. - :n:`open_constr` - Parses an open :token:`term`. + :n:`open_constr {? ( {+, @scope_key } ) }` + Parses an open :token:`term`. Like :n:`constr` above, this class + accepts a list of notation scopes with the same effects. :n:`ident` Parses :token:`ident` or :n:`$@ident`. The first form returns :n:`ident:(@ident)`, diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index bab9d35099..d4749f781a 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -609,7 +609,7 @@ Abbreviations |SSR| extends the :tacn:`set` tactic by supplying: - + an open syntax, similarly to the :tacn:`pose (ssreflect)` tactic; + + an open syntax, similarly to the :tacn:`pose <pose (ssreflect)>` tactic; + a more aggressive matching algorithm; + an improved interpretation of wildcards, taking advantage of the matching algorithm; @@ -899,7 +899,7 @@ context of a goal thanks to the ``in`` tactical. .. tacv:: set @ident := @term in {+ @ident} - This variant of :tacn:`set (ssreflect)` introduces a defined constant + This variant of :tacn:`set <set (ssreflect)>` introduces a defined constant called :token:`ident` in the context, and folds it in the context entries mentioned on the right hand side of ``in``. The body of :token:`ident` is the first subterm matching these context @@ -1202,7 +1202,7 @@ The move tactic. Goal not False. move. - More precisely, the :tacn:`move` tactic inspects the goal and does nothing + More precisely, the :tacn:`move <move (ssreflect)>` tactic inspects the goal and does nothing (:tacn:`idtac`) if an introduction step is possible, i.e. if the goal is a product or a ``let … in``, and performs :tacn:`hnf` otherwise. @@ -1301,7 +1301,7 @@ The apply tactic this use of the :tacn:`refine` tactic implies that the tactic tries to match the goal up to expansion of constants and evaluation of subterms. -:tacn:`apply (ssreflect)` has a special behavior on goals containing +:tacn:`apply <apply (ssreflect)>` has a special behavior on goals containing existential metavariables of sort :g:`Prop`. .. example:: @@ -2461,7 +2461,7 @@ The have tactic. redex, and introduces the lemma under a fresh name, automatically chosen. -Like in the case of the :n:`pose (ssreflect)` tactic (see section :ref:`definitions_ssr`), the types of +Like in the case of the :n:`pose <pose (ssreflect)>` tactic (see section :ref:`definitions_ssr`), the types of the holes are abstracted in term. .. example:: @@ -3775,7 +3775,7 @@ involves the following steps: ``forall n, F1 n = F2 n`` for ``eq_map``). 3. If so :tacn:`under` puts these n goals in head normal form (using - the defective form of the tactic :tacn:`move`), then executes + the defective form of the tactic :tacn:`move <move (ssreflect)>`), then executes the corresponding intro pattern :n:`@i_pattern__i` in each goal. 4. Then :tacn:`under` checks that the first n subgoals @@ -5665,6 +5665,7 @@ Tactics respectively. .. tacn:: move + :name: move (ssreflect) :tacn:`idtac` or :tacn:`hnf` (see :ref:`bookkeeping_ssr`) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index fad02b2645..7bc009fcfe 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -1148,7 +1148,7 @@ Managing the local context or at the bottom of the local context. All hypotheses on which the new hypothesis depends are moved too so as to respect the order of dependencies between hypotheses. It is equivalent to :n:`intro {? @ident__1 }` - followed by the appropriate call to :tacn:`move … after …`, + followed by the appropriate call to :tacn:`move`, :tacn:`move … before …`, :tacn:`move … at top`, or :tacn:`move … at bottom`. @@ -1235,7 +1235,6 @@ Managing the local context hypotheses that depend on it. .. tacn:: move @ident__1 after @ident__2 - :name: move … after … This moves the hypothesis named :n:`@ident__1` in the local context after the hypothesis named :n:`@ident__2`, where “after” is in reference to the @@ -1256,7 +1255,7 @@ Managing the local context :name: move … before … This moves :n:`@ident__1` towards and just before the hypothesis - named :n:`@ident__2`. As for :tacn:`move … after …`, dependencies + named :n:`@ident__2`. As for :tacn:`move`, dependencies over :n:`@ident__1` (when :n:`@ident__1` comes before :n:`@ident__2` in the order of dependencies) or in the type of :n:`@ident__1` (when :n:`@ident__1` comes after :n:`@ident__2` in the order of @@ -2502,7 +2501,7 @@ and an explanation of the underlying technique. :name: inversion ... using ... .. todo using … instead of ... in the name above gives a Sphinx error, even though - this works just find for :tacn:`move … after …` + this works just find for :tacn:`move` Let :n:`@ident` have type :g:`(I t)` (:g:`I` an inductive predicate) in the local context, and :n:`@ident` be a (dependent) inversion lemma. Then, this diff --git a/doc/sphinx/proofs/automatic-tactics/index.rst b/doc/sphinx/proofs/automatic-tactics/index.rst index c3712b109d..e458c3a9f5 100644 --- a/doc/sphinx/proofs/automatic-tactics/index.rst +++ b/doc/sphinx/proofs/automatic-tactics/index.rst @@ -14,7 +14,6 @@ complex goals in new domains. :maxdepth: 1 logic - ../../addendum/omega ../../addendum/micromega ../../addendum/ring ../../addendum/nsatz diff --git a/doc/sphinx/refman-preamble.rst b/doc/sphinx/refman-preamble.rst index 32d3e87e68..dd1d6051b5 100644 --- a/doc/sphinx/refman-preamble.rst +++ b/doc/sphinx/refman-preamble.rst @@ -15,7 +15,7 @@ .. |c_i| replace:: `c`\ :math:`_{i}` .. |c_n| replace:: `c`\ :math:`_{n}` .. |Cic| replace:: CIC -.. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{\beta\delta\iota\zeta}` +.. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{βδιζ}` .. |Latex| replace:: :smallcaps:`LaTeX` .. |Ltac| replace:: `L`:sub:`tac` .. |p_1| replace:: `p`\ :math:`_{1}` diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 453e878a5d..d212256765 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -467,6 +467,7 @@ Displaying information about notations - `tactic` - for currently-defined tactic notations, :token:`tactic`\s and tacticals (corresponding to :token:`ltac_expr` in the documentation). - `vernac` - for :token:`command`\s + - `ltac2` - for Ltac2 notations (corresponding to :token:`ltac2_expr`) This command doesn't display all nonterminals of the grammar. For example, productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index e4f0967794..bca66cc61b 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -58,10 +58,7 @@ theories/micromega/ZifyPow.v theories/micromega/Zify.v theories/nsatz/NsatzTactic.v theories/nsatz/Nsatz.v -theories/omega/Omega.v theories/omega/OmegaLemmas.v -theories/omega/OmegaPlugin.v -theories/omega/OmegaTactic.v theories/omega/PreOmega.v theories/quote/Quote.v theories/romega/ROmega.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index d67906c4a8..6fda3b06ce 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -135,6 +135,7 @@ through the <tt>Require Import</tt> command.</p> theories/Arith/Bool_nat.v theories/Arith/Factorial.v theories/Arith/Wf_nat.v + theories/Arith/Cantor.v </dd> <dt> <b>PArith</b>: diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index 522b9900a5..51e26a9082 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -28,7 +28,7 @@ from bs4 import BeautifulSoup from bs4.element import NavigableString COQDOC_OPTIONS = ['--body-only', '--no-glob', '--no-index', '--no-externals', - '-s', '--html', '--stdout', '--utf8'] + '-s', '--html', '--stdout', '--utf8', '--parse-comments'] COQDOC_SYMBOLS = ["->", "<-", "<->", "=>", "<=", ">=", "<>", "~", "/\\", "\\/", "|-", "*", "forall", "exists"] COQDOC_HEADER = "".join("(** remove printing {} *)".format(s) for s in COQDOC_SYMBOLS) @@ -68,8 +68,19 @@ def lex(source): if isinstance(elem, NavigableString): yield [], elem elif elem.name == "span": - cls = "coqdoc-{}".format(elem['title']) - yield [cls], elem.string + if elem.string: + cls = "coqdoc-{}".format(elem.get("title", "comment")) + yield [cls], elem.string + else: + # handle multi-line comments + children = list(elem.children) + mlc = children[0].startswith("(*") and children[-1].endswith ("*)") + for elem2 in children: + if isinstance(elem2, NavigableString): + cls = ["coqdoc-comment"] if mlc else [] + yield cls, elem2 + elif elem2.name == 'br': + pass elif elem.name == 'br': pass else: diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 1428dae7ef..468b6b648d 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -938,10 +938,11 @@ class CoqtopBlocksTransform(Transform): @staticmethod def split_lines(source): - r"""Split Coq input in chunks + r"""Split Coq input into chunks, which may include single- or + multi-line comments. Nested comments are not supported. A chunk is a minimal sequence of consecutive lines of the input that - ends with a '.' + ends with a '.' or '*)' >>> split_lines('A.\nB.''') ['A.', 'B.'] @@ -962,8 +963,14 @@ class CoqtopBlocksTransform(Transform): >>> split_lines('SearchHead le.\nSearchHead (@eq bool).') ['SearchHead le.', 'SearchHead (@eq bool).'] + + >>> split_lines("(* *) x. (* *)\ny.\n") + ['(* *) x. (* *)', 'y.'] + + >>> split_lines("(* *) x (* \n *)\ny.\n") + ['(* *) x (* \n *)', 'y.'] """ - return re.split(r"(?<=(?<!\.)\.)\n", source.strip()) + return re.split(r"(?:(?<=(?<!\.)\.)|(?<=\*\)))\n", source.strip()) @staticmethod def parse_options(node): @@ -1039,7 +1046,11 @@ class CoqtopBlocksTransform(Transform): if options['warn']: repl.sendone('Set Warnings "default".') for sentence in self.split_lines(node.rawsource): - pairs.append((sentence, repl.sendone(sentence))) + comment = re.compile(r"\s*\(\*.*?\*\)\s*", re.DOTALL) + wo_comments = re.sub(comment, "", sentence) + has_tac = wo_comments != "" and not wo_comments.isspace() + output = repl.sendone(sentence) if has_tac else "" + pairs.append((sentence, output)) if options['abort']: repl.sendone('Abort All.') if options['fail']: @@ -1052,9 +1063,10 @@ class CoqtopBlocksTransform(Transform): # Use Coqdoc to highlight input in_chunks = highlight_using_coqdoc(sentence) dli += nodes.term(sentence, '', *in_chunks, classes=self.block_classes(options['input'])) - # Parse ANSI sequences to highlight output - out_chunks = AnsiColorsParser().colorize_str(output) - dli += nodes.definition(output, *out_chunks, classes=self.block_classes(options['output'], output)) + if output: + # Parse ANSI sequences to highlight output + out_chunks = AnsiColorsParser().colorize_str(output) + dli += nodes.definition(output, *out_chunks, classes=self.block_classes(options['output'], output)) node.clear() node.rawsource = self.make_rawsource(pairs, options['input'], options['output']) node['classes'].extend(self.block_classes(options['input'] or options['output'])) @@ -1180,8 +1192,7 @@ class StdGlossaryIndex(Index): if type == 'term': entries = content[itemname[0].lower()] entries.append([itemname, 0, docname, anchor, '', '', '']) - content = sorted(content.items()) - return content, False + return content.items(), False def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, content=[]): """A grammar production not included in a ``prodn`` directive. diff --git a/doc/tools/coqrst/repl/ansicolors.py b/doc/tools/coqrst/repl/ansicolors.py index 9e23be2409..6700c20b1a 100644 --- a/doc/tools/coqrst/repl/ansicolors.py +++ b/doc/tools/coqrst/repl/ansicolors.py @@ -91,7 +91,10 @@ def parse_ansi(code): leading ‘^[[’ or the final ‘m’ """ classes = [] - parse_style([int(c) for c in code.split(';')], 0, classes) + if code == "37": + pass # ignore white fg + else: + parse_style([int(c) for c in code.split(';')], 0, classes) return ["ansi-" + cls for cls in classes] if __name__ == '__main__': diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 4ba60ddd9f..873b2f8dff 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -21,7 +21,6 @@ (glob_files %{project_root}/plugins/ltac/*.mlg) (glob_files %{project_root}/plugins/micromega/*.mlg) (glob_files %{project_root}/plugins/nsatz/*.mlg) - (glob_files %{project_root}/plugins/omega/*.mlg) (glob_files %{project_root}/plugins/ring/*.mlg) (glob_files %{project_root}/plugins/rtauto/*.mlg) (glob_files %{project_root}/plugins/ssr/*.mlg) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 1f5c1ee3e2..fe166524bf 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1777,7 +1777,6 @@ simple_tactic: [ | "zify_iter_let" tactic (* micromega plugin *) | "zify_elim_let" (* micromega plugin *) | "nsatz_compute" constr (* nsatz plugin *) -| "omega" (* omega plugin *) | "protect_fv" string "in" ident (* ring plugin *) | "protect_fv" string (* ring plugin *) | "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* ring plugin *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 49bcf97850..2b09263cc4 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -1855,7 +1855,6 @@ simple_tactic: [ | "zify_iter_let" ltac_expr (* micromega plugin *) | "zify_elim_let" (* micromega plugin *) | "nsatz_compute" one_term (* nsatz plugin *) -| "omega" (* omega plugin *) | "protect_fv" string OPT ( "in" ident ) | "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) | "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) @@ -35,3 +35,6 @@ (deps test-suite/summary.log)) ; (dirs (:standard _build_ci)) + +(documentation + (package coq)) diff --git a/engine/uState.ml b/engine/uState.ml index 20ea24dd87..81559778f2 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -296,9 +296,6 @@ let add_constraints uctx cstrs = universes = UGraph.merge_constraints cstrs' uctx.universes; weak_constraints = weak; } -(* let addconstrkey = CProfile.declare_profile "add_constraints_context";; *) -(* let add_constraints_context = CProfile.profile2 addconstrkey add_constraints_context;; *) - let add_universe_constraints uctx cstrs = let univs, local = uctx.local in let vars, weak, local' = process_universe_constraints uctx cstrs in diff --git a/engine/univGen.ml b/engine/univGen.ml index 278ca6bf34..b917d91512 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -13,14 +13,14 @@ open Names open Constr open Univ -type univ_unique_id = int (* Generator of levels *) -let new_univ_id, set_remote_new_univ_id = - RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> n) +let new_univ_id = + let cnt = ref 0 in + fun () -> incr cnt; !cnt let new_univ_global () = - Univ.Level.UGlobal.make (Global.current_dirpath ()) (new_univ_id ()) + let s = if Flags.async_proofs_is_worker() then !Flags.async_proofs_worker_id else "" in + Univ.Level.UGlobal.make (Global.current_dirpath ()) s (new_univ_id ()) let fresh_level () = Univ.Level.make (new_univ_global ()) diff --git a/engine/univGen.mli b/engine/univGen.mli index 05737411f5..743d819747 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -13,12 +13,6 @@ open Constr open Environ open Univ - -(** The global universe counter *) -type univ_unique_id -val set_remote_new_univ_id : univ_unique_id RemoteCounter.installer -val new_univ_id : unit -> univ_unique_id (** for the stm *) - (** Side-effecting functions creating new universe levels. *) val new_univ_global : unit -> Level.UGlobal.t diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 4ed6e97526..86bf2c9298 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -406,6 +406,3 @@ let normalize_context_set ~lbound g ctx us algs weak = in let us = normalize_opt_subst us in (us, algs), (ctx', Constraint.union noneqs eqs) - -(* let normalize_conkey = CProfile.declare_profile "normalize_context_set" *) -(* let normalize_context_set a b c = CProfile.profile3 normalize_conkey normalize_context_set a b c *) diff --git a/engine/univProblem.ml b/engine/univProblem.ml index 8d6689933c..10ee601f3f 100644 --- a/engine/univProblem.ml +++ b/engine/univProblem.ml @@ -9,7 +9,6 @@ (************************************************************************) open Univ -open UnivSubst type t = | ULe of Universe.t * Universe.t @@ -22,24 +21,6 @@ let is_trivial = function | ULe (u, v) | UEq (u, v) -> Universe.equal u v | ULub (u, v) | UWeak (u, v) -> Level.equal u v -let subst_univs fn = function - | ULe (u, v) -> - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (ULe (u',v')) - | UEq (u, v) -> - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (ULe (u',v')) - | ULub (u, v) -> - let u' = level_subst_of fn u and v' = level_subst_of fn v in - if Level.equal u' v' then None - else Some (ULub (u',v')) - | UWeak (u, v) -> - let u' = level_subst_of fn u and v' = level_subst_of fn v in - if Level.equal u' v' then None - else Some (UWeak (u',v')) - module Set = struct module S = Set.Make( struct @@ -88,11 +69,6 @@ module Set = struct let equal x y = x == y || equal x y - - let subst_univs subst csts = - fold - (fun c -> Option.fold_right add (subst_univs subst c)) - csts empty end type 'a accumulator = Set.t -> 'a -> 'a option diff --git a/engine/univProblem.mli b/engine/univProblem.mli index 575f5ac847..6c7a11f529 100644 --- a/engine/univProblem.mli +++ b/engine/univProblem.mli @@ -32,8 +32,6 @@ module Set : sig include Set.S with type elt = t val pr : t -> Pp.t - - val subst_univs : universe_subst_fn -> t -> t end type 'a accumulator = Set.t -> 'a -> 'a option diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 330ed5d0ad..c76a4cd751 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -83,12 +83,6 @@ let subst_univs_constr subst c = let f = Univ.make_subst subst in subst_univs_fn_constr f c -let subst_univs_constr = - if Flags.profile then - let subst_univs_constr_key = CProfile.declare_profile "subst_univs_constr" in - CProfile.profile2 subst_univs_constr_key subst_univs_constr - else subst_univs_constr - let normalize_univ_variable ~find = let rec aux cur = let b = find cur in diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 83c158e057..fd3ff25fc1 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -129,10 +129,12 @@ let tokens con = egram.gtokens; !list +(** Used to propagate possible presence of SELF/NEXT in a rule (binary and) *) type ('a, 'b, 'c) ty_and_rec = | NoRec2 : (norec, norec, norec) ty_and_rec | MayRec2 : ('a, 'b, mayrec) ty_and_rec +(** Used to propagate possible presence of SELF/NEXT in a tree (ternary and) *) type ('a, 'b, 'c, 'd) ty_and_rec3 = | NoRec3 : (norec, norec, norec, norec) ty_and_rec3 | MayRec3 : ('a, 'b, 'c, mayrec) ty_and_rec3 @@ -167,6 +169,7 @@ and ('self, 'trec, 'a) ty_symbol = | Sself : ('self, mayrec, 'self) ty_symbol | Snext : ('self, mayrec, 'self) ty_symbol | Snterm : 'a ty_entry -> ('self, norec, 'a) ty_symbol + (* norec but the entry can nevertheless introduce a loop with the current entry*) | Snterml : 'a ty_entry * string -> ('self, norec, 'a) ty_symbol | Stree : ('self, 'trec, Loc.t -> 'a) ty_tree -> ('self, 'trec, 'a) ty_symbol @@ -346,8 +349,11 @@ let insert_tree (type s trs trt tr p k a) entry_name (ar : (trs, trt, tr) ty_and let rec insert : type trs trt tr p f k. (trs, trt, tr) ty_and_ex -> (s, trs, p) ty_symbols -> (p, k, f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = fun ar symbols pf tree action -> match symbols, pf with - TCns (ars, s, sl), RelS pf -> insert_in_tree ar ars s sl pf tree action + TCns (ars, s, sl), RelS pf -> + (* descent in tree at symbol [s] *) + insert_in_tree ar ars s sl pf tree action | TNil, Rel0 -> + (* insert the action *) let node (type tb) ({node = s; son = son; brother = bro} : (_, _, _, tb, _, _) ty_node) = let ar : (norec, tb, tb) ty_and_ex = match get_rec_tree bro with MayRec -> NR10 | NoRec -> NR11 in @@ -381,43 +387,56 @@ let insert_tree (type s trs trt tr p k a) entry_name (ar : (trs, trt, tr) ty_and | MayRec2, _, NoRec -> Node (MayRec3, node NR11) | NoRec2, NoRec2, NoRec -> Node (NoRec3, node NR11) and try_insert : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_rec -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree option = - fun ar ars s sl pf tree action -> + fun ar ars symb symbl pf tree action -> match tree with - Node (arn, {node = s1; son = son; brother = bro}) -> - begin match eq_symbol s s1 with + Node (arn, {node = symb1; son = son; brother = bro}) -> + (* merging rule [symb; symbl -> action] in tree [symb1; son | bro] *) + begin match eq_symbol symb symb1 with | Some Refl -> - let MayRecNR arss = and_symbols_tree sl son in - let son = insert arss sl pf son action in - let node = {node = s1; son = son; brother = bro} in + (* reducing merge of [symb; symbl -> action] with [symb1; son] to merge of [symbl -> action] with [son] *) + let MayRecNR arss = and_symbols_tree symbl son in + let son = insert arss symbl pf son action in + let node = {node = symb1; son = son; brother = bro} in + (* propagate presence of SELF/NEXT *) begin match ar, ars, arn, arss with | MayRec2, _, _, _ -> Some (Node (MayRec3, node)) | NoRec2, NoRec2, NoRec3, NR11 -> Some (Node (NoRec3, node)) end | None -> let ar' = and_and_tree ar arn bro in - if is_before s1 s || derive_eps s && not (derive_eps s1) then + if is_before symb1 symb || derive_eps symb && not (derive_eps symb1) then + (* inserting new rule after current rule, i.e. in [bro] *) let bro = - match try_insert ar' ars s sl pf bro action with - Some bro -> bro + match try_insert ar' ars symb symbl pf bro action with + Some bro -> + (* could insert in [bro] *) + bro | None -> - let MayRecNR arss = and_symbols_tree sl DeadEnd in - let son = insert arss sl pf DeadEnd action in - let node = {node = s; son = son; brother = bro} in + (* not ok to insert in [bro] or after; we insert now *) + let MayRecNR arss = and_symbols_tree symbl DeadEnd in + let son = insert arss symbl pf DeadEnd action in + let node = {node = symb; son = son; brother = bro} in + (* propagate presence of SELF/NEXT *) match ar, ars, arn, arss with | MayRec2, _, _, _ -> Node (MayRec3, node) | NoRec2, NoRec2, NoRec3, NR11 -> Node (NoRec3, node) in - let node = {node = s1; son = son; brother = bro} in + let node = {node = symb1; son = son; brother = bro} in + (* propagate presence of SELF/NEXT *) match ar, arn with | MayRec2, _ -> Some (Node (MayRec3, node)) | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) else - match try_insert ar' ars s sl pf bro action with + (* should insert in [bro] or before the tree [symb1; son | bro] *) + match try_insert ar' ars symb symbl pf bro action with Some bro -> - let node = {node = s1; son = son; brother = bro} in + (* could insert in [bro] *) + let node = {node = symb1; son = son; brother = bro} in begin match ar, arn with | MayRec2, _ -> Some (Node (MayRec3, node)) | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) end - | None -> None + | None -> + (* should insert before [symb1; son | bro] *) + None end | LocAct (_, _) -> None | DeadEnd -> None in @@ -470,6 +489,7 @@ let is_level_labelled n (Level lev) = let insert_level (type s tr p k) entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = match symbols with | TCns (_, Sself, symbols) -> + (* Insert a rule of the form "SELF; ...." *) let Level slev = slev in let RelS pf = pf in let MayRecTree lsuffix = insert_tree entry_name symbols pf action slev.lsuffix in @@ -478,6 +498,7 @@ let insert_level (type s tr p k) entry_name (symbols : (s, tr, p) ty_symbols) (p lsuffix = lsuffix; lprefix = slev.lprefix} | _ -> + (* Insert a rule not starting with SELF *) let Level slev = slev in let MayRecTree lprefix = insert_tree entry_name symbols pf action slev.lprefix in Level @@ -1097,27 +1118,51 @@ let skip_if_empty bp p strm = if Stream.count strm == bp then fun a -> p strm else raise Stream.Failure -let continue entry bp a s son p1 (strm__ : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in +let continue entry bp a symb son p1 (strm__ : _ Stream.t) = + let a = (entry_of_symb entry symb).econtinue 0 bp a strm__ in let act = try p1 strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) + Stream.Failure -> raise (Stream.Error (tree_failed entry a symb son)) in fun _ -> act a -let do_recover parser_of_tree entry nlevn alevn bp a s son +(** Recover from a success on [symb] with result [a] followed by a + failure on [son] in a rule of the form [a = symb; son] *) +let do_recover parser_of_tree entry nlevn alevn bp a symb son (strm__ : _ Stream.t) = - try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with + try + (* Try to replay the son with the top occurrence of NEXT (by + default at level nlevn) and trailing SELF (by default at alevn) + replaced with self at top level; + This allows for instance to recover from a failure on the + second SELF of « SELF; "\/"; SELF » by doing as if it were + « SELF; "\/"; same-entry-at-top-level » with application e.g. to + accept "A \/ forall x, x = x" w/o requiring the expected + parentheses as in "A \/ (forall x, x = x)". *) + parser_of_tree entry nlevn alevn (top_tree entry son) strm__ + with Stream.Failure -> try + (* Discard the rule if what has been consumed before failing is + the empty sequence (due to some OPT or LIST0); example: + « OPT "!"; ident » fails to see an ident and the OPT was resolved + into the empty sequence, with application e.g. to being able to + safely write « LIST1 [ OPT "!"; id = ident -> id] ». *) skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure) strm__ with Stream.Failure -> - continue entry bp a s son (parser_of_tree entry nlevn alevn son) + (* In case of success on just SELF, NEXT or an explicit call to + a subentry followed by a failure on the rest (son), retry + parsing as if this entry had been called at its toplevel; + example: « "{"; entry-at-some-level; "}" » fails on "}" and + is retried with « "{"; same-entry-at-top-level; "}" », allowing + e.g. to parse « {1 + 1} » while « {(1 + 1)} » would + have been expected according to the level. *) + continue entry bp a symb son (parser_of_tree entry nlevn alevn son) strm__ -let recover parser_of_tree entry nlevn alevn bp a s son strm = - do_recover parser_of_tree entry nlevn alevn bp a s son strm +let recover parser_of_tree entry nlevn alevn bp a symb son strm = + do_recover parser_of_tree entry nlevn alevn bp a symb son strm let token_count = ref 0 @@ -1143,15 +1188,22 @@ let token_ematch gram tok = let tematch = L.tok_match tok in fun tok -> tematch tok +(** + nlevn: level for Snext + alevn: level for recursive calls on the left-hand side of the rule (depending on associativity) +*) + let rec parser_of_tree : type s tr r. s ty_entry -> int -> int -> (s, tr, r) ty_tree -> r parser_t = fun entry nlevn alevn -> function DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) | Node (_, {node = Sself; son = LocAct (act, _); brother = DeadEnd}) -> + (* SELF on the right-hand side of the last rule *) (fun (strm__ : _ Stream.t) -> let a = entry.estart alevn strm__ in act a) | Node (_, {node = Sself; son = LocAct (act, _); brother = bro}) -> + (* SELF on the right-hand side of a rule *) let p2 = parser_of_tree entry nlevn alevn bro in (fun (strm__ : _ Stream.t) -> match @@ -1394,6 +1446,33 @@ and parse_top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> a parser fun entry symb -> parser_of_symbol entry 0 (top_symb entry symb) +(** [start_parser_of_levels entry clevn levels levn strm] goes + top-down from level [clevn] to the last level, ignoring rules + between [levn] and [clevn], as if starting from + [max(clevn,levn)]. On each rule of the form [prefix] (where + [prefix] is a rule not starting with [SELF]), it tries to consume + the stream [strm]. + + The interesting case is [entry.estart] which is + [start_parser_of_levels entry 0 entry.edesc], thus practically + going from [levn] to the end. + + More schematically, assuming each level has the form + + level n: [ a = SELF; b = suffix_tree_n -> action_n(a,b) + | a = prefix_tree_n -> action'_n(a) ] + + then the main loop does the following: + + estart n = + if prefix_tree_n matches the stream as a then econtinue n (action'_n(a)) + else start (n+1) + + econtinue n a = + if suffix_tree_n matches the stream as b then econtinue n (action_n(a,b)) + else if n=0 then a else econtinue (n-1) a +*) + let rec start_parser_of_levels entry clevn = function [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) @@ -1426,7 +1505,9 @@ let rec start_parser_of_levels entry clevn = entry.econtinue levn bp a strm) | _ -> fun levn strm -> - if levn > clevn then p1 levn strm + if levn > clevn then + (* Skip rules before [levn] *) + p1 levn strm else let (strm__ : _ Stream.t) = strm in let bp = Stream.count strm__ in @@ -1437,6 +1518,18 @@ let rec start_parser_of_levels entry clevn = entry.econtinue levn bp a strm | _ -> p1 levn strm__ +(** [continue_parser_of_levels entry clevn levels levn bp a strm] goes + bottom-up from the last level to level [clevn], ignoring rules + between [levn] and [clevn], as if stopping at [max(clevn,levn)]. + It tries to consume the stream [strm] on the suffix of rules of + the form [SELF; suffix] knowing that [a] is what consumed [SELF] + at level [levn] (or [levn+1] depending on associativity). + + The interesting case is [entry.econtinue levn bp a] which is [try + continue_parser_of_levels entry 0 entry.edesc levn bp a with + Failure -> a], thus practically going from the end to [levn]. +*) + let rec continue_parser_of_levels entry clevn = function [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) @@ -1452,7 +1545,9 @@ let rec continue_parser_of_levels entry clevn = in let p2 = parser_of_tree entry (succ clevn) alevn tree in fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm + if levn > clevn then + (* Skip rules before [levn] *) + p1 levn bp a strm else let (strm__ : _ Stream.t) = strm in try p1 levn bp a strm__ with diff --git a/ide/coqide/MacOS/Info.plist.template b/ide/coqide/MacOS/Info.plist.template deleted file mode 100644 index e4fb0e5980..0000000000 --- a/ide/coqide/MacOS/Info.plist.template +++ /dev/null @@ -1,89 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> -<plist version="1.0"> -<dict> - <key>CFBundleDocumentTypes</key> - <array> - <dict> - <key>CFBundleTypeExtensions</key> - <array> - <string>*</string> - </array> - <key>CFBundleTypeName</key> - <string>NSStringPboardType</string> - <key>CFBundleTypeOSTypes</key> - <array> - <string>****</string> - </array> - <key>CFBundleTypeRole</key> - <string>Editor</string> - </dict> - <dict> - <key>CFBundleTypeIconFile</key> - <string>coqfile.icns</string> - <key>CFBundleTypeName</key> - <string>Coq file</string> - <key>CFBundleTypeRole</key> - <string>Editor</string> - <key>CFBundleTypeMIMETypes</key> - <array> - <string>text/plain</string> - </array> - <key>CFBundleTypeExtensions</key> - <array> - <string>v</string> - </array> - <key>LSHandlerRank</key> - <string>Owner</string> - </dict> - <dict> - <key>CFBundleTypeName</key> - <string>All</string> - <key>CFBundleTypeRole</key> - <string>Editor</string> - <key>CFBundleTypeMIMETypes</key> - <array> - <string>text/plain</string> - </array> - <key>LSHandlerRank</key> - <string>Default</string> - <key>CFBundleTypeExtensions</key> - <array> - <string>*</string> - </array> - </dict> - </array> - <key>CFBundleIconFile</key> - <string>coqide.icns</string> - <key>CFBundleVersion</key> - <string>390</string> - <key>CFBundleName</key> - <string>CoqIDE</string> - <key>CFBundleShortVersionString</key> - <string>VERSION</string> - <key>CFBundleDisplayName</key> - <string>Coq Proof Assistant vVERSION</string> - <key>CFBundleGetInfoString</key> - <string>Coq_vVERSION</string> - <key>NSHumanReadableCopyright</key> - <string>Copyright 1999-2019, Inria, CNRS and contributors</string> - <key>CFBundleHelpBookFolder</key> - <string>share/doc/coq/html/</string> - <key>CFAppleHelpAnchor</key> - <string>index</string> - <key>CFBundleExecutable</key> - <string>coqide</string> - <key>CFBundlePackageType</key> - <string>APPL</string> - <key>CFBundleInfoDictionaryVersion</key> - <string>6.0</string> - <key>CFBundleIdentifier</key> - <string>fr.inria.coq.coqide</string> - <key>LSApplicationCategoryType</key> - <string>public.app-category.developer-tools</string> - <key>CFBundleDevelopmentRegion</key> - <string>English</string> - <key>NSPrincipalClass</key> - <string>NSApplication</string> -</dict> -</plist> diff --git a/ide/coqide/configwin_ihm.ml b/ide/coqide/configwin_ihm.ml index e768131dcf..da1553d751 100644 --- a/ide/coqide/configwin_ihm.ml +++ b/ide/coqide/configwin_ihm.ml @@ -31,6 +31,10 @@ let set_help_tip wev = function | None -> () | Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help +let select_arch m m_osx = + if Coq_config.arch = "Darwin" then m_osx else m + +(* How the modifiers are named in the preference box *) let modifiers_to_string m = let rec iter m s = match m with @@ -41,6 +45,7 @@ let modifiers_to_string m = `CONTROL -> "<ctrl>" | `SHIFT -> "<shft>" | `LOCK -> "<lock>" + | `META -> select_arch "<meta>" "<cmd>" | `MOD1 -> "<alt>" | `MOD2 -> "<mod2>" | `MOD3 -> "<mod3>" @@ -773,7 +778,7 @@ let modifiers ?(editable=true) ?(expand=true) ?help - ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) + ?(allow=[`CONTROL;`SHIFT;`LOCK;`META;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) ?(f=(fun _ -> ())) label v = Modifiers_param { diff --git a/ide/coqide/coq-ssreflect.lang b/ide/coqide/coq-ssreflect.lang index fc7bc64a68..d71277f42c 100644 --- a/ide/coqide/coq-ssreflect.lang +++ b/ide/coqide/coq-ssreflect.lang @@ -32,7 +32,7 @@ <define-regex id="qualit">(\%{ident}*\.)*\%{ident}</define-regex> <define-regex id="undotted_sep">[-+*{}]</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> - <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)|(Canonical)|(Coercion)</define-regex> + <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Variant)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)|(Canonical)|(Coercion)</define-regex> <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex> <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex> <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex> diff --git a/ide/coqide/coq.lang b/ide/coqide/coq.lang index e9eab48de7..e6e813aca2 100644 --- a/ide/coqide/coq.lang +++ b/ide/coqide/coq.lang @@ -29,7 +29,7 @@ <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> <define-regex id="bullet">([-+*]+|{)(\s|\z)|}(\s*})*</define-regex> - <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion|Universe</define-regex> + <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Variant|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion|Universe</define-regex> <define-regex id="mult_decl">Hypothes[ie]s|Axiom(s)?|Variable(s)?|Parameter(s)?|Context|Implicit\%{space}Type(s)?</define-regex> <define-regex id="locality">((Local|Global)\%{space})?</define-regex> <define-regex id="begin_proof">Theorem|Lemma|Fact|Remark|Corollary|Proposition|Property</define-regex> diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index 20e9f0134f..dc616066c2 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -538,7 +538,7 @@ struct let implicit = BoolOpt ["Printing"; "Implicit"] let coercions = BoolOpt ["Printing"; "Coercions"] - let raw_matching = BoolOpt ["Printing"; "Matching"] + let nested_matching = BoolOpt ["Printing"; "Matching"] let notations = BoolOpt ["Printing"; "Notations"] let parentheses = BoolOpt ["Printing"; "Parentheses"] let all_basic = BoolOpt ["Printing"; "All"] @@ -553,8 +553,8 @@ struct let bool_items = [ { opts = [implicit]; init = false; label = "Display _implicit arguments" }; { opts = [coercions]; init = false; label = "Display _coercions" }; - { opts = [raw_matching]; init = true; - label = "Display raw _matching expressions" }; + { opts = [nested_matching]; init = true; + label = "Display nested _matching expressions" }; { opts = [notations]; init = true; label = "Display _notations" }; { opts = [parentheses]; init = false; label = "Display _parentheses" }; { opts = [all_basic]; init = false; diff --git a/ide/coqide/coq_commands.ml b/ide/coqide/coq_commands.ml index 2d75ad9ff6..3a080d5f51 100644 --- a/ide/coqide/coq_commands.ml +++ b/ide/coqide/coq_commands.ml @@ -93,7 +93,6 @@ let commands = [ ]; ["Read Module"; "Record"; - "Variant"; "Remark"; "Remove LoadPath"; "Remove Printing Constructor"; @@ -151,6 +150,7 @@ let commands = [ "Unset Silent."; "Unset Undo";]; ["Variable"; + "Variant"; "Variables";]; ["Write State";]; ] diff --git a/ide/coqide/coqide_ui.ml b/ide/coqide/coqide_ui.ml index badfabf07e..82eca905ea 100644 --- a/ide/coqide/coqide_ui.ml +++ b/ide/coqide/coqide_ui.ml @@ -77,7 +77,7 @@ let init () = \n <separator/>\ \n <menuitem action='Display implicit arguments' />\ \n <menuitem action='Display coercions' />\ -\n <menuitem action='Display raw matching expressions' />\ +\n <menuitem action='Display nested matching expressions' />\ \n <menuitem action='Display notations' />\ \n <menuitem action='Display parentheses' />\ \n <menuitem action='Display all basic low-level contents' />\ diff --git a/ide/coqide/dune b/ide/coqide/dune index 4bb4672cd4..d2642f77bf 100644 --- a/ide/coqide/dune +++ b/ide/coqide/dune @@ -51,6 +51,9 @@ (modes exe byte) (libraries coqide_gui)) +(documentation + (package coqide)) + ; Input-method bindings (executable (name default_bindings_src) diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index a6a7f7d742..0a0b932c46 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -177,7 +177,6 @@ let concl_next_tac = "symmetry" ] @ [ "assumption"; - "omega"; "ring"; "auto"; "eauto"; @@ -490,11 +489,11 @@ let eval_call c = let print_xml = let m = Mutex.create () in fun oc xml -> - Mutex.lock m; - if !Flags.xml_debug then - Printf.printf "SENT --> %s\n%!" (Xml_printer.to_string_fmt xml); - try Control.protect_sigalrm (Xml_printer.print oc) xml; Mutex.unlock m - with e -> let e = Exninfo.capture e in Mutex.unlock m; Exninfo.iraise e + CThread.with_lock m ~scope:(fun () -> + if !Flags.xml_debug then + Printf.printf "SENT --> %s\n%!" (Xml_printer.to_string_fmt xml); + try Control.protect_sigalrm (Xml_printer.print oc) xml + with e -> let e = Exninfo.capture e in Exninfo.iraise e) let slave_feeder fmt xml_oc msg = let xml = Xmlprotocol.(of_feedback fmt msg) in diff --git a/ide/coqide/index.mld b/ide/coqide/index.mld new file mode 100644 index 0000000000..8852a2a7eb --- /dev/null +++ b/ide/coqide/index.mld @@ -0,0 +1,3 @@ +{0 coqide } + +The coqide package only contains the CoqIDE executable and no OCaml library. diff --git a/ide/coqide/preferences.ml b/ide/coqide/preferences.ml index 5a77f4ebcf..838da6303d 100644 --- a/ide/coqide/preferences.ml +++ b/ide/coqide/preferences.ml @@ -304,7 +304,7 @@ let encoding = new preference ~name:["encoding"] ~init ~repr let automatic_tactics = - let init = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ] in + let init = ["trivial"; "tauto"; "auto"; "auto with *"; "intuition" ] in new preference ~name:["automatic_tactics"] ~init ~repr:Repr.(string_list) let cmd_print = @@ -321,18 +321,21 @@ let attach_modifiers (pref : string preference) prefix = in pref#connect#changed ~callback:cb -let select_arch m m_osx = - if Coq_config.arch = "Darwin" then m_osx else m - let modifier_for_navigation = new preference ~name:["modifier_for_navigation"] - ~init:(select_arch "<Control>" "<Control><Primary>") ~repr:Repr.(string) + (* Note: on Darwin, this will give "<Control><Meta>", i.e. Ctrl and Command; on other + architectures, "<Primary>" binds to "<Control>" so it will give "<Control>" alone *) + ~init:"<Control><Primary>" ~repr:Repr.(string) let modifier_for_templates = new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string) +let select_arch m m_osx = + if Coq_config.arch = "Darwin" then m_osx else m + let modifier_for_display = new preference ~name:["modifier_for_display"] + (* Note: <Primary> (i.e. <Meta>, i.e. "Command") on Darwin, i.e. MacOS X, but <Alt> elsewhere *) ~init:(select_arch "<Alt><Shift>" "<Primary><Shift>")~repr:Repr.(string) let modifier_for_queries = @@ -348,7 +351,9 @@ let attach_modifiers_callback () = () let modifiers_valid = - new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string) + new preference ~name:["modifiers_valid"] + (* Note: <Primary> is providing <Meta> (i.e. "Command") for Darwin, i.e. MacOS X *) + ~init:"<Alt><Control><Shift><Primary>" ~repr:Repr.(string) let browser_cmd_fmt = try diff --git a/index.mld b/index.mld new file mode 100644 index 0000000000..706688656e --- /dev/null +++ b/index.mld @@ -0,0 +1,5 @@ +{0 coq } + +The coq package is a virtual package gathering the coq-core and coq-stdlib packages. + +For the documentation of the OCaml API of Coq, see the {{: ../coq-core/index.html } coq-core } package. diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 3cabf52197..f687c4a640 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -27,6 +27,7 @@ open Glob_term open Glob_ops open Pattern open Detyping +open Structures module NamedDecl = Context.Named.Declaration (*i*) @@ -232,7 +233,7 @@ let get_record_print = let is_record indsp = try - let _ = Recordops.lookup_structure indsp in + let _ = Structure.find indsp in true with Not_found -> false @@ -407,7 +408,7 @@ let pattern_printable_in_both_syntax (ind,_ as c) = let extern_record_pattern cstrsp args = try if !Flags.raw_print then raise Exit; - let projs = Recordops.lookup_projections (fst cstrsp) in + let projs = Structure.find_projections (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () else if PrintingConstructor.active (fst cstrsp) then @@ -614,9 +615,12 @@ let is_gvar id c = match DAst.get c with let is_projection nargs r = if not !Flags.in_debugger && not !Flags.raw_print && !print_projections then try - let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then Some n - else None + match r with + | GlobRef.ConstRef c -> + let n = Structure.projection_nparams c + 1 in + if n <= nargs then Some n + else None + | _ -> None with Not_found -> None else None @@ -689,33 +693,29 @@ let extern_record ref args = try if !Flags.raw_print then raise Exit; let cstrsp = match ref with GlobRef.ConstructRef c -> c | _ -> raise Not_found in - let struc = Recordops.lookup_structure (fst cstrsp) in + let struc = Structure.find (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () else if PrintingConstructor.active (fst cstrsp) then raise Exit else if not (get_record_print ()) then raise Exit; - let projs = struc.Recordops.s_PROJ in - let locals = struc.Recordops.s_PROJKIND in + let projs = struc.Structure.projections in let rec cut args n = if Int.equal n 0 then args else match args with | [] -> raise No_match | _ :: t -> cut t (n - 1) in - let args = cut args struc.Recordops.s_EXPECTEDPARAM in - let rec ip projs locs args acc = + let args = cut args struc.Structure.nparams in + let rec ip projs args acc = match projs with | [] -> acc - | None :: q -> raise No_match - | Some c :: q -> - match locs with - | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") - | { Recordops.pk_true_proj = false } :: locs' -> + | { Structure.proj_body = None } :: _ -> raise No_match + | { Structure.proj_body = Some c; proj_true = false } :: q -> (* we don't want to print locals *) - ip q locs' args acc - | { Recordops.pk_true_proj = true } :: locs' -> + ip q args acc + | { Structure.proj_body = Some c; proj_true = true } :: q -> match args with | [] -> raise No_match (* we give up since the constructor is not complete *) @@ -723,9 +723,9 @@ let extern_record ref args = let arg = Lazy.force arg in let loc = arg.CAst.loc in let ref = extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c) in - ip q locs' tail ((ref, arg) :: acc) + ip q tail ((ref, arg) :: acc) in - Some (List.rev (ip projs locals args [])) + Some (List.rev (ip projs args [])) with | Not_found | No_match | Exit -> None diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 7c63ebda3a..958e1408f8 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -24,6 +24,7 @@ open Glob_term open Glob_ops open Patternops open Pretyping +open Structures open Cases open Constrexpr open Constrexpr_ops @@ -34,6 +35,7 @@ open Inductiveops open Context.Rel.Declaration open NumTok + (** constr_expr -> glob_constr translation: - it adds holes for implicit arguments - it replaces notations by their value (scopes stuff are here) @@ -100,7 +102,7 @@ type internalization_error = | NonLinearPattern of Id.t | BadPatternsNumber of int * int | NotAProjection of qualid - | ProjectionsOfDifferentRecords of Recordops.struc_typ * Recordops.struc_typ + | ProjectionsOfDifferentRecords of Structure.t * Structure.t exception InternalizationError of internalization_error @@ -126,8 +128,8 @@ let explain_bad_patterns_number n1 n2 = str "Expecting " ++ int n1 ++ str (String.plural n1 " pattern") ++ str " but found " ++ int n2 -let inductive_of_record record = - let inductive = GlobRef.IndRef (inductive_of_constructor record.Recordops.s_CONST) in +let inductive_of_record s = + let inductive = GlobRef.IndRef (s.Structure.name) in Nametab.shortest_qualid_of_global Id.Set.empty inductive let explain_field_not_a_projection field_id = @@ -1130,8 +1132,10 @@ let intern_reference qid = let intern_projection qid = try - let gr = Smartlocate.global_of_extended_global (intern_extended_global_of_qualid qid) in - (gr, Recordops.find_projection gr) + match Smartlocate.global_of_extended_global (intern_extended_global_of_qualid qid) with + | GlobRef.ConstRef c as gr -> + (gr, Structure.find_from_projection c) + | _ -> raise Not_found with Not_found -> Loc.raise ?loc:qid.loc (InternalizationError (NotAProjection qid)) @@ -1296,8 +1300,8 @@ let check_applied_projection isproj realref qid = let is_prim = match realref with | None | Some (IndRef _ | ConstructRef _ | VarRef _) -> false | Some (ConstRef c) -> - if Recordops.is_primitive_projection c then true - else if Recordops.is_projection c then false + if PrimitiveProjections.mem c then true + else if Structure.is_projection c then false else error_nonprojection_syntax ?loc:qid.loc qid (* TODO check projargs, note we will need implicit argument info *) in @@ -1498,18 +1502,18 @@ let sort_fields ~complete loc fields completer = | (first_field_ref, _):: _ -> let (first_field_glob_ref, record) = intern_projection first_field_ref in (* the number of parameters *) - let nparams = record.Recordops.s_EXPECTEDPARAM in + let nparams = record.Structure.nparams in (* the reference constructor of the record *) - let base_constructor = GlobRef.ConstructRef record.Recordops.s_CONST in + let base_constructor = GlobRef.ConstructRef (record.Structure.name,1) in let () = check_duplicate ?loc fields in - let build_proj idx proj kind = - if proj = None && complete then + let build_proj idx proj = + if proj.Structure.proj_body = None && complete then (* we don't want anonymous fields *) user_err ?loc (str "This record contains anonymous fields.") else - (idx, proj, kind.Recordops.pk_true_proj) in + (idx, proj.Structure.proj_body, proj.Structure.proj_true) in let proj_list = - List.map2_i build_proj 1 record.Recordops.s_PROJ record.Recordops.s_PROJKIND in + List.map_i build_proj 1 record.Structure.projections in (* now we want to have all fields assignments indexed by their place in the constructor *) let rec index_fields fields remaining_projs acc = @@ -1538,7 +1542,7 @@ let sort_fields ~complete loc fields completer = (* For terms, we keep only regular fields *) None else - Some (idx, completer idx field_ref record.Recordops.s_CONST) in + Some (idx, completer idx field_ref (record.Structure.name,1)) in List.map_filter complete_field remaining_projs in List.rev_append remaining_fields acc in diff --git a/kernel/byterun/dune b/kernel/byterun/dune index b14ad5c558..4d2000bb52 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -1,5 +1,5 @@ (library - (name byterun) + (name coqrun) (synopsis "Coq's Kernel Abstract Reduction Machine [C implementation]") (public_name coq-core.vm) (foreign_stubs diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 6ef0e9fa15..9e0f574fa3 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -295,38 +295,57 @@ let types = PITT_param 1)) in function - | Int63head0 | Int63tail0 -> [int_ty; int_ty] + | Int63head0 | Int63tail0 -> + [int_ty], int_ty | Int63add | Int63sub | Int63mul | Int63div | Int63mod | Int63divs | Int63mods | Int63lsr | Int63lsl | Int63asr - | Int63land | Int63lor | Int63lxor -> [int_ty; int_ty; int_ty] + | Int63land | Int63lor | Int63lxor -> + [int_ty; int_ty], int_ty | Int63addc | Int63subc | Int63addCarryC | Int63subCarryC -> - [int_ty; int_ty; PITT_ind (PIT_carry, int_ty)] + [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 | Int63lts | Int63les -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] - | Int63compare | Int63compares -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] + [int_ty; int_ty], PITT_ind (PIT_pair, (int_ty, int_ty)) + | 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] + [int_ty; int_ty; int_ty], PITT_ind (PIT_pair, (int_ty, int_ty)) + | Int63addMulDiv -> + [int_ty; int_ty; int_ty], int_ty | Float64opp | Float64abs | Float64sqrt - | Float64next_up | Float64next_down -> [float_ty; float_ty] - | Float64ofInt63 -> [int_ty; float_ty] - | Float64normfr_mantissa -> [float_ty; int_ty] - | Float64frshiftexp -> [float_ty; PITT_ind (PIT_pair, (float_ty, int_ty))] - | Float64eq | Float64lt | Float64le -> [float_ty; float_ty; PITT_ind (PIT_bool, ())] - | Float64compare -> [float_ty; float_ty; PITT_ind (PIT_f_cmp, ())] - | Float64classify -> [float_ty; PITT_ind (PIT_f_class, ())] - | Float64add | Float64sub | Float64mul - | Float64div -> [float_ty; float_ty; float_ty] - | Float64ldshiftexp -> [float_ty; int_ty; float_ty] - | Arraymake -> [int_ty; PITT_param 1; array_ty] - | Arrayget -> [array_ty; int_ty; PITT_param 1] - | Arraydefault -> [array_ty; PITT_param 1] - | Arrayset -> [array_ty; int_ty; PITT_param 1; array_ty] - | Arraycopy -> [array_ty; array_ty] - | Arraylength -> [array_ty; int_ty] + | Float64next_up | Float64next_down -> + [float_ty], float_ty + | Float64ofInt63 -> + [int_ty], float_ty + | Float64normfr_mantissa -> + [float_ty], int_ty + | Float64frshiftexp -> + [float_ty], PITT_ind (PIT_pair, (float_ty, int_ty)) + | Float64eq | Float64lt | Float64le -> + [float_ty; float_ty], PITT_ind (PIT_bool, ()) + | Float64compare -> + [float_ty; float_ty], PITT_ind (PIT_f_cmp, ()) + | Float64classify -> + [float_ty], PITT_ind (PIT_f_class, ()) + | Float64add | Float64sub | Float64mul | Float64div -> + [float_ty; float_ty], float_ty + | Float64ldshiftexp -> + [float_ty; int_ty], float_ty + | Arraymake -> + [int_ty; PITT_param 1], array_ty + | Arrayget -> + [array_ty; int_ty], PITT_param 1 + | Arraydefault -> + [array_ty], PITT_param 1 + | Arrayset -> + [array_ty; int_ty; PITT_param 1], array_ty + | Arraycopy -> + [array_ty], array_ty + | Arraylength -> + [array_ty], int_ty let one_param = (* currently if there's a parameter it's always this *) @@ -460,14 +479,17 @@ type args_red = arg_kind list (* Invariant only argument of type int63, float or an inductive can have kind Kwhnf *) -let arity t = let sign = types t in nparams t + List.length sign - 1 +let arity t = + nparams t + List.length (fst (types t)) let kind t = let rec params n = if n <= 0 then [] else Kparam :: params (n - 1) in let args = function PITT_type _ | PITT_ind _ -> Kwhnf | PITT_param _ -> Karg in - params (nparams t) @ List.map args (CList.drop_last (types t)) + params (nparams t) @ List.map args (fst (types t)) -let types t = params t, types t +let types t = + let args_ty, ret_ty = types t in + params t, args_ty, ret_ty (** Special Entries for Register **) diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index de90179726..6661851d53 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -140,8 +140,8 @@ val parse_op_or_type : ?loc:Loc.t -> string -> op_or_type val univs : t -> Univ.AUContext.t -val types : t -> Constr.rel_context * ind_or_type list -(** Parameters * Reduction relevant arguments and output type +val types : t -> Constr.rel_context * ind_or_type list * ind_or_type +(** Parameters * Reduction relevant arguments * output type XXX we could reify universes in ind_or_type (currently polymorphic types like array are assumed to use universe 0). *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index f82b754c59..87b1a71c9d 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -252,9 +252,6 @@ let cook_constant { from = cb; info } = cook_context = Some const_hyps; } -(* let cook_constant_key = CProfile.declare_profile "cook_constant" *) -(* let cook_constant = CProfile.profile2 cook_constant_key cook_constant *) - (********************************) (* Discharging mutual inductive *) diff --git a/kernel/dune b/kernel/dune index 0bf51f80ec..af88e9864f 100644 --- a/kernel/dune +++ b/kernel/dune @@ -4,7 +4,7 @@ (public_name coq-core.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_31 uint63_63 float64_31 float64_63)) - (libraries lib byterun dynlink)) + (libraries lib coqrun dynlink)) (executable (name genOpcodeFiles) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index eb18d4b90e..13044958dc 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -23,7 +23,7 @@ open Context.Rel.Declaration type mind_specif = mutual_inductive_body * one_inductive_body -(* raise Not_found if not an inductive type *) +(* raises an anomaly if not an inductive type *) let lookup_mind_specif env (kn,tyi) = let mib = Environ.lookup_mind kn env in if tyi >= Array.length mib.mind_packets then @@ -717,7 +717,7 @@ let rec ienv_decompose_prod (env,_ as ienv) n c = ienv_decompose_prod ienv' (n-1) b | _ -> assert false -let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) 0)) +let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) "" 0)) let dummy_implicit_sort = mkType (Universe.make dummy_univ) let lambda_implicit_lift n a = let anon = Context.make_annot Anonymous Sorts.Relevant in @@ -1334,11 +1334,6 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = else () -(* -let cfkey = CProfile.declare_profile "check_fix";; -let check_fix env fix = CProfile.profile3 cfkey check_fix env fix;; -*) - (************************************************************************) (* Co-fixpoints. *) diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 5808a3fa65..4afc7c439a 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -30,7 +30,7 @@ type mind_specif = mutual_inductive_body * one_inductive_body (** {6 ... } *) (** Fetching information in the environment about an inductive type. - Raises [Not_found] if the inductive type is not found. *) + Raises an anomaly if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index c5ac57a2cd..d2fb773dc4 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -291,6 +291,11 @@ let subst_ind sub (ind,i as indi) = let ind' = subst_mind sub ind in if ind' == ind then indi else ind',i +let subst_constructor subst (ind,j as ref) = + let ind' = subst_ind subst ind in + if ind==ind' then ref + else (ind',j) + let subst_pind sub (ind,u) = (subst_ind sub ind, u) diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 9cf270cff7..e7bfceb4de 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -127,6 +127,9 @@ val subst_mind : val subst_ind : substitution -> inductive -> inductive +val subst_constructor : + substitution -> constructor -> constructor + val subst_pind : substitution -> pinductive -> pinductive val subst_kn : diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 9ce388929c..22bbcb8a65 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -994,9 +994,8 @@ let extract_prim ml_of l = let decl = ref [] in let cond = ref [] in let type_args p = - let rec aux = function [] | [_] -> [] | h :: t -> h :: aux t in - let params, sign = CPrimitives.types p in - List.length params, Array.of_list (aux sign) in + let params, args_ty, _ = CPrimitives.types p in + List.length params, Array.of_list args_ty in let rec aux l = match l with | Lprim(prefix,kn,p,args) -> diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index f3b483467d..aa30a01134 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -381,10 +381,7 @@ let makeblock env ind tag nparams arity args = Lmakeblock(prefix, ind, tag, args) let makearray args def = - try - let p = Array.map get_value args in - Lval (Nativevalues.parray_of_array p (get_value def)) - with Not_found -> Lparray (args, def) + Lparray (args, def) (* Translation of constants *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 1e39756d47..18c3a3ec9c 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -964,7 +964,8 @@ let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = compare_instances = infer_convert_instances; compare_cumul_instances = infer_inductive_instances; } -let gen_conv cv_pb l2r reds env evars univs t1 t2 = +let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _ -> None)) t1 t2 = + let univs = Environ.universes env in let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 @@ -974,16 +975,7 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = let _ = clos_gen_conv reds cv_pb l2r evars env univs (univs, checked_universes) t1 t2 in () -(* Profiling *) -let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _->None)) = - let univs = Environ.universes env in - if Flags.profile then - let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in - CProfile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs - else gen_conv cv_pb l2r reds env evars univs - let conv = gen_conv CONV - let conv_leq = gen_conv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = @@ -992,7 +984,7 @@ let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = clos_gen_conv reds cv_pb l2r evars env graph univs t1 t2 in s -let infer_conv_universes cv_pb l2r evars reds env t1 t2 = +let infer_conv_universes cv_pb ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env t1 t2 = let univs = Environ.universes env in let b, cstrs = if cv_pb == CUMUL then Constr.leq_constr_univs_infer univs t1 t2 @@ -1001,37 +993,16 @@ let infer_conv_universes cv_pb l2r evars reds env t1 t2 = if b then cstrs else let state = ((univs, Univ.Constraint.empty), inferred_universes) in - let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs state t1 t2 in + let ((_,cstrs), _) = clos_gen_conv ts cv_pb l2r evars env univs state t1 t2 in cstrs -(* Profiling *) -let infer_conv_universes = - if Flags.profile then - let infer_conv_universes_key = CProfile.declare_profile "infer_conv_universes" in - CProfile.profile7 infer_conv_universes_key infer_conv_universes - else infer_conv_universes - -let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) - env t1 t2 = - infer_conv_universes CONV l2r evars ts env t1 t2 - -let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) - env t1 t2 = - infer_conv_universes CUMUL l2r evars ts env t1 t2 +let infer_conv = infer_conv_universes CONV +let infer_conv_leq = infer_conv_universes CUMUL let default_conv cv_pb ?l2r:_ env t1 t2 = gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL -(* -let convleqkey = CProfile.declare_profile "Kernel_reduction.conv_leq";; -let conv_leq env t1 t2 = - CProfile.profile4 convleqkey conv_leq env t1 t2;; - -let convkey = CProfile.declare_profile "Kernel_reduction.conv";; -let conv env t1 t2 = - CProfile.profile4 convleqkey conv env t1 t2;; -*) (* Application with on-the-fly reduction *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 741491c917..3a946fc03a 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -644,12 +644,6 @@ let infer env constr = let constr, t = execute env constr in make_judge constr t -let infer = - if Flags.profile then - let infer_key = CProfile.declare_profile "Fast_infer" in - CProfile.profile2 infer_key (fun b c -> infer b c) - else (fun b c -> infer b c) - let assumption_of_judgment env {uj_val=c; uj_type=t} = infer_assumption env c t @@ -785,15 +779,16 @@ let type_of_prim env u t = | PITT_type (ty,t) -> tr_prim_type (tr_type n) ty t | PITT_param i -> Constr.mkRel (n+i) in - let rec nary_op n = function - | [] -> assert false - | [ret_ty] -> tr_type n ret_ty + let rec nary_op n ret_ty = function + | [] -> tr_type n ret_ty | arg_ty :: r -> - Constr.mkProd(Context.nameR (Id.of_string "x"), tr_type n arg_ty, nary_op (n+1) r) + Constr.mkProd (Context.nameR (Id.of_string "x"), + tr_type n arg_ty, nary_op (n + 1) ret_ty r) in - let params, sign = types t in + let params, args_ty, ret_ty = types t in assert (AUContext.size (univs t) = Instance.length u); - Vars.subst_instance_constr u (Term.it_mkProd_or_LetIn (nary_op 0 sign) params) + Vars.subst_instance_constr u + (Term.it_mkProd_or_LetIn (nary_op 0 ret_ty args_ty) params) let type_of_prim_or_type env u = let open CPrimitives in function diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index b988ec40a7..6db54a3bb6 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -251,28 +251,3 @@ type node = G.node = let repr g = G.repr g.graph let pr_universes prl g = pr_pmap Pp.mt (pr_arc prl) g - -(** Profiling *) - -let merge_constraints = - if Flags.profile then - let key = CProfile.declare_profile "merge_constraints" in - CProfile.profile2 key merge_constraints - else merge_constraints -let check_constraints = - if Flags.profile then - let key = CProfile.declare_profile "check_constraints" in - CProfile.profile2 key check_constraints - else check_constraints - -let check_eq = - if Flags.profile then - let check_eq_key = CProfile.declare_profile "check_eq" in - CProfile.profile3 check_eq_key check_eq - else check_eq - -let check_leq = - if Flags.profile then - let check_leq_key = CProfile.declare_profile "check_leq" in - CProfile.profile3 check_leq_key check_leq - else check_leq diff --git a/kernel/univ.ml b/kernel/univ.ml index a2fd14025e..c2496f10b0 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -38,20 +38,22 @@ struct open Names module UGlobal = struct - type t = DirPath.t * int + type t = DirPath.t * string * int - let make dp i = (DirPath.hcons dp,i) + let make dp s i = (DirPath.hcons dp,s,i) let repr x : t = x - let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' + let equal (d, s, i) (d', s', i') = Int.equal i i' && DirPath.equal d d' && String.equal s s' - let hash (d,i) = Hashset.Combine.combine i (DirPath.hash d) + let hash (d,s,i) = Hashset.Combine.combine3 i (String.hash s) (DirPath.hash d) - let compare (d, i) (d', i') = - let c = Int.compare i i' in - if Int.equal c 0 then DirPath.compare d d' - else c + let compare (d, s, i) (d', s', i') = + if i < i' then -1 + else if i' < i then 1 + else let c = DirPath.compare d d' in + if not (Int.equal c 0) then c + else String.compare s s' end type t = @@ -84,10 +86,7 @@ struct | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 - | Level (dp1, i1), Level (dp2, i2) -> - if i1 < i2 then -1 - else if i1 > i2 then 1 - else DirPath.compare dp1 dp2 + | Level l1, Level l2 -> UGlobal.compare l1 l2 | Level _, _ -> -1 | _, Level _ -> 1 | Var n, Var m -> Int.compare n m @@ -98,8 +97,8 @@ struct | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true - | Level (n,d), Level (n',d') -> - n == n' && d == d' + | Level (d,s,n), Level (d',s',n') -> + n == n' && s==s' && d == d' | Var n, Var n' -> n == n' | _ -> false @@ -107,9 +106,10 @@ struct | SProp as x -> x | Prop as x -> x | Set as x -> x - | Level (d,n) as x -> + | Level (d,s,n) as x -> + let s' = CString.hcons s in let d' = Names.DirPath.hcons d in - if d' == d then x else Level (d',n) + if s' == s && d' == d then x else Level (d',s',n) | Var _n as x -> x open Hashset.Combine @@ -119,7 +119,7 @@ struct | Prop -> combinesmall 1 1 | Set -> combinesmall 1 2 | Var n -> combinesmall 2 n - | Level (d, n) -> combinesmall 3 (combine n (Names.DirPath.hash d)) + | Level l -> combinesmall 3 (UGlobal.hash l) end @@ -200,7 +200,10 @@ module Level = struct | SProp -> "SProp" | Prop -> "Prop" | Set -> "Set" - | Level (d,n) -> Names.DirPath.to_string d^"."^string_of_int n + | Level (d,s,n) -> + Names.DirPath.to_string d ^ + (if CString.is_empty s then "" else "." ^ s) ^ + "." ^ string_of_int n | Var n -> "Var(" ^ string_of_int n ^ ")" let pr u = str (to_string u) @@ -218,7 +221,7 @@ module Level = struct let name u = match data u with - | Level (d, n) -> Some (d, n) + | Level l -> Some l | _ -> None end diff --git a/kernel/univ.mli b/kernel/univ.mli index 7286fc84cb..eeaa1ad62d 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -15,8 +15,8 @@ sig module UGlobal : sig type t - val make : Names.DirPath.t -> int -> t - val repr : t -> Names.DirPath.t * int + val make : Names.DirPath.t -> string -> int -> t + val repr : t -> Names.DirPath.t * string * int val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int diff --git a/kernel/vars.ml b/kernel/vars.ml index b09577d4db..b9991391c2 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -123,11 +123,6 @@ let substn_many lamv n c = | _ -> Constr.map_with_binders succ substrec depth c in substrec n c -(* -let substkey = CProfile.declare_profile "substn_many";; -let substn_many lamv n c = CProfile.profile3 substkey substn_many lamv n c;; -*) - let make_subst = function | [] -> [||] | hd :: tl -> @@ -343,9 +338,6 @@ let univ_instantiate_constr u c = assert (Int.equal (Instance.length u) (AUContext.size c.univ_abstracted_binder)); subst_instance_constr u c.univ_abstracted_value -(* let substkey = CProfile.declare_profile "subst_instance_constr";; *) -(* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) - let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else Context.Rel.map (fun x -> subst_instance_constr s x) ctx diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index c2b087f061..b5604d0593 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -35,6 +35,7 @@ type instruction = | Kpush | Kpop of int | Kpush_retaddr of Label.t + | Kshort_apply of int | Kapply of int | Kappterm of int * int | Kreturn of int @@ -93,6 +94,7 @@ let rec pp_instr i = | Kpush -> str "push" | Kpop n -> str "pop " ++ int n | Kpush_retaddr lbl -> str "push_retaddr " ++ pp_lbl lbl + | Kshort_apply n -> str "short_apply " ++ int n | Kapply n -> str "apply " ++ int n | Kappterm(n, m) -> str "appterm " ++ int n ++ str ", " ++ int m @@ -146,8 +148,8 @@ let rec pp_instr i = (Constant.print (fst id)) | Kcamlprim (op, lbl) -> - str "camlcall " ++ str (CPrimitives.to_string op) ++ spc () ++ - pp_lbl lbl + str "camlcall " ++ str (CPrimitives.to_string op) ++ str ", branch " ++ + pp_lbl lbl ++ str " on accu" and pp_bytecodes c = match c with diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index eeca0d2ad1..d9e2d91177 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -30,6 +30,7 @@ type instruction = | Kpush (** sp = accu :: sp *) | Kpop of int (** sp = skipn n sp *) | Kpush_retaddr of Label.t (** sp = pc :: coq_env :: coq_extra_args :: sp ; coq_extra_args = 0 *) + | Kshort_apply of int (** number of arguments (arguments on top of stack) *) | Kapply of int (** number of arguments (arguments on top of stack) *) | Kappterm of int * int (** number of arguments, slot size *) | Kreturn of int (** slot size *) diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 7d3b3469b0..b4d97228bf 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -461,7 +461,7 @@ let comp_app comp_fun comp_arg cenv f args sz cont = | None -> if nargs <= 4 then comp_args comp_arg cenv args sz - (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) + (Kpush :: (comp_fun cenv f (sz+nargs) (Kshort_apply nargs :: cont))) else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: @@ -757,26 +757,25 @@ let rec compile_lam env cenv lam sz cont = let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args (compile_lam env) cenv args sz cont - | Lprim ((kn,u), op, args) when is_caml_prim op -> + | Lprim (kn, op, args) when is_caml_prim op -> let arity = CPrimitives.arity op in let nparams = CPrimitives.nparams op in let nargs = arity - nparams in - assert (arity = Array.length args && arity <= 4); + assert (arity = Array.length args && arity <= 4 && nargs >= 1); let (jump, cont) = make_branch cont in let lbl_default = Label.create () in let default = - let cont = [Kgetglobal kn; Kapply (arity + Univ.Instance.length u); jump] in + let cont = [Kshort_apply arity; jump] in + let cont = Kpush :: compile_get_global cenv kn (sz + arity) cont in let cont = - if Univ.Instance.is_empty u then cont - else comp_args compile_universe cenv (Univ.Instance.to_array u) (sz + arity) (Kpush::cont) - in - Klabel lbl_default :: - Kpush :: - if Int.equal nparams 0 then cont - else comp_args (compile_lam env) cenv (Array.sub args 0 nparams) (sz + nargs) (Kpush::cont) - in + if Int.equal nparams 0 then cont + else + let params = Array.sub args 0 nparams in + Kpush :: comp_args (compile_lam env) cenv params (sz + nargs) cont in + Klabel lbl_default :: cont in fun_code := Ksequence default :: !fun_code; - comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz (Kcamlprim (op, lbl_default) :: cont) + let cont = Kcamlprim (op, lbl_default) :: cont in + comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz cont | Lprim (kn, op, args) -> comp_args (compile_lam env) cenv args sz (Kprim(op, kn)::cont) diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index caa263432e..44e933ef26 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -300,8 +300,11 @@ let emit_instr env = function out env opPOP; out_int env n | Kpush_retaddr lbl -> out env opPUSH_RETADDR; out_label env lbl + | Kshort_apply n -> + assert (1 <= n && n <= 4); + out env(opAPPLY1 + n - 1) | Kapply n -> - if n <= 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) + out env opAPPLY; out_int env n | Kappterm(n, sz) -> if n < 4 then (out env(opAPPTERM1 + n - 1); out_int env sz) else (out env opAPPTERM; out_int env n; out_int env sz) diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index e353348ac7..ee32384ec9 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -494,10 +494,6 @@ let makeblock tag nparams arity args = else Lmakeblock(tag, args) let makearray args def = - try - let p = Array.map get_value args in - Lval (val_of_parray @@ Parray.unsafe_of_array p (get_value def)) - with Not_found -> let ar = Lmakeblock(0, args) in (* build the ocaml array *) let kind = Lmakeblock(0, [|ar; def|]) in (* Parray.Array *) Lmakeblock(0,[|kind|]) (* the reference *) diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 9944458d6b..938d1f28f7 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -459,8 +459,6 @@ let val_of_int i = (Obj.magic i : values) let val_of_uint i = (Obj.magic i : structured_values) -let val_of_parray p = (Obj.magic p : structured_values) - let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in Obj.set_field r 0 (Obj.repr kn); diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index d15595766a..534a85d773 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -148,7 +148,6 @@ val val_of_atom : atom -> values val val_of_int : int -> structured_values val val_of_block : tag -> structured_values array -> structured_values val val_of_uint : Uint63.t -> structured_values -val val_of_parray : structured_values Parray.t -> structured_values external val_of_annot_switch : annot_switch -> values = "%identity" external val_of_proj_name : Projection.Repr.t -> values = "%identity" diff --git a/lib/cProfile.ml b/lib/cProfile.ml index b68d35d2d4..7245b35d59 100644 --- a/lib/cProfile.ml +++ b/lib/cProfile.ml @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +let enable_profile = false + let word_length = Sys.word_size / 8 let float_of_time t = float_of_int t /. 100. @@ -87,9 +89,9 @@ let init_alloc = ref 0.0 let reset_profile () = List.iter reset_record !prof_table let init_profile () = - (* We test Flags.profile as a way to support declaring profiled + (* We test enable_profile as a way to support declaring profiled functions in plugins *) - if !prof_table <> [] || Flags.profile then begin + if !prof_table <> [] || enable_profile then begin let outside = create_record () in stack := [outside]; last_alloc := get_alloc (); diff --git a/lib/flags.ml b/lib/flags.ml index 57e879add7..c87a375356 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -51,8 +51,6 @@ let xml_debug = ref false let in_debugger = ref false let in_toplevel = ref false -let profile = false - let raw_print = ref false let we_are_parsing = ref false diff --git a/lib/flags.mli b/lib/flags.mli index e10e2c8cb8..2f59a0cc18 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -44,8 +44,6 @@ val xml_debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref -val profile : bool - (* development flag to detect race conditions, it should go away. *) val we_are_parsing : bool ref diff --git a/lib/future.ml b/lib/future.ml index 23d089fb6b..247b139798 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -112,8 +112,8 @@ let create_delegate ?(blocking=true) ~name fix_exn = if not blocking then (fun () -> raise (NotReady name)), ignore else let lock = Mutex.create () in let cond = Condition.create () in - (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock), - (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in + (fun () -> CThread.with_lock lock ~scope:(fun () -> Condition.wait cond lock)), + (fun () -> CThread.with_lock lock ~scope:(fun () -> Condition.broadcast cond)) in let ck = create ~name ~fix_exn (Delegated wait) in ck, assignment signal ck diff --git a/lib/pp.mli b/lib/pp.mli index b3c2301d34..865f97166f 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -171,7 +171,7 @@ val prvecti_with_sep : val pr_enum : ('a -> t) -> 'a list -> t (** [pr_enum pr [a ; b ; ... ; c]] outputs - [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *) + [pr a ++ str "," ++ spc () ++ pr b ++ str "," ++ spc () ++ ... ++ str "and" ++ spc () ++ pr c]. *) val pr_sequence : ('a -> t) -> 'a list -> t (** Sequence of objects separated by space (unless an element is empty). *) @@ -188,7 +188,6 @@ val pp_with : Format.formatter -> t -> unit val string_of_ppcmds : t -> string - (** Tag prefix to start a multi-token diff span *) val start_pfx : string diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml deleted file mode 100644 index 5e1150146e..0000000000 --- a/lib/remoteCounter.ml +++ /dev/null @@ -1,52 +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) *) -(************************************************************************) - -type 'a getter = unit -> 'a -type 'a installer = ('a getter) -> unit - -type remote_counters_status = (string * Obj.t) list - -let counters : remote_counters_status ref = ref [] - -let (!!) x = !(!x) - -let new_counter ~name a ~incr ~build = - assert(not (List.mem_assoc name !counters)); - let data = ref (ref a) in - counters := (name, Obj.repr data) :: !counters; - let m = Mutex.create () in - let mk_thsafe_local_getter f () = - (* - slaves must use a remote counter getter, not this one! *) - (* - in the main process there is a race condition between slave - managers (that are threads) and the main thread, hence the mutex *) - if Flags.async_proofs_is_worker () then - CErrors.anomaly(Pp.str"Slave processes must install remote counters."); - Mutex.lock m; let x = f () in Mutex.unlock m; - build x in - let mk_thsafe_remote_getter f () = - Mutex.lock m; let x = f () in Mutex.unlock m; x in - let getter = ref(mk_thsafe_local_getter (fun () -> !data := incr !!data; !!data)) in - let installer f = - if not (Flags.async_proofs_is_worker ()) then - CErrors.anomaly(Pp.str"Only slave processes can install a remote counter."); - getter := mk_thsafe_remote_getter f in - (fun () -> !getter ()), installer - -let backup () = !counters - -let snapshot () = - List.map (fun (n,v) -> n, Obj.repr (ref (ref !!(Obj.obj v)))) !counters - -let restore l = - List.iter (fun (name, data) -> - assert(List.mem_assoc name !counters); - let dataref = Obj.obj (List.assoc name !counters) in - !dataref := !!(Obj.obj data)) - l diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli deleted file mode 100644 index 42d1f8a8d1..0000000000 --- a/lib/remoteCounter.mli +++ /dev/null @@ -1,31 +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) *) -(************************************************************************) - -(* Remote counters are *global* counters for fresh ids. In the master/slave - * scenario, the slave installs a getter that asks the master for a fresh - * value. In the scenario of a slave that runs after the death of the master - * on some marshalled data, a backup of all counters status should be taken and - * restored to avoid reusing ids. - * Counters cannot be created by threads, they must be created once and forall - * as toplevel module declarations. *) - - -type 'a getter = unit -> 'a -type 'a installer = ('a getter) -> unit - -val new_counter : name:string -> - 'a -> incr:('a -> 'a) -> build:('a -> 'b) -> 'b getter * 'b installer - -type remote_counters_status -val backup : unit -> remote_counters_status -(* like backup but makes a copy so that further increment does not alter - * the snapshot *) -val snapshot : unit -> remote_counters_status -val restore : remote_counters_status -> unit diff --git a/library/globnames.ml b/library/globnames.ml index 654349dea0..491c89e68e 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -31,10 +31,6 @@ let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" -let subst_constructor subst (ind,j as ref) = - let ind' = subst_ind subst ind in - if ind==ind' then ref - else (ind',j) let subst_global_reference subst ref = match ref with | VarRef var -> ref diff --git a/library/globnames.mli b/library/globnames.mli index 8acea5ef28..58e0efbc7a 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -34,7 +34,6 @@ val destConstructRef : GlobRef.t -> constructor val is_global : GlobRef.t -> constr -> bool [@@ocaml.deprecated "Use [Constr.isRefX] instead."] -val subst_constructor : substitution -> constructor -> constructor val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr Univ.univ_abstracted option val subst_global_reference : substitution -> GlobRef.t -> GlobRef.t diff --git a/library/lib.ml b/library/lib.ml index fa0a95d366..3172511c26 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -280,7 +280,7 @@ let start_mod is_type export id mp fs = else Nametab.exists_dir dir in if exists then - user_err ~hdr:"open_module" (Id.print id ++ str " already exists"); + user_err ~hdr:"open_module" (Id.print id ++ str " already exists."); add_entry (make_foname id) (OpenedModule (is_type,export,prefix,fs)); lib_state := { !lib_state with path_prefix = prefix} ; prefix diff --git a/man/coqdep.1 b/man/coqdep.1 index b0d9606969..5ca558b7c5 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -1,7 +1,7 @@ .TH COQ 1 .SH NAME -coqdep \- Compute inter-module dependencies for Coq and Caml programs +coqdep \- Compute inter-module dependencies for Coq programs .SH SYNOPSIS .B coqdep @@ -23,7 +23,7 @@ coqdep \- Compute inter-module dependencies for Coq and Caml programs .SH DESCRIPTION .B coqdep -compute inter-module dependencies for Coq and Caml programs, +compute inter-module dependencies for Coq programs, and prints the dependencies on the standard output in a format readable by make. When a directory is given as argument, it is recursively looked at. @@ -41,11 +41,6 @@ printed except if .BR \-boot \& is given. -Dependencies of Caml modules are computed by looking at -.IR open \& -directives and the dot notation -.IR module.value \&. - .SH OPTIONS .TP @@ -75,6 +70,21 @@ Output dependencies for .vos files (this is not the default as it breaks dune's .B \-boot For coq developers, prints dependencies over coq library files (omitted by default). +.TP +.B \-noinit +Currently no effect. + + +.SH EXIT STATUS +.IP "1" +A file given on the command line cannot be found or some file +cannot be opened. +.IP "0" +In all other cases. In particular, when a dependency cannot be +found or an invalid option is encountered, +.B coqdep +prints a warning and exits with status +.B 0\fR. .SH SEE ALSO diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0cad192332..30f90dd1fc 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -22,7 +22,6 @@ open Reductionops open Inductive open Termops open Inductiveops -open Recordops open Namegen open Miniml open Table @@ -428,6 +427,7 @@ and extract_really_ind env kn mib = (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) let mip0 = mib.mind_packets.(0) in + let ndecls = List.length mib.mind_params_ctxt in let npar = mib.mind_nparams in let epar = push_rel_context mib.mind_params_ctxt env in let sg = Evd.from_env env in @@ -463,17 +463,17 @@ and extract_really_ind env kn mib = if not p.ip_logical then let types = arities_of_constructors env ((kn,i),u) in for j = 0 to Array.length types - 1 do - let t = snd (decompose_prod_n npar types.(j)) in + let t = snd (decompose_prod_n_assum ndecls types.(j)) in let prods,head = dest_prod epar t in let nprods = List.length prods in let args = match Constr.kind head with | App (f,args) -> args (* [Constr.kind f = Ind ip] *) | _ -> [||] in - let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in - let db = db_from_ind dbmap npar in + let dbmap = parse_ind_args p.ip_sign args (nprods + ndecls) in + let db = db_from_ind dbmap ndecls in p.ip_types.(j) <- - extract_type_cons epar sg db dbmap (EConstr.of_constr t) (npar+1) + extract_type_cons epar sg db dbmap (EConstr.of_constr t) (ndecls+1) done done; (* Third pass: we determine special cases. *) @@ -531,7 +531,7 @@ and extract_really_ind env kn mib = let n = nb_default_params env sg (EConstr.of_constr ty) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip in - List.iter (Option.iter check_proj) (lookup_projections ip) + List.iter (Option.iter check_proj) (Structures.Structure.find_projections ip) with Not_found -> () end; Record field_glob @@ -1129,7 +1129,7 @@ let extract_constant env kn cb = (match cb.const_body with | Primitive _ | Undef _ -> warn_info (); mk_typ_ax () | Def c -> - (match Recordops.find_primitive_projection kn with + (match Structures.PrimitiveProjections.find_opt kn with | None -> mk_typ (get_body c) | Some p -> let body = fake_match_projection env p in @@ -1142,7 +1142,7 @@ let extract_constant env kn cb = (match cb.const_body with | Primitive _ | Undef _ -> warn_info (); mk_ax () | Def c -> - (match Recordops.find_primitive_projection kn with + (match Structures.PrimitiveProjections.find_opt kn with | None -> mk_def (get_body c) | Some p -> let body = fake_match_projection env p in diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index cfdaac710b..268d4bf9e9 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1525,8 +1525,7 @@ let inline_test r t = else let c = match r with GlobRef.ConstRef c -> c | _ -> assert false in let has_body = - try constant_has_body (Global.lookup_constant c) - with Not_found -> false + Environ.mem_constant c (Global.env()) && constant_has_body (Global.lookup_constant c) in has_body && (let t1 = eta_red t in diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index cbdebb7bbc..6236a5147d 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -2058,13 +2058,12 @@ let make_graph (f_ref : GlobRef.t) = let sigma = Evd.from_env env in let c, c_body = match f_ref with - | GlobRef.ConstRef c -> ( - try (c, Global.lookup_constant c) - with Not_found -> + | GlobRef.ConstRef c -> + if Environ.mem_constant c (Global.env ()) then (c, Global.lookup_constant c) else CErrors.user_err Pp.( str "Cannot find " - ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) ) + ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) | _ -> CErrors.user_err Pp.(str "Not a function reference") in match Global.body_of_constant_body Library.indirect_accessor c_body with diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index c7bda43465..1640bff43b 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -373,11 +373,6 @@ end) = struct end -(* let my_type_of env evars c = Typing.e_type_of env evars c *) -(* let mytypeofkey = CProfile.declare_profile "my_type_of";; *) -(* let my_type_of = CProfile.profile3 mytypeofkey my_type_of *) - - let type_app_poly env env evd f args = let evars, c = app_poly_nocheck env evd f args in let evd', t = Typing.type_of env (goalevars evars) c in @@ -2066,9 +2061,6 @@ let get_hyp gl (c,l) clause l2r = let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } -(* let rewriteclaustac_key = CProfile.declare_profile "cl_rewrite_clause_tac";; *) -(* let cl_rewrite_clause_tac = CProfile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) - (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 5e88bf7c79..f2f5fc16a6 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -91,6 +91,13 @@ let to_int v = Some (out_gen (topwit wit_int) v) else None +let of_ident id = in_gen (topwit wit_ident) id + +let to_ident v = + if has_type v (topwit wit_ident) then + Some (out_gen (topwit wit_ident) v) + else None + let to_list v = prj Val.typ_list v let to_option v = prj Val.typ_opt v diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 8ca2510459..c748fb3d1a 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -39,6 +39,8 @@ sig val to_uconstr : t -> Ltac_pretype.closed_glob_constr option val of_int : int -> t val to_int : t -> int option + val of_ident : Id.t -> t + val to_ident : t -> Id.t option val to_list : t -> t list option val to_option : t -> t option option val to_pair : t -> (t * t) option diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 53aa619d10..1018271751 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -449,6 +449,8 @@ let bound_monomials (sys : WithProof.t list) = in List.map snd (List.filter has_mon bounds) @ snd l +let bound_monomials = tr_sys "bound_monomials" bound_monomials + let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth; @@ -1181,10 +1183,12 @@ let nlia enum prfdepth sys = It would only be safe if the variable is linear... *) let sys1 = - elim_simple_linear_equality (WithProof.subst_constant true sys) + normalise + (elim_simple_linear_equality (WithProof.subst_constant true sys)) in + let bnd1 = bound_monomials sys1 in let sys2 = saturate_by_linear_equalities sys1 in - let sys3 = nlinear_preprocess (sys1 @ sys2) in + let sys3 = nlinear_preprocess (rev_concat [bnd1; sys1; sys2]) in let sys4 = make_cstr_system (*sys2@*) sys3 in (* [reduction_equations] is too brutal - there should be some non-linear reasoning *) xlia (List.map fst sys) enum reduction_equations sys4 diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 74b0708743..d18065088c 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -24,17 +24,17 @@ let warn_deprecated_Spec = DECLARE PLUGIN "zify_plugin" VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF -| ["Add" "Zify" "InjTyp" constr(t) ] -> { Zify.InjTable.register t } -| ["Add" "Zify" "BinOp" constr(t) ] -> { Zify.BinOp.register t } -| ["Add" "Zify" "UnOp" constr(t) ] -> { Zify.UnOp.register t } -| ["Add" "Zify" "CstOp" constr(t) ] -> { Zify.CstOp.register t } -| ["Add" "Zify" "BinRel" constr(t) ] -> { Zify.BinRel.register t } -| ["Add" "Zify" "PropOp" constr(t) ] -> { Zify.PropBinOp.register t } -| ["Add" "Zify" "PropBinOp" constr(t) ] -> { Zify.PropBinOp.register t } -| ["Add" "Zify" "PropUOp" constr(t) ] -> { Zify.PropUnOp.register t } -| ["Add" "Zify" "BinOpSpec" constr(t) ] -> { Zify.BinOpSpec.register t } -| ["Add" "Zify" "UnOpSpec" constr(t) ] -> { Zify.UnOpSpec.register t } -| ["Add" "Zify" "Saturate" constr(t) ] -> { Zify.Saturate.register t } +| ["Add" "Zify" "InjTyp" reference(t) ] -> { Zify.InjTable.register t } +| ["Add" "Zify" "BinOp" reference(t) ] -> { Zify.BinOp.register t } +| ["Add" "Zify" "UnOp" reference(t) ] -> { Zify.UnOp.register t } +| ["Add" "Zify" "CstOp" reference(t) ] -> { Zify.CstOp.register t } +| ["Add" "Zify" "BinRel" reference(t) ] -> { Zify.BinRel.register t } +| ["Add" "Zify" "PropOp" reference(t) ] -> { Zify.PropBinOp.register t } +| ["Add" "Zify" "PropBinOp" reference(t) ] -> { Zify.PropBinOp.register t } +| ["Add" "Zify" "PropUOp" reference(t) ] -> { Zify.PropUnOp.register t } +| ["Add" "Zify" "BinOpSpec" reference(t) ] -> { Zify.BinOpSpec.register t } +| ["Add" "Zify" "UnOpSpec" reference(t) ] -> { Zify.UnOpSpec.register t } +| ["Add" "Zify" "Saturate" reference(t) ] -> { Zify.Saturate.register t } END TACTIC EXTEND ITER diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 61966b60c0..3ea7408067 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -23,6 +23,19 @@ let zify str = (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref ("ZifyClasses." ^ str))) +(** classes *) +let coq_InjTyp = lazy (Coqlib.lib_ref "ZifyClasses.InjTyp") + +let coq_BinOp = lazy (Coqlib.lib_ref "ZifyClasses.BinOp") +let coq_UnOp = lazy (Coqlib.lib_ref "ZifyClasses.UnOp") +let coq_CstOp = lazy (Coqlib.lib_ref "ZifyClasses.CstOp") +let coq_BinRel = lazy (Coqlib.lib_ref "ZifyClasses.BinRel") +let coq_PropBinOp = lazy (Coqlib.lib_ref "ZifyClasses.PropBinOp") +let coq_PropUOp = lazy (Coqlib.lib_ref "ZifyClasses.PropUOp") +let coq_BinOpSpec = lazy (Coqlib.lib_ref "ZifyClasses.BinOpSpec") +let coq_UnOpSpec = lazy (Coqlib.lib_ref "ZifyClasses.UnOpSpec") +let coq_Saturate = lazy (Coqlib.lib_ref "ZifyClasses.Saturate") + (* morphism like lemma *) let mkapp2 = lazy (zify "mkapp2") @@ -33,6 +46,7 @@ let mkrel = lazy (zify "mkrel") let iff_refl = lazy (zify "iff_refl") let eq_iff = lazy (zify "eq_iff") let rew_iff = lazy (zify "rew_iff") +let rew_iff_rev = lazy (zify "rew_iff_rev") (* propositional logic *) @@ -46,7 +60,7 @@ let op_iff_morph = lazy (zify "iff_morph") let op_not = lazy (zify "not") let op_not_morph = lazy (zify "not_morph") let op_True = lazy (zify "True") -let whd = Reductionops.clos_whd_flags CClosure.all +let op_I = lazy (zify "I") (** [unsafe_to_constr c] returns a [Constr.t] without considering an evar_map. This is useful for calling Constr.hash *) @@ -59,6 +73,7 @@ let gl_pr_constr e = let evd = Evd.from_env genv in pr_constr genv evd e +let whd = Reductionops.clos_whd_flags CClosure.all let is_convertible env evd t1 t2 = Reductionops.(is_conv env evd t1 t2) (** [get_type_of] performs beta reduction ; @@ -66,14 +81,36 @@ let is_convertible env evd t1 t2 = Reductionops.(is_conv env evd t1 t2) let get_type_of env evd e = Tacred.cbv_beta env evd (Retyping.get_type_of env evd e) +(* arguments are dealt with in a second step *) + let rec find_option pred l = match l with | [] -> raise Not_found | e :: l -> ( match pred e with Some r -> r | None -> find_option pred l ) -(** [HConstr] is a map indexed by EConstr.t. - It should only be used using closed terms. - *) +module ConstrMap = struct + open Names.GlobRef + + type 'a t = 'a list Map.t + + let add gr e m = + Map.update gr (function None -> Some [e] | Some l -> Some (e :: l)) m + + let empty = Map.empty + + let find evd h m = + match Map.find (fst (EConstr.destRef evd h)) m with + | e :: _ -> e + | [] -> assert false + + let find_all evd h m = Map.find (fst (EConstr.destRef evd h)) m + + let fold f m acc = + Map.fold + (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) + m acc +end + module HConstr = struct module M = Map.Make (struct type t = EConstr.t @@ -81,20 +118,11 @@ module HConstr = struct let compare c c' = Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') end) - type 'a t = 'a list M.t - - let lfind h m = try M.find h m with Not_found -> [] - - let add h e m = - let l = lfind h m in - M.add h (e :: l) m + type 'a t = 'a M.t + let add h e m = M.add h e m let empty = M.empty - let find h m = match lfind h m with e :: _ -> e | [] -> raise Not_found - let find_all = lfind - - let fold f m acc = - M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc + let find = M.find end (** [get_projections_from_constant (evd,c) ] @@ -331,7 +359,8 @@ module type Elt = sig (** name *) val name : string - val table : (term_kind * decl_kind) HConstr.t ref + val gref : GlobRef.t Lazy.t + val table : (term_kind * decl_kind) ConstrMap.t ref val cast : elt decl -> decl_kind val dest : decl_kind -> elt decl option @@ -346,12 +375,12 @@ module type Elt = sig (* val arity : int*) end -let table = Summary.ref ~name:"zify_table" HConstr.empty -let saturate = Summary.ref ~name:"zify_saturate" HConstr.empty -let specs = Summary.ref ~name:"zify_specs" HConstr.empty -let table_cache = ref HConstr.empty -let saturate_cache = ref HConstr.empty -let specs_cache = ref HConstr.empty +let table = Summary.ref ~name:"zify_table" ConstrMap.empty +let saturate = Summary.ref ~name:"zify_saturate" ConstrMap.empty +let specs = Summary.ref ~name:"zify_specs" ConstrMap.empty +let table_cache = ref ConstrMap.empty +let saturate_cache = ref ConstrMap.empty +let specs_cache = ref ConstrMap.empty (** Each type-class gives rise to a different table. They only differ on how projections are extracted. *) @@ -362,6 +391,7 @@ module EInj = struct type elt = EInjT.t let name = "EInj" + let gref = coq_InjTyp let table = table let cast x = InjTyp x let dest = function InjTyp x -> Some x | _ -> None @@ -419,6 +449,7 @@ module EBinOp = struct open EBinOpT let name = "BinOp" + let gref = coq_BinOp let table = table let mk_elt evd i a = @@ -460,6 +491,7 @@ module ECstOp = struct open ECstOpT let name = "CstOp" + let gref = coq_CstOp let table = table let cast x = CstOp x let dest = function CstOp x -> Some x | _ -> None @@ -486,6 +518,7 @@ module EUnOp = struct open EUnOpT let name = "UnOp" + let gref = coq_UnOp let table = table let cast x = UnOp x let dest = function UnOp x -> Some x | _ -> None @@ -518,6 +551,7 @@ module EBinRel = struct open EBinRelT let name = "BinRel" + let gref = coq_BinRel let table = table let cast x = BinRel x let dest = function BinRel x -> Some x | _ -> None @@ -544,6 +578,7 @@ module EPropBinOp = struct open EPropBinOpT let name = "PropBinOp" + let gref = coq_PropBinOp let table = table let cast x = PropOp x let dest = function PropOp x -> Some x | _ -> None @@ -556,7 +591,8 @@ module EPropUnOp = struct open EPropUnOpT - let name = "PropUnOp" + let name = "PropUOp" + let gref = coq_PropUOp let table = table let cast x = PropUnOp x let dest = function PropUnOp x -> Some x | _ -> None @@ -567,7 +603,7 @@ end let constr_of_term_kind = function Application c -> c | OtherTerm c -> c module type S = sig - val register : Constrexpr.constr_expr -> unit + val register : Libnames.qualid -> unit val print : unit -> unit end @@ -586,17 +622,26 @@ module MakeTable (E : Elt) = struct failwith ("Cannot register term " ^ t) | Some a -> E.mk_elt evd i a + let safe_ref evd c = + try + fst (EConstr.destRef evd c) + with DestKO -> CErrors.user_err Pp.(str "Add Zify "++str E.name ++ str ": the term "++ + gl_pr_constr c ++ str " should be a global reference") + let register_hint evd t elt = match EConstr.kind evd t with | App (c, _) -> - E.table := HConstr.add c (Application t, E.cast elt) !E.table - | _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table + let gr = safe_ref evd c in + E.table := ConstrMap.add gr (Application t, E.cast elt) !E.table + | _ -> + let gr = safe_ref evd t in + E.table := ConstrMap.add gr (OtherTerm t, E.cast elt) !E.table let register_constr env evd c = let c = EConstr.of_constr c in let t = get_type_of env evd c in match EConstr.kind evd t with - | App (intyp, args) -> + | App (intyp, args) when EConstr.isRefX evd (Lazy.force E.gref) intyp -> let styp = args.(E.get_key) in let elt = {decl = c; deriv = make_elt (evd, c)} in register_hint evd styp elt @@ -605,10 +650,11 @@ module MakeTable (E : Elt) = struct raise (CErrors.user_err Pp.( - str ": Cannot register term " - ++ pr_constr env evd c ++ str ". It has type " - ++ pr_constr env evd t - ++ str " which should be of the form [F X1 .. Xn]")) + str "Cannot register " ++ pr_constr env evd c + ++ str ". It has type " ++ pr_constr env evd t + ++ str " instead of type " + ++ Printer.pr_global (Lazy.force E.gref) + ++ str " X1 ... Xn")) let register_obj : Constr.constr -> Libobject.obj = let cache_constr (_, c) = @@ -622,22 +668,24 @@ module MakeTable (E : Elt) = struct ("register-zify-" ^ E.name) ~cache:cache_constr ~subst:(Some subst_constr) - (** [register c] is called from the VERNACULAR ADD [name] constr(t). + (** [register c] is called from the VERNACULAR ADD [name] reference(t). The term [c] is interpreted and registered as a [superglobal_object_nodischarge]. TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. *) let register c = - let env = Global.env () in - let evd = Evd.from_env env in - let evd, c = Constrintern.interp_open_constr env evd c in - let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in - () + try + let c = UnivGen.constr_of_monomorphic_global (Nametab.locate c) in + let _ = Lib.add_anonymous_leaf (register_obj c) in + () + with Not_found -> + raise + (CErrors.user_err Pp.(Libnames.pr_qualid c ++ str " does not exist.")) let pp_keys () = let env = Global.env () in let evd = Evd.from_env env in - HConstr.fold + ConstrMap.fold (fun _ (k, d) acc -> match E.dest d with | None -> acc @@ -656,6 +704,7 @@ module ESat = struct open ESatT let name = "Saturate" + let gref = coq_Saturate let table = saturate let cast x = Saturate x let dest = function Saturate x -> Some x | _ -> None @@ -669,6 +718,7 @@ module EUnopSpec = struct type elt = ESpecT.t let name = "UnopSpec" + let gref = coq_UnOpSpec let table = specs let cast x = UnOpSpec x let dest = function UnOpSpec x -> Some x | _ -> None @@ -682,6 +732,7 @@ module EBinOpSpec = struct type elt = ESpecT.t let name = "BinOpSpec" + let gref = coq_BinOpSpec let table = specs let cast x = BinOpSpec x let dest = function BinOpSpec x -> Some x | _ -> None @@ -947,9 +998,11 @@ let app_binop evd src binop arg1 prf1 arg2 prf2 = type typed_constr = {constr : EConstr.t; typ : EConstr.t; inj : EInjT.t} let get_injection env evd t = - match snd (HConstr.find t !table_cache) with - | InjTyp i -> i - | _ -> raise Not_found + try + match snd (ConstrMap.find evd t !table_cache) with + | InjTyp i -> i + | _ -> raise Not_found + with DestKO -> raise Not_found (* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *) let arrow = @@ -1087,7 +1140,7 @@ let declared_term env evd hd args = | PropUnOp _ -> decomp t 1 | _ -> None ) in - find_option match_operator (HConstr.find_all hd !table) + find_option match_operator (ConstrMap.find_all evd hd !table) let rec trans_expr env evd e = let inj = e.inj in @@ -1099,7 +1152,7 @@ let rec trans_expr env evd e = let k, t = find_option (match_operator env evd c a) - (HConstr.find_all c !table_cache) + (ConstrMap.find_all evd c !table_cache) in let n = Array.length a in match k with @@ -1243,7 +1296,7 @@ let rec trans_prop env evd e = let k, t = find_option (match_operator env evd c a) - (HConstr.find_all c !table_cache) + (ConstrMap.find_all evd c !table_cache) in let n = Array.length a in match k with @@ -1262,7 +1315,7 @@ let rec trans_prop env evd e = in trans_binrel evd e rop a.(n - 2) a1 a.(n - 1) a2 | _ -> IProof - with Not_found -> IProof ) + with Not_found | DestKO -> IProof ) let trans_check_prop env evd t = if is_prop env evd t then Some (trans_prop env evd t) else None @@ -1319,7 +1372,15 @@ let trans_concl prfp = Tactics.change_concl t') | TProof (t, prf) -> Proofview.Goal.enter (fun gl -> - Equality.general_rewrite true Locus.AllOccurrences true false prf) + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let typ = get_type_of env evd prf in + match EConstr.kind evd typ with + | App (c, a) when Array.length a = 2 -> + Tactics.apply + (EConstr.mkApp (Lazy.force rew_iff_rev, [|a.(0); a.(1); prf|])) + | _ -> + raise (CErrors.anomaly Pp.(str "zify cannot transform conclusion"))) let tclTHENOpt e tac tac' = match e with None -> tac' | Some e' -> Tacticals.New.tclTHEN (tac e') tac' @@ -1359,7 +1420,7 @@ let do_let tac (h : Constr.named_declaration) = find_option (match_operator env evd eq [|EConstr.of_constr ty; EConstr.mkVar x; EConstr.of_constr t|]) - (HConstr.find_all eq !table_cache)); + (ConstrMap.find_all evd eq !table_cache)); tac x (EConstr.of_constr t) (EConstr.of_constr ty) with Not_found -> Tacticals.New.tclIDTAC) @@ -1453,12 +1514,12 @@ let rec spec_of_term env evd (senv : spec_env) t = try (EConstr.mkVar (HConstr.find t' senv'.map), senv') with Not_found -> ( try - match snd (HConstr.find c !specs_cache) with + match snd (ConstrMap.find evd c !specs_cache) with | UnOpSpec s | BinOpSpec s -> let thm = EConstr.mkApp (s.deriv.ESpecT.spec, a') in register_constr senv' t' thm | _ -> (get_name t' senv', senv') - with Not_found -> (t', senv') ) + with Not_found | DestKO -> (t', senv') ) let interp_pscript s = match s with @@ -1493,47 +1554,58 @@ let spec_of_hyps = let iter_specs = spec_of_hyps let find_hyp evd t l = - try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l)) + try + Some + (EConstr.mkVar + (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l))) with Not_found -> None -let sat_constr c d = - Proofview.Goal.enter (fun gl -> - let evd = Tacmach.New.project gl in - let env = Tacmach.New.pf_env gl in - let hyps = Tacmach.New.pf_hyps_types gl in - match EConstr.kind evd c with - | App (c, args) -> - if Array.length args = 2 then - let h1 = - Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) - in - let h2 = - Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) - in - match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with - | Some h1, Some h2 -> - let n = - Tactics.fresh_id_in_env Id.Set.empty - (Names.Id.of_string "__sat") - env - in - let trm = - EConstr.mkApp - ( d.ESatT.satOK - , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] ) - in - Tactics.pose_proof (Names.Name n) trm - | _, _ -> Tacticals.New.tclIDTAC - else Tacticals.New.tclIDTAC - | _ -> Tacticals.New.tclIDTAC) +let find_proof evd t l = + if EConstr.eq_constr evd t (Lazy.force op_True) then Some (Lazy.force op_I) + else find_hyp evd t l + +(** [sat_constr env evd sub taclist hyps c d]= (sub',taclist',hyps') where + - sub' is a fresh subscript obtained from sub + - taclist' is obtained from taclist by posing the lemma 'd' applied to 'c' + - hyps' is obtained from hyps' + taclist and hyps are threaded to avoid adding duplicates + *) +let sat_constr env evd (sub,taclist, hyps) c d = + match EConstr.kind evd c with + | App (c, args) -> + if Array.length args = 2 then + let h1 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) + in + let h2 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) + in + let n = Nameops.add_subscript (Names.Id.of_string "__sat") sub in + let trm = + match (find_proof evd h1 hyps, find_proof evd h2 hyps) with + | Some h1, Some h2 -> + (EConstr.mkApp (d.ESatT.satOK, [|args.(0); args.(1); h1; h2|])) + | Some h1, _ -> + EConstr.mkApp (d.ESatT.satOK, [|args.(0); args.(1); h1|]) + | _, _ -> EConstr.mkApp (d.ESatT.satOK, [|args.(0); args.(1)|]) + in + let rtrm = Tacred.cbv_beta env evd trm in + let typ = Retyping.get_type_of env evd rtrm in + match find_hyp evd typ hyps with + | None -> (Nameops.Subscript.succ sub, (Tactics.pose_proof (Names.Name n) rtrm :: taclist) , (n,typ)::hyps) + | Some _ -> (sub, taclist, hyps) + else (sub,taclist,hyps) + | _ -> (sub,taclist,hyps) + let get_all_sat env evd c = List.fold_left (fun acc e -> match e with _, Saturate s -> s :: acc | _ -> acc) [] - (HConstr.find_all c !saturate_cache) + ( try ConstrMap.find_all evd c !saturate_cache + with DestKO | Not_found -> [] ) let saturate = Proofview.Goal.enter (fun gl -> @@ -1550,8 +1622,10 @@ let saturate = Array.iter sat args; if Array.length args = 2 then let ds = get_all_sat env evd c in - if ds = [] then () - else List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds + if ds = [] || CstrTable.HConstr.mem table t + then () + else List.iter (fun x -> + CstrTable.HConstr.add table t x.deriv) ds else () | Prod (a, t1, t2) when a.Context.binder_name = Names.Anonymous -> sat t1; sat t2 @@ -1560,5 +1634,6 @@ let saturate = (* Collect all the potential saturation lemma *) sat concl; List.iter (fun (_, t) -> sat t) hyps; - Tacticals.New.tclTHENLIST - (CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table [])) + let s0 = fresh_subscript env in + let (_,tacs,_) = CstrTable.HConstr.fold (fun c d acc -> sat_constr env evd acc c d) table (s0,[],hyps) in + Tacticals.New.tclTHENLIST tacs) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 555bb4c7fb..68f23393ee 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -7,10 +7,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Constrexpr module type S = sig - val register : constr_expr -> unit + val register : Libnames.qualid -> unit val print : unit -> unit end diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml deleted file mode 100644 index 9d92ffde74..0000000000 --- a/plugins/omega/coq_omega.ml +++ /dev/null @@ -1,1939 +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) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -open CErrors -open Util -open Names -open Constr -open Context -open Nameops -open EConstr -open Tacticals.New -open Tacmach.New -open Tactics -open Libnames -open Nametab -open Contradiction -open Tactypes -open Context.Named.Declaration - -module NamedDecl = Context.Named.Declaration - -module ZOmega = struct - type bigint = Z.t - let equal = Z.equal - let less_than = Z.lt - let add = Z.add - let sub = Z.sub - let mult = Z.mul - let euclid = Z.div_rem - let neg = Z.neg - let zero = Z.zero - let one = Z.one - let to_string = Z.to_string -end - -module OmegaSolver = Omega.MakeOmegaSolver (ZOmega) -open OmegaSolver - -(* Added by JCF, 09/03/98 *) - -let elim_id id = simplest_elim (mkVar id) - -let resolve_id id = apply (mkVar id) - -let display_system_flag = ref false -let display_action_flag = ref false -let old_style_flag = ref false -let letin_flag = ref true - -(* Should we reset all variable labels between two runs of omega ? *) - -let reset_flag = ref true - -(* Coq < 8.5 was not performing such resets, hence omega was slightly - non-deterministic: successive runs of omega on the same problem may - lead to distinct proof-terms. - At the very least, these terms differed on the inner - variable names, but they could even be non-convertible : - the OmegaSolver relies on Hashtbl.iter, it can hence find a different - solution when variable indices differ. *) - -let read f () = !f -let write f x = f:=x - -open Goptions - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"System"]; - optread = read display_system_flag; - optwrite = write display_system_flag } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"Action"]; - optread = read display_action_flag; - optwrite = write display_action_flag } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"OldStyle"]; - optread = read old_style_flag; - optwrite = write old_style_flag } - -let () = - declare_bool_option - { optdepr = true; - optkey = ["Stable";"Omega"]; - optread = read reset_flag; - optwrite = write reset_flag } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Omega";"UseLocalDefs"]; - optread = read letin_flag; - optwrite = write letin_flag } - -let intref, reset_all_references = - let refs = ref [] in - (fun n -> let r = ref n in refs := (r,n) :: !refs; r), - (fun () -> List.iter (fun (r,n) -> r:=n) !refs) - -let new_identifier = - let cpt = intref 0 in - (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s) - -let new_identifier_var = - let cpt = intref 0 in - (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s) - -let new_id = - let cpt = intref 0 in fun () -> incr cpt; !cpt - -let new_var_num = - let cpt = intref 1000 in (fun () -> incr cpt; !cpt) - -let new_var = - let cpt = intref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) - -let display_var i = Printf.sprintf "X%d" i - -let intern_id,unintern_id,reset_intern_tables = - let cpt = ref 0 in - let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : Id.t) -> - try Hashtbl.find table name with Not_found -> - let idx = !cpt in - Hashtbl.add table name idx; - Hashtbl.add co_table idx name; - incr cpt; idx), - (fun idx -> - try Hashtbl.find co_table idx with Not_found -> - let v = new_var () in - Hashtbl.add table v idx; Hashtbl.add co_table idx v; v), - (fun () -> cpt := 0; Hashtbl.clear table) - -let mk_then tacs = tclTHENLIST tacs - -let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) - -let generalize_tac t = generalize t -let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] -let pf_nf gl c = pf_apply Tacred.simpl gl c - -let rev_assoc k = - let rec loop = function - | [] -> raise Not_found - | (v,k')::_ when Int.equal k k' -> v - | _ :: l -> loop l - in - loop - -let tag_hypothesis, hyp_of_tag, clear_tags = - let l = ref ([]:(Id.t * int) list) in - (fun h id -> l := (h,id):: !l), - (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"), - (fun () -> l := []) - -let hide_constr,find_constr,clear_constr_tables,dump_tables = - let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in - (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun sigma h -> - try List.assoc_f (eq_constr_nounivs sigma) h !l with Not_found -> failwith "find_contr"), - (fun () -> l := []), - (fun () -> !l) - -let reset_all () = - if !reset_flag then begin - reset_all_references (); - reset_intern_tables (); - clear_tags (); - clear_constr_tables () - end - -(* Lazy evaluation is used for Coq constants, because this code - is evaluated before the compiled modules are loaded. - To use the constant Zplus, one must type "Lazy.force coq_Zplus" - This is the right way to access to Coq constants in tactics ML code *) - -let gen_constant k = lazy (k |> Coqlib.lib_ref |> UnivGen.constr_of_monomorphic_global - |> EConstr.of_constr) - - -(* Zarith *) -let coq_xH = gen_constant "num.pos.xH" -let coq_xO = gen_constant "num.pos.xO" -let coq_xI = gen_constant "num.pos.xI" -let coq_Z0 = gen_constant "num.Z.Z0" -let coq_Zpos = gen_constant "num.Z.Zpos" -let coq_Zneg = gen_constant "num.Z.Zneg" -let coq_Z = gen_constant "num.Z.type" -let coq_comparison = gen_constant "core.comparison.type" -let coq_Gt = gen_constant "core.comparison.Gt" -let coq_Zplus = gen_constant "num.Z.add" -let coq_Zmult = gen_constant "num.Z.mul" -let coq_Zopp = gen_constant "num.Z.opp" -let coq_Zminus = gen_constant "num.Z.sub" -let coq_Zsucc = gen_constant "num.Z.succ" -let coq_Zpred = gen_constant "num.Z.pred" -let coq_Z_of_nat = gen_constant "num.Z.of_nat" -let coq_inj_plus = gen_constant "num.Nat2Z.inj_add" -let coq_inj_mult = gen_constant "num.Nat2Z.inj_mul" -let coq_inj_minus1 = gen_constant "num.Nat2Z.inj_sub" -let coq_inj_minus2 = gen_constant "plugins.omega.inj_minus2" -let coq_inj_S = gen_constant "num.Nat2Z.inj_succ" -let coq_inj_eq = gen_constant "plugins.omega.inj_eq" -let coq_inj_neq = gen_constant "plugins.omega.inj_neq" -let coq_inj_le = gen_constant "plugins.omega.inj_le" -let coq_inj_lt = gen_constant "plugins.omega.inj_lt" -let coq_inj_ge = gen_constant "plugins.omega.inj_ge" -let coq_inj_gt = gen_constant "plugins.omega.inj_gt" -let coq_fast_Zplus_assoc_reverse = gen_constant "plugins.omega.fast_Zplus_assoc_reverse" -let coq_fast_Zplus_assoc = gen_constant "plugins.omega.fast_Zplus_assoc" -let coq_fast_Zmult_assoc_reverse = gen_constant "plugins.omega.fast_Zmult_assoc_reverse" -let coq_fast_Zplus_permute = gen_constant "plugins.omega.fast_Zplus_permute" -let coq_fast_Zplus_comm = gen_constant "plugins.omega.fast_Zplus_comm" -let coq_fast_Zmult_comm = gen_constant "plugins.omega.fast_Zmult_comm" -let coq_Zmult_le_approx = gen_constant "plugins.omega.Zmult_le_approx" -let coq_OMEGA1 = gen_constant "plugins.omega.OMEGA1" -let coq_OMEGA2 = gen_constant "plugins.omega.OMEGA2" -let coq_OMEGA3 = gen_constant "plugins.omega.OMEGA3" -let coq_OMEGA4 = gen_constant "plugins.omega.OMEGA4" -let coq_OMEGA5 = gen_constant "plugins.omega.OMEGA5" -let coq_OMEGA6 = gen_constant "plugins.omega.OMEGA6" -let coq_OMEGA7 = gen_constant "plugins.omega.OMEGA7" -let coq_OMEGA8 = gen_constant "plugins.omega.OMEGA8" -let coq_OMEGA9 = gen_constant "plugins.omega.OMEGA9" -let coq_fast_OMEGA10 = gen_constant "plugins.omega.fast_OMEGA10" -let coq_fast_OMEGA11 = gen_constant "plugins.omega.fast_OMEGA11" -let coq_fast_OMEGA12 = gen_constant "plugins.omega.fast_OMEGA12" -let coq_fast_OMEGA13 = gen_constant "plugins.omega.fast_OMEGA13" -let coq_fast_OMEGA14 = gen_constant "plugins.omega.fast_OMEGA14" -let coq_fast_OMEGA15 = gen_constant "plugins.omega.fast_OMEGA15" -let coq_fast_OMEGA16 = gen_constant "plugins.omega.fast_OMEGA16" -let coq_OMEGA17 = gen_constant "plugins.omega.OMEGA17" -let coq_OMEGA18 = gen_constant "plugins.omega.OMEGA18" -let coq_OMEGA19 = gen_constant "plugins.omega.OMEGA19" -let coq_OMEGA20 = gen_constant "plugins.omega.OMEGA20" -let coq_fast_Zred_factor0 = gen_constant "plugins.omega.fast_Zred_factor0" -let coq_fast_Zred_factor1 = gen_constant "plugins.omega.fast_Zred_factor1" -let coq_fast_Zred_factor2 = gen_constant "plugins.omega.fast_Zred_factor2" -let coq_fast_Zred_factor3 = gen_constant "plugins.omega.fast_Zred_factor3" -let coq_fast_Zred_factor4 = gen_constant "plugins.omega.fast_Zred_factor4" -let coq_fast_Zred_factor5 = gen_constant "plugins.omega.fast_Zred_factor5" -let coq_fast_Zred_factor6 = gen_constant "plugins.omega.fast_Zred_factor6" -let coq_fast_Zmult_plus_distr_l = gen_constant "plugins.omega.fast_Zmult_plus_distr_l" -let coq_fast_Zopp_plus_distr = gen_constant "plugins.omega.fast_Zopp_plus_distr" -let coq_fast_Zopp_mult_distr_r = gen_constant "plugins.omega.fast_Zopp_mult_distr_r" -let coq_fast_Zopp_eq_mult_neg_1 = gen_constant "plugins.omega.fast_Zopp_eq_mult_neg_1" -let coq_Zegal_left = gen_constant "plugins.omega.Zegal_left" -let coq_Zne_left = gen_constant "plugins.omega.Zne_left" -let coq_Zlt_left = gen_constant "plugins.omega.Zlt_left" -let coq_Zge_left = gen_constant "plugins.omega.Zge_left" -let coq_Zgt_left = gen_constant "plugins.omega.Zgt_left" -let coq_Zle_left = gen_constant "plugins.omega.Zle_left" -let coq_new_var = gen_constant "plugins.omega.new_var" -let coq_intro_Z = gen_constant "plugins.omega.intro_Z" - -let coq_dec_eq = gen_constant "num.Z.eq_decidable" -let coq_dec_Zne = gen_constant "plugins.omega.dec_Zne" -let coq_dec_Zle = gen_constant "num.Z.le_decidable" -let coq_dec_Zlt = gen_constant "num.Z.lt_decidable" -let coq_dec_Zgt = gen_constant "plugins.omega.dec_Zgt" -let coq_dec_Zge = gen_constant "plugins.omega.dec_Zge" - -let coq_not_Zeq = gen_constant "plugins.omega.not_Zeq" -let coq_not_Zne = gen_constant "plugins.omega.not_Zne" -let coq_Znot_le_gt = gen_constant "plugins.omega.Znot_le_gt" -let coq_Znot_lt_ge = gen_constant "plugins.omega.Znot_lt_ge" -let coq_Znot_ge_lt = gen_constant "plugins.omega.Znot_ge_lt" -let coq_Znot_gt_le = gen_constant "plugins.omega.Znot_gt_le" -let coq_neq = gen_constant "plugins.omega.neq" -let coq_Zne = gen_constant "plugins.omega.Zne" -let coq_Zle = gen_constant "num.Z.le" -let coq_Zlt = gen_constant "num.Z.lt" -let coq_Zge = gen_constant "num.Z.ge" -let coq_Zgt = gen_constant "num.Z.gt" - -(* Peano/Datatypes *) -let coq_nat = gen_constant "num.nat.type" -let coq_O = gen_constant "num.nat.O" -let coq_S = gen_constant "num.nat.S" -let coq_le = gen_constant "num.nat.le" -let coq_lt = gen_constant "num.nat.lt" -let coq_ge = gen_constant "num.nat.ge" -let coq_gt = gen_constant "num.nat.gt" -let coq_plus = gen_constant "num.nat.add" -let coq_minus = gen_constant "num.nat.sub" -let coq_mult = gen_constant "num.nat.mul" -let coq_pred = gen_constant "num.nat.pred" - -(* Compare_dec/Peano_dec/Minus *) -let coq_pred_of_minus = gen_constant "num.nat.pred_of_minus" -let coq_le_gt_dec = gen_constant "num.nat.le_gt_dec" -let coq_dec_eq_nat = gen_constant "num.nat.eq_dec" -let coq_dec_le = gen_constant "num.nat.dec_le" -let coq_dec_lt = gen_constant "num.nat.dec_lt" -let coq_dec_ge = gen_constant "num.nat.dec_ge" -let coq_dec_gt = gen_constant "num.nat.dec_gt" -let coq_not_eq = gen_constant "num.nat.not_eq" -let coq_not_le = gen_constant "num.nat.not_le" -let coq_not_lt = gen_constant "num.nat.not_lt" -let coq_not_ge = gen_constant "num.nat.not_ge" -let coq_not_gt = gen_constant "num.nat.not_gt" - -(* Logic/Decidable *) -let coq_eq_ind_r = gen_constant "core.eq.ind_r" - -let coq_dec_or = gen_constant "core.dec.or" -let coq_dec_and = gen_constant "core.dec.and" -let coq_dec_imp = gen_constant "core.dec.imp" -let coq_dec_iff = gen_constant "core.dec.iff" -let coq_dec_not = gen_constant "core.dec.not" -let coq_dec_False = gen_constant "core.dec.False" -let coq_dec_not_not = gen_constant "core.dec.not_not" -let coq_dec_True = gen_constant "core.dec.True" - -let coq_not_or = gen_constant "core.dec.not_or" -let coq_not_and = gen_constant "core.dec.not_and" -let coq_not_imp = gen_constant "core.dec.not_imp" -let coq_not_iff = gen_constant "core.dec.not_iff" -let coq_not_not = gen_constant "core.dec.dec_not_not" -let coq_imp_simp = gen_constant "core.dec.imp_simp" -let coq_iff = gen_constant "core.iff.type" -let coq_not = gen_constant "core.not.type" -let coq_and = gen_constant "core.and.type" -let coq_or = gen_constant "core.or.type" -let coq_eq = gen_constant "core.eq.type" -let coq_ex = gen_constant "core.ex.type" -let coq_False = gen_constant "core.False.type" -let coq_True = gen_constant "core.True.type" - -(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) - -(* For unfold *) -let evaluable_ref_of_constr s c = - let env = Global.env () in - let evd = Evd.from_env env in - let open Tacred in - match EConstr.kind evd (Lazy.force c) with - | Const (kn,u) when is_evaluable env (EvalConstRef kn) -> - EvalConstRef kn - | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) - -let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) -let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) -let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus) -let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) -let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) -let sp_not = lazy (evaluable_ref_of_constr "not" coq_not) - -let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) -let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) -let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_gen_eq ty t1 t2 = mkApp (Lazy.force coq_eq, [| ty; t1; t2 |]) -let mk_eq t1 t2 = mk_gen_eq (Lazy.force coq_Z) t1 t2 -let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) -let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) -let mk_and t1 t2 = mkApp (Lazy.force coq_and, [| t1; t2 |]) -let mk_or t1 t2 = mkApp (Lazy.force coq_or, [| t1; t2 |]) -let mk_not t = mkApp (Lazy.force coq_not, [| t |]) -let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) - -let mk_integer n = - let rec loop n = - if n =? one then Lazy.force coq_xH else - mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop (n/two) |]) - in - if n =? zero then Lazy.force coq_Z0 - else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), - [| loop (abs n) |]) - -type omega_constant = - | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred - | Plus | Mult | Minus | Pred | S | O - | Zpos | Zneg | Z0 | Z_of_nat - | Eq | Neq - | Zne | Zle | Zlt | Zge | Zgt - | Z | Nat - | And | Or | False | True | Not | Iff - | Le | Lt | Ge | Gt - | Other of string - -type result = - | Kvar of Id.t - | Kapp of omega_constant * constr list - | Kimp of constr * constr - | Kufo - -(* Nota: Kimp correspond to a binder (Prod), but hopefully we won't - have to bother with term lifting: Kimp will correspond to anonymous - product, for which (Rel 1) doesn't occur in the right term. - Moreover, we'll work on fully introduced goals, hence no Rel's in - the term parts that we manipulate, but rather Var's. - Said otherwise: all constr manipulated here are closed *) - -let destructurate_prop sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let c, args = decompose_app sigma t in - match EConstr.kind sigma c, args with - | _, [_;_;_] when eq_constr (Lazy.force coq_eq) c -> Kapp (Eq,args) - | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) - | _, [_;_] when eq_constr c (Lazy.force coq_and) -> Kapp (And,args) - | _, [_;_] when eq_constr c (Lazy.force coq_or) -> Kapp (Or,args) - | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) - | _, [_] when eq_constr c (Lazy.force coq_not) -> Kapp (Not,args) - | _, [] when eq_constr c (Lazy.force coq_False) -> Kapp (False,args) - | _, [] when eq_constr c (Lazy.force coq_True) -> Kapp (True,args) - | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) - | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) - | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) - | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) - | Const (sp,_), args -> - Kapp (Other (string_of_path (path_of_global (GlobRef.ConstRef sp))),args) - | Construct (csp,_) , args -> - Kapp (Other (string_of_path (path_of_global (GlobRef.ConstructRef csp))), args) - | Ind (isp,_), args -> - Kapp (Other (string_of_path (path_of_global (GlobRef.IndRef isp))),args) - | Var id,[] -> Kvar id - | Prod ({binder_name=Anonymous},typ,body), [] -> Kimp(typ,body) - | Prod ({binder_name=Name _},_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") - | _ -> Kufo - -let nf = Tacred.simpl - -let destructurate_type env sigma t = - let is_conv = Reductionops.is_conv env sigma in - let c, args = decompose_app sigma (nf env sigma t) in - match EConstr.kind sigma c, args with - | _, [] when is_conv c (Lazy.force coq_Z) -> Kapp (Z,args) - | _, [] when is_conv c (Lazy.force coq_nat) -> Kapp (Nat,args) - | _ -> Kufo - -let destructurate_term sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let c, args = decompose_app sigma t in - match EConstr.kind sigma c, args with - | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) - | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) - | _, [_] when eq_constr c (Lazy.force coq_Zsucc) -> Kapp (Zsucc,args) - | _, [_] when eq_constr c (Lazy.force coq_Zpred) -> Kapp (Zpred,args) - | _, [_] when eq_constr c (Lazy.force coq_Zopp) -> Kapp (Zopp,args) - | _, [_;_] when eq_constr c (Lazy.force coq_plus) -> Kapp (Plus,args) - | _, [_;_] when eq_constr c (Lazy.force coq_mult) -> Kapp (Mult,args) - | _, [_;_] when eq_constr c (Lazy.force coq_minus) -> Kapp (Minus,args) - | _, [_] when eq_constr c (Lazy.force coq_pred) -> Kapp (Pred,args) - | _, [_] when eq_constr c (Lazy.force coq_S) -> Kapp (S,args) - | _, [] when eq_constr c (Lazy.force coq_O) -> Kapp (O,args) - | _, [_] when eq_constr c (Lazy.force coq_Zpos) -> Kapp (Zneg,args) - | _, [_] when eq_constr c (Lazy.force coq_Zneg) -> Kapp (Zpos,args) - | _, [] when eq_constr c (Lazy.force coq_Z0) -> Kapp (Z0,args) - | _, [_] when eq_constr c (Lazy.force coq_Z_of_nat) -> Kapp (Z_of_nat,args) - | Var id,[] -> Kvar id - | _ -> Kufo - -let recognize_number sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let rec loop t = - match decompose_app sigma t with - | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t - | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t - | f, [] when eq_constr f (Lazy.force coq_xH) -> one - | _ -> failwith "not a number" - in - match decompose_app sigma t with - | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t - | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) - | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero - | _ -> failwith "not a number" - -type constr_path = - | P_APP of int - (* Abstraction and product *) - | P_TYPE - -let context sigma operation path (t : constr) = - let rec loop i p0 t = - match (p0,EConstr.kind sigma t) with - | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) - | ([], _) -> operation i t - | ((P_APP n :: p), App (f,v)) -> - let v' = Array.copy v in - v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') - | (p, Fix ((_,n as ln),(tys,lna,v))) -> - let l = Array.length v in - let v' = Array.copy v in - v'.(n)<- loop (Util.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) - | ((P_TYPE :: p), Prod (n,t,c)) -> - (mkProd (n,loop i p t,c)) - | ((P_TYPE :: p), Lambda (n,t,c)) -> - (mkLambda (n,loop i p t,c)) - | ((P_TYPE :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,loop i p t,c)) - | (p, _) -> - failwith ("abstract_path " ^ string_of_int(List.length p)) - in - loop 1 path t - -let occurrence sigma path (t : constr) = - let rec loop p0 t = match (p0,EConstr.kind sigma t) with - | (p, Cast (c,_,_)) -> loop p c - | ([], _) -> t - | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) - | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) - | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term - | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term - | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term - | (p, _) -> - failwith ("occurrence " ^ string_of_int(List.length p)) - in - loop path t - -let abstract_path sigma typ path t = - let term_occur = ref (mkRel 0) in - let abstract = context sigma (fun i t -> term_occur:= t; mkRel i) path t in - mkLambda (make_annot (Name (Id.of_string "x")) Sorts.Relevant, typ, abstract), !term_occur - -let focused_simpl path = - let open Tacmach.New in - Proofview.Goal.enter begin fun gl -> - let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - convert_concl ~check:false newc DEFAULTcast - end - -let focused_simpl path = focused_simpl path - -type oformula = - | Oplus of oformula * oformula - | Otimes of oformula * oformula - | Oatom of Id.t - | Oz of bigint - | Oufo of constr - -let rec oprint = function - | Oplus(t1,t2) -> - print_string "("; oprint t1; print_string "+"; - oprint t2; print_string ")" - | Otimes (t1,t2) -> - print_string "("; oprint t1; print_string "*"; - oprint t2; print_string ")" - | Oatom s -> print_string (Id.to_string s) - | Oz i -> print_string (string_of_bigint i) - | Oufo f -> print_string "?" - -let rec weight = function - | Oatom c -> intern_id c - | Oz _ -> -1 - | Otimes(c,_) -> weight c - | Oplus _ -> failwith "weight" - | Oufo _ -> -1 - -let rec val_of = function - | Oatom c -> mkVar c - | Oz c -> mk_integer c - | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) - | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) - | Oufo c -> c - -let compile name kind = - let rec loop accu = function - | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r - | Oz n -> - let id = new_id () in - tag_hypothesis name id; - {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly (Pp.str "compile_equation.") - in - loop [] - -let decompile af = - let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) - | [] -> Oz af.constant - in - loop af.body - -(** Backward compat to emulate the old Refine: normalize the goal conclusion *) -let new_hole env sigma c = - let c = Reductionops.nf_betaiota env sigma c in - Evarutil.new_evar env sigma c - -let clever_rewrite_base_poly typ p result theorem = - let open Tacmach.New in - Proofview.Goal.enter begin fun gl -> - let full = pf_concl gl in - let env = pf_env gl in - let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in - Refine.refine ~typecheck:false begin fun sigma -> - let t = - applist - (mkLambda - (make_annot (Name (Id.of_string "P")) Sorts.Relevant, - mkArrow typ Sorts.Relevant mkProp, - mkLambda - (make_annot (Name (Id.of_string "H")) Sorts.Relevant, - applist (mkRel 1,[result]), - mkApp (Lazy.force coq_eq_ind_r, - [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), - [abstracted]) - in - let argt = mkApp (abstracted, [|result|]) in - let (sigma, hole) = new_hole env sigma argt in - (sigma, applist (t, [hole])) - end - end - -let clever_rewrite_base p result theorem = - clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem - -let clever_rewrite_base_nat p result theorem = - clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem - -let clever_rewrite_gen p result (t,args) = - let theorem = applist(t, args) in - clever_rewrite_base p result theorem - -let clever_rewrite_gen_nat p result (t,args) = - let theorem = applist(t, args) in - clever_rewrite_base_nat p result theorem - -(** Solve using the term the term [t _] *) -let refine_app gl t = - let open Tacmach.New in - Refine.refine ~typecheck:false begin fun sigma -> - let env = pf_env gl in - let ht = match EConstr.kind sigma (pf_get_type_of gl t) with - | Prod (_, t, _) -> t - | _ -> assert false - in - let (sigma, hole) = new_hole env sigma ht in - (sigma, applist (t, [hole])) - end - -let clever_rewrite p vpath t = - let open Tacmach.New in - Proofview.Goal.enter begin fun gl -> - let full = pf_concl gl in - let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in - let t' = applist(t, (vargs @ [abstracted])) in - refine_app gl t' - end - -(** simpl_coeffs : - The subterm at location [path_init] in the current goal should - look like [(v1*c1 + (v2*c2 + ... (vn*cn + k)))], and we reduce - via "simpl" each [ci] and the final constant [k]. - The path [path_k] gives the location of constant [k]. - Earlier, the whole was a mere call to [focused_simpl], - leading to reduction inside the atoms [vi], which is bad, - for instance when the atom is an evaluable definition - (see #4132). *) - -let simpl_coeffs path_init path_k = - Proofview.Goal.enter begin fun gl -> - let sigma = project gl in - let rec loop n t = - if Int.equal n 0 then pf_nf gl t - else - (* t should be of the form ((v * c) + ...) *) - match EConstr.kind sigma t with - | App(f,[|t1;t2|]) -> - (match EConstr.kind sigma t1 with - | App (g,[|v;c|]) -> - let c' = pf_nf gl c in - let t2' = loop (pred n) t2 in - mkApp (f,[|mkApp (g,[|v;c'|]);t2'|]) - | _ -> assert false) - | _ -> assert false - in - let n = Util.(-) (List.length path_k) (List.length path_init) in - let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl) - in - convert_concl ~check:false newc DEFAULTcast - end - -let rec shuffle p (t1,t2) = - match t1,t2 with - | Oplus(l1,r1), Oplus(l2,r2) -> - if weight l1 > weight l2 then - let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - (clever_rewrite p [[P_APP 1;P_APP 1]; - [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, - Oplus(l1,t')) - else - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in - (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_permute) - :: tac, - Oplus(l2,t')) - | Oplus(l1,r1), t2 -> - if weight l1 > weight t2 then - let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, - Oplus(l1, t') - else - [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - | t1,Oplus(l2,r2) -> - if weight l2 > weight t1 then - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_permute) - :: tac, - Oplus(l2,t') - else [],Oplus(t1,t2) - | Oz t1,Oz t2 -> - [focused_simpl p], Oz(Z.add t1 t2) - | t1,t2 -> - if weight t1 < weight t2 then - [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - else [],Oplus(t1,t2) - -let shuffle_mult p_init k1 e1 k2 e2 = - let rec loop p = function - | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then - let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA10) - in - if Z.add (Z.mul k1 c1) (Z.mul k2 c2) =? zero then - let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: - loop p (l1,l2) - else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2]; - [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: - loop (P_APP 2 :: p) (l1,l2') - else - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2]; - [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: - loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) ([],l2) - | [],[] -> [simpl_coeffs p_init p] - in - loop p_init (e1,e2) - -let shuffle_mult_right p_init e1 k2 e2 = - let rec loop p = function - | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then - let tac = - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA15) - in - if Z.add c1 (Z.mul k2 c2) =? zero then - let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) - in - tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: - loop p (l1,l2) - else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) (l1,l2') - else - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) ([],l2) - | [],[] -> [simpl_coeffs p_init p] - in - loop p_init (e1,e2) - -let rec shuffle_cancel p = function - | [] -> [focused_simpl p] - | ({c=c1}::l1) -> - let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] - (if c1 >? zero then - (Lazy.force coq_fast_OMEGA13) - else - (Lazy.force coq_fast_OMEGA14)) - in - tac :: shuffle_cancel p l1 - -let rec scalar p n = function - | Oplus(t1,t2) -> - let tac1,t1' = scalar (P_APP 1 :: p) n t1 and - tac2,t2' = scalar (P_APP 2 :: p) n t2 in - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_plus_distr_l) :: - (tac1 @ tac2), Oplus(t1',t2') - | Otimes(t1,Oz x) -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_assoc_reverse); - focused_simpl (P_APP 2 :: p)], - Otimes(t1,Oz (n*x)) - | Otimes(t1,t2) -> CErrors.user_err Pp.(str "Omega: Can't solve a goal with non-linear products") - | (Oatom _ as t) -> [], Otimes(t,Oz n) - | Oz i -> [focused_simpl p],Oz(n*i) - | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) - -let scalar_norm p_init = - let rec loop p = function - | [] -> [simpl_coeffs p_init p] - | (_::l) -> - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l - in - loop p_init - -let norm_add p_init = - let rec loop p = function - | [] -> [simpl_coeffs p_init p] - | _:: l -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) l - in - loop p_init - -let scalar_norm_add p_init = - let rec loop p = function - | [] -> [simpl_coeffs p_init p] - | _ :: l -> - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l - in - loop p_init - -let rec negate p = function - | Oplus(t1,t2) -> - let tac1,t1' = negate (P_APP 1 :: p) t1 and - tac2,t2' = negate (P_APP 2 :: p) t2 in - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_plus_distr) :: - (tac1 @ tac2), - Oplus(t1',t2') - | Otimes(t1,Oz x) -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_mult_distr_r); - focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) - | Otimes(t1,t2) -> CErrors.user_err Pp.(str "Omega: Can't solve a goal with non-linear products") - | (Oatom _ as t) -> - let r = Otimes(t,Oz(negone)) in - [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r - | Oz i -> [focused_simpl p],Oz(neg i) - | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) - -let rec transform sigma p t = - let default isnat t' = - try - let v,th,_ = find_constr sigma t' in - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with e when CErrors.noncritical e -> - let v = new_identifier_var () - and th = new_identifier () in - hide_constr t' v th isnat; - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - in - try match destructurate_term sigma t with - | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform sigma (P_APP 1 :: p) t1 - and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in - let tac,t' = shuffle p (t1',t2') in - tac1 @ tac2 @ tac, t' - | Kapp(Zminus,[t1;t2]) -> - let tac,t = - transform sigma p - (mkApp (Lazy.force coq_Zplus, - [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - unfold sp_Zminus :: tac,t - | Kapp(Zsucc,[t1]) -> - let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer one |])) in - unfold sp_Zsucc :: tac,t - | Kapp(Zpred,[t1]) -> - let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer negone |])) in - unfold sp_Zpred :: tac,t - | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform sigma (P_APP 1 :: p) t1 - and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in - begin match t1',t2' with - | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' - | (Oz n,_) -> - let sym = - clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_comm) in - let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' - | _ -> default false t - end - | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number sigma t)) - with e when CErrors.noncritical e -> default false t) - | Kvar s -> [],Oatom s - | Kapp(Zopp,[t]) -> - let tac,t' = transform sigma (P_APP 1 :: p) t in - let tac',t'' = negate p t' in - tac @ tac', t'' - | Kapp(Z_of_nat,[t']) -> default true t' - | _ -> default false t - with e when noncritical e -> default false t - -let shrink_pair p f1 f2 = - match f1,f2 with - | Oatom v,Oatom _ -> - let r = Otimes(Oatom v,Oz two) in - clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r - | Oatom v, Otimes(_,c2) -> - let r = Otimes(Oatom v,Oplus(c2,Oz one)) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor2), r - | Otimes (v1,c1),Oatom v -> - let r = Otimes(Oatom v,Oplus(c1,Oz one)) in - clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zred_factor3), r - | Otimes (Oatom v,c1),Otimes (v2,c2) -> - let r = Otimes(Oatom v,Oplus(c1,c2)) in - clever_rewrite p - [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor4),r - | t1,t2 -> - begin - oprint t1; print_newline (); oprint t2; print_newline (); - flush stdout; CErrors.user_err Pp.(str "shrink.1") - end - -let reduce_factor p = function - | Oatom v -> - let r = Otimes(Oatom v,Oz one) in - [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r - | Otimes(Oatom v,Oz n) as f -> [],f - | Otimes(Oatom v,c) -> - let rec compute = function - | Oz n -> n - | Oplus(t1,t2) -> Z.add (compute t1) (compute t2) - | _ -> CErrors.user_err Pp.(str "condense.1") - in - [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) - | t -> oprint t; CErrors.user_err Pp.(str "reduce_factor.1") - -let rec condense p = function - | Oplus(f1,(Oplus(f2,r) as t)) -> - if Int.equal (weight f1) (weight f2) then begin - let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in - let assoc_tac = - clever_rewrite p - [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc) in - let tac_list,t' = condense p (Oplus(t,r)) in - (assoc_tac :: shrink_tac :: tac_list), t' - end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) t in - (tac @ tac'), Oplus(f,t') - end - | Oplus(f1,Oz n) -> - let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) - | Oplus(f1,f2) -> - if Int.equal (weight f1) (weight f2) then begin - let tac_shrink,t = shrink_pair p f1 f2 in - let tac,t' = condense p t in - tac_shrink :: tac,t' - end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) f2 in - (tac @ tac'),Oplus(f,t') - end - | Oz _ as t -> [],t - | t -> - let tac,t' = reduce_factor p t in - let final = Oplus(t',Oz zero) in - let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in - tac @ [tac'], final - -let rec clear_zero p = function - | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> - let tac = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in - let tac',t = clear_zero p r in - tac :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) - | t -> [],t - -open Proofview -open Proofview.Notations - -let replay_history tactic_normalisation = - let aux = Id.of_string "auxiliary" in - let aux1 = Id.of_string "auxiliary_1" in - let aux2 = Id.of_string "auxiliary_2" in - let izero = mk_integer zero in - let rec loop t : unit Proofview.tactic = - match t with - | HYP e :: l -> - begin - try - tclTHEN - (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) - (loop l) - with Not_found -> loop l end - | NEGATE_CONTRADICT (e2,e1,b) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let k = if b then negone else one in - let p_initial = [P_APP 1;P_TYPE] in - let tac= shuffle_mult_right p_initial e1.body k e2.body in - tclTHENLIST [ - generalize_tac - [mkApp (Lazy.force coq_OMEGA17, [| - val_of eq1; - val_of eq2; - mk_integer k; - mkVar id1; mkVar id2 |])]; - mk_then tac; - intro_using_then aux (fun aux -> - resolve_id aux); - reflexivity - ] - | CONTRADICTION (e1,e2) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac = shuffle_cancel p_initial e1.body in - let solve_le = - let not_sup_sup = mkApp (Lazy.force coq_eq, - [| - Lazy.force coq_comparison; - Lazy.force coq_Gt; - Lazy.force coq_Gt |]) - in - tclTHENS - (tclTHENLIST [ - unfold sp_Zle; - simpl_in_concl; - intro; - (absurd not_sup_sup) ]) - [ assumption ; reflexivity ] - in - let theorem = - mkApp (Lazy.force coq_OMEGA2, [| - val_of eq1; val_of eq2; - mkVar (hyp_of_tag e1.id); - mkVar (hyp_of_tag e2.id) |]) - in - Proofview.tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) solve_le - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - let id = hyp_of_tag e1.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let rhs = mk_plus (mk_times eq2 kk) dd in - let state_eg = mk_eq eq1 rhs in - let tac = scalar_norm_add [P_APP 3] e2.body in - tclTHENS - (cut state_eg) - [ tclTHENS - (intro_using_then aux (fun aux -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA1, - [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); - (intro_mustbe_force id); - (cut (mk_gt kk dd)) ])) - [ tclTHENS - (cut (mk_gt kk izero)) - [ intro_using_then aux1 (fun aux1 -> - intro_using_then aux2 (fun aux2 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Zmult_le_approx, - [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); - (clear [aux1;aux2;id]); - (intro_mustbe_force id); - (loop l) ])); - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] - ]; - tclTHEN (mk_then tac) reflexivity ] - - | NOT_EXACT_DIVIDE (e1,k) :: l -> - let c = floor_div e1.constant k in - let d = Z.sub e1.constant (Z.mul c k) in - let e2 = {id=e1.id; kind=EQUA;constant = c; - body = map_eq_linear (fun c -> c / k) e1.body } in - let eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS - (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) - [ intro_using_then aux2 (fun aux2 -> - intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, - [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - unfold sp_not; - intro_using_then aux (fun aux -> - tclTHENLIST [ - resolve_id aux; - mk_then tac; - assumption - ])])) ; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ] - | EXACT_DIVIDE (e1,k) :: l -> - let id = hyp_of_tag e1.id in - let e2 = map_eq_afine (fun c -> c / k) e1 in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k in - let state_eq = mk_eq eq1 (mk_times eq2 kk) in - if e1.kind == DISE then - let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS - (cut state_eq) - [ intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, - [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); - (intro_mustbe_force id); - (loop l) ]); - tclTHEN (mk_then tac) reflexivity ] - else - let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS (cut state_eq) - [ - tclTHENS - (cut (mk_gt kk izero)) - [ intro_using_then aux2 (fun aux2 -> - intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA3, - [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); - (clear [aux1;aux2;id]); - (intro_mustbe_force id); - (loop l) ])); - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] - | (MERGE_EQ(e3,e1,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2 in - let eq1 = val_of(decompile e1) - and eq2 = val_of (decompile (negate_eq e1)) in - let tac = - clever_rewrite [P_APP 3] [[P_APP 1]] - (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - scalar_norm [P_APP 3] e1.body - in - tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) - [ intro_using_then aux (fun aux -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); - (intro_mustbe_force id); - (loop l) ]); - tclTHEN (mk_then tac) reflexivity] - - | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> - let id = new_identifier () - and id2 = hyp_of_tag orig.id in - tag_hypothesis id e.id; - let eq1 = val_of(decompile def) - and eq2 = val_of(decompile orig) in - let vid = unintern_id v in - let theorem = - mkApp (Lazy.force coq_ex, [| - Lazy.force coq_Z; - mkLambda - (make_annot (Name vid) Sorts.Relevant, - Lazy.force coq_Z, - mk_eq (mkRel 1) eq1) |]) - in - let mm = mk_integer m in - let p_initial = [P_APP 2;P_TYPE] in - let tac = - clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) - [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - shuffle_mult_right p_initial - orig.body m ({c= negone;v= v}::def.body) in - tclTHENS - (cut theorem) - [ tclTHENLIST [ intro_using_then aux (fun aux -> - (elim_id aux) <*> - (clear [aux])); - intro_using_then vid (fun vid -> - intro_using_then aux (fun aux -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA9, - [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); - mk_then tac; - (clear [aux]); - (intro_mustbe_force id); - (loop l) ]))]; - tclTHEN (exists_tac eq1) reflexivity ] - | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> - let id1 = new_identifier () - and id2 = new_identifier () in - tag_hypothesis id1 e1; tag_hypothesis id2 e2; - let id = hyp_of_tag e.id in - let tac1 = norm_add [P_APP 2;P_TYPE] e.body in - let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in - let eq = val_of(decompile e) in - tclTHENS - (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) - [tclTHENLIST [ mk_then tac1; (intro_mustbe_force id1); (loop act1) ]; - tclTHENLIST [ mk_then tac2; (intro_mustbe_force id2); (loop act2) ]] - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - if k1 =? one && e2.kind == EQUA then - let tac_thm = - match e1.kind with - | EQUA -> Lazy.force coq_OMEGA5 - | INEQ -> Lazy.force coq_OMEGA6 - | DISE -> Lazy.force coq_OMEGA20 - in - let kk = mk_integer k2 in - let p_initial = - if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in - let tac = shuffle_mult_right p_initial e1.body k2 e2.body in - tclTHENLIST [ - (generalize_tac - [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); - mk_then tac; - (intro_mustbe_force id); - (loop l) - ] - else - let kk1 = mk_integer k1 - and kk2 = mk_integer k2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in - tclTHENS (cut (mk_gt kk1 izero)) - [tclTHENS - (cut (mk_gt kk2 izero)) - [ intro_using_then aux2 (fun aux2 -> - intro_using_then aux1 (fun aux1 -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; - mkVar aux1;mkVar aux2; - mkVar id1;mkVar id2 |])]); - (clear [aux1;aux2]); - mk_then tac; - (intro_mustbe_force id); - (loop l) ])); - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ] - | CONSTANT_NOT_NUL(e,k) :: l -> - tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl - | CONSTANT_NUL(e) :: l -> - tclTHEN (resolve_id (hyp_of_tag e)) reflexivity - | CONSTANT_NEG(e,k) :: l -> - tclTHENLIST [ - (generalize_tac [mkVar (hyp_of_tag e)]); - unfold sp_Zle; - simpl_in_concl; - unfold sp_not; - intro_using_then aux (fun aux -> - resolve_id aux <*> reflexivity) - ] - | _ -> Proofview.tclUNIT () - in - loop - -let normalize sigma p_initial t = - let (tac,t') = transform sigma p_initial t in - let (tac',t'') = condense p_initial t' in - let (tac'',t''') = clear_zero p_initial t'' in - tac @ tac' @ tac'' , t''' - -let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = - let p_initial = [P_APP pos ;P_TYPE] in - let (tac,t') = normalize sigma p_initial t in - let shift_left = - tclTHEN - (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) - (tclTRY (clear [id])) - in - if not (List.is_empty tac) then - let id' = new_identifier () in - ((id',(tclTHENLIST [ shift_left; mk_then tac; (intro_mustbe_force id') ])) - :: tactic, - compile id' flag t' :: defs) - else - (tactic,defs) - -let destructure_omega env sigma tac_def (id,c) = - if String.equal (atompart_of_id id) "State" then - tac_def - else - try match destructurate_prop sigma c with - | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type env sigma typ with Kapp(Z,[]) -> true | _ -> false end -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def - | Kapp(Zne,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def - | Kapp(Zle,[t1;t2]) -> - let t = mk_plus t2 (mk_inv t1) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def - | Kapp(Zlt,[t1;t2]) -> - let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def - | Kapp(Zge,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def - | Kapp(Zgt,[t1;t2]) -> - let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def - | _ -> tac_def - with e when noncritical e -> tac_def - -let reintroduce id = - (* [id] cannot be cleared if dependent: protect it by a try *) - tclTHEN (tclTRY (clear [id])) (intro_using_then id (fun _ -> tclUNIT())) - -let coq_omega = - Proofview.Goal.enter begin fun gl -> - clear_constr_tables (); - let hyps_types = Tacmach.New.pf_hyps_types gl in - let destructure_omega = Tacmach.New.pf_apply destructure_omega gl in - let tactic_normalisation, system = - List.fold_left destructure_omega ([],[]) hyps_types in - let prelude,sys = - List.fold_left - (fun (tac,sys) (t,(v,th,b)) -> - if b then - let id = new_identifier () in - let i = new_id () in - tag_hypothesis id i; - (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); - (intros_mustbe_force [v; id]); - (elim_id id); - (clear [id]); - (intros_mustbe_force [th;id]); - tac ]), - {kind = INEQ; - body = [{v=intern_id v; c=one}]; - constant = zero; id = i} :: sys - else - (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_new_var, [t]))); - (intros_mustbe_force [v;th]); - tac ]), - sys) - (Proofview.tclUNIT (),[]) (dump_tables ()) - in - let system = system @ sys in - if !display_system_flag then display_system display_var system; - if !old_style_flag then begin - try - let _ = simplify (new_id,new_var_num,display_var) false system in - Proofview.tclUNIT () - with UNSOLVABLE -> - let _,path = depend [] [] (history ()) in - if !display_action_flag then display_action display_var path; - (tclTHEN prelude (replay_history tactic_normalisation path)) - end else begin - try - let path = simplify_strong (new_id,new_var_num,display_var) system in - if !display_action_flag then display_action display_var path; - tclTHEN prelude (replay_history tactic_normalisation path) - with NO_CONTRADICTION as e -> - let _, info = Exninfo.capture e in - tclZEROMSG ~info (Pp.str"Omega can't solve this system") - end - end - -let coq_omega = coq_omega - -let nat_inject = - Proofview.Goal.enter begin fun gl -> - let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in - let rec explore p t : unit Proofview.tactic = - Proofview.tclEVARMAP >>= fun sigma -> - try match destructurate_term sigma t with - | Kapp(Plus,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_plus),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) - ] - | Kapp(Mult,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_mult),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) - ] - | Kapp(Minus,[t1;t2]) -> - let id = new_identifier () in - tclTHENS - (tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intro_mustbe_force id)) - [ - tclTHENLIST [ - (clever_rewrite_gen p - (mk_minus (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); - (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) ]; - (tclTHEN - (clever_rewrite_gen p (mk_integer zero) - ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) - (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) - ] - | Kapp(S,[t']) -> - let rec is_number t = - try match destructurate_term sigma t with - Kapp(S,[t]) -> is_number t - | Kapp(O,[]) -> true - | _ -> false - with e when noncritical e -> false - in - let rec loop p t : unit Proofview.tactic = - try match destructurate_term sigma t with - Kapp(S,[t]) -> - (tclTHEN - (clever_rewrite_gen p - (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t])) - (loop (P_APP 1 :: p) t)) - | _ -> explore p t - with e when noncritical e -> explore p t - in - if is_number t' then focused_simpl p else loop p t - | Kapp(Pred,[t]) -> - let t_minus_one = - mkApp (Lazy.force coq_minus, [| t; - mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in - tclTHEN - (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one - ((Lazy.force coq_pred_of_minus),[t])) - (explore p t_minus_one) - | Kapp(O,[]) -> focused_simpl p - | _ -> Proofview.tclUNIT () - with e when noncritical e -> Proofview.tclUNIT () - - and loop = function - | [] -> Proofview.tclUNIT () - | (i,t)::lit -> - Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma t with - Kapp(Le,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Lt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Ge,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Gt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Neq,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Eq,[typ;t1;t2]) -> - if is_conv typ (Lazy.force coq_nat) then - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 2; P_TYPE] t1); - (explore [P_APP 3; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - else loop lit - | _ -> loop lit - with e when noncritical e -> loop lit end - in - let hyps_types = Tacmach.New.pf_hyps_types gl in - loop (List.rev hyps_types) - end - -let dec_binop = function - | Zne -> coq_dec_Zne - | Zle -> coq_dec_Zle - | Zlt -> coq_dec_Zlt - | Zge -> coq_dec_Zge - | Zgt -> coq_dec_Zgt - | Le -> coq_dec_le - | Lt -> coq_dec_lt - | Ge -> coq_dec_ge - | Gt -> coq_dec_gt - | _ -> raise Not_found - -let not_binop = function - | Zne -> coq_not_Zne - | Zle -> coq_Znot_le_gt - | Zlt -> coq_Znot_lt_ge - | Zge -> coq_Znot_ge_lt - | Zgt -> coq_Znot_gt_le - | Le -> coq_not_le - | Lt -> coq_not_lt - | Ge -> coq_not_ge - | Gt -> coq_not_gt - | _ -> raise Not_found - -(** A decidability check : for some [t], could we build a term - of type [decidable t] (i.e. [t\/~t]) ? Otherwise, we raise - [Undecidable]. Note that a successful check implies that - [t] has type Prop. -*) - -exception Undecidable - -let rec decidability env sigma t = - match destructurate_prop sigma t with - | Kapp(Or,[t1;t2]) -> - mkApp (Lazy.force coq_dec_or, [| t1; t2; - decidability env sigma t1; decidability env sigma t2 |]) - | Kapp(And,[t1;t2]) -> - mkApp (Lazy.force coq_dec_and, [| t1; t2; - decidability env sigma t1; decidability env sigma t2 |]) - | Kapp(Iff,[t1;t2]) -> - mkApp (Lazy.force coq_dec_iff, [| t1; t2; - decidability env sigma t1; decidability env sigma t2 |]) - | Kimp(t1,t2) -> - (* This is the only situation where it's not obvious that [t] - is in Prop. The recursive call on [t2] will ensure that. *) - mkApp (Lazy.force coq_dec_imp, - [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) - | Kapp(Not,[t1]) -> - mkApp (Lazy.force coq_dec_not, [| t1; decidability env sigma t1 |]) - | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type env sigma typ with - | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) - | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) - | _ -> raise Undecidable - end - | Kapp(op,[t1;t2]) -> - (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |]) - with Not_found -> raise Undecidable) - | Kapp(False,[]) -> Lazy.force coq_dec_False - | Kapp(True,[]) -> Lazy.force coq_dec_True - | _ -> raise Undecidable - -let fresh_id avoid id gl = - fresh_id_in_env avoid id (Proofview.Goal.env gl) - -let onClearedName id tac = - (* We cannot ensure that hyps can be cleared (because of dependencies), *) - (* so renaming may be necessary *) - tclTHEN - (tclTRY (clear [id])) - (Proofview.Goal.enter begin fun gl -> - let id = fresh_id Id.Set.empty id gl in - tclTHEN (introduction id) (tac id) - end) - -let onClearedName2 id tac = - tclTHEN - (tclTRY (clear [id])) - (Proofview.Goal.enter begin fun gl -> - let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in - let id2 = fresh_id (Id.Set.singleton id1) (add_suffix id "_right") gl in - tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] - end) - -let destructure_hyps = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let decidability = decidability env sigma in - let rec loop = function - | [] -> (tclTHEN nat_inject coq_omega) - | LocalDef (i,body,typ) :: lit when !letin_flag -> - Proofview.tclEVARMAP >>= fun sigma -> - begin - try - match destructurate_type env sigma typ with - | Kapp(Nat,_) | Kapp(Z,_) -> - let hid = fresh_id Id.Set.empty (add_suffix i.binder_name "_eqn") gl in - let hty = mk_gen_eq typ (mkVar i.binder_name) body in - tclTHEN - (assert_by (Name hid) hty reflexivity) - (loop (LocalAssum (make_annot hid Sorts.Relevant, hty) :: lit)) - | _ -> loop lit - with e when noncritical e -> loop lit - end - | decl :: lit -> (* variable without body (or !letin_flag isn't set) *) - let i = NamedDecl.get_id decl in - Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma (NamedDecl.get_type decl) with - | Kapp(False,[]) -> elim_id i - | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit - | Kapp(Or,[t1;t2]) -> - (tclTHENS - (elim_id i) - [ onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t1)::lit))); - onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t2)::lit))) ]) - | Kapp(And,[t1;t2]) -> - tclTHEN - (elim_id i) - (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (make_annot i1 Sorts.Relevant,t1) :: - LocalAssum (make_annot i2 Sorts.Relevant,t2) :: lit))) - | Kapp(Iff,[t1;t2]) -> - tclTHEN - (elim_id i) - (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (make_annot i1 Sorts.Relevant,mkArrow t1 Sorts.Relevant t2) :: - LocalAssum (make_annot i2 Sorts.Relevant,mkArrow t2 Sorts.Relevant t1) :: lit))) - | Kimp(t1,t2) -> - (* t1 and t2 might be in Type rather than Prop. - For t1, the decidability check will ensure being Prop. *) - if Termops.is_Prop sigma (Retyping.get_type_of env sigma t2) - then - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; d1; mkVar i|])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) t2) :: lit)))) - ] - else - loop lit - | Kapp(Not,[t]) -> - begin match destructurate_prop sigma t with - Kapp(Or,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and (mk_not t1) (mk_not t2)) :: lit)))) - ] - | Kapp(And,[t1;t2]) -> - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_and, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) (mk_not t2)) :: lit)))) - ] - | Kapp(Iff,[t1;t2]) -> - let d1 = decidability t1 in - let d2 = decidability t2 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_iff, - [| t1; t2; d1; d2; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_and t1 (mk_not t2)) - (mk_and (mk_not t1) t2)) :: lit)))) - ] - | Kimp(t1,t2) -> - (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. - For t1, being decidable implies being Prop. *) - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> - (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and t1 (mk_not t2)) :: lit)))) - ] - | Kapp(Not,[t]) -> - let d = decidability t in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t) :: lit)))) - ] - | Kapp(op,[t1;t2]) -> - (try - let thm = not_binop op in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - with Not_found -> loop lit) - | Kapp(Eq,[typ;t1;t2]) -> - if !old_style_flag then begin - match destructurate_type env sigma typ with - | Kapp(Nat,_) -> - tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Z,_) -> - tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) - ] - | _ -> loop lit - end else begin - match destructurate_type env sigma typ with - | Kapp(Nat,_) -> - (tclTHEN - (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) - decl)) - (loop lit)) - | Kapp(Z,_) -> - (tclTHEN - (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) - decl)) - (loop lit)) - | _ -> loop lit - end - | _ -> loop lit - end - | _ -> loop lit - with - | Undecidable -> loop lit - | e when noncritical e -> loop lit - end - in - let hyps = Proofview.Goal.hyps gl in - loop hyps - end - -let destructure_goal = - Proofview.Goal.enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let decidability = decidability env sigma in - let rec loop t = - Proofview.tclEVARMAP >>= fun sigma -> - let prop () = Proofview.tclUNIT (destructurate_prop sigma t) in - Proofview.V82.wrap_exceptions prop >>= fun prop -> - match prop with - | Kapp(Not,[t]) -> - (tclTHEN - (tclTHEN (unfold sp_not) intro) - destructure_hyps) - | Kimp(a,b) -> (tclTHEN intro (loop b)) - | Kapp(False,[]) -> destructure_hyps - | _ -> - let goal_tac = - try - let dec = decidability t in - tclTHEN - (Proofview.Goal.enter begin fun gl -> - refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) - end) - intro - with Undecidable -> Tactics.elim_type (Lazy.force coq_False) - | e when Proofview.V82.catchable_exception e -> - let e, info = Exninfo.capture e in - Proofview.tclZERO ~info e - in - tclTHEN goal_tac destructure_hyps - in - (loop concl) - end - -let destructure_goal = destructure_goal - -let warn_omega_is_deprecated = - let name = "omega-is-deprecated" in - let category = "deprecated" in - CWarnings.create ~name ~category (fun () -> - Pp.str "omega is deprecated since 8.12; use “lia” instead.") - -let omega_solver = - Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) - warn_omega_is_deprecated (); - Coqlib.check_required_library ["Coq";"omega";"Omega"]; - reset_all (); - destructure_goal diff --git a/plugins/omega/coq_omega.mli b/plugins/omega/coq_omega.mli deleted file mode 100644 index e723082803..0000000000 --- a/plugins/omega/coq_omega.mli +++ /dev/null @@ -1,11 +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) *) -(************************************************************************) - -val omega_solver : unit Proofview.tactic diff --git a/plugins/omega/dune b/plugins/omega/dune index a3c9342322..e69de29bb2 100644 --- a/plugins/omega/dune +++ b/plugins/omega/dune @@ -1,7 +0,0 @@ -(library - (name omega_plugin) - (public_name coq-core.plugins.omega) - (synopsis "Coq's omega plugin") - (libraries coq-core.plugins.ltac)) - -(coq.pp (modules g_omega)) diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg deleted file mode 100644 index 888a62b2bc..0000000000 --- a/plugins/omega/g_omega.mlg +++ /dev/null @@ -1,29 +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) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - - -DECLARE PLUGIN "omega_plugin" - -{ - -open Ltac_plugin - -} - -TACTIC EXTEND omega -| [ "omega" ] -> { Coq_omega.omega_solver } -END diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml deleted file mode 100644 index 24cd342e42..0000000000 --- a/plugins/omega/omega.ml +++ /dev/null @@ -1,708 +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) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(* 13/10/2002 : modified to cope with an external numbering of equations *) -(* and hypothesis. Its use for Omega is not more complex and it makes *) -(* things much simpler for the reflexive version where we should limit *) -(* the number of source of numbering. *) -(**************************************************************************) - -module type INT = sig - type bigint - val equal : bigint -> bigint -> bool - val less_than : bigint -> bigint -> bool - val add : bigint -> bigint -> bigint - val sub : bigint -> bigint -> bigint - val mult : bigint -> bigint -> bigint - val euclid : bigint -> bigint -> bigint * bigint - val neg : bigint -> bigint - val zero : bigint - val one : bigint - val to_string : bigint -> string -end - -let debug = ref false - -module MakeOmegaSolver (I:INT) = struct - -type bigint = I.bigint -let (=?) = I.equal -let (<?) = I.less_than -let (<=?) x y = I.less_than x y || x = y -let (>?) x y = I.less_than y x -let (>=?) x y = I.less_than y x || x = y -let (+) = I.add -let (-) = I.sub -let ( * ) = I.mult -let (/) x y = fst (I.euclid x y) -let (mod) x y = snd (I.euclid x y) -let zero = I.zero -let one = I.one -let two = one + one -let negone = I.neg one -let abs x = if I.less_than x zero then I.neg x else x -let string_of_bigint = I.to_string -let neg = I.neg - -(* To ensure that polymorphic (<) is not used mistakenly on big integers *) -(* Warning: do not use (=) either on big int *) -let (<) = ((<) : int -> int -> bool) -let (>) = ((>) : int -> int -> bool) -let (<=) = ((<=) : int -> int -> bool) -let (>=) = ((>=) : int -> int -> bool) - -let pp i = print_int i; print_newline (); flush stdout - -let push v l = l := v :: !l - -let rec pgcd x y = if y =? zero then x else pgcd y (x mod y) - -let pgcd_l = function - | [] -> failwith "pgcd_l" - | x :: l -> List.fold_left pgcd x l - -let floor_div a b = - match a >=? zero , b >? zero with - | true,true -> a / b - | false,false -> a / b - | true, false -> (a-one) / b - one - | false,true -> (a+one) / b - one - -type coeff = {c: bigint ; v: int} - -type linear = coeff list - -type eqn_kind = EQUA | INEQ | DISE - -type afine = { - (* a number uniquely identifying the equation *) - id: int ; - (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) - kind: eqn_kind; - (* the variables and their coefficient *) - body: coeff list; - (* a constant *) - constant: bigint } - -type state_action = { - st_new_eq : afine; - st_def : afine; (* /!\ this represents [st_def = st_var] *) - st_orig : afine; - st_coef : bigint; - st_var : int } - -type action = - | DIVIDE_AND_APPROX of afine * afine * bigint * bigint - | NOT_EXACT_DIVIDE of afine * bigint - | FORGET_C of int - | EXACT_DIVIDE of afine * bigint - | SUM of int * (bigint * afine) * (bigint * afine) - | STATE of state_action - | HYP of afine - | FORGET of int * int - | FORGET_I of int * int - | CONTRADICTION of afine * afine - | NEGATE_CONTRADICT of afine * afine * bool - | MERGE_EQ of int * afine * int - | CONSTANT_NOT_NUL of int * bigint - | CONSTANT_NUL of int - | CONSTANT_NEG of int * bigint - | SPLIT_INEQ of afine * (int * action list) * (int * action list) - | WEAKEN of int * bigint - -exception UNSOLVABLE - -exception NO_CONTRADICTION - -let display_eq print_var (l,e) = - let _ = - List.fold_left - (fun not_first f -> - print_string - (if f.c <? zero then "- " else if not_first then "+ " else ""); - let c = abs f.c in - if c =? one then - Printf.printf "%s " (print_var f.v) - else - Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); - true) - false l - in - if e >? zero then - Printf.printf "+ %s " (string_of_bigint e) - else if e <? zero then - Printf.printf "- %s " (string_of_bigint (abs e)) - -let rec trace_length l = - let action_length accu = function - | SPLIT_INEQ (_,(_,l1),(_,l2)) -> - accu + one + trace_length l1 + trace_length l2 - | _ -> accu + one in - List.fold_left action_length zero l - -let operator_of_eq = function - | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" - -let kind_of = function - | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" - -let display_system print_var l = - List.iter - (fun { kind=b; body=e; constant=c; id=id} -> - Printf.printf "E%d: " id; - display_eq print_var (e,c); - Printf.printf "%s 0\n" (operator_of_eq b)) - l; - print_string "------------------------\n\n" - -let display_inequations print_var l = - List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; - print_string "------------------------\n\n" - -let sbi = string_of_bigint - -let rec display_action print_var = function - | act :: l -> begin match act with - | DIVIDE_AND_APPROX (e1,e2,k,d) -> - Printf.printf - "Inequation E%d is divided by %s and the constant coefficient is \ - rounded by subtracting %s.\n" e1.id (sbi k) (sbi d) - | NOT_EXACT_DIVIDE (e,k) -> - Printf.printf - "Constant in equation E%d is not divisible by the pgcd \ - %s of its other coefficients.\n" e.id (sbi k) - | EXACT_DIVIDE (e,k) -> - Printf.printf - "Equation E%d is divided by the pgcd \ - %s of its coefficients.\n" e.id (sbi k) - | WEAKEN (e,k) -> - Printf.printf - "To ensure a solution in the dark shadow \ - the equation E%d is weakened by %s.\n" e (sbi k) - | SUM (e,(c1,e1),(c2,e2)) -> - Printf.printf - "We state %s E%d = %s %s E%d + %s %s E%d.\n" - (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) - (kind_of e2.kind) e2.id - | STATE { st_new_eq = e } -> - Printf.printf "We define a new equation E%d: " e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0" - | HYP e -> - Printf.printf "We define E%d: " e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0\n" - | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e - | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 - | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 - | MERGE_EQ (e,e1,e2) -> - Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e - | CONTRADICTION (e1,e2) -> - Printf.printf - "Equations E%d and E%d imply a contradiction on their \ - constant factors.\n" e1.id e2.id - | NEGATE_CONTRADICT(e1,e2,b) -> - Printf.printf - "Equations E%d and E%d state that their body is at the same time \ - equal and different\n" e1.id e2.id - | CONSTANT_NOT_NUL (e,k) -> - Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) - | CONSTANT_NEG(e,k) -> - Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) - | CONSTANT_NUL e -> - Printf.printf "Inequation E%d states 0 != 0.\n" e - | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> - Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; - display_action print_var l1; - print_newline (); - display_action print_var l2; - print_newline () - end; display_action print_var l - | [] -> - flush stdout - -let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) - -(*""*) -let add_event, history, clear_history = - let accu = ref [] in - (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), - (fun () -> !accu), - (fun () -> accu := []) - -let nf_linear = List.sort (fun x y -> Util.(-) y.v x.v) - -let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) - -let map_eq_linear f = - let rec loop = function - | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l - | [] -> [] - in - loop - -let map_eq_afine f e = - { id = e.id; kind = e.kind; body = map_eq_linear f e.body; - constant = f e.constant } - -let negate_eq = map_eq_afine (fun x -> neg x) - -let rec sum p0 p1 = match (p0,p1) with - | ([], l) -> l | (l, []) -> l - | (((x1::l1) as l1'), ((x2::l2) as l2')) -> - if x1.v = x2.v then - let c = x1.c + x2.c in - if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 - else if x1.v > x2.v then - x1 :: sum l1 l2' - else - x2 :: sum l1' l2 - -let sum_afine new_eq_id eq1 eq2 = - { kind = eq1.kind; id = new_eq_id (); - body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } - -exception FACTOR1 - -let rec chop_factor_1 = function - | x :: l -> - if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') - | [] -> raise FACTOR1 - -exception CHOPVAR - -let rec chop_var v = function - | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l') - | [] -> raise CHOPVAR - -let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = - if e = [] then begin - match eq_flag with - | EQUA -> - if x =? zero then [] else begin - add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE - end - | DISE -> - if x <> zero then [] else begin - add_event (CONSTANT_NUL id); raise UNSOLVABLE - end - | INEQ -> - if x >=? zero then [] else begin - add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE - end - end else - let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in - if eq_flag=EQUA && x mod gcd <> zero then begin - add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE - end else if eq_flag=DISE && x mod gcd <> zero then begin - add_event (FORGET_C eq.id); [] - end else if gcd <> one then begin - let c = floor_div x gcd in - let d = x - c * gcd in - let new_eq = {id=id; kind=eq_flag; constant=c; - body=map_eq_linear (fun c -> c / gcd) e} in - add_event (if eq_flag=EQUA || eq_flag = DISE then EXACT_DIVIDE(eq,gcd) - else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); - [new_eq] - end else [eq] - -let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 - ({body=e1; constant=c1} as eq1) = - try - let (f,_) = chop_var v e1 in - let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c - else failwith "eliminate_with_in" in - let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in - add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res - with CHOPVAR -> eq1 - -let omega_mod a b = a - b * floor_div (two * a + b) (two * b) -let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = - let e = original.body in - let sigma = new_var_id () in - if e == [] then begin - display_system print_var [original] ; failwith "TL" - end; - let smallest,var = - List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p)) - (abs (List.hd e).c, (List.hd e).v) (List.tl e) - in - let m = smallest + one in - let new_eq = - { constant = omega_mod original.constant m; - body = {c= neg m;v=sigma} :: - map_eq_linear (fun a -> omega_mod a m) original.body; - id = new_eq_id (); kind = EQUA } in - let definition = - { constant = neg (floor_div (two * original.constant + m) (two * m)); - body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m))) - original.body; - id = new_eq_id (); kind = EQUA } in - add_event (STATE {st_new_eq = new_eq; st_def = definition; - st_orig = original; st_coef = m; st_var = sigma}); - let new_eq = List.hd (normalize new_eq) in - let eliminated_var, def = chop_var var new_eq.body in - let other_equations = - Util.List.map_append - (fun e -> - normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in - let inequations = - Util.List.map_append - (fun e -> - normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in - let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in - let mod_original = map_eq_afine (fun c -> c / m) original' in - add_event (EXACT_DIVIDE (original',m)); - List.hd (normalize mod_original),other_equations,inequations - -let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = - if !debug then display_system print_var (e::other); - try - let v,def = chop_factor_1 e.body in - (Util.List.map_append - (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, - Util.List.map_append - (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs) - with FACTOR1 -> - eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs) - -let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = - let rec fst_eq_1 = function - (eq::l) -> - if List.exists (fun x -> abs x.c =? one) eq.body then eq,l - else let (eq',l') = fst_eq_1 l in (eq',eq::l') - | [] -> raise Not_found in - match sys_eq with - [] -> if !debug then display_system print_var sys_ineq; sys_ineq - | (e1::rest) -> - let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in - if eq.body = [] then - if eq.constant =? zero then begin - add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) - end else begin - add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE - end - else - banerjee new_ids - (eliminate_one_equation new_ids (eq,other,sys_ineq)) - -type kind = INVERTED | NORMAL - -let redundancy_elimination new_eq_id system = - let normal = function - ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED - | e -> e,NORMAL in - let table = Hashtbl.create 7 in - List.iter - (fun e -> - let ({body=ne} as nx) ,kind = normal e in - if ne = [] then - if nx.constant <? zero then begin - add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE - end else add_event (FORGET_C nx.id) - else - try - let (optnormal,optinvert) = Hashtbl.find table ne in - let final = - if kind = NORMAL then begin - match optnormal with - Some v -> - let kept = - if v.constant <? nx.constant - then begin add_event (FORGET (v.id,nx.id));v end - else begin add_event (FORGET (nx.id,v.id));nx end in - (Some(kept),optinvert) - | None -> Some nx,optinvert - end else begin - match optinvert with - Some v -> - let _kept = - if v.constant >? nx.constant - then begin add_event (FORGET_I (v.id,nx.id));v end - else begin add_event (FORGET_I (nx.id,v.id));nx end in - (optnormal,Some(if v.constant >? nx.constant then v else nx)) - | None -> optnormal,Some nx - end in - begin match final with - (Some high, Some low) -> - if high.constant <? low.constant then begin - add_event(CONTRADICTION (high,negate_eq low)); - raise UNSOLVABLE - end - | _ -> () end; - Hashtbl.remove table ne; - Hashtbl.add table ne final - with Not_found -> - Hashtbl.add table ne - (if kind = NORMAL then (Some nx,None) else (None,Some nx))) - system; - let accu_eq = ref [] in - let accu_ineq = ref [] in - Hashtbl.iter - (fun p0 p1 -> match (p0,p1) with - | (e, (Some x, Some y)) when x.constant =? y.constant -> - let id=new_eq_id () in - add_event (MERGE_EQ(id,x,y.id)); - push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq - | (e, (optnorm,optinvert)) -> - begin match optnorm with - Some x -> push x accu_ineq | _ -> () end; - begin match optinvert with - Some x -> push (negate_eq x) accu_ineq | _ -> () end) - table; - !accu_eq,!accu_ineq - -exception SOLVED_SYSTEM - -let select_variable system = - let table = Hashtbl.create 7 in - let push v c= - try let r = Hashtbl.find table v in r := max !r (abs c) - with Not_found -> Hashtbl.add table v (ref (abs c)) in - List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; - let vmin,cmin = ref (-1), ref zero in - let var_cpt = ref 0 in - Hashtbl.iter - (fun v ({contents = c}) -> - incr var_cpt; - if c <? !cmin || !vmin = (-1) then begin vmin := v; cmin := c end) - table; - if !var_cpt < 1 then raise SOLVED_SYSTEM; - !vmin - -let classify v system = - List.fold_left - (fun (not_occ,below,over) eq -> - try let f,eq' = chop_var v eq.body in - if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) - else (not_occ,below,((neg f.c,eq) :: over)) - with CHOPVAR -> (eq::not_occ,below,over)) - ([],[],[]) system - -let product new_eq_id dark_shadow low high = - List.fold_left - (fun accu (a,eq1) -> - List.fold_left - (fun accu (b,eq2) -> - let eq = - sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) - (map_eq_afine (fun c -> c * a) eq2) in - add_event(SUM(eq.id,(b,eq1),(a,eq2))); - match normalize eq with - | [eq] -> - let final_eq = - if dark_shadow then - let delta = (a - one) * (b - one) in - add_event(WEAKEN(eq.id,delta)); - {id = eq.id; kind=INEQ; body = eq.body; - constant = eq.constant - delta} - else eq - in final_eq :: accu - | (e::_) -> failwith "Product dardk" - | [] -> accu) - accu high) - [] low - -let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = - let v = select_variable system in - let (ineq_out, ineq_low,ineq_high) = classify v system in - let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in - if !debug then display_system print_var expanded; expanded - -let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = - if List.exists (fun e -> e.kind = DISE) system then - failwith "disequation in simplify"; - clear_history (); - List.iter (fun e -> add_event (HYP e)) system; - let system = Util.List.map_append normalize system in - let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in - let system = (eqs @ simp_eq,simp_ineq) in - let rec loop1a system = - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq - and loop1b sys_ineq = - let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in - if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) - in - let rec loop2 system = - try - let expanded = fourier_motzkin new_ids dark_shadow system in - loop2 (loop1b expanded) - with SOLVED_SYSTEM -> - if !debug then display_system print_var system; system - in - loop2 (loop1a system) - -let rec depend relie_on accu = function - | act :: l -> - begin match act with - | DIVIDE_AND_APPROX (e,_,_,_) -> - if Int.List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | EXACT_DIVIDE (e,_) -> - if Int.List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | WEAKEN (e,_) -> - if Int.List.mem e relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | SUM (e,(_,e1),(_,e2)) -> - if Int.List.mem e relie_on then - depend (e1.id::e2.id::relie_on) (act::accu) l - else - depend relie_on accu l - | STATE {st_new_eq=e;st_orig=o} -> - if Int.List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l - else depend relie_on accu l - | HYP e -> - if Int.List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | FORGET_C _ -> depend relie_on accu l - | FORGET _ -> depend relie_on accu l - | FORGET_I _ -> depend relie_on accu l - | MERGE_EQ (e,e1,e2) -> - if Int.List.mem e relie_on then - depend (e1.id::e2::relie_on) (act::accu) l - else - depend relie_on accu l - | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l - | CONTRADICTION (e1,e2) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l - | NEGATE_CONTRADICT (e1,e2,_) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | SPLIT_INEQ _ -> failwith "depend" - end - | [] -> relie_on, accu - -let negation (eqs,ineqs) = - let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in - let normal = function - | ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED - | e -> e,NORMAL in - let table = Hashtbl.create 7 in - List.iter (fun e -> - let {body=ne;constant=c} ,kind = normal e in - Hashtbl.add table (ne,c) (kind,e)) diseq; - List.iter (fun e -> - assert (e.kind = EQUA); - let {body=ne;constant=c},kind = normal e in - try - let (kind',e') = Hashtbl.find table (ne,c) in - add_event (NEGATE_CONTRADICT (e,e',kind=kind')); - raise UNSOLVABLE - with Not_found -> ()) eqs - -exception FULL_SOLUTION of action list * int list - -let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = - clear_history (); - List.iter (fun e -> add_event (HYP e)) system; - (* Initial simplification phase *) - let rec loop1a system = - negation system; - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq - and loop1b sys_ineq = - let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in - if simp_eq = [] then dise @ simp_ineq - else loop1a (simp_eq,dise @ simp_ineq) - in - let rec loop2 system = - try - let expanded = fourier_motzkin new_ids false system in - loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system print_var system; system - in - let rec explode_diseq = function - | (de::diseq,ineqs,expl_map) -> - let id1 = new_eq_id () - and id2 = new_eq_id () in - let e1 = - {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear neg de.body; - constant = neg de.constant - one} in - let new_sys = - List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) - ineqs @ - List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) - ineqs - in - explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) - | ([],ineqs,expl_map) -> ineqs,expl_map - in - try - let system = Util.List.map_append normalize system in - let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in - let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in - let system = (eqs @ simp_eq,simp_ineq @ dise) in - let system' = loop1a system in - let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in - let first_segment = history () in - let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in - let all_solutions = - List.map - (fun (decomp,sys) -> - clear_history (); - try let _ = loop2 sys in raise NO_CONTRADICTION - with UNSOLVABLE -> - let relie_on,path = depend [] [] (history ()) in - let dc,_ = List.partition (fun (_,id,_) -> Int.List.mem id relie_on) decomp in - let red = List.map (fun (x,_,_) -> x) dc in - (red,relie_on,decomp,path)) - sys_exploded - in - let max_count sys = - let tbl = Hashtbl.create 7 in - let augment x = - try incr (Hashtbl.find tbl x) - with Not_found -> Hashtbl.add tbl x (ref 1) in - let eq = ref (-1) and c = ref 0 in - List.iter (function - | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) - | (l,_,_,_) -> List.iter augment l) sys; - Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; - !eq - in - let rec solve systems = - try - let id = max_count systems in - let rec sign = function - | ((id',_,b)::l) -> if id=id' then b else sign l - | [] -> failwith "solve" in - let s1,s2 = - List.partition (fun (_,_,decomp,_) -> sign decomp) systems in - let remove_int (dep,ro,dc,pa) = - (Util.List.except Int.equal id dep,ro,dc,pa) - in - let s1' = List.map remove_int s1 in - let s2' = List.map remove_int s2 in - let (r1,relie1) = solve s1' - and (r2,relie2) = solve s2' in - let (eq,id1,id2) = Int.List.assoc id explode_map in - [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], - eq.id :: Util.List.union Int.equal relie1 relie2 - with FULL_SOLUTION (x0,x1) -> (x0,x1) - in - let act,relie_on = solve all_solutions in - snd(depend relie_on act first_segment) - with UNSOLVABLE -> snd (depend [] [] (history ())) - -end diff --git a/plugins/omega/omega_plugin.mlpack b/plugins/omega/omega_plugin.mlpack deleted file mode 100644 index df7f1047f2..0000000000 --- a/plugins/omega/omega_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Omega -Coq_omega -G_omega diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 935cef58b9..ad85f68b03 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -46,6 +46,7 @@ open Ssrtacticals open Ssrbwd open Ssrequality open Ssripats +open Libobject (** Ssreflect load check. *) @@ -79,8 +80,39 @@ let ssrtac_entry name = { mltac_index = 0; } -let register_ssrtac name f = - Tacenv.register_ml_tactic (ssrtac_name name) [|f|] +let cache_tactic_notation (_, (key, body, parule)) = + Tacenv.register_alias key body; + Pptactic.declare_notation_tactic_pprule key parule + +type tactic_grammar_obj = KerName.t * Tacenv.alias_tactic * Pptactic.pp_tactic + +let inSsrGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "SsrGrammar") with + load_function = (fun _ -> cache_tactic_notation); + cache_function = cache_tactic_notation; + classify_function = (fun x -> Keep x)} + +let path = MPfile (DirPath.make @@ List.map Id.of_string ["ssreflect"; "ssr"; "Coq"]) + +let register_ssrtac name f prods = + let open Pptactic in + Tacenv.register_ml_tactic (ssrtac_name name) [|f|]; + let map id = Reference (Locus.ArgVar (CAst.make id)) in + let get_id = function + | TacTerm s -> None + | TacNonTerm (_, (_, ido)) -> ido in + let ids = List.map_filter get_id prods in + let tac = TacML (CAst.make (ssrtac_entry name, List.map map ids)) in + let key = KerName.make path (Label.make ("ssrparser_" ^ name)) in + let body = Tacenv.{ alias_args = ids; alias_body = tac; alias_deprecation = None } in + let parule = { + pptac_level = 0; + pptac_prods = prods + } in + let obj () = + Lib.add_anonymous_leaf (inSsrGrammar (key, body, parule)) in + Mltop.declare_cache_obj obj __coq_plugin_name; + key let cast_arg wit v = Taccoerce.Value.cast (Genarg.topwit wit) v @@ -933,7 +965,7 @@ END { let pr_intros sep intrs = - if intrs = [] then mt() else sep () ++ str "=>" ++ pr_ipats intrs + if intrs = [] then mt() else sep () ++ str "=>" ++ sep () ++ pr_ipats intrs let pr_ssrintros _ _ _ = pr_intros mt } @@ -963,15 +995,6 @@ END { -let () = register_ssrtac "tclintros" begin fun args ist -> match args with -| [arg] -> - let arg = cast_arg wit_ssrintrosarg arg in - let tac, intros = arg in - ssrevaltac ist tac <*> tclIPATssr intros -| _ -> assert false -end - - (** Defined identifier *) let pr_ssrfwdid id = pr_spc () ++ pr_id id @@ -1672,20 +1695,28 @@ let _ = add_internal_name (is_tagged perm_tag) { -type ssrargfmt = ArgSsr of string | ArgSep of string + let ssrtac_expr ?loc key args = + TacAlias (CAst.make ?loc (key, (List.map (fun x -> Tacexpr.TacGeneric (None, x)) args))) -let set_pr_ssrtac name prec afmt = (* FIXME *) () (* - let fmt = List.map (function - | ArgSep s -> Egramml.GramTerminal s - | ArgSsr s -> Egramml.GramTerminal s - | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in - let tacname = ssrtac_name name in () *) +let mk_non_term wit id = + let open Pptactic in + TacNonTerm (None, (Extend.Uentry (Genarg.ArgT.Any (Genarg.get_arg_tag wit)), Some id)) -let ssrtac_expr ?loc name args = TacML (CAst.make ?loc (ssrtac_entry name, args)) +let tclintroskey = + let prods = + [ mk_non_term wit_ssrintrosarg (Names.Id.of_string "arg") ] in + let tac = begin fun args ist -> match args with + | [arg] -> + let arg = cast_arg wit_ssrintrosarg arg in + let tac, intros = arg in + ssrevaltac ist tac <*> tclIPATssr intros + | _ -> assert false + end in + register_ssrtac "tclintros" tac prods let tclintros_expr ?loc tac ipats = - let args = [Tacexpr.TacGeneric (None, in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in - ssrtac_expr ?loc "tclintros" args + let args = [in_gen (rawwit wit_ssrintrosarg) (tac, ipats)] in + ssrtac_expr ?loc tclintroskey args } @@ -1768,18 +1799,20 @@ END { -let () = register_ssrtac "tcldo" begin fun args ist -> match args with -| [arg] -> - let arg = cast_arg wit_ssrdoarg arg in - ssrdotac ist arg -| _ -> assert false -end - -let _ = set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] +let tcldokey = + let open Pptactic in + let prods = [ TacTerm "do"; mk_non_term wit_ssrdoarg (Names.Id.of_string "arg") ] in + let tac = begin fun args ist -> match args with + | [arg] -> + let arg = cast_arg wit_ssrdoarg arg in + ssrdotac ist arg + | _ -> assert false + end in + register_ssrtac "tcldo" tac prods let ssrdotac_expr ?loc n m tac clauses = let arg = ((n, m), tac), clauses in - ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (None, in_gen (rawwit wit_ssrdoarg) arg)] + ssrtac_expr ?loc tcldokey [in_gen (rawwit wit_ssrdoarg) arg] } @@ -1815,22 +1848,26 @@ END { -let () = register_ssrtac "tclseq" begin fun args ist -> match args with -| [tac; dir; arg] -> - let tac = cast_arg wit_ssrtclarg tac in - let dir = cast_arg wit_ssrseqdir dir in - let arg = cast_arg wit_ssrseqarg arg in - tclSEQAT ist tac dir arg -| _ -> assert false -end - -let _ = set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] +let tclseqkey = + let prods = + [ mk_non_term wit_ssrtclarg (Names.Id.of_string "tac") + ; mk_non_term wit_ssrseqdir (Names.Id.of_string "dir") + ; mk_non_term wit_ssrseqarg (Names.Id.of_string "arg") ] in + let tac = begin fun args ist -> match args with + | [tac; dir; arg] -> + let tac = cast_arg wit_ssrtclarg tac in + let dir = cast_arg wit_ssrseqdir dir in + let arg = cast_arg wit_ssrseqarg arg in + tclSEQAT ist tac dir arg + | _ -> assert false + end in + register_ssrtac "tclseq" tac prods let tclseq_expr ?loc tac dir arg = let arg1 = in_gen (rawwit wit_ssrtclarg) tac in let arg2 = in_gen (rawwit wit_ssrseqdir) dir in let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in - ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric (None, x)) [arg1; arg2; arg3]) + ssrtac_expr ?loc tclseqkey [arg1; arg2; arg3] } @@ -2453,8 +2490,9 @@ GRAMMAR EXTEND Gram GLOBAL: ltac_expr; ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> - { ssrtac_expr ~loc "abstract" - [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; + { TacML (CAst.make ~loc ( + ssrtac_entry "abstract", [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)])) + } ]]; END TACTIC EXTEND ssrabstract | [ "abstract" ssrdgens(gens) ] -> { diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 7774258fca..805be1fc87 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -22,7 +22,6 @@ open Vars open Libnames open Tactics open Termops -open Recordops open Tacmach open Glob_term open Util @@ -333,7 +332,8 @@ type tpattern = { let all_ok _ _ = true let proj_nparams c = - try 1 + Recordops.find_projection_nparams (GlobRef.ConstRef c) with _ -> 0 + try 1 + Structures.Structure.projection_nparams c + with Not_found -> 0 let isRigid c = match kind c with | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true @@ -429,9 +429,13 @@ let ungen_upat lhs (sigma, uc, t) u = | _ -> KpatRigid in sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} -let nb_cs_proj_args pc f u = +let nb_cs_proj_args ise pc f u = + let open Structures in + let open ValuePattern in let na k = - List.length (snd (lookup_canonical_conversion (Global.env()) (GlobRef.ConstRef pc, k))).o_TCOMPS in + let open CanonicalSolution in + let _, { cvalue_arguments } = find (Global.env()) ise (GlobRef.ConstRef pc, k) in + List.length cvalue_arguments in let nargs_of_proj t = match kind t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be @@ -441,7 +445,7 @@ let nb_cs_proj_args pc f u = | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (Sorts.family s)) | Const (c',_) when Constant.CanOrd.equal c' pc -> nargs_of_proj u.up_f - | Proj (c',_) when Constant.CanOrd.equal (Projection.constant c') pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.CanOrd.equal (Names.Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 @@ -467,7 +471,7 @@ let splay_app ise = | Cast _ | Evar _ -> loop c [| |] | _ -> c, [| |] -let filter_upat i0 f n u fpats = +let filter_upat ise i0 f n u fpats = let na = Array.length u.up_a in if n < na then fpats else let np = match u.up_k with @@ -479,7 +483,7 @@ let filter_upat i0 f n u fpats = | KpatRigid when isRigid f -> na | KpatFlex -> na | KpatProj pc -> - let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np + let np = na + nb_cs_proj_args ise pc f u in if n < np then -1 else np | _ -> -1 in if np < na then fpats else let () = if !i0 < np then i0 := n in (u, np) :: fpats @@ -568,7 +572,7 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = let f, a = splay_app ise c in let i0 = ref (-1) in - let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in + let fpats = List.fold_right (filter_upat ise i0 f (Array.length a)) upats [] in while !i0 >= 0 do let i = !i0 in i0 := -1; let one_match (u, np) = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index e1d6fff3e4..5eb8a88698 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -19,7 +19,7 @@ open Context open Vars open Reduction open Reductionops -open Recordops +open Structures open Evarutil open Evardefine open Evarsolve @@ -230,33 +230,30 @@ let occur_rigidly flags env evd (evk,_) t = projection would have been reduced) *) let check_conv_record env sigma (t1,sk1) (t2,sk2) = + let open ValuePattern in let (proji, u), arg = Termops.global_app_of_constr sigma t1 in - let canon_s,sk2_effective = + let (sigma, solution), sk2_effective = try match EConstr.kind sigma t2 with Prod (_,a,b) -> (* assert (l2=[]); *) let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then - lookup_canonical_conversion env (proji, Prod_cs), + CanonicalSolution.find env sigma (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) else raise Not_found | Sort s -> let s = ESorts.kind sigma s in - lookup_canonical_conversion env + CanonicalSolution.find env sigma (proji, Sort_cs (Sorts.family s)),[] | Proj (p, c) -> - lookup_canonical_conversion env (proji, Proj_cs (Projection.repr p)), Stack.append_app [|c|] sk2 + CanonicalSolution.find env sigma(proji, Proj_cs (Names.Projection.repr p)), Stack.append_app [|c|] sk2 | _ -> let (c2, _) = try destRef sigma t2 with DestKO -> raise Not_found in - lookup_canonical_conversion env (proji, Const_cs c2),sk2 + CanonicalSolution.find env sigma (proji, Const_cs c2),sk2 with Not_found -> - let (c, cs) = lookup_canonical_conversion env (proji,Default_cs) in - (c,cs),[] + CanonicalSolution.find env sigma (proji,Default_cs), [] in - let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; - o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in - let us = List.map EConstr.of_constr us in - let params = List.map EConstr.of_constr params in + let open CanonicalSolution in let params1, c1, extra_args1 = match arg with | Some c -> (* A primitive projection applied to c *) @@ -267,28 +264,19 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = with _ -> raise Not_found in Stack.append_app_list ind_args Stack.empty, c, sk1 | None -> - match Stack.strip_n_app nparams sk1 with + match Stack.strip_n_app solution.nparams sk1 with | Some (params1, c1, extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = - let l_us = List.length us in + let l_us = List.length solution.cvalue_arguments in if Int.equal l_us 0 then Stack.empty,sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - let u, ctx' = UnivGen.fresh_instance_from ctx None in - let subst = Univ.make_inverse_instance_subst u in - let c = EConstr.of_constr c in - let c' = subst_univs_level_constr subst c in - let t' = EConstr.of_constr t' in - let t' = subst_univs_level_constr subst t' in - let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in - let params = List.map (fun c -> subst_univs_level_constr subst c) params in - let us = List.map (fun c -> subst_univs_level_constr subst c) us in - let h, _ = decompose_app_vect sigma t' in - ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), - (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n, Stack.zip sigma (t2,sk2)) + let h, _ = decompose_app_vect sigma solution.body in + sigma,(h, t2),solution.constant,solution.abstractions_ty,(Stack.append_app_list solution.params Stack.empty,params1), + (Stack.append_app_list solution.cvalue_arguments Stack.empty,us2),(extra_args1,extra_args2),c1, + (solution.cvalue_abstraction, Stack.zip sigma (t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -926,7 +914,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty and f2 i = (try if not flags.with_cs then raise Not_found - else conv_record flags env i + else conv_record flags env (try check_conv_record env i appr1 appr2 with Not_found -> check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -989,7 +977,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f3 i = (try if not flags.with_cs then raise Not_found - else conv_record flags env i (check_conv_record env i appr1 appr2) + else conv_record flags env (check_conv_record env i appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = evar_eqappr_x flags env i pbty @@ -1003,7 +991,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f3 i = (try if not flags.with_cs then raise Not_found - else conv_record flags env i (check_conv_record env i appr2 appr1) + else conv_record flags env (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = evar_eqappr_x flags env i pbty appr1 @@ -1113,7 +1101,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | LetIn _, _ -> assert false end -and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = +and conv_record flags env (evd,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = (* Tries to unify the states (proji params1 c1 | sk1) = (proji params2 (c (?xs:bs)) | sk2) @@ -1137,7 +1125,6 @@ and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk had to be initially resolved *) - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape sk1 sk2 then let (evd',ks,_,test) = List.fold_left @@ -1195,13 +1182,6 @@ let evar_conv_x flags = evar_conv_x flags let evar_unify = conv_fun evar_conv_x -(* Profiling *) -let evar_conv_x = - if Flags.profile then - let evar_conv_xkey = CProfile.declare_profile "evar_conv_x" in - CProfile.profile6 evar_conv_xkey evar_conv_x - else evar_conv_x - let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x () let evar_conv_x flags = Hook.get evar_conv_hook_get flags diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index be03ced7eb..965cd7de67 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -78,7 +78,7 @@ val check_problems_are_solved : env -> evar_map -> unit val check_conv_record : env -> evar_map -> state -> state -> - Univ.ContextSet.t * (constr * constr) + evar_map * (constr * constr) * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * constr Stack.t) * (constr Stack.t * constr Stack.t) * constr * diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index cb52e32cd5..4c2fc26b45 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -35,6 +35,7 @@ open Environ open EConstr open Vars open Reductionops +open Structures open Type_errors open Typing open Evarutil @@ -801,8 +802,8 @@ struct in let app_f = match EConstr.kind sigma fj.uj_val with - | Const (p, u) when Recordops.is_primitive_projection p -> - let p = Option.get @@ Recordops.find_primitive_projection p in + | Const (p, u) when PrimitiveProjections.mem p -> + let p = Option.get @@ PrimitiveProjections.find_opt p in let p = Projection.make p false in let npars = Projection.npars p in fun n -> diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index c31ecc135c..980575abac 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -12,7 +12,7 @@ Cbv Find_subterm Evardefine Evarsolve -Recordops +Structures Heads Evarconv Typing diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli deleted file mode 100644 index 83927085e9..0000000000 --- a/pretyping/recordops.mli +++ /dev/null @@ -1,101 +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) *) -(************************************************************************) - -open Names -open Constr - -(** Operations concerning records and canonical structures *) - -(** {6 Records } *) -(** A structure S is a non recursive inductive type with a single - constructor (the name of which defaults to Build_S) *) - -type proj_kind = { - pk_name: Name.t; - pk_true_proj: bool; - pk_canonical: bool; -} - -type struc_typ = { - s_CONST : constructor; - s_EXPECTEDPARAM : int; - s_PROJKIND : proj_kind list; - s_PROJ : Constant.t option list; -} - -val register_structure : struc_typ -> unit -val subst_structure : Mod_subst.substitution -> struc_typ -> struc_typ -val rebuild_structure : Environ.env -> struc_typ -> struc_typ - -(** [lookup_structure isp] returns the struc_typ associated to the - inductive path [isp] if it corresponds to a structure, otherwise - it fails with [Not_found] *) -val lookup_structure : inductive -> struc_typ - -(** [lookup_projections isp] returns the projections associated to the - inductive path [isp] if it corresponds to a structure, otherwise - it fails with [Not_found] *) -val lookup_projections : inductive -> Constant.t option list - -(** raise [Not_found] if not a projection *) -val find_projection_nparams : GlobRef.t -> int - -(** raise [Not_found] if not a projection *) -val find_projection : GlobRef.t -> struc_typ - -val is_projection : Constant.t -> bool - -(** Sets up the mapping from constants to primitive projections *) -val register_primitive_projection : Projection.Repr.t -> Constant.t -> unit - -val is_primitive_projection : Constant.t -> bool - -val find_primitive_projection : Constant.t -> Projection.Repr.t option - -(** {6 Canonical structures } *) -(** A canonical structure declares "canonical" conversion hints between - the effective components of a structure and the projections of the - structure *) - -(** A cs_pattern characterizes the form of a component of canonical structure *) -type cs_pattern = - Const_cs of GlobRef.t - | Proj_cs of Projection.Repr.t - | Prod_cs - | Sort_cs of Sorts.family - | Default_cs - -type obj_typ = { - o_ORIGIN : GlobRef.t; - o_DEF : constr; - o_CTX : Univ.AUContext.t; - o_INJ : int option; (** position of trivial argument *) - o_TABS : constr list; (** ordered *) - o_TPARAMS : constr list; (** ordered *) - o_NPARAMS : int; - o_TCOMPS : constr list } (** ordered *) - -(** Return the form of the component of a canonical structure *) -val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * constr list - -val pr_cs_pattern : cs_pattern -> Pp.t - -type cs = GlobRef.t * inductive - -val lookup_canonical_conversion : Environ.env -> (GlobRef.t * cs_pattern) -> constr * obj_typ -val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> - cs -> unit -val subst_canonical_structure : Mod_subst.substitution -> cs -> cs -val is_open_canonical_projection : - Environ.env -> Evd.evar_map -> EConstr.t -> bool -val canonical_projections : unit -> - ((GlobRef.t * cs_pattern) * obj_typ) list - -val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> cs diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 4083d3bc23..cb576a379a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1038,13 +1038,6 @@ let nf_all env sigma = (********************************************************************) (* Conversion *) (********************************************************************) -(* -let fkey = CProfile.declare_profile "fhnf";; -let fhnf info v = CProfile.profile2 fkey fhnf info v;; - -let fakey = CProfile.declare_profile "fhnf_apply";; -let fhnf_apply info k h a = CProfile.profile4 fakey fhnf_apply info k h a;; -*) let is_transparent e k = match Conv_oracle.get_strategy (Environ.oracle e) k with diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 064990f6bf..cdb86afa1a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -249,17 +249,6 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) | _ -> assert false -(* Profiling *) -(* let get_type_of polyprop lax env sigma c = *) -(* let f,_,_,_ = retype ~polyprop sigma in *) -(* if lax then f env c else anomaly_on_error (f env) c *) - -(* let get_type_of_key = CProfile.declare_profile "get_type_of" *) -(* let get_type_of = CProfile.profile5 get_type_of_key get_type_of *) - -(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) -(* get_type_of polyprop lax env sigma c *) - let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_ = retype ~polyprop sigma in if lax then f env c else anomaly_on_error (f env) c diff --git a/pretyping/recordops.ml b/pretyping/structures.ml index aa862a912e..3ef6e98373 100644 --- a/pretyping/recordops.ml +++ b/pretyping/structures.ml @@ -37,71 +37,67 @@ open Reductionops * the constant realizing this projection (if any). *) -type proj_kind = { - pk_name: Name.t; - pk_true_proj: bool; - pk_canonical: bool; +module Structure = struct + +type projection = { + proj_name : Names.Name.t; + proj_true : bool; + proj_canonical : bool; + proj_body : Names.Constant.t option; +} + +type t = { + name : Names.inductive; + projections : projection list; + nparams : int; } -type struc_typ = { - s_CONST : constructor; - s_EXPECTEDPARAM : int; - s_PROJKIND : proj_kind list; - s_PROJ : Constant.t option list } +let make env name projections = + let nparams = Inductiveops.inductive_nparams env name in + { name; projections; nparams } let structure_table = - Summary.ref (Indmap.empty : struc_typ Indmap.t) ~name:"record-structs" + Summary.ref (Indmap.empty : t Indmap.t) ~name:"record-structs" let projection_table = - Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" + Summary.ref (Cmap.empty : t Cmap.t) ~name:"record-projs" -let register_structure ({ s_CONST = (ind,_); s_PROJ = projs; } as struc) = - structure_table := Indmap.add ind struc !structure_table; +let register ({ name; projections; nparams } as s) = + structure_table := Indmap.add name s !structure_table; projection_table := - List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc)) - projs !projection_table - -let subst_structure subst struc = - let projs' = - (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) - (* the first component of subst_con. *) - List.Smart.map - (Option.Smart.map (subst_constant subst)) - struc.s_PROJ - in - let id' = Globnames.subst_constructor subst struc.s_CONST in - if projs' == struc.s_PROJ && id' == struc.s_CONST - then struc - else { struc with s_CONST = id'; s_PROJ = projs' } + List.fold_right (fun { proj_body } m -> + Option.fold_right (fun proj -> Cmap.add proj s) proj_body m) + projections !projection_table -let rebuild_structure env struc = - let mib = Environ.lookup_mind (fst (fst struc.s_CONST)) env in - let npars = mib.Declarations.mind_nparams in - { struc with s_EXPECTEDPARAM = npars } +let subst subst ({ name; projections; nparams } as s) = + let subst_projection subst ({ proj_body } as p) = + let proj_body = Option.Smart.map (subst_constant subst) proj_body in + if proj_body == p.proj_body then p else + { p with proj_body } in + let projections = List.Smart.map (subst_projection subst) projections in + let name = Mod_subst.subst_ind subst name in + if projections == s.projections && + name == s.name + then s + else { name; projections; nparams } -let lookup_structure indsp = Indmap.find indsp !structure_table +let rebuild env s = + let mib = Environ.lookup_mind (fst s.name) env in + let nparams = mib.Declarations.mind_nparams in + { s with nparams } -let lookup_projections indsp = (lookup_structure indsp).s_PROJ +let find indsp = Indmap.find indsp !structure_table -let find_projection_nparams = function - | GlobRef.ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM - | _ -> raise Not_found +let find_projections indsp = + (find indsp).projections |> + List.map (fun { proj_body } -> proj_body) -let find_projection = function - | GlobRef.ConstRef cst -> Cmap.find cst !projection_table - | _ -> raise Not_found +let find_from_projection cst = Cmap.find cst !projection_table -let is_projection cst = Cmap.mem cst !projection_table +let projection_nparams cst = (Cmap.find cst !projection_table).nparams -let prim_table = - Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" - -let register_primitive_projection p c = - prim_table := Cmap_env.add c p !prim_table - -let is_primitive_projection c = Cmap_env.mem c !prim_table +let is_projection cst = Cmap.mem cst !projection_table -let find_primitive_projection c = - try Some (Cmap_env.find c !prim_table) with Not_found -> None +end (************************************************************************) (*s A canonical structure declares "canonical" conversion hints between *) @@ -142,49 +138,55 @@ type obj_typ = { o_NPARAMS : int; o_TCOMPS : constr list } (* ordered *) -type cs_pattern = +module ValuePattern = struct + +type t = Const_cs of GlobRef.t - | Proj_cs of Projection.Repr.t + | Proj_cs of Names.Projection.Repr.t | Prod_cs | Sort_cs of Sorts.family | Default_cs -let eq_cs_pattern env p1 p2 = match p1, p2 with -| Const_cs gr1, Const_cs gr2 -> Environ.QGlobRef.equal env gr1 gr2 -| Proj_cs p1, Proj_cs p2 -> Environ.QProjection.Repr.equal env p1 p2 -| Prod_cs, Prod_cs -> true -| Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2 -| Default_cs, Default_cs -> true -| _ -> false - -let rec assoc_pat env a = function - | ((pat, t), e) :: xs -> if eq_cs_pattern env pat a then (t, e) else assoc_pat env a xs - | [] -> raise Not_found - - -let object_table = - Summary.ref (GlobRef.Map.empty : ((cs_pattern * constr) * obj_typ) list GlobRef.Map.t) - ~name:"record-canonical-structs" - -let canonical_projections () = - GlobRef.Map.fold (fun x -> List.fold_right (fun ((y,_),c) acc -> ((x,y),c)::acc)) - !object_table [] - -let keep_true_projections projs kinds = - let filter (p, { pk_true_proj ; pk_canonical }) = if pk_true_proj then Some (p, pk_canonical) else None in - List.map_filter filter (List.combine projs kinds) +let equal env p1 p2 = match p1, p2 with + | Const_cs gr1, Const_cs gr2 -> Environ.QGlobRef.equal env gr1 gr2 + | Proj_cs p1, Proj_cs p2 -> Environ.QProjection.Repr.equal env p1 p2 + | Prod_cs, Prod_cs -> true + | Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2 + | Default_cs, Default_cs -> true + | _ -> false -let rec cs_pattern_of_constr env t = +let rec of_constr env t = match kind t with | App (f,vargs) -> - let patt, n, args = cs_pattern_of_constr env f in + let patt, n, args = of_constr env f in patt, n, args @ Array.to_list vargs | Rel n -> Default_cs, Some n, [] | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] - | Proj (p, c) -> Proj_cs (Projection.repr p), None, [c] + | Proj (p, c) -> Proj_cs (Names.Projection.repr p), None, [c] | Sort s -> Sort_cs (Sorts.family s), None, [] | _ -> Const_cs (fst @@ destRef t) , None, [] +let print = function + Const_cs c -> Nametab.pr_global_env Id.Set.empty c + | Proj_cs p -> Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef (Names.Projection.Repr.constant p)) + | Prod_cs -> str "_ -> _" + | Default_cs -> str "_" + | Sort_cs s -> Sorts.pr_sort_family s + +end + +let rec assoc_pat env a = function + | ((pat, t), e) :: xs -> if ValuePattern.equal env pat a then (t, e) else assoc_pat env a xs + | [] -> raise Not_found + +let object_table = + Summary.ref (GlobRef.Map.empty : ((ValuePattern.t * constr) * obj_typ) list GlobRef.Map.t) + ~name:"record-canonical-structs" + +let keep_true_projections projs = + let filter { Structure.proj_true ; proj_canonical; proj_body } = if proj_true then Some (proj_body, proj_canonical) else None in + List.map_filter filter projs + let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" (fun (sign,env,t,ref,proji_sp) -> @@ -213,17 +215,17 @@ let compute_canonical_projections env ~warn (gref,ind) = let t = EConstr.Unsafe.to_constr t in let o_TABS = List.rev_map snd sign in let args = snd (decompose_app t) in - let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = - lookup_structure ind in + let { Structure.nparams = p; projections = lpj } = + Structure.find ind in let o_TPARAMS, projs = List.chop p args in let o_NPARAMS = List.length o_TPARAMS in - let lpj = keep_true_projections lpj kl in + let lpj = keep_true_projections lpj in let nenv = Termops.push_rels_assum sign env in List.fold_left2 (fun acc (spopt, canonical) t -> if canonical then Option.cata (fun proji_sp -> - match cs_pattern_of_constr nenv t with + match ValuePattern.of_constr nenv t with | patt, o_INJ, o_TCOMPS -> ((GlobRef.ConstRef proji_sp, (patt, t)), { o_ORIGIN = gref ; o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) @@ -235,13 +237,6 @@ let compute_canonical_projections env ~warn (gref,ind) = else acc ) [] lpj projs -let pr_cs_pattern = function - Const_cs c -> Nametab.pr_global_env Id.Set.empty c - | Proj_cs p -> Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef (Projection.Repr.constant p)) - | Prod_cs -> str "_ -> _" - | Default_cs -> str "_" - | Sort_cs s -> Sorts.pr_sort_family s - let warn_redundant_canonical_projection = CWarnings.create ~name:"redundant-canonical-projection" ~category:"typechecker" (fun (hd_val,prj,new_can_s,old_can_s) -> @@ -249,26 +244,13 @@ let warn_redundant_canonical_projection = ++ strbrk " by " ++ prj ++ strbrk " in " ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s) -let register_canonical_structure ~warn env sigma o = - compute_canonical_projections env ~warn o |> - List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> - let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in - match assoc_pat env cs_pat l with - | exception Not_found -> - object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table - | _, cs -> - if warn - then - let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in - let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in - let prj = Nametab.pr_global_env Id.Set.empty proj in - let hd_val = pr_cs_pattern cs_pat in - warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) - ) +module Instance = struct -type cs = GlobRef.t * inductive +type t = GlobRef.t * inductive -let subst_canonical_structure subst (gref,ind as obj) = +let repr = fst + +let subst subst (gref,ind as obj) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) match gref with @@ -286,7 +268,7 @@ let error_not_structure ref description = (Id.print (Nametab.basename_of_global ref) ++ str"." ++ spc() ++ description)) -let check_and_decompose_canonical_structure env sigma ref = +let make env sigma ref = let vc = match ref with | GlobRef.ConstRef sp -> @@ -311,17 +293,71 @@ let check_and_decompose_canonical_structure env sigma ref = | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in let s = - try lookup_structure indsp + try Structure.find indsp with Not_found -> error_not_structure ref (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in - let ntrue_projs = List.count (fun { pk_true_proj } -> pk_true_proj) s.s_PROJKIND in - if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then + let ntrue_projs = List.count (fun { Structure.proj_true = x } -> x) s.Structure.projections in + if s.Structure.nparams + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (ref,indsp) -let lookup_canonical_conversion env (proj,pat) = - assoc_pat env pat (GlobRef.Map.find proj !object_table) +let register ~warn env sigma o = + compute_canonical_projections env ~warn o |> + List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> + let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in + match assoc_pat env cs_pat l with + | exception Not_found -> + object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table + | _, cs -> + if warn + then + let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in + let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in + let prj = Nametab.pr_global_env Id.Set.empty proj in + let hd_val = ValuePattern.print cs_pat in + warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) + ) + +end + +(** The canonical solution of a problem (proj,val) is a global + [constant = fun abs : abstractions_ty => body] and + [ body = RecodConstructor params canon_values ] and the canonical value + corresponding to val is [val cvalue_arguments]. + It is possible that val is one of the [abs] abstractions, eg [Default_cs], + and in that case [cvalue_abstraction = Some i] *) + +module CanonicalSolution = struct +type t = { + constant : EConstr.t; + + abstractions_ty : EConstr.t list; + body : EConstr.t; + + nparams : int; + params : EConstr.t list; + cvalue_abstraction : int option; + cvalue_arguments : EConstr.t list; +} + +let find env sigma (proj,pat) = + let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = assoc_pat env pat (GlobRef.Map.find proj !object_table) in + let us = List.map EConstr.of_constr us in + let params = List.map EConstr.of_constr params in + let u, ctx' = UnivGen.fresh_instance_from ctx None in + let subst = Univ.make_inverse_instance_subst u in + let c = EConstr.of_constr c in + let c' = EConstr.Vars.subst_univs_level_constr subst c in + let t' = EConstr.of_constr t' in + let t' = EConstr.Vars.subst_univs_level_constr subst t' in + let bs' = List.map (EConstr.of_constr %> EConstr.Vars.subst_univs_level_constr subst) bs in + let params = List.map (fun c -> EConstr.Vars.subst_univs_level_constr subst c) params in + let us = List.map (fun c -> EConstr.Vars.subst_univs_level_constr subst c) us in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + sigma, { body = t'; constant = c'; abstractions_ty = bs'; nparams; params; cvalue_arguments = us; cvalue_abstraction = n } + let rec get_nth n = function | [] -> raise Not_found @@ -336,12 +372,12 @@ let rec decompose_projection sigma c args = | Cast (c, _, _) -> decompose_projection sigma c args | App (c, arg) -> decompose_projection sigma c (arg :: args) | Const (c, u) -> - let n = find_projection_nparams (GlobRef.ConstRef c) in + let n = Structure.projection_nparams c in (* Check if there is some canonical projection attached to this structure *) let _ = GlobRef.Map.find (GlobRef.ConstRef c) !object_table in get_nth n args | Proj (p, c) -> - let _ = GlobRef.Map.find (GlobRef.ConstRef (Projection.constant p)) !object_table in + let _ = GlobRef.Map.find (GlobRef.ConstRef (Names.Projection.constant p)) !object_table in c | _ -> raise Not_found @@ -355,3 +391,44 @@ let is_open_canonical_projection env sigma c = not (isConstruct sigma hd) with Failure _ -> false with Not_found -> false + +end + +module CSTable = struct + +type entry = { + projection : Names.GlobRef.t; + value : ValuePattern.t; + solution : Names.GlobRef.t; +} + +let canonical_entry_of_object projection ((value,_), { o_ORIGIN = solution }) = + { projection; value; solution } + +let entries () = + GlobRef.Map.fold (fun p ol acc -> + List.fold_right (fun o acc -> canonical_entry_of_object p o :: acc) ol acc) + !object_table [] + +let entries_for ~projection:p = + try + GlobRef.Map.find p !object_table |> + List.map (canonical_entry_of_object p) + with Not_found -> [] + +end + +module PrimitiveProjections = struct + +let prim_table = + Summary.ref (Cmap_env.empty : Names.Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" + +let register p c = + prim_table := Cmap_env.add c p !prim_table + +let mem c = Cmap_env.mem c !prim_table + +let find_opt c = + try Some (Cmap_env.find c !prim_table) with Not_found -> None + +end diff --git a/pretyping/structures.mli b/pretyping/structures.mli new file mode 100644 index 0000000000..05b21b1033 --- /dev/null +++ b/pretyping/structures.mli @@ -0,0 +1,162 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + + +(** A structure S is a non recursive inductive type with a single + constructor *) +module Structure : sig + +(** A projection to a structure field *) +type projection = { + proj_name : Names.Name.t; (** field name *) + proj_true : bool; (** false for primitive records *) + proj_canonical : bool; (** false = not to be used for CS inference *) + proj_body : Names.Constant.t option; (** the projection function *) +} + +type t = { + name : Names.inductive; + projections : projection list; + nparams : int; +} + +val make : Environ.env -> Names.inductive -> projection list -> t + +val register : t -> unit +val subst : Mod_subst.substitution -> t -> t + +(** refreshes nparams, e.g. after section discharging *) +val rebuild : Environ.env -> t -> t + +(** [find isp] returns the Structure.t associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val find : Names.inductive -> t + +(** raise [Not_found] if not a structure projection *) +val find_from_projection : Names.Constant.t -> t + +(** [lookup_projections isp] returns the projections associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val find_projections : Names.inductive -> Names.Constant.t option list + +(** raise [Not_found] if not a projection *) +val projection_nparams : Names.Constant.t -> int + +val is_projection : Names.Constant.t -> bool + +end + +(** A canonical instance declares "canonical" conversion hints between + the effective components of a structure and the projections of the + structure *) +module Instance : sig + +type t + +(** Process a record instance, checkig it can be registered as canonical. + The record type must be declared as a canonical Structure.t beforehand. *) +val make : Environ.env -> Evd.evar_map -> Names.GlobRef.t -> t + +(** Register an instance as canonical *) +val register : warn:bool -> Environ.env -> Evd.evar_map -> t -> unit + +val subst : Mod_subst.substitution -> t -> t +val repr : t -> Names.GlobRef.t + +end + + +(** A ValuePattern.t characterizes the form of a component of canonical + instance and is used to query the data base of canonical instances *) +module ValuePattern : sig + +type t = + | Const_cs of Names.GlobRef.t + | Proj_cs of Names.Projection.Repr.t + | Prod_cs + | Sort_cs of Sorts.family + | Default_cs + +val equal : Environ.env -> t -> t -> bool +val print : t -> Pp.t + +(** Return the form of the component of a canonical structure *) +val of_constr : Environ.env -> Constr.t -> t * int option * Constr.t list + +end + + +(** The canonical solution of a problem (proj,val) is a global + [constant = fun abs : abstractions_ty => body] and + [body = RecodConstructor params canon_values] and the canonical value + corresponding to val is [val cvalue_arguments]. + It is possible that val is one of the [abs] abstractions, eg [Default_cs], + and in that case [cvalue_abstraction = Some i] *) +module CanonicalSolution : sig + +type t = { + constant : EConstr.t; + + abstractions_ty : EConstr.t list; + body : EConstr.t; + + nparams : int; + params : EConstr.t list; + cvalue_abstraction : int option; + cvalue_arguments : EConstr.t list; +} + +(** [find (p,v)] returns a s such that p s = v. + The solution s gets a fresh universe instance and is decomposed into + bits for consumption by evarconv. Can raise [Not_found] on failure *) +val find : + Environ.env -> Evd.evar_map -> (Names.GlobRef.t * ValuePattern.t) -> + Evd.evar_map * t + +(** [is_open_canonical_projection env sigma t] is true if t is a FieldName + applied to term which is not a constructor. Used by evarconv not to + unfold too much and lose a projection too early *) +val is_open_canonical_projection : + Environ.env -> Evd.evar_map -> EConstr.t -> bool + +end + +(** Low level access to the Canonical Structure database *) +module CSTable : sig + +type entry = { + projection : Names.GlobRef.t; + value : ValuePattern.t; + solution : Names.GlobRef.t; +} + +(** [all] returns the list of tuples { p ; v ; s } + Note: p s = v *) +val entries : unit -> entry list + +(** [entries_for p] returns the list of canonical entries that have + p as their FieldName *) +val entries_for : projection:Names.GlobRef.t -> entry list + +end + +(** Some extra info for structures which are primitive records *) +module PrimitiveProjections : sig + +(** Sets up the mapping from constants to primitive projections *) +val register : Names.Projection.Repr.t -> Names.Constant.t -> unit + +val mem : Names.Constant.t -> bool + +val find_opt : Names.Constant.t -> Names.Projection.Repr.t option + +end diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 4e89018656..b59d4b5655 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1015,12 +1015,6 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = in app_stack (redrec (c, empty_stack)) *) -let whd_simpl_stack = - if Flags.profile then - let key = CProfile.declare_profile "whd_simpl_stack" in - CProfile.profile3 key whd_simpl_stack - else whd_simpl_stack - (* Same as [whd_simpl] but also reduces constants that do not hide a reducible fix, but does this reduction of constants only until it immediately hides a non reducible fix or a cofix *) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 51b228a640..dd1d27e4c5 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -242,10 +242,6 @@ let get_solve_all_instances, solve_all_instances_hook = Hook.make () let solve_all_instances env evd filter unique split fail = Hook.get get_solve_all_instances env evd filter unique split fail -(** Profiling resolution of typeclasses *) -(* let solve_classeskey = CProfile.declare_profile "solve_typeclasses" *) -(* let solve_problem = CProfile.profile5 solve_classeskey solve_problem *) - let resolve_typeclasses ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ()) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses filter evd) then evd diff --git a/pretyping/unification.ml b/pretyping/unification.ml index df0f49a033..43d562f77d 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -22,13 +22,13 @@ open Namegen open Evd open Reduction open Reductionops +open Structures open Evarutil open Evardefine open Evarsolve open Pretype_errors open Retyping open Coercion -open Recordops open Locus open Locusops open Find_subterm @@ -509,13 +509,13 @@ let key_of env sigma b flags f = match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && (TransparentState.is_transparent_constant flags.modulo_delta cst - || Recordops.is_primitive_projection cst) -> + || PrimitiveProjections.mem cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && TransparentState.is_transparent_variable flags.modulo_delta id -> Some (IsKey (VarKey id)) - | Proj (p, c) when Projection.unfolded p + | Proj (p, c) when Names.Projection.unfolded p || (is_transparent env (ConstKey (Projection.constant p)) && (TransparentState.is_transparent_constant flags.modulo_delta (Projection.constant p))) -> Some (IsProj (p, c)) @@ -1077,7 +1077,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp_or_Proj sigma cM then - if is_open_canonical_projection curenv sigma cM then + if CanonicalSolution.is_open_canonical_projection curenv sigma cM then solve_canonical_projection curenvnb pb opt cM cN substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1091,7 +1091,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else try f1 () with e when precatchable_exception e -> if isApp_or_Proj sigma cN then - if is_open_canonical_projection curenv sigma cN then + if CanonicalSolution.is_open_canonical_projection curenv sigma cN then solve_canonical_projection curenvnb pb opt cN cM substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1099,12 +1099,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and solve_canonical_projection curenvnb pb opt cM cN (sigma,ms,es) = let f1l1 = whd_nored_state (fst curenvnb) sigma (cM,Stack.empty) in let f2l2 = whd_nored_state (fst curenvnb) sigma (cN,Stack.empty) in - let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let (sigma,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in if Reductionops.Stack.compare_shape ts ts1 then - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> @@ -2070,11 +2069,5 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let w_unify env evd cv_pb flags ty1 ty2 = w_unify env evd cv_pb ~flags:flags ty1 ty2 -let w_unify = - if Flags.profile then - let wunifkey = CProfile.declare_profile "w_unify" in - CProfile.profile6 wunifkey w_unify - else w_unify - let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = w_unify env evd cv_pb flags ty1 ty2 diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 44d3b44077..b529bba3f5 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -298,7 +298,7 @@ let meta_reducible_instance env evd b = if not is_coerce then irec g else u with Not_found -> u) | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> - let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in + let m = try destMeta evd c with DestKO -> destMeta evd (pi1 (destCast evd c)) (* idem *) in (match try let g, s = Metamap.find m metas in diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index dd80ff21aa..a9f203014f 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -56,12 +56,8 @@ module Make(T : Task) () = struct type response = | Response of T.response | RespFeedback of Feedback.feedback - | RespGetCounterNewUnivLevel type request = Request of T.request - type more_data = - | MoreDataUnivLevel of UnivGen.univ_unique_id list - let slave_respond (Request r) = let res = T.perform r in Response res @@ -94,16 +90,6 @@ module Make(T : Task) () = struct with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_response: "^s) - let marshal_more_data oc (res : more_data) = - try marshal_to_channel oc res - with Failure s | Invalid_argument s | Sys_error s -> - marshal_err ("marshal_more_data: "^s) - - let unmarshal_more_data ic = - try (CThread.thread_friendly_input_value ic : more_data) - with Failure s | Invalid_argument s | Sys_error s -> - marshal_err ("unmarshal_more_data: "^s) - let report_status ?(id = !Flags.async_proofs_worker_id) s = let open Feedback in feedback ~id:Stateid.initial (WorkerStatus(id, s)) @@ -198,8 +184,6 @@ module Make(T : Task) () = struct | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in - let more_univs n = - CList.init n (fun _ -> UnivGen.new_univ_id ()) in let rec kill_if () = if not (Worker.is_alive proc) then () @@ -231,9 +215,6 @@ module Make(T : Task) () = struct marshal_request oc (Request req); let rec continue () = match unmarshal_response ic with - | RespGetCounterNewUnivLevel -> - marshal_more_data oc (MoreDataUnivLevel (more_univs 10)); - continue () | RespFeedback fbk -> T.forward_feedback fbk; continue () | Response resp -> match T.use_response !worker_age task resp with @@ -315,13 +296,6 @@ module Make(T : Task) () = struct let ic, oc = Spawned.get_channels () in slave_oc := Some oc; slave_ic := Some ic - let bufferize f = - let l = ref [] in - fun () -> - match !l with - | [] -> let data = f () in l := List.tl data; List.hd data - | x::tl -> l := tl; x - let slave_handshake () = Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc) @@ -339,11 +313,6 @@ module Make(T : Task) () = struct Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc) () in ignore (Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x)); - (* We ask master to allocate universe identifiers *) - UnivGen.set_remote_new_univ_id (bufferize @@ Control.protect_sigalrm (fun () -> - marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; - match unmarshal_more_data (Option.get !slave_ic) with - | MoreDataUnivLevel l -> l)); let working = ref false in slave_handshake (); while true do diff --git a/stm/stm.ml b/stm/stm.ml index 9480bbdc2e..6287943cee 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -98,8 +98,7 @@ let forward_feedback, forward_feedback_hook = let m = Mutex.create () in Hook.make ~default:(function | { doc_id = did; span_id = id; route; contents } -> - try Mutex.lock m; feedback ~did ~id ~route contents; Mutex.unlock m - with e -> Mutex.unlock m; raise e) () + CThread.with_lock m ~scope:(fun () -> feedback ~did ~id ~route contents)) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun ~doc:_ _ _ -> ()) () @@ -758,17 +757,16 @@ end = struct (* {{{ *) let worker = ref None let set_last_job j = - Mutex.lock m; - job := Some j; - Condition.signal c; - Mutex.unlock m + CThread.with_lock m ~scope:(fun () -> + job := Some j; + Condition.signal c) let get_last_job () = - Mutex.lock m; - while Option.is_empty !job do Condition.wait c m; done; - match !job with - | None -> assert false - | Some x -> job := None; Mutex.unlock m; x + CThread.with_lock m ~scope:(fun () -> + while Option.is_empty !job do Condition.wait c m; done; + match !job with + | None -> assert false + | Some x -> job := None; x) let run_command () = try while true do get_last_job () () done @@ -2449,24 +2447,21 @@ let join ~doc = VCS.print (); doc -let dump_snapshot () = Slaves.dump_snapshot (), RemoteCounter.snapshot () - -type tasks = int Slaves.tasks * RemoteCounter.remote_counters_status -let check_task name (tasks,rcbackup) i = - RemoteCounter.restore rcbackup; +type tasks = int Slaves.tasks +let check_task name tasks i = let vcs = VCS.backup () in try let rc = State.purify (Slaves.check_task name tasks) i in VCS.restore vcs; rc with e when CErrors.noncritical e -> VCS.restore vcs; false -let info_tasks (tasks,_) = Slaves.info_tasks tasks -let finish_tasks name u p (t,rcbackup as tasks) = - RemoteCounter.restore rcbackup; +let info_tasks = Slaves.info_tasks + +let finish_tasks name u p tasks = let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = State.purify (Slaves.finish_task name u p t) i in + let u = State.purify (Slaves.finish_task name u p tasks) i in VCS.restore vcs; u in try @@ -2517,13 +2512,13 @@ let snapshot_vio ~create_vos ~doc ~output_native_objects ldir long_f_dot_vo = CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); (* LATER: when create_vos is true, it could be more efficient to not allocate the futures; but for now it seems useful for synchronization of the workers, below, [snapshot] gets computed even if [create_vos] is true. *) - let (tasks,counters) = dump_snapshot() in + let tasks = Slaves.dump_snapshot() in let except = List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty tasks in let todo_proofs = if create_vos then Library.ProofsTodoSomeEmpty except - else Library.ProofsTodoSome (except,tasks,counters) + else Library.ProofsTodoSome (except,tasks) in Library.save_library_to todo_proofs ~output_native_objects ldir long_f_dot_vo (Global.opaque_tables ()); doc diff --git a/stm/tQueue.ml b/stm/tQueue.ml index 2aaca85582..f5bd726dde 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -68,61 +68,54 @@ let create () = { let pop ?(picky=(fun _ -> true)) ?(destroy=ref false) tq = let { queue = q; lock = m; cond = c; cond_waiting = cn } = tq in - Mutex.lock m; - if tq.release then (Mutex.unlock m; raise BeingDestroyed); - while not (PriorityQueue.exists picky q || !destroy) do - tq.nwaiting <- tq.nwaiting + 1; - Condition.broadcast cn; - Condition.wait c m; - tq.nwaiting <- tq.nwaiting - 1; - if tq.release || !destroy then (Mutex.unlock m; raise BeingDestroyed) - done; - if !destroy then (Mutex.unlock m; raise BeingDestroyed); - let x = PriorityQueue.pop ~picky q in - Condition.signal c; - Condition.signal cn; - Mutex.unlock m; - x + CThread.with_lock m ~scope:(fun () -> + if tq.release then raise BeingDestroyed; + while not (PriorityQueue.exists picky q || !destroy) do + tq.nwaiting <- tq.nwaiting + 1; + Condition.broadcast cn; + Condition.wait c m; + tq.nwaiting <- tq.nwaiting - 1; + if tq.release || !destroy then raise BeingDestroyed + done; + if !destroy then raise BeingDestroyed; + let x = PriorityQueue.pop ~picky q in + Condition.signal c; + Condition.signal cn; + x) let broadcast tq = let { lock = m; cond = c } = tq in - Mutex.lock m; - Condition.broadcast c; - Mutex.unlock m + CThread.with_lock m ~scope:(fun () -> + Condition.broadcast c) let push tq x = let { queue = q; lock = m; cond = c; release } = tq in if release then CErrors.anomaly(Pp.str "TQueue.push while being destroyed! Only 1 producer/destroyer allowed."); - Mutex.lock m; - PriorityQueue.push q x; - Condition.broadcast c; - Mutex.unlock m + CThread.with_lock m ~scope:(fun () -> + PriorityQueue.push q x; + Condition.broadcast c) let length tq = let { queue = q; lock = m } = tq in - Mutex.lock m; - let n = PriorityQueue.length q in - Mutex.unlock m; - n + CThread.with_lock m ~scope:(fun () -> + PriorityQueue.length q) let clear tq = let { queue = q; lock = m; cond = c } = tq in - Mutex.lock m; - PriorityQueue.clear q; - Mutex.unlock m + CThread.with_lock m ~scope:(fun () -> + PriorityQueue.clear q) let clear_saving tq f = let { queue = q; lock = m; cond = c } = tq in - Mutex.lock m; let saved = ref [] in - while not (PriorityQueue.is_empty q) do - let elem = PriorityQueue.pop q in - match f elem with - | Some x -> saved := x :: !saved - | None -> () - done; - Mutex.unlock m; + CThread.with_lock m ~scope:(fun () -> + while not (PriorityQueue.is_empty q) do + let elem = PriorityQueue.pop q in + match f elem with + | Some x -> saved := x :: !saved + | None -> () + done); List.rev !saved let is_empty tq = PriorityQueue.is_empty tq.queue @@ -130,32 +123,28 @@ let is_empty tq = PriorityQueue.is_empty tq.queue let destroy tq = tq.release <- true; while tq.nwaiting > 0 do - Mutex.lock tq.lock; - Condition.broadcast tq.cond; - Mutex.unlock tq.lock; + CThread.with_lock tq.lock ~scope:(fun () -> + Condition.broadcast tq.cond) done; tq.release <- false let wait_until_n_are_waiting_and_queue_empty j tq = - Mutex.lock tq.lock; - while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do - Condition.wait tq.cond_waiting tq.lock - done; - Mutex.unlock tq.lock + CThread.with_lock tq.lock ~scope:(fun () -> + while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do + Condition.wait tq.cond_waiting tq.lock + done) let wait_until_n_are_waiting_then_snapshot j tq = let l = ref [] in - Mutex.lock tq.lock; - while not (PriorityQueue.is_empty tq.queue) do - l := PriorityQueue.pop tq.queue :: !l - done; - while tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done; - List.iter (PriorityQueue.push tq.queue) (List.rev !l); - if !l <> [] then Condition.broadcast tq.cond; - Mutex.unlock tq.lock; + CThread.with_lock tq.lock ~scope:(fun () -> + while not (PriorityQueue.is_empty tq.queue) do + l := PriorityQueue.pop tq.queue :: !l + done; + while tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done; + List.iter (PriorityQueue.push tq.queue) (List.rev !l); + if !l <> [] then Condition.broadcast tq.cond); List.rev !l let set_order tq rel = - Mutex.lock tq.lock; - PriorityQueue.set_rel rel tq.queue; - Mutex.unlock tq.lock + CThread.with_lock tq.lock ~scope:(fun () -> + PriorityQueue.set_rel rel tq.queue) diff --git a/stm/workerPool.ml b/stm/workerPool.ml index 45c92c3748..fef9300377 100644 --- a/stm/workerPool.ml +++ b/stm/workerPool.ml @@ -72,12 +72,7 @@ let worker_handshake slave_ic slave_oc = exit 1 let locking { lock; pool = p } f = - try - Mutex.lock lock; - let x = f p in - Mutex.unlock lock; - x - with e -> Mutex.unlock lock; raise e + CThread.with_lock lock ~scope:(fun () -> f p) let rec create_worker extra pool priority id = let cancel = ref false in diff --git a/tactics/auto.ml b/tactics/auto.ml index 353e138599..0189e3ab04 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -500,12 +500,6 @@ let delta_auto debug mod_delta n lems dbnames = (search d n mod_delta db_list hints) end -let delta_auto = - if Flags.profile then - let key = CProfile.declare_profile "delta_auto" in - CProfile.profile5 key delta_auto - else delta_auto - let auto ?(debug=Off) n = delta_auto debug false n let new_auto ?(debug=Off) n = delta_auto debug true n diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index af0ca22868..794d2bb94f 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -32,18 +32,25 @@ let compare_term_label t1 t2 = match t1, t2 with type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything -let decomp_pat = +let decomp_pat p = let rec decrec acc = function | PApp (f,args) -> decrec (Array.to_list args @ acc) f - | PProj (p, c) -> (PRef (GlobRef.ConstRef (Projection.constant p)), c :: acc) + | PProj (p, c) -> + let hole = PMeta None in + let params = List.make (Projection.npars p) hole in + (PRef (GlobRef.ConstRef (Projection.constant p)), params @ c :: acc) | c -> (c,acc) in - decrec [] + decrec [] p let decomp sigma t = let rec decrec acc c = match EConstr.kind sigma c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f - | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc) + | Proj (p, c) -> + (* Hack: fake evar to generate [Everything] in the functions below *) + let hole = mkEvar (Evar.unsafe_of_int (-1), []) in + let params = List.make (Projection.npars p) hole in + (mkConst (Projection.constant p), params @ c :: acc) | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) in diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 20c557b282..5df9fab236 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -359,9 +359,6 @@ let e_search_auto debug (in_depth,p) lems db_list = tclIDTAC gl end -(* let e_search_auto_key = CProfile.declare_profile "e_search_auto" *) -(* let e_search_auto = CProfile.profile5 e_search_auto_key e_search_auto *) - let eauto_with_bases ?(debug=Off) np lems db_list = Hints.wrap_hint_warning (e_search_auto debug np lems db_list) diff --git a/tactics/equality.ml b/tactics/equality.ml index 633b9da053..497ce4ae1a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -379,11 +379,10 @@ let find_elim hdcncl lft2rgt dep cls ot = let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (KerName.make mp l') in - try - let _ = Global.lookup_constant c1' in c1' - with Not_found -> + if not (Environ.mem_constant c1' (Global.env ())) then user_err ~hdr:"Equality.find_elim" - (str "Cannot find rewrite principle " ++ Label.print l' ++ str ".") + (str "Cannot find rewrite principle " ++ Label.print l' ++ str "."); + c1' end | _ -> begin match if is_eq then eq_elimination_ref false sort else None with diff --git a/tactics/hints.ml b/tactics/hints.ml index 5e9c3baeb1..31b276bb3e 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -320,7 +320,7 @@ let strip_params env sigma c = | App (f, args) -> (match EConstr.kind sigma f with | Const (cst,_) -> - (match Recordops.find_primitive_projection cst with + (match Structures.PrimitiveProjections.find_opt cst with | Some p -> let p = Projection.make p false in let npars = Projection.npars p in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 5338e0eef5..783a317b3a 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -293,31 +293,34 @@ let match_with_equation env sigma t = let (hdapp,args) = destApp sigma t in match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if Coqlib.check_ind_ref "core.eq.type" ind then - Some (build_coq_eq_data()),hdapp, - PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if Coqlib.check_ind_ref "core.identity.type" ind then - Some (build_coq_identity_data()),hdapp, - PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if Coqlib.check_ind_ref "core.JMeq.type" ind then - Some (build_coq_jmeq_data()),hdapp, - HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) - else - let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc in - let nconstr = Array.length mip.mind_consnames in - if Int.equal nconstr 1 then - let (ctx, cty) = constr_types.(0) in - let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in - if is_matching env sigma coq_refl_leibniz1_pattern cty then - None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) - else if is_matching env sigma coq_refl_leibniz2_pattern cty then - None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if is_matching env sigma coq_refl_jm_pattern cty then - None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) - else raise NoEquationFound - else raise NoEquationFound - | _ -> raise NoEquationFound + (try + if Coqlib.check_ind_ref "core.eq.type" ind then + Some (build_coq_eq_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.identity.type" ind then + Some (build_coq_identity_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.JMeq.type" ind then + Some (build_coq_jmeq_data()),hdapp, + HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in + let nconstr = Array.length mip.mind_consnames in + if Int.equal nconstr 1 then + let (ctx, cty) = constr_types.(0) in + let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + if is_matching env sigma coq_refl_leibniz1_pattern cty then + None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) + else if is_matching env sigma coq_refl_leibniz2_pattern cty then + None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if is_matching env sigma coq_refl_jm_pattern cty then + None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else raise NoEquationFound + else raise NoEquationFound + with UserError _ -> + raise NoEquationFound) + | _ -> raise NoEquationFound (* Note: An "equality type" is any type with a single argument-free constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 67bf8d0d29..c24520b371 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1555,7 +1555,7 @@ let make_projection env sigma params cstr sign elim i n c u = | Some proj -> let args = Context.Rel.to_extended_vect mkRel 0 sign in let proj = - match Recordops.find_primitive_projection proj with + match Structures.PrimitiveProjections.find_opt proj with | Some proj -> mkProj (Projection.make proj false, mkApp (c, args)) | None -> @@ -1585,7 +1585,7 @@ let descend_in_conjunctions avoid tac (err, info) c = let params = List.map EConstr.of_constr params in let cstr = (get_constructors env indf).(0) in let elim = - try DefinedRecord (Recordops.lookup_projections ind) + try DefinedRecord (Structures.Structure.find_projections ind) with Not_found -> let u = EInstance.kind sigma u in let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in @@ -1886,12 +1886,6 @@ let cut_and_apply c = (* Exact tactics *) (********************************************************************) -(* let convert_leqkey = CProfile.declare_profile "convert_leq";; *) -(* let convert_leq = CProfile.profile3 convert_leqkey convert_leq *) - -(* let refine_no_checkkey = CProfile.declare_profile "refine_no_check";; *) -(* let refine_no_check = CProfile.profile2 refine_no_checkkey refine_no_check *) - let exact_no_check c = Refine.refine ~typecheck:false (fun h -> (h,c)) diff --git a/test-suite/bugs/closed/bug_12806.v b/test-suite/bugs/closed/bug_12806.v new file mode 100644 index 0000000000..ee221d33a6 --- /dev/null +++ b/test-suite/bugs/closed/bug_12806.v @@ -0,0 +1,9 @@ +Require Import Ltac2.Ltac2. + +Declare Scope my_scope. +Delimit Scope my_scope with my_scope. + +Notation "###" := tt : my_scope. + +Ltac2 Notation "bar" c(open_constr(my_scope)) := c. +Ltac2 Eval bar ###. diff --git a/test-suite/bugs/closed/bug_13581.v b/test-suite/bugs/closed/bug_13581.v new file mode 100644 index 0000000000..910537cf11 --- /dev/null +++ b/test-suite/bugs/closed/bug_13581.v @@ -0,0 +1,60 @@ +From Coq Require Extraction. + +Record mixin_of T0 (b : unit) (T := T0) := Mixin { _ : T0 -> let U:=T0 in U }. +Definition d := Mixin nat tt (fun x => x). + +Extraction TestCompile d. + +(* Extra tests *) + +Record R T0 (b:nat) (c:=b) (T:=T0) (e:nat) (d:c=e) := Build + { g : T0 -> let U:=T0 in U ; h : d = d ; x : nat ; y := x+x }. + +Definition r := {| g := (fun x : nat => x) ; h := eq_refl (eq_refl 0) ; x := 0 |}. + +Extraction TestCompile r. +(* +(** val r0 : nat r **) + +let r0 = + { g = (fun x0 -> x0); x = O } +*) + +Inductive I T (a:T) (U:=T) (b:T) (c:=(a,b)) : forall d (e:=S d) (h : S d = e), Type := +| C : I T a b 0 eq_refl +| D : J T a b true eq_refl -> I T a b 1 eq_refl +with J T (a:T) (U:=T) (b:T) (c:=(a,b)) : forall (d:bool) (h:d = true), Type := +| E : I T a b 0 eq_refl -> J T a b true eq_refl. + +Definition c := D _ _ _ (E _ _ _ (C nat 0 0)). + +Extraction TestCompile c. + +(* +(** val c : nat i **) + +let c = + D (E C) +*) + +CoInductive V T0 (b:nat) (c:=b) (T:=T0) (e:nat) (d:c=e) := + { k : T; b := c+e ; m : nat; z : option (W nat 0 0 eq_refl) } +with W T0 (b:nat) (c:=b) (T:=T0) (e:nat) (d:c=e) := + { l : V nat 0 0 eq_refl }. + +CoFixpoint v := + {| k := 0 ; m := 0 ; z := Some w ; |} +with w := {| l := v |}. + +Extraction TestCompile v. +(* +(** val v0 : nat v **) + +let rec v0 = + lazy (Build_V (O, O, (Some w0))) + +(** val w0 : nat w **) + +and w0 = + lazy (Build_W v0) +*) diff --git a/test-suite/bugs/closed/bug_1362.v b/test-suite/bugs/closed/bug_1362.v index 6cafb9f0cd..18b8d743b3 100644 --- a/test-suite/bugs/closed/bug_1362.v +++ b/test-suite/bugs/closed/bug_1362.v @@ -1,26 +1,17 @@ (** Omega is now aware of the bodies of context variables (of type Z or nat). *) -Require Import ZArith Omega. +Require Import ZArith Lia. Open Scope Z. Goal let x := 3 in x = 3. intros. -omega. +lia. Qed. Open Scope nat. Goal let x := 2 in x = 2. intros. -omega. +lia. Qed. - -(** NB: this could be disabled for compatibility reasons *) - -Unset Omega UseLocalDefs. - -Goal let x := 4 in x = 4. -intros. -Fail omega. -Abort. diff --git a/test-suite/bugs/closed/bug_14006.v b/test-suite/bugs/closed/bug_14006.v new file mode 100644 index 0000000000..b857959ae9 --- /dev/null +++ b/test-suite/bugs/closed/bug_14006.v @@ -0,0 +1,3 @@ +From Coq Require Import Int63 PArray. +Definition t : array nat := [| 1; 3; 2 | 4 |]. +Definition vm_accu_set v := Eval vm_compute in t.[1 <- v]. diff --git a/test-suite/bugs/closed/bug_14009.v b/test-suite/bugs/closed/bug_14009.v new file mode 100644 index 0000000000..bf86f5117e --- /dev/null +++ b/test-suite/bugs/closed/bug_14009.v @@ -0,0 +1,16 @@ +Class Bin {P:Type} (A B : P) := {}. + +Set Primitive Projections. + +Record test (n : nat) := { proj : Prop }. +Axiom Bin_test : forall {t1 t2 : test O}, Bin (proj _ t1) (proj _ t2). + +Create HintDb db discriminated. +#[local] Hint Resolve Bin_test : db. +#[local] Hint Opaque proj : db. + +Goal forall t1 t2 : test O, Bin (proj O t1) (proj O t2). +Proof. +intros. +solve [typeclasses eauto with db]. +Qed. diff --git a/test-suite/bugs/closed/bug_14011.v b/test-suite/bugs/closed/bug_14011.v new file mode 100644 index 0000000000..ccbeca792d --- /dev/null +++ b/test-suite/bugs/closed/bug_14011.v @@ -0,0 +1,32 @@ +(** Test that Ltac2 Array.init doesn't compute the first argument twice, and has the correct asymptotics when nested *) +Require Import Ltac2.Ltac2. + +(** Non-performance-based test *) +Ltac2 foo () := + let x := { contents := 0 } in + let _ := Array.init 1 (fun _ => x.(contents) := Int.add 1 (x.(contents))) in + Control.assert_true (Int.equal 1 (x.(contents))). + +Ltac2 Eval foo (). + +Ltac2 Type rec singleton := [ Single (int) | Arr (singleton array) ]. +Ltac2 rec init_rec (n : int) := + match Int.equal n 0 with + | true => Single 0 + | false => Arr (Array.init 1 (fun _ => init_rec (Int.sub n 1))) + end. +Ltac2 rec timing (n : int) := + (match Int.equal n 0 with + | true => () + | false => timing (Int.sub n 1) + end; + Message.print (Message.concat (Message.of_int n) (Message.of_string ": ")); + let _ := Control.time None (fun _ => init_rec n) in + ()). +(** Should take less than 0.1 seconds if the asymptotics are correct. +Previous behavior was to take an expected 1 million times the age of +the universe. Capping the time at 100 seconds seems like a reasonable +middle ground between these times, as I expect that compilation of Coq +itself will not finish in reasonable time if the computer is running +1000x slower than modern machines. *) +Timeout 100 Ltac2 Eval timing 100. diff --git a/test-suite/bugs/closed/bug_14131.v b/test-suite/bugs/closed/bug_14131.v new file mode 100644 index 0000000000..611464458e --- /dev/null +++ b/test-suite/bugs/closed/bug_14131.v @@ -0,0 +1,19 @@ +Set Implicit Arguments. +Unset Elimination Schemes. + +Inductive JMeq (A:Type) (x:A) : forall B:Type, B -> Prop := + JMeq_refl : JMeq x x. + +Set Elimination Schemes. + +Register JMeq as core.JMeq.type. + +Axiom JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), + P x -> forall y, JMeq x y -> P y. + +Register JMeq_ind as core.JMeq.ind. + +Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), + P x -> forall y, JMeq y x -> P y. +Proof. intros. try rewrite H0. +Abort. diff --git a/test-suite/bugs/closed/bug_1912.v b/test-suite/bugs/closed/bug_1912.v index 0228abbb9b..9f6c8177f6 100644 --- a/test-suite/bugs/closed/bug_1912.v +++ b/test-suite/bugs/closed/bug_1912.v @@ -1,6 +1,6 @@ -Require Import Omega. +Require Import Lia ZArith. Goal forall x, Z.succ (Z.pred x) = x. intros x. -omega. +lia. Qed. diff --git a/test-suite/bugs/closed/bug_4132.v b/test-suite/bugs/closed/bug_4132.v index 67ecc3087f..2ebbb66758 100644 --- a/test-suite/bugs/closed/bug_4132.v +++ b/test-suite/bugs/closed/bug_4132.v @@ -1,5 +1,5 @@ -Require Import ZArith Omega. +Require Import ZArith Lia. Open Scope Z_scope. (** bug 4132: omega was using "simpl" either on whole equations, or on @@ -14,18 +14,18 @@ Lemma foo (H : - zxy' <= zxy) (H' : zxy' <= x') : - b <= zxy. Proof. -omega. (* was: Uncaught exception Invalid_argument("index out of bounds"). *) +lia. (* was: Uncaught exception Invalid_argument("index out of bounds"). *) Qed. Lemma foo2 x y (b := 5) (H1 : x <= y) (H2 : y <= b) : x <= b. -omega. (* Pierre L: according to a comment of bug report #4132, +lia. (* Pierre L: according to a comment of bug report #4132, this might have triggered "index out of bounds" in the past, but I never managed to reproduce that in any version, even before my fix. *) Qed. Lemma foo3 x y (b := 0) (H1 : x <= y) (H2 : y <= b) : x <= b. -omega. (* Pierre L: according to a comment of bug report #4132, +lia. (* Pierre L: according to a comment of bug report #4132, this might have triggered "Failure(occurrence 2)" in the past, but I never managed to reproduce that. *) Qed. diff --git a/test-suite/bugs/closed/bug_4717.v b/test-suite/bugs/closed/bug_4717.v index bd9bac37ef..81bc70d076 100644 --- a/test-suite/bugs/closed/bug_4717.v +++ b/test-suite/bugs/closed/bug_4717.v @@ -1,6 +1,6 @@ (* Omega being smarter on recognizing nat and Z *) -Require Import Omega. +Require Import Lia ZArith. Definition nat' := nat. @@ -10,13 +10,13 @@ Theorem le_not_eq_lt : forall (n m:nat), n < m. Proof. intros. - omega. + lia. Qed. Goal forall (x n : nat'), x = x + n - n. Proof. intros. - omega. + lia. Qed. Open Scope Z_scope. @@ -29,5 +29,5 @@ Theorem Zle_not_eq_lt : forall n m, n < m. Proof. intros. - omega. + lia. Qed. diff --git a/test-suite/bugs/closed/bug_9000.v b/test-suite/bugs/closed/bug_9000.v new file mode 100644 index 0000000000..e239c8b1fe --- /dev/null +++ b/test-suite/bugs/closed/bug_9000.v @@ -0,0 +1,17 @@ +Set Primitive Projections. +Class type (t : Type) : Type := + { bar : t -> Prop }. + +Instance type_nat : type nat := + { bar := fun _ => True }. + +Definition foo_bar {n : nat} : bar n := I. + +#[local] Hint Resolve (@foo_bar) : typeclass_instances. +#[local] Hint Resolve I : typeclass_instances. +Check ltac:(typeclasses eauto with nocore typeclass_instances) : True. +Check ltac:(typeclasses eauto with nocore typeclass_instances foo) : bar _. +Existing Class bar. +Check ltac:(typeclasses eauto with nocore typeclass_instances foo) : bar _. +#[local] Hint Resolve (@foo_bar) : foo. +Check ltac:(typeclasses eauto with nocore typeclass_instances foo) : bar _. diff --git a/test-suite/bugs/closed/bug_9512.v b/test-suite/bugs/closed/bug_9512.v index bad9d64f65..f42e32cf25 100644 --- a/test-suite/bugs/closed/bug_9512.v +++ b/test-suite/bugs/closed/bug_9512.v @@ -1,4 +1,4 @@ -Require Import Coq.ZArith.BinInt Coq.omega.Omega Coq.micromega.Lia. +Require Import Coq.ZArith.BinInt Coq.micromega.Lia. Set Primitive Projections. Record params := { width : Z }. @@ -10,7 +10,6 @@ Set Printing All. Lemma foo : width p = 0%Z -> width p = 0%Z. intros. - assert_succeeds (enough True; [omega|]). assert_succeeds (enough True; [lia|]). (* H : @eq Z (width p) Z0 *) @@ -26,12 +25,6 @@ Lemma foo : width p = 0%Z -> width p = 0%Z. (* @eq Z (width p) Z0 *) assert_succeeds (enough True; [lia|]). - (* Tactic failure: <tactic closure> fails. *) - (* assert_succeeds (enough True; [omega|]). *) - (* Tactic failure: <tactic closure> fails. *) - - (* omega. *) - (* Error: Omega can't solve this system *) lia. (* Tactic failure: Cannot find witness. *) diff --git a/test-suite/bugs/opened/bug_1615.v b/test-suite/bugs/opened/bug_1615.v deleted file mode 100644 index c045335410..0000000000 --- a/test-suite/bugs/opened/bug_1615.v +++ /dev/null @@ -1,11 +0,0 @@ -Require Import Omega. - -Lemma foo : forall n m : Z, (n >= 0)%Z -> (n * m >= 0)%Z -> (n <= n + n * m)%Z. -Proof. - intros. omega. -Qed. - -Lemma foo' : forall n m : nat, n <= n + n * m. -Proof. - intros. Fail omega. -Abort. diff --git a/test-suite/bugs/opened/bug_6602.v b/test-suite/bugs/opened/bug_6602.v deleted file mode 100644 index 3690adf90a..0000000000 --- a/test-suite/bugs/opened/bug_6602.v +++ /dev/null @@ -1,17 +0,0 @@ -Require Import Omega. - -Lemma test_nat: - forall n, (5 + pred n <= 5 + n). -Proof. - intros. - zify. - omega. -Qed. - -Lemma test_N: - forall n, (5 + N.pred n <= 5 + n)%N. -Proof. - intros. - zify. - omega. -Qed. diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v index d2e6794c0b..1f4913b49d 100644 --- a/test-suite/interactive/ParalITP_smallproofs.v +++ b/test-suite/interactive/ParalITP_smallproofs.v @@ -140,35 +140,35 @@ Qed. Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. Proof. intros. - omega. + lia. Qed. Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. Proof. intros. - omega. + lia. Qed. Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). Proof. intros. - omega. + lia. Qed. Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. Proof. intros. - omega. + lia. Qed. @@ -1414,13 +1414,13 @@ Qed. Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. Proof. intros. - omega. + lia. Qed. Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. Proof. intros. - omega. + lia. Qed. @@ -1501,7 +1501,7 @@ Proof. [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1)); [ idtac | apply f_equal with Z; auto with zarith ]; rewrite absolu_plus; - [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega + [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; lia | auto with zarith | intro; discriminate ] | rewrite <- H1; reflexivity ]. diff --git a/test-suite/ltac2/std_tactics.v b/test-suite/ltac2/std_tactics.v new file mode 100644 index 0000000000..39b620a6ac --- /dev/null +++ b/test-suite/ltac2/std_tactics.v @@ -0,0 +1,29 @@ +Require Import Ltac2.Ltac2. + +Axiom f: nat -> nat. +Definition g := f. + +Axiom Foo1: nat -> Prop. +Axiom Foo2: nat -> Prop. +Axiom Impl: forall n: nat, Foo1 (f n) -> Foo2 (f n). + +Create HintDb foo discriminated. +#[export] Hint Constants Opaque : foo. +#[export] Hint Resolve Impl : foo. + +Goal forall x, Foo1 (f x) -> Foo2 (g x). +Proof. + auto with foo. + #[export] Hint Transparent g : foo. + auto with foo. +Qed. + +Goal forall (x: nat), exists y, f x = g y. +Proof. + intros. + eexists. + unify f g. + lazy_match! goal with + | [ |- ?a ?b = ?rhs ] => unify ($a $b) $rhs + end. +Abort. diff --git a/test-suite/micromega/bug_11089.v b/test-suite/micromega/bug_11089.v new file mode 100644 index 0000000000..e62b5b8d9e --- /dev/null +++ b/test-suite/micromega/bug_11089.v @@ -0,0 +1,13 @@ +Require Import Lia. +Unset Lia Cache. +Definition t := nat. +Goal forall (n : t), n = n. +Proof. + intros. + lia. +Qed. +Goal let t' := nat in forall (n : t'), n = n. +Proof. + intros. + lia. +Qed. diff --git a/test-suite/micromega/bug_11656.v b/test-suite/micromega/bug_11656.v new file mode 100644 index 0000000000..19846ad50a --- /dev/null +++ b/test-suite/micromega/bug_11656.v @@ -0,0 +1,11 @@ +Require Import Lia. +Require Import NArith. +Open Scope N_scope. + +Goal forall (a b c: N), + a <> 0 -> + c <> 0 -> + a * ((b + 1) * c) <> 0. +Proof. + intros. nia. +Qed. diff --git a/test-suite/micromega/bug_12184.v b/test-suite/micromega/bug_12184.v new file mode 100644 index 0000000000..d329a3fa7f --- /dev/null +++ b/test-suite/micromega/bug_12184.v @@ -0,0 +1,8 @@ +Require Import Lia. +Require Import ZArith. + +Goal forall p : positive, (0 < Z.pos (2^p)%positive)%Z. +Proof. + intros p. + lia. +Qed. diff --git a/test-suite/micromega/bug_14054.v b/test-suite/micromega/bug_14054.v new file mode 100644 index 0000000000..d97e13375f --- /dev/null +++ b/test-suite/micromega/bug_14054.v @@ -0,0 +1,46 @@ +(* bug 13242 *) + +Require Import Lia. +Fail Add Zify InjTyp id. + +(* bug 14054 *) + +Require Import Coq.ZArith.ZArith. Open Scope Z_scope. +Require Coq.Init.Byte . +Require Import Coq.micromega.ZifyClasses Coq.micromega.Lia. + +Notation byte := Coq.Init.Byte.byte. + +Module byte. + Definition unsigned(b: byte): Z := Z.of_N (Byte.to_N b). +End byte. + +Section WithA. + Context (A: Type). + Fixpoint tuple(n: nat): Type := + match n with + | O => unit + | S m => A * tuple m + end. +End WithA. + +Module LittleEndian. + Fixpoint combine (n : nat) : forall (bs : tuple byte n), Z := + match n with + | O => fun _ => 0 + | S n => fun bs => Z.lor (byte.unsigned (fst bs)) + (Z.shiftl (combine n (snd bs)) 8) + end. + Lemma combine_bound: forall {n: nat} (t: tuple byte n), + 0 <= LittleEndian.combine n t < 2 ^ (8 * Z.of_nat n). + Admitted. +End LittleEndian. + +Instance InjByteTuple{n: nat}: InjTyp (tuple byte n) Z := {| + inj := LittleEndian.combine n; + pred x := 0 <= x < 2 ^ (8 * Z.of_nat n); + cstr := @LittleEndian.combine_bound n; +|}. +Fail Add Zify InjTyp InjByteTuple. +Fail Add Zify UnOp InjByteTuple. +Fail Add Zify UnOp X. diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v index d70bb809c6..d22e2b7c8c 100644 --- a/test-suite/micromega/example.v +++ b/test-suite/micromega/example.v @@ -12,6 +12,12 @@ Open Scope Z_scope. Require Import ZMicromega. Require Import VarMap. +Lemma power_pos : forall x y, 0 <= x \/ False -> x^ y >= 0. +Proof. + intros. + lia. +Qed. + Lemma not_so_easy : forall x n : Z, 2*x + 1 <= 2 *n -> x <= n-1. Proof. diff --git a/test-suite/micromega/example_nia.v b/test-suite/micromega/example_nia.v index 485c24f0c9..e79b76b810 100644 --- a/test-suite/micromega/example_nia.v +++ b/test-suite/micromega/example_nia.v @@ -7,10 +7,16 @@ (************************************************************************) Require Import ZArith. -Require Import Psatz. Open Scope Z_scope. -Require Import ZMicromega. +Require Import ZMicromega Lia. Require Import VarMap. +Unset Nia Cache. + +Goal forall (x y: Z), 0 < (1+y^2)^(x^2). +Proof. nia. Qed. + +Goal forall (x y: Z), 0 <= (y^2)^x. +Proof. nia. Qed. (* false in Q : x=1/2 and n=1 *) @@ -347,8 +353,8 @@ Lemma hol_light17 : forall x y, -> x * y * (x + y) <= x ^ 2 + y ^ 2. Proof. intros. - Fail nia. -Abort. + nia. +Qed. Lemma hol_light18 : forall x y, @@ -507,3 +513,24 @@ Proof. intros. lia. Qed. + +Lemma mult : forall x x0 x1 x2 n n0 n1 n2, + 0 <= x -> 0 <= x0 -> 0 <= x1 -> 0 <= x2 -> + 0 <= n -> 0 <= n0 -> 0 <= n1 -> 0 <= n2 -> + (n1 * x <= n2 * x1) -> + (n * x0 <= n0 * x2) -> + (n1 * n * (x * x0) > n2 * n0 * (x1 * x2)) -> False. +Proof. + intros. + nia. +Qed. + + +Lemma mult_nat : forall x x0 x1 x2 n n0 n1 n2, + (n1 * x <= n2 * x1)%nat -> + (n * x0 <= n0 * x2)%nat -> + (n1 * n * (x * x0) > n2 * n0 * (x1 * x2))%nat -> False. +Proof. + intros. + nia. +Qed. diff --git a/test-suite/micromega/zify.v b/test-suite/micromega/zify.v index a12623c3c0..2ea320047d 100644 --- a/test-suite/micromega/zify.v +++ b/test-suite/micromega/zify.v @@ -167,6 +167,12 @@ Goal @zero znat = 0%nat. reflexivity. Qed. +Require Import ZifyBool. +Instance Op_bool_inj : UnOp (inj : bool -> bool) := + { TUOp := id; TUOpInj := fun _ => eq_refl }. +Add Zify UnOp Op_bool_inj. + + Goal forall (x y : positive) (F : forall (P: Pos.le x y) , positive) (P : Pos.le x y), (F P + 1 = 1 + F P)%positive. Proof. @@ -228,6 +234,7 @@ Proof. intros. lia. Qed. + Ltac Zify.zify_pre_hook ::= unfold is_true in *. Goal forall x y : nat, is_true (Nat.eqb x 1) -> diff --git a/test-suite/misc/vio_checking.sh b/test-suite/misc/vio_checking.sh new file mode 100755 index 0000000000..ffa909e93b --- /dev/null +++ b/test-suite/misc/vio_checking.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env bash + +set -ex + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +cd misc + +rm -f vio_checking{,bad}.{vo,vio} + +coqc -vio vio_checking.v +coqc -vio vio_checking_bad.v + +coqc -schedule-vio-checking 2 vio_checking.vio + +if coqc -schedule-vio-checking 2 vio_checking_bad.vio; then + echo 'vio-checking on vio_checking_bad.vio should have failed!' + exit 1 +fi +if coqc -schedule-vio-checking 2 vio_checking.vio vio_checking_bad.vio; then + echo 'vio-checking on vio_checking vio_checking_bad.vio should have failed!' + exit 1 +fi + +coqc -vio2vo vio_checking.vio +coqchk -silent vio_checking.vo + +if coqc -vio2vo vio_checking_bad.vio; then + echo 'vio2vo on vio_checking_bad.vio should have failed!' + exit 1 +fi diff --git a/test-suite/misc/vio_checking.v b/test-suite/misc/vio_checking.v new file mode 100644 index 0000000000..8dd5e47383 --- /dev/null +++ b/test-suite/misc/vio_checking.v @@ -0,0 +1,9 @@ + +Lemma foo : Type. +Proof. exact Type. Qed. + +Lemma foo1 : Type. +Proof. exact Type. Qed. + +Lemma foo2 : Type. +Proof. exact foo1. Qed. diff --git a/test-suite/misc/vio_checking_bad.v b/test-suite/misc/vio_checking_bad.v new file mode 100644 index 0000000000..f32d06f34a --- /dev/null +++ b/test-suite/misc/vio_checking_bad.v @@ -0,0 +1,4 @@ +(* a file to check that vio-checking is not a noop *) + +Lemma foo : Type. +Proof. match goal with |- ?G => exact G end. Qed. diff --git a/test-suite/output/bug_13240.out b/test-suite/output/bug_13240.out new file mode 100644 index 0000000000..5fccef5cfe --- /dev/null +++ b/test-suite/output/bug_13240.out @@ -0,0 +1,3 @@ +Ltac t1 a b := a ; last b +Ltac t2 := do !idtac +Ltac t3 := idtac => True diff --git a/test-suite/output/bug_13240.v b/test-suite/output/bug_13240.v new file mode 100644 index 0000000000..a999450cd2 --- /dev/null +++ b/test-suite/output/bug_13240.v @@ -0,0 +1,10 @@ +Require Import ssreflect. + +Ltac t1 a b := a; last b. +Print t1. + +Ltac t2 := do !idtac. +Print t2. + +Ltac t3 := idtac => True. +Print t3. diff --git a/test-suite/primitive/arrays/set.v b/test-suite/primitive/arrays/set.v index f265c37ea8..787d2867dd 100644 --- a/test-suite/primitive/arrays/set.v +++ b/test-suite/primitive/arrays/set.v @@ -20,3 +20,50 @@ Definition x3 := Eval compute in t.[1]. Definition foo9 := (eq_refl : x3 = 3). Definition x4 := Eval cbn in t.[1]. Definition foo10 := (eq_refl : x4 = 3). + +Ltac check_const_eq name constr := + let v := (eval cbv delta [name] in name) in + tryif constr_eq v constr + then idtac + else fail 0 "Not syntactically equal:" name ":=" v "<>" constr. + +Notation check_const_eq name constr := (ltac:(check_const_eq name constr; exact constr)) (only parsing). + +(* Stuck primitive *) +Definition lazy_stuck_set := Eval lazy in (fun A (t : array A) v => t.[1 <- v]). +Definition vm_stuck_set := Eval vm_compute in (fun A (t : array A) v => t.[1 <- v]). +Definition native_stuck_set := Eval native_compute in (fun A (t : array A) v => t.[1 <- v]). +Definition compute_stuck_set := Eval compute in (fun A (t : array A) v => t.[1 <- v]). +Definition cbn_stuck_set := Eval cbn in (fun A (t : array A) v => t.[1 <- v]). + +Check check_const_eq lazy_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq vm_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq native_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq compute_stuck_set (fun A (t : array A) v => t.[1 <- v]). +Check check_const_eq cbn_stuck_set (fun A (t : array A) v => t.[1 <- v]). + +(* Not stuck primitive, but with an accumulator as last argument *) +Definition lazy_accu_set := Eval lazy in (fun v => t.[1 <- v]). +Definition vm_accu_set := Eval vm_compute in (fun v => t.[1 <- v]). +Definition native_accu_set := Eval native_compute in (fun v => t.[1 <- v]). +Definition compute_accu_set := Eval compute in (fun v => t.[1 <- v]). +Definition cbn_accu_set := Eval cbn in (fun v => t.[1 <- v]). + +Check check_const_eq lazy_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq vm_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq native_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq compute_accu_set (fun v => [| 1; v; 2 | 4 |]). +Check check_const_eq cbn_accu_set (fun v => [| 1; v; 2 | 4 |]). + +(* Under-application *) +Definition lazy_set := Eval lazy in @PArray.set. +Definition vm_set := Eval vm_compute in @PArray.set. +Definition native_set := Eval native_compute in @PArray.set. +Definition compute_set := Eval compute in @PArray.set. +Definition cbn_set := Eval cbn in @PArray.set. + +Check check_const_eq lazy_set (@PArray.set). +Check check_const_eq vm_set (fun A (t : array A) i v => t.[i <- v]). +Check check_const_eq native_set (fun A (t : array A) i v => t.[i <- v]). +Check check_const_eq compute_set (@PArray.set). +Check check_const_eq cbn_set (@PArray.set). diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 69ed621877..ae71ddfd1d 100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -19,6 +19,7 @@ Require Export ZArith. Require Export ZArithRing. +Require Import Lia. Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. @@ -140,35 +141,35 @@ Qed. Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0. Proof. intros. - omega. + lia. Qed. Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0. Proof. intros. - omega. + lia. Qed. Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n). Proof. intros. - omega. + lia. Qed. Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0. Proof. - intros; omega. + intros; lia. Qed. Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n. Proof. intros. - omega. + lia. Qed. @@ -573,7 +574,7 @@ Qed. -Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. +Local Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith. Lemma Zle_reg_mult_l : @@ -1158,7 +1159,7 @@ Proof. intros [| p| p]; intros; [ Falsum | constructor | constructor ]. Qed. -Hint Resolve square_pos: zarith. +Local Hint Resolve square_pos: zarith. (*###########################################################################*) (** Properties of positive numbers, mapping between Z and nat *) @@ -1414,13 +1415,13 @@ Qed. Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n. Proof. intros. - omega. + lia. Qed. Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n. Proof. intros. - omega. + lia. Qed. @@ -1501,7 +1502,7 @@ Proof. [ replace (Z.abs_nat x) with (Z.abs_nat (x - 1 + 1)); [ idtac | apply f_equal with Z; auto with zarith ]; rewrite absolu_plus; - [ unfold Z.abs_nat at 2, nat_of_P, Pos.iter_op in |- *; omega + [ unfold Z.abs_nat at 2, nat_of_P, Pos.iter_op in |- *; lia | auto with zarith | intro; discriminate ] | rewrite <- H1; reflexivity ]. @@ -1985,7 +1986,7 @@ Proof. intros [| p| p] Hp; trivial. Qed. -Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 +Local Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8 Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17 Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26 Zsgn_27: zarith. @@ -2388,7 +2389,7 @@ Proof. intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. Qed. -Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 +Local Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9 Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith. @@ -2949,7 +2950,7 @@ Proof. ring. Qed. -Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. +Local Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith. (*###########################################################################*) (** Properties of Arity *) @@ -3020,7 +3021,7 @@ Proof. Flip. Qed. -Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. +Local Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith. (*###########################################################################*) (** Properties of Zpower *) @@ -3038,4 +3039,4 @@ Proof. ring. Qed. -Hint Resolve Zpower_1 Zpower_2: zarith. +Local Hint Resolve Zpower_1 Zpower_2: zarith. diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v index d52a853aae..24634bd321 100644 --- a/test-suite/success/Abstract.v +++ b/test-suite/success/Abstract.v @@ -1,6 +1,6 @@ (* Cf BZ#546 *) -Require Import Omega. +Require Import Lia. Section S. @@ -19,7 +19,7 @@ induction n. replace (2 * S n0) with (2*n0 + 2) ; auto with arith. apply DummyApp. 2:exact Dummy2. - apply IHn0 ; abstract omega. + apply IHn0 ; abstract lia. Defined. End S. diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v index 5e0f90d59b..a530c34297 100644 --- a/test-suite/success/Omega.v +++ b/test-suite/success/Omega.v @@ -1,5 +1,4 @@ - -Require Import Omega. +Require Import Lia ZArith. (* Submitted by Xavier Urbain 18 Jan 2002 *) @@ -7,14 +6,14 @@ Lemma lem1 : forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. Proof. intros x y. - omega. + lia. Qed. (* Proposed by Pierre Crégut *) Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. intro. - omega. + lia. Qed. (* Proposed by Jean-Christophe Filliâtre *) @@ -22,7 +21,7 @@ Qed. Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. - omega. + lia. Qed. (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) @@ -32,7 +31,7 @@ Section A. Variable x y : Z. Hypothesis H : (x > y)%Z. Lemma lem4 : (x > y)%Z. - omega. + lia. Qed. End A. @@ -48,7 +47,7 @@ Hypothesis L : (R1 >= 0)%Z -> S2 = S1. Hypothesis M : (H <= 2 * S)%Z. Hypothesis N : (S < H)%Z. Lemma lem5 : (H > 0)%Z. - omega. + lia. Qed. End B. @@ -56,11 +55,11 @@ End B. Lemma lem6 : forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. intros. - omega. + lia. Qed. (* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) -Require Import Omega. +Require Import Lia. Section C. Parameter g : forall m : nat, m <> 0 -> Prop. Parameter f : forall (m : nat) (H : m <> 0), g m H. @@ -68,21 +67,21 @@ Variable n : nat. Variable ap_n : n <> 0. Let delta := f n ap_n. Lemma lem7 : n = n. - omega. + lia. Qed. End C. (* Problem of dependencies *) -Require Import Omega. +Require Import Lia. Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. -intros; omega. +intros; lia. Qed. (* Bug that what caused by the use of intro_using in Omega *) -Require Import Omega. +Require Import Lia. Lemma lem9 : forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. -intros; omega. +intros; lia. Qed. (* Check that the interpretation of mult on nat enforces its positivity *) @@ -90,5 +89,5 @@ Qed. (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). Proof. -intros; zify; omega. +intros; lia. Qed. diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v index 6fd936935c..6ce7264b7a 100644 --- a/test-suite/success/Omega0.v +++ b/test-suite/success/Omega0.v @@ -1,4 +1,4 @@ -Require Import ZArith Omega. +Require Import ZArith Lia. Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) @@ -8,7 +8,7 @@ Lemma test_romega_0 : 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. -omega. +lia. Qed. Lemma test_romega_0b : @@ -16,7 +16,7 @@ Lemma test_romega_0b : 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. -omega. +lia. Qed. Lemma test_romega_1 : @@ -29,7 +29,7 @@ Lemma test_romega_1 : z >= 0. Proof. intros. -omega. +lia. Qed. Lemma test_romega_1b : @@ -42,21 +42,21 @@ Lemma test_romega_1b : z >= 0. Proof. intros z z1 z2. -omega. +lia. Qed. Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. -omega. +lia. Qed. Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. -omega. +lia. Qed. Lemma test_romega_3 : forall a b h hl hr ha hb, @@ -70,7 +70,7 @@ Lemma test_romega_3 : forall a b h hl hr ha hb, 0 <= hb - h <= 1. Proof. intros. -omega. +lia. Qed. Lemma test_romega_3b : forall a b h hl hr ha hb, @@ -84,7 +84,7 @@ Lemma test_romega_3b : forall a b h hl hr ha hb, 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. -omega. +lia. Qed. @@ -94,7 +94,7 @@ Lemma test_romega_4 : forall hr ha, hr = 0. Proof. intros hr ha. -omega. +lia. Qed. Lemma test_romega_5 : forall hr ha, @@ -103,45 +103,45 @@ Lemma test_romega_5 : forall hr ha, hr = 0. Proof. intros hr ha. -omega. +lia. Qed. Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. Proof. intros. -omega. +lia. Qed. Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. Proof. intros z. -omega. +lia. Qed. Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -omega. +lia. Qed. Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -omega. +lia. Qed. (* Magaud BZ#240 *) Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. intros. -omega. +lia. Qed. Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. intros x y. -omega. +lia. Qed. diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v index 4e726335c9..b2eef5bcd5 100644 --- a/test-suite/success/Omega2.v +++ b/test-suite/success/Omega2.v @@ -1,4 +1,4 @@ -Require Import ZArith Omega. +Require Import ZArith Lia. (* Submitted by Yegor Bryukhov (BZ#922) *) @@ -23,6 +23,6 @@ forall v1 v2 v3 v4 v5 : Z, ((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) -> False. intros. -omega. +lia. Qed. diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v index 0223255067..32bc99621a 100644 --- a/test-suite/success/OmegaPre.v +++ b/test-suite/success/OmegaPre.v @@ -1,4 +1,4 @@ -Require Import ZArith Nnat Omega. +Require Import ZArith Nnat Lia. Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) @@ -16,112 +16,111 @@ Open Scope Z_scope. Goal forall a:Z, Z.max a a = a. intros. -zify; omega. +lia. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. -zify; omega. +lia. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. -zify; omega. +lia. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. -zify; omega. +lia. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. -zify. -intuition; subst; zify; omega. (* pure multiplication: zify; omega alone can't do it *) +intuition; subst; lia. Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. -zify; omega. +lia. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. -zify; omega. +lia. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. -zify; omega. +lia. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. -zify; omega. +lia. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. -zify; omega. +lia. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. -zify; omega. +lia. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. -zify; omega. +lia. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. -zify; omega. +lia. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. -zify; omega. +lia. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. -zify; omega. +lia. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. -zify; omega. +lia. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. -zify; omega. +lia. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. -zify; omega. +lia. Qed. Goal forall m:N, (m*m>=0)%N. intros. -zify; omega. +lia. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. -zify; omega. +lia. Qed. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 02adb012d9..ef8617cd9e 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -85,19 +85,19 @@ Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) error end. -Require Import Omega Setoid. +Require Import Lia Setoid. Next Obligation. intros ; simpl in *. apply H. - simpl in * ; omega. + simpl in * ; lia. Qed. Next Obligation. simpl in *; intros. revert H0 ; clear_subset_proofs. intros. - case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst. + case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by lia. subst. revert H0 ; clear_subset_proofs ; tauto. - apply H. simpl. omega. + apply H. simpl. lia. Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v index 6ca32f450f..c0e86b00dd 100644 --- a/test-suite/success/ROmegaPre.v +++ b/test-suite/success/ROmegaPre.v @@ -32,8 +32,7 @@ Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. -zify. -intuition; subst; lia. (* pure multiplication: omega alone can't do it *) +intuition; subst; lia. Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. diff --git a/test-suite/success/RemoteUnivs.v b/test-suite/success/RemoteUnivs.v new file mode 100644 index 0000000000..5ab4937dda --- /dev/null +++ b/test-suite/success/RemoteUnivs.v @@ -0,0 +1,31 @@ + + +Goal Type * Type. +Proof. + split. + par: exact Type. +Qed. + +Goal Type. +Proof. + exact Type. +Qed. + +(* (* coqide test, note the delegated proofs seem to get an empty dirpath? + or I got confused because I had lemma foo in file foo + *) +Definition U := Type. + +Lemma foo : U. +Proof. + exact Type. +Qed. + + +Lemma foo1 : Type. +Proof. + exact (U:Type). +Qed. + +Print foo. +*) diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v index ff34840d83..b7d5276bc8 100644 --- a/test-suite/success/fix.v +++ b/test-suite/success/fix.v @@ -61,7 +61,7 @@ Qed. (* Check mutually inductive statements *) -Require Import ZArith_base Omega. +Require Import ZArith_base Lia. Open Scope Z_scope. Inductive even: Z -> Prop := @@ -75,13 +75,13 @@ with odd_pos_even_pos : forall n, odd n -> n >= 1. Proof. intros. destruct H. - omega. + lia. apply odd_pos_even_pos in H. - omega. + lia. intros. destruct H. apply even_pos_odd_pos in H. - omega. + lia. Qed. CoInductive a : Prop := acons : b -> a diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index 5638a7d3eb..06847f4f96 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -23,7 +23,7 @@ Qed. Print Equivalent Keys. End foo. -Require Import Arith List Omega. +Require Import Arith List. Definition G {A} (f : A -> A -> A) (x : A) := f x x. diff --git a/test-suite/success/rewrite_iterated.v b/test-suite/success/rewrite_iterated.v index 962dada35a..946011e393 100644 --- a/test-suite/success/rewrite_iterated.v +++ b/test-suite/success/rewrite_iterated.v @@ -1,8 +1,8 @@ -Require Import Arith Omega. +Require Import Arith Lia. Lemma test : forall p:nat, p<>0 -> p-1+1=p. Proof. - intros; omega. + intros; lia. Qed. (** Test of new syntax for rewrite : ! ? and so on... *) diff --git a/test-suite/success/search.v b/test-suite/success/search.v index 92de43e052..627e109d5f 100644 --- a/test-suite/success/search.v +++ b/test-suite/success/search.v @@ -32,4 +32,4 @@ Require Import ZArith. Search Z.mul Z.add "distr". Search "+"%Z "*"%Z "distr" -positive -Prop. -Search (?x * _ + ?x * _)%Z outside OmegaLemmas. +Search (?x * _ + ?x * _)%Z outside Lia. diff --git a/test-suite/vio/univ_constraints_statements_body.v b/test-suite/vio/univ_constraints_statements_body.v new file mode 100644 index 0000000000..6302adefc2 --- /dev/null +++ b/test-suite/vio/univ_constraints_statements_body.v @@ -0,0 +1,7 @@ +Definition T := Type. +Definition T1 : T := Type. + +Lemma x : True. +Proof. +exact (let a : T := Type in I). +Qed. diff --git a/theories/Arith/Cantor.v b/theories/Arith/Cantor.v new file mode 100644 index 0000000000..b63d970db7 --- /dev/null +++ b/theories/Arith/Cantor.v @@ -0,0 +1,88 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Implementation of the Cantor pairing and its inverse function *) + +Require Import PeanoNat Lia. + +(** Bijections between [nat * nat] and [nat] *) + +(** Cantor pairing [to_nat] *) + +Definition to_nat '(x, y) : nat := + y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)). + +(** Cantor pairing inverse [of_nat] *) + +Definition of_nat (n : nat) : nat * nat := + nat_rec _ (0, 0) (fun _ '(x, y) => + match x with | S x => (x, S y) | _ => (S y, 0) end) n. + +(** [of_nat] is the left inverse for [to_nat] *) + +Lemma cancel_of_to p : of_nat (to_nat p) = p. +Proof. + enough (H : forall n p, to_nat p = n -> of_nat n = p) by now apply H. + intro n. induction n as [|n IHn]. + - now intros [[|?] [|?]]. + - intros [x [|y]]. + + destruct x as [|x]; [discriminate|]. + intros [=H]. cbn. fold (of_nat n). + rewrite (IHn (0, x)); [reflexivity|]. + rewrite <- H. cbn. now rewrite PeanoNat.Nat.add_0_r. + + intros [=H]. cbn. fold (of_nat n). + rewrite (IHn (S x, y)); [reflexivity|]. + rewrite <- H. cbn. now rewrite Nat.add_succ_r. +Qed. + +(** [to_nat] is injective *) + +Corollary to_nat_inj p q : to_nat p = to_nat q -> p = q. +Proof. + intros H %(f_equal of_nat). now rewrite ?cancel_of_to in H. +Qed. + +(** [to_nat] is the left inverse for [of_nat] *) + +Lemma cancel_to_of n : to_nat (of_nat n) = n. +Proof. + induction n as [|n IHn]; [reflexivity|]. + cbn. fold (of_nat n). destruct (of_nat n) as [[|x] y]. + - rewrite <- IHn. cbn. now rewrite PeanoNat.Nat.add_0_r. + - rewrite <- IHn. cbn. now rewrite (Nat.add_succ_r y x). +Qed. + +(** [of_nat] is injective *) + +Corollary of_nat_inj n m : of_nat n = of_nat m -> n = m. +Proof. + intros H %(f_equal to_nat). now rewrite ?cancel_to_of in H. +Qed. + +(** Polynomial specifications of [to_nat] *) + +Lemma to_nat_spec x y : + to_nat (x, y) * 2 = y * 2 + (y + x) * S (y + x). +Proof. + cbn. induction (y + x) as [|n IHn]; cbn; lia. +Qed. + +Lemma to_nat_spec2 x y : + to_nat (x, y) = y + (y + x) * S (y + x) / 2. +Proof. + now rewrite <- Nat.div_add_l, <- to_nat_spec, Nat.div_mul. +Qed. + +(** [to_nat] is non-decreasing in (the sum of) pair components *) + +Lemma to_nat_non_decreasing x y : y + x <= to_nat (x, y). +Proof. + pose proof (to_nat_spec x y). nia. +Qed. diff --git a/theories/Compat/Coq813.v b/theories/Compat/Coq813.v index fe7431dcd3..5cfb9d84c7 100644 --- a/theories/Compat/Coq813.v +++ b/theories/Compat/Coq813.v @@ -11,3 +11,13 @@ (** Compatibility file for making Coq act similar to Coq v8.13 *) Require Export Coq.Compat.Coq814. + +Require Coq.micromega.Lia. +Module Export Coq. + Module Export omega. + Module Export Omega. + #[deprecated(since="8.12", note="The omega tactic was removed in v8.14. You're now relying on the lia tactic.")] + Ltac omega := Lia.lia. + End Omega. + End omega. +End Coq. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 5298f3160a..2a5eb2db39 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -8,8 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Setoid. -Require Import PeanoNat Le Gt Minus Bool Lt. +Require Import PeanoNat Bool. Set Implicit Arguments. (* Set Universe Polymorphism. *) @@ -264,15 +263,13 @@ Section Facts. forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. Proof. intros l l1 l2; revert l1 l2 l. - intro l1; induction l1 as [ | x1 l1]; intro l2; destruct l2 as [ | x2 l2]; - simpl; auto; intros l H. - absurd (length (x2 :: l2 ++ l) <= length l). - simpl; rewrite app_length; auto with arith. - rewrite <- H; auto with arith. - absurd (length (x1 :: l1 ++ l) <= length l). - simpl; rewrite app_length; auto with arith. - rewrite H; auto with arith. - injection H as [= H H0]; f_equal; eauto. + intro l1; induction l1 as [ | x1 l1]; intro l2; destruct l2 as [ | x2 l2]. + - now intros. + - intros l Hl. apply (f_equal (@length A)) in Hl. + now rewrite ?app_length, Nat.add_cancel_r in Hl. + - intros l Hl. apply (f_equal (@length A)) in Hl. + now rewrite ?app_length, Nat.add_cancel_r in Hl. + - intros l [=H1 H2 %IHl1]. now subst. Qed. Lemma app_inv_tail_iff: @@ -472,7 +469,7 @@ Section Elts. - destruct l; simpl; [ inversion 2 | auto ]. - destruct l; simpl. * inversion 2. - * intros d ie; right; apply hn; auto with arith. + * intros d ie; right; apply hn. now apply Nat.succ_le_mono. Qed. Lemma In_nth l x d : In x l -> @@ -481,9 +478,9 @@ Section Elts. induction l as [|a l IH]. - easy. - intros [H|H]. - * subst; exists 0; simpl; auto with arith. + * subst; exists 0; simpl; auto using Nat.lt_0_succ. * destruct (IH H) as (n & Hn & Hn'). - exists (S n); simpl; auto with arith. + apply Nat.succ_lt_mono in Hn. now exists (S n). Qed. Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. @@ -491,7 +488,7 @@ Section Elts. intro l; induction l as [|? ? IHl]; intro n; destruct n; simpl; intros d H; auto. - inversion H. - - apply IHl; auto with arith. + - apply IHl. now apply Nat.succ_le_mono. Qed. Lemma nth_indep : @@ -499,7 +496,8 @@ Section Elts. Proof. intro l; induction l. - inversion 1. - - intros [|n] d d'; simpl; auto with arith. + - intros [|n] d d'; [intros; reflexivity|]. + intros H. apply IHl. now apply Nat.succ_lt_mono. Qed. Lemma app_nth1 : @@ -507,7 +505,8 @@ Section Elts. Proof. intro l; induction l. - inversion 1. - - intros l' d [|n]; simpl; auto with arith. + - intros l' d [|n]; simpl; [intros; reflexivity|]. + intros H. apply IHl. now apply Nat.succ_lt_mono. Qed. Lemma app_nth2 : @@ -515,15 +514,15 @@ Section Elts. Proof. intro l; induction l as [|? ? IHl]; intros l' d [|n]; auto. - inversion 1. - - intros; simpl; rewrite IHl; auto with arith. + - intros; simpl; rewrite IHl; [reflexivity|now apply Nat.succ_le_mono]. Qed. Lemma app_nth2_plus : forall l l' d n, nth (length l + n) (l ++ l') d = nth n l' d. Proof. intros. - rewrite app_nth2, minus_plus; trivial. - auto with arith. + rewrite app_nth2, Nat.add_comm, Nat.add_sub; trivial. + now apply Nat.le_add_r. Qed. Lemma nth_middle : forall l l' a d, @@ -540,7 +539,7 @@ Section Elts. revert l. induction n as [|n IH]; intros [|a l] H; try easy. - exists nil; exists l; now simpl. - - destruct (IH l) as (l1 & l2 & Hl & Hl1); auto with arith. + - destruct (IH l) as (l1 & l2 & Hl & Hl1); [now apply Nat.succ_lt_mono|]. exists (a::l1); exists l2; simpl; split; now f_equal. Qed. @@ -557,7 +556,7 @@ Section Elts. rewrite Hnth; f_equal. + apply IHl with d d'; [ now inversion Hlen | ]. intros n Hlen'; apply (Hnth (S n)). - now simpl; apply lt_n_S. + now apply (Nat.succ_lt_mono n (length l)). + simpl; apply Nat.lt_0_succ. Qed. @@ -575,18 +574,18 @@ Section Elts. induction l as [|a l IH]. - easy. - intros [H|H]. - * subst; exists 0; simpl; auto with arith. + * subst; now exists 0. * destruct (IH H) as (n,Hn). - exists (S n); simpl; auto with arith. + now exists (S n). Qed. Lemma nth_error_None l n : nth_error l n = None <-> length l <= n. Proof. revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; auto. - - split; auto with arith. - - split; now auto with arith. - - rewrite IHl; split; auto with arith. + - now split; intros; [apply Nat.le_0_l|]. + - now split; [|intros ? %Nat.nle_succ_0]. + - now rewrite IHl, Nat.succ_le_mono. Qed. Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. @@ -594,8 +593,8 @@ Section Elts. revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; [now destruct 1 | inversion 1]. - split; [now destruct 1 | inversion 1]. - - split; now auto with arith. - - rewrite IHl; split; auto with arith. + - now split; intros; [apply Nat.lt_0_succ|]. + - now rewrite IHl, Nat.succ_lt_mono. Qed. Lemma nth_error_split l n a : nth_error l n = Some a -> @@ -613,7 +612,7 @@ Section Elts. Proof. revert l. induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. - simpl in *. apply IHn. auto with arith. + simpl in *. apply IHn. now apply Nat.succ_lt_mono. Qed. Lemma nth_error_app2 l l' n : length l <= n -> @@ -621,7 +620,7 @@ Section Elts. Proof. revert l. induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. - simpl in *. apply IHn. auto with arith. + simpl in *. apply IHn. now apply Nat.succ_le_mono. Qed. (** Results directly relating [nth] and [nth_error] *) @@ -841,8 +840,9 @@ Section Elts. Theorem count_occ_In l x : In x l <-> count_occ l x > 0. Proof. induction l as [|y l IHl]; simpl. - - split; [destruct 1 | apply gt_irrefl]. + - split; [destruct 1 | apply Nat.nlt_0_r]. - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition. + now apply Nat.lt_0_succ. Qed. Theorem count_occ_not_In l x : ~ In x l <-> count_occ l x = 0. @@ -990,26 +990,22 @@ Section ListOps. elim (length l); simpl; auto. Qed. - Lemma rev_nth : forall l d n, n < length l -> + Lemma rev_nth : forall l d n, n < length l -> nth n (rev l) d = nth (length l - S n) l d. Proof. intro l; induction l as [|a l IHl]. - intros d n H; inversion H. - intros ? n H. - simpl in H. - simpl (rev (a :: l)). - simpl (length (a :: l) - S n). - inversion H. - rewrite <- minus_n_n; simpl. - rewrite <- rev_length. - rewrite app_nth2; auto. - rewrite <- minus_n_n; auto. - rewrite app_nth1; auto. - rewrite (minus_plus_simpl_l_reverse (length l) n 1). - replace (1 + length l) with (S (length l)); auto with arith. - rewrite <- minus_Sn_m; auto with arith. - apply IHl ; auto with arith. - rewrite rev_length; auto. + - intros d n H; inversion H. + - intros ? n H. simpl in H. + inversion H. + + rewrite Nat.sub_diag; simpl. + rewrite <- rev_length. + rewrite app_nth2; auto. + now rewrite Nat.sub_diag. + + simpl. rewrite app_nth1; [|now rewrite rev_length]. + rewrite IHl; [|eassumption]. + destruct (length l); [exfalso; now apply (Nat.nlt_0_r n)|]. + rewrite (Nat.sub_succ_l n); [reflexivity|]. + now apply Nat.succ_le_mono. Qed. @@ -1168,10 +1164,18 @@ Section Map. intro l; induction l; simpl map; intros d n; destruct n; firstorder. Qed. + Lemma nth_error_map : forall n l, + nth_error (map l) n = option_map f (nth_error l n). + Proof. + intro n. induction n as [|n IHn]; intro l. + - now destruct l. + - destruct l as [|? l]; [reflexivity|exact (IHn l)]. + Qed. + Lemma map_nth_error : forall n l d, nth_error l n = Some d -> nth_error (map l) n = Some (f d). Proof. - intro n; induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. + intros n l d H. now rewrite nth_error_map, H. Qed. Lemma map_app : forall l l', @@ -1352,7 +1356,7 @@ Proof. + inversion Hlen. + now rewrite nth_overflow; destruct n. - destruct n; simpl; [ reflexivity | apply IHln ]. - destruct Hlen; [ left; apply lt_S_n | right ]; assumption. + destruct Hlen; [ left; apply Nat.succ_lt_mono | right ]; assumption. Qed. @@ -1388,8 +1392,7 @@ Proof. intros A l. enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0). induction l as [|? ? IHl]; simpl; auto. - intros; rewrite IHl. - simpl; auto with arith. + now intros; rewrite IHl, Nat.add_succ_r. Qed. (************************************) @@ -1494,7 +1497,7 @@ End Fold_Right_Recursor. simpl; intros n ? ? H0. destruct (orb_false_elim _ _ H0); clear H0; auto. destruct n ; auto. - rewrite IHl; auto with arith. + rewrite IHl; auto. now apply Nat.succ_lt_mono. Qed. Lemma existsb_app : forall l1 l2, @@ -1930,37 +1933,35 @@ Section length_order. Lemma lel_refl : lel l l. Proof. - unfold lel; auto with arith. + now apply Nat.le_refl. Qed. Lemma lel_trans : lel l m -> lel m n -> lel l n. Proof. unfold lel; intros. now_show (length l <= length n). - apply le_trans with (length m); auto with arith. + now apply Nat.le_trans with (length m). Qed. Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m). Proof. - unfold lel; simpl; auto with arith. + now intros ? %Nat.succ_le_mono. Qed. Lemma lel_cons : lel l m -> lel l (b :: m). Proof. - unfold lel; simpl; auto with arith. + intros. now apply Nat.le_le_succ_r. Qed. Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m. Proof. - unfold lel; simpl; auto with arith. + intros. now apply Nat.succ_le_mono. Qed. Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'. Proof. - intro l'; elim l'; auto with arith. - intros a' y H H0. - now_show (nil = a' :: y). - absurd (S (length y) <= 0); auto with arith. + intro l'; elim l'; [now intros|]. + now intros a' y H H0 %Nat.nle_succ_0. Qed. End length_order. @@ -2135,7 +2136,7 @@ Section Cutting. rewrite (length_zero_iff_nil l) in H1. subst. now simpl. - intro l; destruct l as [|x xs]; simpl. * now reflexivity. - * simpl. intro H. apply Peano.le_S_n in H. f_equal. apply iHk, H. + * simpl. intro H. f_equal. apply iHk. now apply Nat.succ_le_mono. Qed. Lemma firstn_O l: firstn 0 l = []. @@ -2144,17 +2145,17 @@ Section Cutting. Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n. Proof. induction n as [|k iHk]; simpl; [auto | intro l; destruct l as [|x xs]; simpl]. - - auto with arith. - - apply Peano.le_n_S, iHk. + - now apply Nat.le_0_l. + - now rewrite <- Nat.succ_le_mono. Qed. Lemma firstn_length_le: forall l:list A, forall n:nat, n <= length l -> length (firstn n l) = n. Proof. intro l; induction l as [|x xs Hrec]. - - simpl. intros n H. apply le_n_0_eq in H. rewrite <- H. now simpl. + - simpl. intros n H. apply Nat.le_0_r in H. now subst. - intro n; destruct n as [|n]. * now simpl. - * simpl. intro H. apply le_S_n in H. now rewrite (Hrec n H). + * simpl. intro H. f_equal. apply Hrec. now apply Nat.succ_le_mono. Qed. Lemma firstn_app n: @@ -2163,7 +2164,7 @@ Section Cutting. Proof. induction n as [|k iHk]; intros l1 l2. - now simpl. - destruct l1 as [|x xs]. - * unfold firstn at 2, length. now rewrite 2!app_nil_l, <- minus_n_O. + * reflexivity. * rewrite <- app_comm_cons. simpl. f_equal. apply iHk. Qed. @@ -2172,13 +2173,13 @@ Section Cutting. firstn ((length l1) + n) (l1 ++ l2) = l1 ++ firstn n l2. Proof. induction n as [| k iHk];intros l1 l2. - unfold firstn at 2. rewrite <- plus_n_O, app_nil_r. - rewrite firstn_app. rewrite <- minus_diag_reverse. + rewrite firstn_app. rewrite Nat.sub_diag. unfold firstn at 2. rewrite app_nil_r. apply firstn_all. - destruct l2 as [|x xs]. - * simpl. rewrite app_nil_r. apply firstn_all2. auto with arith. + * simpl. rewrite app_nil_r. apply firstn_all2. now apply Nat.le_add_r. * rewrite firstn_app. assert (H0 : (length l1 + S k - length l1) = S k). - auto with arith. - rewrite H0, firstn_all2; [reflexivity | auto with arith]. + now rewrite Nat.add_comm, Nat.add_sub. + rewrite H0, firstn_all2; [reflexivity | now apply Nat.le_add_r]. Qed. Lemma firstn_firstn: @@ -2279,11 +2280,7 @@ Section Cutting. destruct (Nat.le_ge_cases (length (rev l)) x) as [L | L]. - rewrite skipn_all2; [apply Nat.sub_0_le in L | trivial]. now rewrite L, Nat.sub_0_r, skipn_all. - - replace (length (rev l) - (length (rev l) - x)) - with (length (rev l) + x - length (rev l)). - rewrite minus_plus. reflexivity. - rewrite <- (Nat.sub_add _ _ L) at 2. - now rewrite <-!(Nat.add_comm x), <-minus_plus_simpl_l_reverse. + - f_equal. now apply Nat.eq_sym, Nat.add_sub_eq_l, Nat.sub_add. Qed. Lemma removelast_firstn : forall n l, n < length l -> @@ -2298,7 +2295,7 @@ Section Cutting. change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l). change (firstn (S n) (a::l)) with (a::firstn n l). rewrite removelast_app. - rewrite IHn; auto with arith. + rewrite IHn; [reflexivity|now apply Nat.succ_le_mono]. clear IHn; destruct l; simpl in *; try discriminate. inversion_clear H as [|? H1]. @@ -2323,7 +2320,7 @@ Section Cutting. simpl in H. change (removelast (a :: l)) with (removelast ((a::nil)++l)). rewrite removelast_app. - simpl; f_equal; auto with arith. + simpl; f_equal. apply IHn. now apply Nat.succ_lt_mono. intro H0; rewrite H0 in H; inversion_clear H as [|? H1]; inversion_clear H1. Qed. @@ -2415,7 +2412,7 @@ Section Add. Lemma Add_length a l l' : Add a l l' -> length l' = S (length l). Proof. - induction 1; simpl; auto with arith. + induction 1; simpl; now auto. Qed. Lemma Add_inv a l : In a l -> exists l', Add a l' l. @@ -2594,13 +2591,13 @@ Section ReDun. - destruct i, j; simpl in *; auto. * elim Hal. eapply nth_error_In; eauto. * elim Hal. eapply nth_error_In; eauto. - * f_equal. apply IH; auto with arith. } + * f_equal. now apply IH;[apply Nat.succ_lt_mono|]. } { induction l as [|a l IHl]; intros H; constructor. * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn). assert (n < length l) by (now rewrite <- nth_error_Some, Hn). - specialize (H 0 (S n)). simpl in H. discriminate H; auto with arith. + specialize (H 0 (S n)). simpl in H. now discriminate H; [apply Nat.lt_0_succ|]. * apply IHl. - intros i j Hi E. apply eq_add_S, H; simpl; auto with arith. } + intros i j Hi %Nat.succ_lt_mono E. now apply eq_add_S, H. } Qed. Lemma NoDup_nth l d : @@ -2612,14 +2609,17 @@ Section ReDun. { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi Hj E. - inversion Hi. - destruct i, j; simpl in *; auto. - * elim Hal. subst a. apply nth_In; auto with arith. - * elim Hal. subst a. apply nth_In; auto with arith. - * f_equal. apply IH; auto with arith. } + * elim Hal. subst a. now apply nth_In, Nat.succ_lt_mono. + * elim Hal. subst a. now apply nth_In, Nat.succ_lt_mono. + * f_equal. apply IH; [| |assumption]; now apply Nat.succ_lt_mono. } { induction l as [|a l IHl]; intros H; constructor. * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn'). - specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith. + specialize (H 0 (S n)). simpl in H. + apply Nat.succ_lt_mono in Hn. + discriminate H; eauto using Nat.lt_0_succ. * apply IHl. - intros i j Hi Hj E. apply eq_add_S, H; simpl; auto with arith. } + intros i j Hi %Nat.succ_lt_mono Hj %Nat.succ_lt_mono E. + now apply eq_add_S, H. } Qed. (** Having [NoDup] hypotheses bring more precise facts about [incl]. *) @@ -2628,7 +2628,7 @@ Section ReDun. NoDup l -> incl l l' -> length l <= length l'. Proof. intros N. revert l'. induction N as [|a l Hal N IH]; simpl. - - auto with arith. + - intros. now apply Nat.le_0_l. - intros l' H. destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } rewrite (Add_length AD). apply le_n_S. apply IH. @@ -2645,7 +2645,7 @@ Section ReDun. rewrite (Add_in AD) in Hx. simpl in Hx. destruct Hx as [Hx|Hx]; [left; trivial|right]. revert x Hx. apply (IH l''); trivial. - * apply le_S_n. now rewrite <- (Add_length AD). + * apply Nat.succ_le_mono. now rewrite <- (Add_length AD). * now apply incl_Add_inv with a l'. Qed. @@ -2720,9 +2720,8 @@ Section NatSeq. intro len; induction len as [|len IHlen]; intros start n d H. inversion H. simpl seq. - destruct n; simpl. - auto with arith. - rewrite IHlen;simpl; auto with arith. + destruct n; simpl. now rewrite Nat.add_0_r. + now rewrite IHlen; [rewrite Nat.add_succ_r|apply Nat.succ_lt_mono]. Qed. Lemma seq_shift : forall len start, @@ -2730,25 +2729,29 @@ Section NatSeq. Proof. intro len; induction len as [|len IHlen]; simpl; auto. intros. - rewrite IHlen. - auto with arith. + now rewrite IHlen. Qed. Lemma in_seq len start n : In n (seq start len) <-> start <= n < start+len. Proof. - revert start. induction len as [|len IHlen]; simpl; intros. - - rewrite <- plus_n_O. split;[easy|]. - intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')). - - rewrite IHlen, <- plus_n_Sm; simpl; split. - + intros [H|H]; subst; intuition auto with arith. - + intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition. + revert start. induction len as [|len IHlen]; simpl; intros start. + - rewrite <- plus_n_O. split;[easy|]. + intros (H,H'). apply (Nat.lt_irrefl start). + eapply Nat.le_lt_trans; eassumption. + - rewrite IHlen, <- plus_n_Sm; simpl; split. + + intros [H|H]; subst; intuition. + * apply -> Nat.succ_le_mono. apply Nat.le_add_r. + * now apply Nat.lt_le_incl. + + intros (H,H'). inversion H. + * now left. + * right. subst. now split; [apply -> Nat.succ_le_mono|]. Qed. Lemma seq_NoDup len start : NoDup (seq start len). Proof. revert start; induction len; simpl; constructor; trivial. - rewrite in_seq. intros (H,_). apply (Lt.lt_irrefl _ H). + rewrite in_seq. intros (H,_). now apply (Nat.lt_irrefl start). Qed. Lemma seq_app : forall len1 len2 start, @@ -3051,6 +3054,53 @@ Hint Constructors Exists : core. #[global] Hint Constructors Forall : core. +Lemma Exists_map A B (f : A -> B) P l : + Exists P (map f l) <-> Exists (fun x => P (f x)) l. +Proof. + induction l as [|a l IHl]. + - cbn. now rewrite Exists_nil. + - cbn. now rewrite ?Exists_cons, IHl. +Qed. + +Lemma Exists_concat A P (ls : list (list A)) : + Exists P (concat ls) <-> Exists (Exists P) ls. +Proof. + induction ls as [|l ls IHls]. + - cbn. now rewrite Exists_nil. + - cbn. now rewrite Exists_app, Exists_cons, IHls. +Qed. + +Lemma Exists_flat_map A B P ls (f : A -> list B) : + Exists P (flat_map f ls) <-> Exists (fun d => Exists P (f d)) ls. +Proof. + now rewrite flat_map_concat_map, Exists_concat, Exists_map. +Qed. + +Lemma Forall_map A B (f : A -> B) P l : + Forall P (map f l) <-> Forall (fun x => P (f x)) l. +Proof. + induction l as [|a l IHl]. + - constructor; intros; now constructor. + - constructor; intro H; + (constructor; [exact (Forall_inv H) | apply IHl; exact (Forall_inv_tail H)]). +Qed. + +Lemma Forall_concat A P (ls : list (list A)) : + Forall P (concat ls) <-> Forall (Forall P) ls. +Proof. + induction ls as [|l ls IHls]. + - constructor; intros; now constructor. + - cbn. rewrite Forall_app. constructor; intro H. + + constructor; [exact (proj1 H) | apply IHls; exact (proj2 H)]. + + constructor; [exact (Forall_inv H) | apply IHls; exact (Forall_inv_tail H)]. +Qed. + +Lemma Forall_flat_map A B P ls (f : A -> list B) : + Forall P (flat_map f ls) <-> Forall (fun d => Forall P (f d)) ls. +Proof. + now rewrite flat_map_concat_map, Forall_concat, Forall_map. +Qed. + Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, (exists k, Forall (P k) l) -> Forall (fun x => exists k, P k x) l. Proof. @@ -3320,6 +3370,22 @@ Section Repeat. now rewrite Heq in Hneq. Qed. + Lemma nth_repeat a m n : + nth n (repeat a m) a = a. + Proof. + revert n. induction m as [|m IHm]. + - now intros [|n]. + - intros [|n]; [reflexivity|exact (IHm n)]. + Qed. + + Lemma nth_error_repeat a m n : + n < m -> nth_error (repeat a m) n = Some a. + Proof. + intro Hnm. rewrite (nth_error_nth' _ a). + - now rewrite nth_repeat. + - now rewrite repeat_length. + Qed. + End Repeat. Lemma repeat_to_concat A n (a:A) : @@ -3357,11 +3423,12 @@ Qed. Lemma list_max_le : forall l n, list_max l <= n <-> Forall (fun k => k <= n) l. Proof. -intro l; induction l as [|a l IHl]; simpl; intros n; split; intros H; intuition. -- apply Nat.max_lub_iff in H. - now constructor; [ | apply IHl ]. -- inversion_clear H as [ | ? ? Hle HF ]. - apply IHl in HF; apply Nat.max_lub; assumption. + intro l; induction l as [|a l IHl]; simpl; intros n; split. + - now intros. + - intros. now apply Nat.le_0_l. + - intros [? ?] %Nat.max_lub_iff. now constructor; [|apply IHl]. + - intros H. apply Nat.max_lub_iff. + constructor; [exact (Forall_inv H)|apply IHl; exact (Forall_inv_tail H)]. Qed. Lemma list_max_lt : forall l n, l <> nil -> diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 3dac62c476..23bc396fd7 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -676,7 +676,7 @@ Qed. We show instead that functional relation reification and the functional form of the axiom of choice are equivalent on decidable - relation with [nat] as codomain + relations with [nat] as codomain. *) Require Import Wf_nat. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 4735d6c9ca..a151cca3af 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -43,7 +43,7 @@ Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g #[universes(template)] Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. -Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}. +Definition delta {A} (a:A) := {| pi1 := a; pi2 := a; eq := eq_refl a |}. Arguments pi1 {A} _. Arguments pi2 {A} _. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 37d20bffad..c1928fef8d 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -30,6 +30,7 @@ *) Require Import FunInd Orders OrdersFacts MSetInterface PeanoNat. +Require Arith. (* contains deprecated dependencies *) Local Open Scope list_scope. Local Open Scope lazy_bool_scope. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 2a26b6b12a..4bf971668d 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -218,7 +218,6 @@ Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. apply Zdiv_lt_upper_bound;auto with zarith. apply Z.lt_le_trans with y;auto with zarith. rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. - assert (0 < 2^p);auto with zarith. replace (2^p) with 0. destruct x;change (0<y);auto with zarith. destruct p;trivial;discriminate. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index a3ebe67325..d3fac82d09 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -1428,7 +1428,7 @@ Proof. assert (Hp3: (0 < Φ (WW ih il))). {simpl zn2z_to_Z;apply Z.lt_le_trans with (φ ih * wB)%Z; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } + } cbv zeta. case_eq (ih <? j)%int63;intros Heq. rewrite -> ltb_spec in Heq. @@ -1465,7 +1465,6 @@ Proof. apply Hrec; rewrite H; clear u H. assert (Hf1: 0 <= Φ (WW ih il) / φ j) by (apply Z_div_pos; auto with zarith). case (Zle_lt_or_eq 1 (φ j)); auto with zarith; intros Hf2. - 2: contradict Heq0; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. split. replace (φ j + Φ (WW ih il) / φ j)%Z with (1 * 2 + ((φ j - 2) + Φ (WW ih il) / φ j)) by lia. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 47137414dc..ff1a2b5a53 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1775,8 +1775,6 @@ weak_Zmult_plus_distr_r (now Z.mul_add_distr_pos) Definition Zne (x y:Z) := x <> y. (* TODO : to remove someday ? *) -Register Zne as plugins.omega.Zne. - Ltac elim_compare com1 com2 := case (Dcompare (com1 ?= com2)%Z); [ idtac | let x := fresh "H" in diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index ed47539e1e..5490044ac7 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -16,9 +16,11 @@ Require Export ZArith_base. Require Export Zpow_def. -(** Extra modules using [Omega] or [Ring]. *) +(** Extra modules using [Ring]. *) -Require Export Omega. +Require Export OmegaLemmas. +Require Export PreOmega. +Require Export ZArith_hints. Require Export Zcomplements. Require Export Zpower. Require Export Zdiv. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 7f72d42d1f..b7cd849323 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -959,13 +959,6 @@ Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m). Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m). Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m). -Register neq as plugins.omega.neq. -Register inj_eq as plugins.omega.inj_eq. -Register inj_neq as plugins.omega.inj_neq. -Register inj_le as plugins.omega.inj_le. -Register inj_lt as plugins.omega.inj_lt. -Register inj_ge as plugins.omega.inj_ge. -Register inj_gt as plugins.omega.inj_gt. (** For the others, a Notation is fine *) @@ -1033,5 +1026,3 @@ Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z.of_nat (n - m) = 0. Proof. intros. rewrite not_le_minus_0; auto with arith. Qed. - -Register inj_minus2 as plugins.omega.inj_minus2. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 4c533ac458..bef9cede12 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -64,11 +64,6 @@ Proof. apply Z.lt_gt_cases. Qed. -Register dec_Zne as plugins.omega.dec_Zne. -Register dec_Zgt as plugins.omega.dec_Zgt. -Register dec_Zge as plugins.omega.dec_Zge. -Register not_Zeq as plugins.omega.not_Zeq. - (** * Relating strict and large orders *) Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing). @@ -120,12 +115,6 @@ Proof. destruct (Z.eq_decidable n m); [assumption|now elim H]. Qed. -Register Znot_le_gt as plugins.omega.Znot_le_gt. -Register Znot_lt_ge as plugins.omega.Znot_lt_ge. -Register Znot_ge_lt as plugins.omega.Znot_ge_lt. -Register Znot_gt_le as plugins.omega.Znot_gt_le. -Register not_Zne as plugins.omega.not_Zne. - (** * Equivalence and order properties *) (** Reflexivity *) diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 10ea6cc03e..369a0c46ae 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -93,11 +93,3 @@ Proof. apply Z.le_lt_trans with (m*n+p); trivial. now apply Z.add_lt_mono_l. Qed. - -Register Zegal_left as plugins.omega.Zegal_left. -Register Zne_left as plugins.omega.Zne_left. -Register Zlt_left as plugins.omega.Zlt_left. -Register Zgt_left as plugins.omega.Zgt_left. -Register Zle_left as plugins.omega.Zle_left. -Register Zge_left as plugins.omega.Zge_left. -Register Zmult_le_approx as plugins.omega.Zmult_le_approx. diff --git a/theories/dune b/theories/dune index 1cd3d8c119..57b97f080c 100644 --- a/theories/dune +++ b/theories/dune @@ -22,7 +22,6 @@ coq-core.plugins.ring coq-core.plugins.nsatz - coq-core.plugins.omega coq-core.plugins.zify coq-core.plugins.micromega @@ -34,3 +33,6 @@ coq-core.plugins.derive)) (include_subdirs qualified) + +(documentation + (package coq-stdlib)) diff --git a/theories/extraction/ExtrOcamlBigIntConv.v b/theories/extraction/ExtrOcamlBigIntConv.v index 29bd732c78..b4aed4c3f7 100644 --- a/theories/extraction/ExtrOcamlBigIntConv.v +++ b/theories/extraction/ExtrOcamlBigIntConv.v @@ -8,12 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Extraction to Ocaml: conversion from/to [big_int] *) +(** Extraction to OCaml: conversion from/to [Z.t] *) -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) +(** NB: The extracted code should be linked with [zarith.cm(x)a] and with + the [big.ml] wrapper. The latter can be found in the sources of Coq. *) Require Coq.extraction.Extraction. diff --git a/theories/extraction/ExtrOcamlNatBigInt.v b/theories/extraction/ExtrOcamlNatBigInt.v index 8a7ba92a94..c854f8fd5d 100644 --- a/theories/extraction/ExtrOcamlNatBigInt.v +++ b/theories/extraction/ExtrOcamlNatBigInt.v @@ -8,17 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Extraction of [nat] into Ocaml's [big_int] *) +(** Extraction of [nat] into Zarith's [Z.t] *) Require Coq.extraction.Extraction. Require Import Arith Even Div2 EqNat Euclid. Require Import ExtrOcamlBasic. -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) +(** NB: The extracted code should be linked with [zarith.cm(x)a] and with + the [big.ml] wrapper. The latter can be found in the sources of Coq. *) (** Disclaimer: trying to obtain efficient certified programs by extracting [nat] into [big_int] isn't necessarily a good idea. diff --git a/theories/extraction/ExtrOcamlZBigInt.v b/theories/extraction/ExtrOcamlZBigInt.v index 40a47b36fa..df9153a46d 100644 --- a/theories/extraction/ExtrOcamlZBigInt.v +++ b/theories/extraction/ExtrOcamlZBigInt.v @@ -8,17 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *) +(** Extraction of [positive], [N], and [Z], into Zarith's [Z.t] *) Require Coq.extraction.Extraction. Require Import ZArith NArith. Require Import ExtrOcamlBasic. -(** NB: The extracted code should be linked with [nums.cm(x)a] - from ocaml's stdlib and with the wrapper [big.ml] that - simplifies the use of [Big_int] (it can be found in the sources - of Coq). *) +(** NB: The extracted code should be linked with [zarith.cm(x)a] and with + the [big.ml] wrapper. The latter can be found in the sources of Coq. *) (** Disclaimer: trying to obtain efficient certified programs by extracting [Z] into [big_int] isn't necessarily a good idea. diff --git a/theories/index.mld b/theories/index.mld new file mode 100644 index 0000000000..360864342b --- /dev/null +++ b/theories/index.mld @@ -0,0 +1,3 @@ +{0 coq-stdlib } + +The coq-stdlib package only contains Coq theory files for the standard library and no OCaml libraries. diff --git a/theories/micromega/OrderedRing.v b/theories/micromega/OrderedRing.v index 5fa3740ab1..bfbd6fd8d3 100644 --- a/theories/micromega/OrderedRing.v +++ b/theories/micromega/OrderedRing.v @@ -423,7 +423,7 @@ Qed. (* The following theorems are used to build a morphism from Z to R and prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) -(* Surprisingly, multilication is needed to prove the following theorem *) +(* Surprisingly, multiplication is needed to prove the following theorem *) Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. Proof. @@ -457,4 +457,3 @@ apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. Qed.*) End STRICT_ORDERED_RING. - diff --git a/theories/micromega/Zify.v b/theories/micromega/Zify.v index 01cc9ad810..3a50001b1f 100644 --- a/theories/micromega/Zify.v +++ b/theories/micromega/Zify.v @@ -33,5 +33,6 @@ Ltac zify := intros; zify_elim_let ; zify_op ; (zify_iter_specs) ; - zify_saturate ; - zify_to_euclidean_division_equations ; zify_post_hook. + zify_to_euclidean_division_equations ; + zify_post_hook; + zify_saturate. diff --git a/theories/micromega/ZifyClasses.v b/theories/micromega/ZifyClasses.v index f6ade67c5f..25d9fa9104 100644 --- a/theories/micromega/ZifyClasses.v +++ b/theories/micromega/ZifyClasses.v @@ -7,7 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Set Primitive Projections. (** An alternative to [zify] in ML parametrised by user-provided classes instances. @@ -220,6 +219,13 @@ Proof. exact (fun H => proj1 IFF H). Qed. +Lemma rew_iff_rev (P Q : Prop) (IFF : P <-> Q) : Q -> P. +Proof. + exact (fun H => proj2 IFF H). +Qed. + + + (** Registering constants for use by the plugin *) Register eq_iff as ZifyClasses.eq_iff. Register target_prop as ZifyClasses.target_prop. @@ -247,11 +253,22 @@ Register eq as ZifyClasses.eq. Register mkinjprop as ZifyClasses.mkinjprop. Register iff_refl as ZifyClasses.iff_refl. Register rew_iff as ZifyClasses.rew_iff. +Register rew_iff_rev as ZifyClasses.rew_iff_rev. Register source_prop as ZifyClasses.source_prop. Register injprop_ok as ZifyClasses.injprop_ok. Register iff as ZifyClasses.iff. + +Register InjTyp as ZifyClasses.InjTyp. +Register BinOp as ZifyClasses.BinOp. +Register UnOp as ZifyClasses.UnOp. +Register CstOp as ZifyClasses.CstOp. +Register BinRel as ZifyClasses.BinRel. +Register PropOp as ZifyClasses.PropOp. +Register PropUOp as ZifyClasses.PropUOp. Register BinOpSpec as ZifyClasses.BinOpSpec. Register UnOpSpec as ZifyClasses.UnOpSpec. +Register Saturate as ZifyClasses.Saturate. + (** Propositional logic *) Register and as ZifyClasses.and. @@ -264,3 +281,4 @@ Register impl_morph as ZifyClasses.impl_morph. Register not as ZifyClasses.not. Register not_morph as ZifyClasses.not_morph. Register True as ZifyClasses.True. +Register I as ZifyClasses.I. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index 9881e73f76..8dee70be45 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -307,15 +307,15 @@ Instance Op_N_mul : BinOp N.mul := Add Zify BinOp Op_N_mul. Instance Op_N_sub : BinOp N.sub := - {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max|}. + {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max |}. Add Zify BinOp Op_N_sub. Instance Op_N_div : BinOp N.div := - {| TBOp := Z.div ; TBOpInj := N2Z.inj_div|}. + {| TBOp := Z.div ; TBOpInj := N2Z.inj_div |}. Add Zify BinOp Op_N_div. Instance Op_N_mod : BinOp N.modulo := - {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem|}. + {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem |}. Add Zify BinOp Op_N_mod. Instance Op_N_pred : UnOp N.pred := @@ -332,19 +332,19 @@ Add Zify UnOp Op_N_succ. (* zify_Z_rel *) Instance Op_Z_ge : BinRel Z.ge := - {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y)|}. + {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y) |}. Add Zify BinRel Op_Z_ge. Instance Op_Z_lt : BinRel Z.lt := - {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y)|}. + {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y) |}. Add Zify BinRel Op_Z_lt. Instance Op_Z_gt : BinRel Z.gt := - {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y)|}. + {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y) |}. Add Zify BinRel Op_Z_gt. Instance Op_Z_le : BinRel Z.le := - {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y)|}. + {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y) |}. Add Zify BinRel Op_Z_le. Instance Op_eqZ : BinRel (@eq Z) := @@ -460,7 +460,7 @@ Add Zify UnOp Op_Z_to_nat. (** Specification of derived operators over Z *) Instance ZmaxSpec : BinOpSpec Z.max := - {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}. + {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec |}. Add Zify BinOpSpec ZmaxSpec. Instance ZminSpec : BinOpSpec Z.min := @@ -470,49 +470,30 @@ Add Zify BinOpSpec ZminSpec. Instance ZsgnSpec : UnOpSpec Z.sgn := {| UPred := fun n r : Z => 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - (1) ; - USpec := Z.sgn_spec|}. + USpec := Z.sgn_spec |}. Add Zify UnOpSpec ZsgnSpec. Instance ZabsSpec : UnOpSpec Z.abs := {| UPred := fun n r: Z => 0 <= n /\ r = n \/ n < 0 /\ r = - n ; - USpec := Z.abs_spec|}. + USpec := Z.abs_spec |}. Add Zify UnOpSpec ZabsSpec. (** Saturate positivity constraints *) -Instance SatProd : Saturate Z.mul := - {| - PArg1 := fun x => 0 <= x; - PArg2 := fun y => 0 <= y; - PRes := fun r => 0 <= r; - SatOk := Z.mul_nonneg_nonneg - |}. -Add Zify Saturate SatProd. - -Instance SatProdPos : Saturate Z.mul := +Instance SatPowPos : Saturate Z.pow := {| PArg1 := fun x => 0 < x; - PArg2 := fun y => 0 < y; + PArg2 := fun y => 0 <= y; PRes := fun r => 0 < r; - SatOk := Z.mul_pos_pos + SatOk := Z.pow_pos_nonneg |}. -Add Zify Saturate SatProdPos. - -Lemma pow_pos_strict : - forall a b, - 0 < a -> 0 < b -> 0 < a ^ b. -Proof. - intros. - apply Z.pow_pos_nonneg; auto. - apply Z.lt_le_incl;auto. -Qed. - +Add Zify Saturate SatPowPos. -Instance SatPowPos : Saturate Z.pow := +Instance SatPowNonneg : Saturate Z.pow := {| - PArg1 := fun x => 0 < x; - PArg2 := fun y => 0 < y; - PRes := fun r => 0 < r; - SatOk := pow_pos_strict + PArg1 := fun x => 0 <= x; + PArg2 := fun y => True; + PRes := fun r => 0 <= r; + SatOk := fun a b Ha _ => @Z.pow_nonneg a b Ha |}. -Add Zify Saturate SatPowPos. +Add Zify Saturate SatPowNonneg. diff --git a/theories/omega/Omega.v b/theories/omega/Omega.v deleted file mode 100644 index 5c52284621..0000000000 --- a/theories/omega/Omega.v +++ /dev/null @@ -1,24 +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) *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(* We import what is necessary for Omega *) -Require Export ZArith_base. -Require Export OmegaLemmas. -Require Export PreOmega. -Require Export ZArith_hints. - -Declare ML Module "omega_plugin". diff --git a/theories/omega/OmegaLemmas.v b/theories/omega/OmegaLemmas.v index 08e9ac345d..8ccd8d76f6 100644 --- a/theories/omega/OmegaLemmas.v +++ b/theories/omega/OmegaLemmas.v @@ -261,47 +261,3 @@ Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. - -Register fast_Zplus_assoc_reverse as plugins.omega.fast_Zplus_assoc_reverse. -Register fast_Zplus_assoc as plugins.omega.fast_Zplus_assoc. -Register fast_Zmult_assoc_reverse as plugins.omega.fast_Zmult_assoc_reverse. -Register fast_Zplus_permute as plugins.omega.fast_Zplus_permute. -Register fast_Zplus_comm as plugins.omega.fast_Zplus_comm. -Register fast_Zmult_comm as plugins.omega.fast_Zmult_comm. - -Register OMEGA1 as plugins.omega.OMEGA1. -Register OMEGA2 as plugins.omega.OMEGA2. -Register OMEGA3 as plugins.omega.OMEGA3. -Register OMEGA4 as plugins.omega.OMEGA4. -Register OMEGA5 as plugins.omega.OMEGA5. -Register OMEGA6 as plugins.omega.OMEGA6. -Register OMEGA7 as plugins.omega.OMEGA7. -Register OMEGA8 as plugins.omega.OMEGA8. -Register OMEGA9 as plugins.omega.OMEGA9. -Register fast_OMEGA10 as plugins.omega.fast_OMEGA10. -Register fast_OMEGA11 as plugins.omega.fast_OMEGA11. -Register fast_OMEGA12 as plugins.omega.fast_OMEGA12. -Register fast_OMEGA13 as plugins.omega.fast_OMEGA13. -Register fast_OMEGA14 as plugins.omega.fast_OMEGA14. -Register fast_OMEGA15 as plugins.omega.fast_OMEGA15. -Register fast_OMEGA16 as plugins.omega.fast_OMEGA16. -Register OMEGA17 as plugins.omega.OMEGA17. -Register OMEGA18 as plugins.omega.OMEGA18. -Register OMEGA19 as plugins.omega.OMEGA19. -Register OMEGA20 as plugins.omega.OMEGA20. - -Register fast_Zred_factor0 as plugins.omega.fast_Zred_factor0. -Register fast_Zred_factor1 as plugins.omega.fast_Zred_factor1. -Register fast_Zred_factor2 as plugins.omega.fast_Zred_factor2. -Register fast_Zred_factor3 as plugins.omega.fast_Zred_factor3. -Register fast_Zred_factor4 as plugins.omega.fast_Zred_factor4. -Register fast_Zred_factor5 as plugins.omega.fast_Zred_factor5. -Register fast_Zred_factor6 as plugins.omega.fast_Zred_factor6. - -Register fast_Zmult_plus_distr_l as plugins.omega.fast_Zmult_plus_distr_l. -Register fast_Zopp_plus_distr as plugins.omega.fast_Zopp_plus_distr. -Register fast_Zopp_mult_distr_r as plugins.omega.fast_Zopp_mult_distr_r. -Register fast_Zopp_eq_mult_neg_1 as plugins.omega.fast_Zopp_eq_mult_neg_1. - -Register new_var as plugins.omega.new_var. -Register intro_Z as plugins.omega.intro_Z. diff --git a/theories/omega/OmegaPlugin.v b/theories/omega/OmegaPlugin.v deleted file mode 100644 index e0cf24f6aa..0000000000 --- a/theories/omega/OmegaPlugin.v +++ /dev/null @@ -1,17 +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) *) -(************************************************************************) - -(* To strictly import the omega tactic *) - -Require ZArith_base. -Require OmegaLemmas. -Require PreOmega. - -Declare ML Module "omega_plugin". diff --git a/theories/omega/OmegaTactic.v b/theories/omega/OmegaTactic.v deleted file mode 100644 index e0cf24f6aa..0000000000 --- a/theories/omega/OmegaTactic.v +++ /dev/null @@ -1,17 +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) *) -(************************************************************************) - -(* To strictly import the omega tactic *) - -Require ZArith_base. -Require OmegaLemmas. -Require PreOmega. - -Declare ML Module "omega_plugin". diff --git a/theories/omega/PreOmega.v b/theories/omega/PreOmega.v index 70f25e7243..bf873785d0 100644 --- a/theories/omega/PreOmega.v +++ b/theories/omega/PreOmega.v @@ -12,9 +12,10 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Local Open Scope Z_scope. -(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) +(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: + the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) -(** These tactic use the complete specification of [Z.div] and +(** These tactics use the complete specification of [Z.div] and [Z.modulo] ([Z.quot] and [Z.rem], respectively) to remove these functions from the goal without losing information. The [Z.euclidean_division_equations_cleanup] tactic removes needless @@ -127,449 +128,6 @@ Module Z. Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. End Z. -Set Warnings "-deprecated-tactic". - -(** * zify: the Z-ification tactic *) - -(* This tactic searches for nat and N and positive elements in the goal and - translates everything into Z. It is meant as a pre-processor for - (r)omega; for instance a positivity hypothesis is added whenever - - a multiplication is encountered - - an atom is encountered (that is a variable or an unknown construct) - - Recognized relations (can be handled as deeply as allowed by setoid rewrite): - - { eq, le, lt, ge, gt } on { Z, positive, N, nat } - - Recognized operations: - - on Z: Z.min, Z.max, Z.abs, Z.sgn are translated in term of <= < = - - on nat: + * - S O pred min max Pos.to_nat N.to_nat Z.abs_nat - - on positive: Zneg Zpos xI xO xH + * - Pos.succ Pos.pred Pos.min Pos.max Pos.of_succ_nat - - on N: N0 Npos + * - N.pred N.succ N.min N.max N.of_nat Z.abs_N -*) - - - - -(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_core t thm a := - (* Let's introduce the specification theorem for t *) - pose proof (thm a); - (* Then we replace (t a) everywhere with a fresh variable *) - let z := fresh "z" in set (z:=t a) in *; clearbody z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_var_or_term t thm a := - (* If a is a variable, no need for aliasing *) - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_core t thm a) || - (* Otherwise, a is a complex term: we alias it. *) - (remember a as za; zify_unop_core t thm za). - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop t thm a := - (* If a is a scalar, we can simply reduce the unop. *) - (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) - let isz := isZcst a in - match isz with - | true => - let u := eval compute in (t a) in - change (t a) with u in * - | _ => zify_unop_var_or_term t thm a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) - let isz := isZcst a in - match isz with - | true => zify_unop_core t thm a - | _ => zify_unop_var_or_term t thm a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_binop t thm a b:= - (* works as zify_unop, except that we should be careful when - dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with - | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with - | H : za = b |- _ => zify_unop_nored (t za) (thm za) za - | _ => zify_unop_nored (t za) (thm za) b - end) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_op_1 := - match goal with - | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b - | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b - | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b - | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b - | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a - | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a - | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a - | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a - end. - -Ltac zify_op := repeat zify_op_1. - - -(** II) Conversion from nat to Z *) - - -Definition Z_of_nat' := Z.of_nat. - -Ltac hide_Z_of_nat t := - let z := fresh "z" in set (z:=Z.of_nat t) in *; - change Z.of_nat with Z_of_nat' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_nat_rel := - match goal with - (* I: equalities *) - | x := ?t : nat |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) - | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H - | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) - (* II: less than *) - | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H - | |- context [ lt ?a ?b ] => rewrite (Nat2Z.inj_lt a b) - (* III: less or equal *) - | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H - | |- context [ le ?a ?b ] => rewrite (Nat2Z.inj_le a b) - (* IV: greater than *) - | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H - | |- context [ gt ?a ?b ] => rewrite (Nat2Z.inj_gt a b) - (* V: greater or equal *) - | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H - | |- context [ ge ?a ?b ] => rewrite (Nat2Z.inj_ge a b) - end. - -Ltac zify_nat_op := - match goal with - (* misc type conversions: positive/N/Z to nat *) - | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H - | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a) - | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H - | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a) - | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H - | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a) - - (* plus -> Z.add *) - | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H - | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b) - - (* min -> Z.min *) - | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H - | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b) - - (* max -> Z.max *) - | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H - | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b) - - (* minus -> Z.max (Z.sub ... ...) 0 *) - | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H - | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b) - - (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) - | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H - | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a) - - (* mult -> Z.mul and a positivity hypothesis *) - | H : context [ Z.of_nat (mult ?a ?b) ] |- _ => - pose proof (Nat2Z.is_nonneg (mult a b)); - rewrite (Nat2Z.inj_mul a b) in * - | |- context [ Z.of_nat (mult ?a ?b) ] => - pose proof (Nat2Z.is_nonneg (mult a b)); - rewrite (Nat2Z.inj_mul a b) in * - - (* O -> Z0 *) - | H : context [ Z.of_nat O ] |- _ => change (Z.of_nat O) with Z0 in H - | |- context [ Z.of_nat O ] => change (Z.of_nat O) with Z0 - - (* S -> number or Z.succ *) - | H : context [ Z.of_nat (S ?a) ] |- _ => - let isnat := isnatcst a in - match isnat with - | true => - let t := eval compute in (Z.of_nat (S a)) in - change (Z.of_nat (S a)) with t in H - | _ => rewrite (Nat2Z.inj_succ a) in H - | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), - hide [Z.of_nat (S a)] in this one hypothesis *) - change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H - end - | |- context [ Z.of_nat (S ?a) ] => - let isnat := isnatcst a in - match isnat with - | true => - let t := eval compute in (Z.of_nat (S a)) in - change (Z.of_nat (S a)) with t - | _ => rewrite (Nat2Z.inj_succ a) - | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), - hide [Z.of_nat (S a)] in the goal *) - change (Z.of_nat (S a)) with (Z_of_nat' (S a)) - end - - (* atoms of type nat : we add a positivity condition (if not already there) *) - | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a - | _ : context [ Z.of_nat ?a ] |- _ => - pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a - | |- context [ Z.of_nat ?a ] => - pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. - -(* III) conversion from positive to Z *) - -Definition Zpos' := Zpos. -Definition Zneg' := Zneg. - -Ltac hide_Zpos t := - let z := fresh "z" in set (z:=Zpos t) in *; - change Zpos with Zpos' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive_rel := - match goal with - (* I: equalities *) - | x := ?t : positive |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq positive ?a ?b) => apply Pos2Z.inj - | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H - | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) - (* II: less than *) - | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H - | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) - (* III: less or equal *) - | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H - | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) - (* IV: greater than *) - | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H - | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) - (* V: greater or equal *) - | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H - | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive_op := - match goal with - (* Z.pow_pos -> Z.pow *) - | H : context [ Z.pow_pos ?a ?b ] |- _ => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) in H - | |- context [ Z.pow_pos ?a ?b ] => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) - (* Zneg -> -Zpos (except for numbers) *) - | H : context [ Zneg ?a ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) in H - | _ => change (Zneg a) with (- Zpos a) in H - end - | |- context [ Zneg ?a ] => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) - | _ => change (Zneg a) with (- Zpos a) - end - - (* misc type conversions: nat to positive *) - | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Z.power_pos *) - | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Pos.add -> Z.add *) - | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H - | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) - - (* Pos.min -> Z.min *) - | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H - | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b) - - (* Pos.max -> Z.max *) - | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H - | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) - - (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) - | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub_max a b) in H - | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub_max a b) - - (* Pos.succ -> Z.succ *) - | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H - | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a) - - (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *) - | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H - | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a) - - (* Pos.mul -> Z.mul and a positivity hypothesis *) - | H : context [ Zpos (?a * ?b) ] |- _ => - pose proof (Pos2Z.is_pos (Pos.mul a b)); - change (Zpos (a*b)) with (Zpos a * Zpos b) in * - | |- context [ Zpos (?a * ?b) ] => - pose proof (Pos2Z.is_pos (Pos.mul a b)); - change (Zpos (a*b)) with (Zpos a * Zpos b) in * - - (* xO *) - | H : context [ Zpos (xO ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H - | _ => rewrite (Pos2Z.inj_xO a) in H - end - | |- context [ Zpos (xO ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) - | _ => rewrite (Pos2Z.inj_xO a) - end - (* xI *) - | H : context [ Zpos (xI ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H - | _ => rewrite (Pos2Z.inj_xI a) in H - end - | |- context [ Zpos (xI ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) - | _ => rewrite (Pos2Z.inj_xI a) - end - - (* xI : nothing to do, just prevent adding a useless positivity condition *) - | H : context [ Zpos xH ] |- _ => hide_Zpos xH - | |- context [ Zpos xH ] => hide_Zpos xH - - (* atoms of type positive : we add a positivity condition (if not already there) *) - | _ : 0 < Zpos ?a |- _ => hide_Zpos a - | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a - | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_positive := - repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. - - - - - -(* IV) conversion from N to Z *) - -Definition Z_of_N' := Z.of_N. - -Ltac hide_Z_of_N t := - let z := fresh "z" in set (z:=Z.of_N t) in *; - change Z.of_N with Z_of_N' in z; - unfold z in *; clear z. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N_rel := - match goal with - (* I: equalities *) - | x := ?t : N |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) - | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H - | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) - (* II: less than *) - | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H - | |- context [ (?a < ?b)%N ] => rewrite (N2Z.inj_lt a b) - (* III: less or equal *) - | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H - | |- context [ (?a <= ?b)%N ] => rewrite (N2Z.inj_le a b) - (* IV: greater than *) - | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H - | |- context [ (?a > ?b)%N ] => rewrite (N2Z.inj_gt a b) - (* V: greater or equal *) - | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H - | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N_op := - match goal with - (* misc type conversions: nat to positive *) - | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H - | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a) - | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H - | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a) - | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H - | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a) - | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H - | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0 - - (* N.add -> Z.add *) - | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H - | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b) - - (* N.min -> Z.min *) - | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H - | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b) - - (* N.max -> Z.max *) - | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H - | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b) - - (* N.sub -> Z.max 0 (Z.sub ... ...) *) - | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H - | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b) - - (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) - | H : context [ Z.of_N (N.pred ?a) ] |- _ => rewrite (N.pred_sub a) in H - | |- context [ Z.of_N (N.pred ?a) ] => rewrite (N.pred_sub a) - - (* N.succ -> Z.succ *) - | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H - | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a) - - (* N.mul -> Z.mul and a positivity hypothesis *) - | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * - | |- context [ Z.of_N (N.mul ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * - - (* N.div -> Z.div and a positivity hypothesis *) - | H : context [ Z.of_N (N.div ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * - | |- context [ Z.of_N (N.div ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * - - (* N.modulo -> Z.rem / Z.modulo and a positivity hypothesis (N.modulo agrees with Z.modulo on everything except 0; so we pose both the non-zero proof for this agreement, but also replace things with [Z.rem]) *) - | H : context [ Z.of_N (N.modulo ?a ?b) ] |- _ => - pose proof (N2Z.is_nonneg (N.modulo a b)); - pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - rewrite (N2Z.inj_rem a b) in * - | |- context [ Z.of_N (N.div ?a ?b) ] => - pose proof (N2Z.is_nonneg (N.modulo a b)); - pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); - rewrite (N2Z.inj_rem a b) in * - - (* atoms of type N : we add a positivity condition (if not already there) *) - | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a - | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a - | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a - end. - -#[deprecated( note = "Use 'zify' instead")] -Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. - -(** The complete Z-ification tactic *) - Require Import ZifyClasses ZifyInst. Require Zify. diff --git a/tools/coqdep.ml b/tools/coqdep.ml index f1dbac889b..199fc4225d 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -34,7 +34,8 @@ let usage () = eprintf " -boot : For coq developers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; - eprintf " -f file : read -I, -Q, -R and filenames from _CoqProject-formatted FILE."; + eprintf " -noinit : currently no effect\n"; + eprintf " -f file : read -I, -Q, -R and filenames from _CoqProject-formatted FILE.\n"; eprintf " -I dir : add (non recursively) dir to ocaml path\n"; eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; eprintf " -Q dir logname : add (recursively) and open (non recursively) dir to coq load path under logical name logname\n"; @@ -64,6 +65,7 @@ let rec parse = function | "-sort" :: ll -> option_sort := true; parse ll | "-vos" :: ll -> write_vos := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll + | "-noinit" :: ll -> (* do nothing *) parse ll | "-f" :: f :: ll -> treat_coqproject f; parse ll | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () @@ -80,6 +82,8 @@ let rec parse = function | "-dyndep" :: "both" :: ll -> option_dynlink := Both; parse ll | "-dyndep" :: "var" :: ll -> option_dynlink := Variable; parse ll | ("-h"|"--help"|"-help") :: _ -> usage () + | opt :: ll when String.length opt > 0 && opt.[0] = '-' -> + coqdep_warning "unknown option %s" opt; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index dca9291da3..a6634586f3 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -157,6 +157,18 @@ let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 +let error_cannot_stat s unix_error = + (* Print an arbitrary line number, such that the message matches + common error message pattern. *) + Printf.eprintf "File \"%s\", line 1: %s\n" s (error_message unix_error); + exit 1 + +let error_cannot_open s msg = + (* Print an arbitrary line number, such that the message matches + common error message pattern. *) + Printf.eprintf "File \"%s\", line 1: %s\n" s msg; + exit 1 + let warning_module_notfound f s = coqdep_warning "in file %s, library %s is required and has not been found in the loadpath!" f (String.concat "." s) @@ -368,7 +380,7 @@ let rec find_dependencies basename = | Syntax_error (i,j) -> close_in chan; error_cannot_parse f (i,j) - with Sys_error _ -> [] (* TODO: report an error? *) + with Sys_error msg -> error_cannot_open (basename ^ ".v") msg let write_vos = ref false @@ -472,7 +484,12 @@ let rec treat_file old_dirname old_name = | (Some d1,d2) -> Some (d1//d2) in let complete_name = file_name name dirname in - match try (stat complete_name).st_kind with _ -> S_BLK with + let stat_res = + try stat complete_name + with Unix_error(error, _, _) -> error_cannot_stat complete_name error + in + match stat_res.st_kind + with | S_DIR -> (if name.[0] <> '.' then let newdirname = diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune index cc888a959f..432d88b2ff 100644 --- a/tools/coqdoc/dune +++ b/tools/coqdoc/dune @@ -5,6 +5,13 @@ (coqdoc.css as tools/coqdoc/coqdoc.css) (coqdoc.sty as tools/coqdoc/coqdoc.sty))) +; File needs to be here too. +(install + (section share) + (package coq-core) + (files + (coqdoc.sty as texmf/tex/latex/misc/coqdoc.sty))) + (executable (name main) (public_name coqdoc) diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 9cb3baf92c..e0a1d40395 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -74,7 +74,7 @@ let is_tactic = "info"; "field"; "specialize"; "evar"; "solve"; "instantiate"; "info_auto"; "info_eauto"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; - "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; + "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "set"; "assert"; "do"; "repeat"; "cut"; "assumption"; "exact"; "split"; "subst"; "try"; "discriminate"; "simpl"; "unfold"; "red"; "compute"; "at"; "in"; "by"; diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 041097d2d3..df6f04792e 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -194,7 +194,7 @@ let compile opts stm_options injections copts ~echo ~f_in ~f_out = if mode = BuildVio then dump_empty_vos() | Vio2Vo -> - + Flags.async_proofs_worker_id := "Vio2Vo"; let sum, lib, univs, tasks, proofs = Library.load_library_todo long_f_dot_in in let univs, proofs = Stm.finish_tasks long_f_dot_out univs proofs tasks in @@ -223,6 +223,7 @@ let compile_file opts stm_opts copts injections = (* VIO Dispatching *) (******************************************************************************) let check_vio_tasks copts = + Flags.async_proofs_worker_id := "VioChecking"; let rc = List.fold_left (fun acc (n,f) -> let f_in = ensure ".vio" f f in diff --git a/user-contrib/Ltac2/Array.v b/user-contrib/Ltac2/Array.v index 5adba829c5..b5e7f37c9f 100644 --- a/user-contrib/Ltac2/Array.v +++ b/user-contrib/Ltac2/Array.v @@ -70,7 +70,7 @@ Ltac2 init (l : int) (f : int->'a) := | true => empty () | false => let arr:=make l (f 0) in - init_aux arr 0 (length arr) f; + init_aux arr 1 (Int.sub l 1) f; arr end. diff --git a/user-contrib/Ltac2/Ltac1.v b/user-contrib/Ltac2/Ltac1.v index fd1555c2fb..0f7167939b 100644 --- a/user-contrib/Ltac2/Ltac1.v +++ b/user-contrib/Ltac2/Ltac1.v @@ -40,5 +40,8 @@ Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_ap Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". +Ltac2 @ external of_ident : ident -> t := "ltac2" "ltac1_of_ident". +Ltac2 @ external to_ident : t -> ident option := "ltac2" "ltac1_to_ident". + Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/user-contrib/Ltac2/Notations.v b/user-contrib/Ltac2/Notations.v index 931d753521..6ddad8f1c9 100644 --- a/user-contrib/Ltac2/Notations.v +++ b/user-contrib/Ltac2/Notations.v @@ -593,6 +593,8 @@ Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) Ltac2 Notation typeclasses_eauto := typeclasses_eauto. +Ltac2 Notation "unify" x(constr) y(constr) := Std.unify x y. + (** Congruence *) Ltac2 f_equal0 () := ltac1:(f_equal). diff --git a/user-contrib/Ltac2/Std.v b/user-contrib/Ltac2/Std.v index b69a95faf3..3675df9f75 100644 --- a/user-contrib/Ltac2/Std.v +++ b/user-contrib/Ltac2/Std.v @@ -259,3 +259,5 @@ Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> iden Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". + +Ltac2 @ external unify : constr -> constr -> unit := "ltac2" "tac_unify". diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index fa7df5dfeb..4758ecf5bd 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1186,6 +1186,16 @@ let () = define1 "ltac1_to_constr" ltac1 begin fun v -> return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) end +let () = define1 "ltac1_of_ident" ident begin fun c -> + let open Ltac_plugin in + return (Value.of_ext val_ltac1 (Taccoerce.Value.of_ident c)) +end + +let () = define1 "ltac1_to_ident" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option Value.of_ident (Taccoerce.Value.to_ident v)) +end + let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> let open Geninterp.Val in return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) @@ -1744,6 +1754,16 @@ let () = add_scope "constr" (fun arg -> Tac2entries.ScopeRule (Pcoq.Symbol.nterm Pcoq.Constr.constr, act) ) +let () = add_scope "open_constr" (fun arg -> + let delimiters = List.map (function + | SexprRec (_, { v = Some s }, []) -> s + | _ -> scope_fail "open_constr" arg) + arg + in + let act e = Tac2quote.of_open_constr ~delimiters e in + Tac2entries.ScopeRule (Pcoq.Symbol.nterm Pcoq.Constr.constr, act) + ) + let add_expr_scope name entry f = add_scope name begin function | [] -> Tac2entries.ScopeRule (Pcoq.Symbol.nterm entry, f) @@ -1772,7 +1792,6 @@ let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_ let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching let () = add_expr_scope "format" Pcoq.Prim.lstring Tac2quote.of_format -let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern (** seq scope, a bit hairy *) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 6be5ba80d5..7af530ab0f 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -50,6 +50,12 @@ let q_pose = Pcoq.Entry.create "q_pose" let q_assert = Pcoq.Entry.create "q_assert" end +let () = + let entries = [ + Pcoq.AnyEntry Pltac.ltac2_expr; + ] in + Pcoq.register_grammars_by_name "ltac2" entries + (** Tactic definition *) type tacdef = { diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index 90c8528203..0171ddfcf8 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -467,7 +467,9 @@ let polymorphic ((n, t) : type_scheme) : mix_type_scheme = let warn_not_unit = CWarnings.create ~name:"not-unit" ~category:"ltac" - (fun () -> strbrk "The following expression should have type unit.") + (fun (env, t) -> + strbrk "This expression should have type unit but has type " ++ + pr_glbtype env t ++ str ".") let warn_redundant_clause = CWarnings.create ~name:"redundant-clause" ~category:"ltac" @@ -480,7 +482,7 @@ let check_elt_unit loc env t = | GTypRef (Tuple 0, []) -> true | GTypRef _ -> false in - if not maybe_unit then warn_not_unit ?loc () + if not maybe_unit then warn_not_unit ?loc (env, t) let check_elt_empty loc env t = match kind env t with | GTypVar _ -> @@ -504,7 +506,7 @@ let check_unit ?loc t = | GTypRef (Tuple 0, []) -> true | GTypRef _ -> false in - if not maybe_unit then warn_not_unit ?loc () + if not maybe_unit then warn_not_unit ?loc (env, t) let check_redundant_clause = function | [] -> () diff --git a/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml index d1a72fcfd1..2d65f9ec3e 100644 --- a/user-contrib/Ltac2/tac2quote.ml +++ b/user-contrib/Ltac2/tac2quote.ml @@ -102,18 +102,22 @@ let of_anti f = function let of_ident {loc;v=id} = inj_wit ?loc wit_ident id +let quote_constr ?delimiters c = + let loc = Constrexpr_ops.constr_loc c in + Option.cata + (List.fold_left (fun c d -> + CAst.make ?loc @@ Constrexpr.CDelimiters(Id.to_string d, c)) + c) + c delimiters + let of_constr ?delimiters c = let loc = Constrexpr_ops.constr_loc c in - let c = Option.cata - (List.fold_left (fun c d -> - CAst.make ?loc @@ Constrexpr.CDelimiters(Id.to_string d, c)) - c) - c delimiters - in + let c = quote_constr ?delimiters c in inj_wit ?loc wit_constr c -let of_open_constr c = +let of_open_constr ?delimiters c = let loc = Constrexpr_ops.constr_loc c in + let c = quote_constr ?delimiters c in inj_wit ?loc wit_open_constr c let of_bool ?loc b = diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli index fcd1339cd7..6e2f548319 100644 --- a/user-contrib/Ltac2/tac2quote.mli +++ b/user-contrib/Ltac2/tac2quote.mli @@ -36,7 +36,7 @@ val of_ident : Id.t CAst.t -> raw_tacexpr val of_constr : ?delimiters:Id.t list -> Constrexpr.constr_expr -> raw_tacexpr -val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr +val of_open_constr : ?delimiters:Id.t list -> Constrexpr.constr_expr -> raw_tacexpr val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr diff --git a/user-contrib/Ltac2/tac2stdlib.ml b/user-contrib/Ltac2/tac2stdlib.ml index 895b6d3975..c7dfb3e69e 100644 --- a/user-contrib/Ltac2/tac2stdlib.ml +++ b/user-contrib/Ltac2/tac2stdlib.ml @@ -572,3 +572,7 @@ end let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> Tac2tactics.typeclasses_eauto str n dbs end + +let () = define_prim2 "tac_unify" constr constr begin fun x y -> + Tac2tactics.unify x y +end diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 54f5a2cf68..a30f6e7945 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -414,6 +414,8 @@ let typeclasses_eauto strategy depth dbs = in Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs +let unify x y = Tactics.unify x y + (** Inversion *) let inversion knd arg pat ids = diff --git a/user-contrib/Ltac2/tac2tactics.mli b/user-contrib/Ltac2/tac2tactics.mli index f63f7e722a..47a3fd5987 100644 --- a/user-contrib/Ltac2/tac2tactics.mli +++ b/user-contrib/Ltac2/tac2tactics.mli @@ -119,6 +119,8 @@ val eauto : Hints.debug -> int option -> int option -> constr thunk list -> val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> Id.t list option -> unit Proofview.tactic +val unify : constr -> constr -> unit tactic + val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic val contradiction : constr_with_bindings option -> unit tactic diff --git a/vernac/canonical.ml b/vernac/canonical.ml index eaa6c84791..2c04032ca0 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -7,30 +7,30 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open Libobject -open Recordops +open Structures let open_canonical_structure i (_, (o,_)) = let env = Global.env () in let sigma = Evd.from_env env in - if Int.equal i 1 then register_canonical_structure env sigma ~warn:false o + if Int.equal i 1 then Instance.register env sigma ~warn:false o let cache_canonical_structure (_, (o,_)) = let env = Global.env () in let sigma = Evd.from_env env in - register_canonical_structure ~warn:true env sigma o + Instance.register ~warn:true env sigma o -let discharge_canonical_structure (_,((gref, _ as x), local)) = +let discharge_canonical_structure (_,(x, local)) = + let gref = Instance.repr x in if local || (Globnames.isVarRef gref && Lib.is_in_section gref) then None else Some (x, local) -let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = +let inCanonStruc : Instance.t * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = simple_open open_canonical_structure; cache_function = cache_canonical_structure; - subst_function = (fun (subst,(c,local)) -> subst_canonical_structure subst c, local); + subst_function = (fun (subst,(c,local)) -> Instance.subst subst c, local); classify_function = (fun x -> Substitute x); discharge_function = discharge_canonical_structure } @@ -39,4 +39,4 @@ let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x) let declare_canonical_structure ?(local=false) ref = let env = Global.env () in let sigma = Evd.from_env env in - add_canonical_structure (check_and_decompose_canonical_structure env sigma ref, local) + add_canonical_structure (Instance.make env sigma ref, local) diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index 86b15739f9..26d696ff8e 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -90,7 +90,7 @@ let uniform_cond sigma ctx lt = let class_of_global = function | GlobRef.ConstRef sp -> - (match Recordops.find_primitive_projection sp with + (match Structures.PrimitiveProjections.find_opt sp with | Some p -> CL_PROJ p | None -> CL_CONST sp) | GlobRef.IndRef sp -> CL_IND sp | GlobRef.VarRef id -> CL_SECVAR id @@ -141,8 +141,8 @@ let get_target env t ind = CL_FUN else match pi1 (find_class_type env Evd.empty (EConstr.of_constr t)) with - | CL_CONST p when Recordops.is_primitive_projection p -> - CL_PROJ (Option.get @@ Recordops.find_primitive_projection p) + | CL_CONST p when Structures.PrimitiveProjections.mem p -> + CL_PROJ (Option.get @@ Structures.PrimitiveProjections.find_opt p) | x -> x let strength_of_cl = function @@ -265,7 +265,7 @@ let inCoercion : coe_info_typ -> obj = let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = let isproj = match coef with - | GlobRef.ConstRef c -> Recordops.find_primitive_projection c + | GlobRef.ConstRef c -> Structures.PrimitiveProjections.find_opt c | _ -> None in let c = { diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml index 1b811f3db7..39520a68ec 100644 --- a/vernac/comSearch.ml +++ b/vernac/comSearch.ml @@ -41,8 +41,8 @@ let kind_searcher = Decls.(function Inr (fun gr -> List.exists (fun c -> GlobRef.equal c.Coercionops.coe_value gr && (k' <> SubClass && k' <> IdentityCoercion || c.Coercionops.coe_is_identity)) coercions) | IsDefinition CanonicalStructure -> - let canonproj = Recordops.canonical_projections () in - Inr (fun gr -> List.exists (fun c -> GlobRef.equal (snd c).Recordops.o_ORIGIN gr) canonproj) + let canonproj = Structures.CSTable.entries () in + Inr (fun gr -> List.exists (fun c -> GlobRef.equal c.Structures.CSTable.solution gr) canonproj) | IsDefinition Scheme -> let schemes = DeclareScheme.all_schemes () in Inr (fun gr -> Indset.exists (fun c -> GlobRef.equal (GlobRef.IndRef c) gr) schemes) diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 7050ddc042..2ab6e3bb15 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -76,7 +76,7 @@ let objInductive : inductive_obj Libobject.Dyn.tag = let inInductive v = Libobject.Dyn.Easy.inj v objInductive -let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c +let cache_prim (_,(p,c)) = Structures.PrimitiveProjections.register p c let load_prim _ p = cache_prim p diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 15e6d4ef37..95e05556b9 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -216,7 +216,7 @@ let consistency_checks exists dir dirinfo = else if Nametab.exists_dir dir then user_err ~hdr:"consistency_checks" - (DirPath.print dir ++ str " already exists") + (DirPath.print dir ++ str " already exists.") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i diff --git a/vernac/library.ml b/vernac/library.ml index cc9e3c3c44..eedf8aa670 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -448,10 +448,10 @@ let save_library_base f sum lib univs tasks proofs = Sys.remove f; Exninfo.iraise reraise -type ('document,'counters) todo_proofs = +type 'document todo_proofs = | ProofsTodoNone (* for .vo *) | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) - | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list * 'counters (* for .vio *) + | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list (* for .vio *) let save_library_to todo_proofs ~output_native_objects dir f otab = assert( @@ -464,7 +464,7 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = let except = match todo_proofs with | ProofsTodoNone -> Future.UUIDSet.empty | ProofsTodoSomeEmpty except -> except - | ProofsTodoSome (except,l,_) -> except + | ProofsTodoSome (except,l) -> except in let cenv, seg, ast = Declaremods.end_library ~output_native_objects ~except dir in let opaque_table, f2t_map = Opaqueproof.dump ~except otab in @@ -473,13 +473,13 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = | ProofsTodoNone -> None, None | ProofsTodoSomeEmpty _except -> None, Some (Univ.ContextSet.empty,false) - | ProofsTodoSome (_except, tasks, rcbackup) -> + | ProofsTodoSome (_except, tasks) -> let tasks = List.map Stateid.(fun (r,b) -> try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b with Not_found -> assert b; { r with uuid = -1 }, b) tasks in - Some (tasks,rcbackup), + Some tasks, Some (Univ.ContextSet.empty,false) in let sd = { diff --git a/vernac/library.mli b/vernac/library.mli index d0e9f84691..4c6c654c58 100644 --- a/vernac/library.mli +++ b/vernac/library.mli @@ -41,13 +41,13 @@ type seg_proofs = Opaqueproof.opaque_proofterm array argument. [output_native_objects]: when producing vo objects, also compile the native-code version. *) -type ('document,'counters) todo_proofs = +type 'document todo_proofs = | ProofsTodoNone (* for .vo *) | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) - | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list * 'counters (* for .vio *) + | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list (* for .vio *) val save_library_to : - ('document,'counters) todo_proofs -> + 'document todo_proofs -> output_native_objects:bool -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 2fe402ff08..f9f65a8c30 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1664,7 +1664,7 @@ let add_notation_interpretation env decl_ntn = decl_ntn_scope = sc; } = decl_ntn in match interp_non_syntax_modifiers modifiers with - | None -> CErrors.user_err (str"Only modifiers not affecting parsing are supported here") + | None -> CErrors.user_err (str"Only modifiers not affecting parsing are supported here.") | Some (only_parsing,only_printing,entry) -> let df' = add_notation_interpretation_core ~local:false df env entry c sc only_parsing false None in Dumpglob.dump_notation (loc,df') sc true @@ -1845,6 +1845,6 @@ let inCustomEntry : locality_flag * string -> obj = let declare_custom_entry local s = if Egramcoq.exists_custom_entry s then - user_err Pp.(str "Custom entry " ++ str s ++ str " already exists") + user_err Pp.(str "Custom entry " ++ str s ++ str " already exists.") else Lib.add_anonymous_leaf (inCustomEntry (local,s)) diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index ec6e3b44ba..a3cd7a8edc 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -24,7 +24,6 @@ open Impargs open Libobject open Libnames open Globnames -open Recordops open Printer open Printmod open Context.Rel.Declaration @@ -1005,22 +1004,24 @@ let print_path_between cls clt = print_path ((cls, clt), p) let print_canonical_projections env sigma grefs = - let match_proj_gref ((x,y),c) gr = - GlobRef.equal x gr || - begin match y with - | Const_cs y -> GlobRef.equal y gr + let open Structures in + let match_proj_gref { CSTable.projection; value; solution } gr = + GlobRef.equal projection gr || + begin match value with + | ValuePattern.Const_cs y -> GlobRef.equal y gr | _ -> false end || - GlobRef.equal c.o_ORIGIN gr + GlobRef.equal solution gr in let projs = List.filter (fun p -> List.for_all (match_proj_gref p) grefs) - (canonical_projections ()) + (CSTable.entries ()) in prlist_with_sep fnl - (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ + (fun { CSTable.projection; value; solution } -> + ValuePattern.print value ++ str " <- " ++ - pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )") + pr_global projection ++ str " ( " ++ pr_global solution ++ str " )") projs (*************************************************************************) diff --git a/vernac/record.ml b/vernac/record.ml index ff6bdc5199..53f3508806 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -22,6 +22,7 @@ open Type_errors open Constrexpr open Constrexpr_ops open Context.Rel.Declaration +open Structures module RelDecl = Context.Rel.Declaration @@ -348,7 +349,7 @@ let instantiate_possibly_recursive_type ind u ntypes paramdecls fields = this could be refactored as noted above by moving to the higher-level declare constant API *) let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramdecls - paramargs decl impls fid subst sp_projs nfi ti i indsp mib lifted_fields x rp = + paramargs decl impls fid subst nfi ti i indsp mib lifted_fields x rp = let ccl = subst_projection fid subst ti in let body, p_opt = match decl with | LocalDef (_,ci,_) -> subst_projection fid subst ci, None @@ -396,32 +397,33 @@ let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramde ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl end; let i = if is_local_assum decl then i+1 else i in - (Some kn::sp_projs, i, Projection term::subst) + (Some kn, i, Projection term::subst) (** [build_proj] will build a projection for each field, or skip if the field is anonymous, i.e. [_ : t] *) let build_proj env mib indsp primitive x rp lifted_fields ~poly paramdecls paramargs ~uinstance ~kind ~univs - (nfi,i,kinds,sp_projs,subst) flags decl impls = + (nfi,i,kinds,subst) flags decl impls = let fi = RelDecl.get_name decl in let ti = RelDecl.get_type decl in - let (sp_projs,i,subst) = + let (sp_proj,i,subst) = match fi with | Anonymous -> - (None::sp_projs,i,NoProjection fi::subst) + (None,i,NoProjection fi::subst) | Name fid -> try build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramdecls paramargs decl impls fid - subst sp_projs nfi ti i indsp mib lifted_fields x rp + subst nfi ti i indsp mib lifted_fields x rp with NotDefinable why as exn -> let _, info = Exninfo.capture exn in warning_or_error ~info flags.pf_subclass indsp why; - (None::sp_projs,i,NoProjection fi::subst) + (None,i,NoProjection fi::subst) in (nfi - 1, i, - { Recordops.pk_name = fi - ; pk_true_proj = is_local_assum decl - ; pk_canonical = flags.pf_canonical } :: kinds - , sp_projs, subst) + { Structure.proj_name = fi + ; proj_true = is_local_assum decl + ; proj_canonical = flags.pf_canonical + ; proj_body = sp_proj } :: kinds + , subst) (** [declare_projections] prepares the common context for all record projections and then calls [build_proj] for each one. *) @@ -445,11 +447,12 @@ let declare_projections indsp univs ?(kind=Decls.StructureComponent) binder_name | PrimRecord _ -> true | FakeRecord | NotRecord -> false in - let (_,_,kinds,sp_projs,_) = + let (_,_,canonical_projections,_) = List.fold_left3 (build_proj env mib indsp primitive x rp lifted_fields ~poly paramdecls paramargs ~uinstance ~kind ~univs) - (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) - in (kinds,sp_projs) + (List.length fields,0,[],[]) flags (List.rev fields) (List.rev fieldimpls) + in + List.rev canonical_projections open Typeclasses @@ -485,20 +488,17 @@ let check_template ~template ~poly ~univs ~params { Data.id; rdata = { DataR.min (* auto detect template *) ComInductive.should_auto_template id (template && template_candidate ()) -let load_structure i (_, structure) = - Recordops.register_structure structure +let load_structure i (_, structure) = Structure.register structure -let cache_structure o = - load_structure 1 o +let cache_structure o = load_structure 1 o -let subst_structure (subst, obj) = - Recordops.subst_structure subst obj +let subst_structure (subst, obj) = Structure.subst subst obj let discharge_structure (_, x) = Some x -let rebuild_structure s = Recordops.rebuild_structure (Global.env()) s +let rebuild_structure s = Structure.rebuild (Global.env()) s -let inStruc : Recordops.struc_typ -> Libobject.obj = +let inStruc : Structure.t -> Libobject.obj = let open Libobject in declare_object {(default_object "STRUCTURE") with cache_function = cache_structure; @@ -601,17 +601,10 @@ let declare_structure ~cumulative finite ~ubind ~univs ~variances paramimpls par let map i { Data.is_coercion; coers; rdata = { DataR.implfs; fields; _}; _ } = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in - let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers implfs fields in + let projections = declare_projections rsp ctx ~kind binder_name.(i) coers implfs fields in let build = GlobRef.ConstructRef cstr in let () = if is_coercion then ComCoercion.try_add_new_coercion build ~local:false ~poly in - let npars = Inductiveops.inductive_nparams (Global.env()) rsp in - let struc = { - Recordops.s_CONST = cstr; - s_PROJ = List.rev sp_projs; - s_PROJKIND = List.rev kinds; - s_EXPECTEDPARAM = npars; - } - in + let struc = Structure.make (Global.env ()) rsp projections in let () = declare_structure_entry struc in rsp in @@ -674,7 +667,7 @@ let build_record_constant ~rdata ~ubind ~univs ~variances ~cumulative ~template meth_info = b; meth_const = y; } in - let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in + let l = List.map3 map (List.rev fields) coers (Structure.find_projections ind) in GlobRef.IndRef ind, l in List.map map inds @@ -773,11 +766,9 @@ let add_inductive_class env sigma ind = let k = let ctx = oneind.mind_arity_ctxt in let univs = Declareops.inductive_polymorphic_context mind in - let env = push_context ~strict:false (Univ.AUContext.repr univs) env in - let env = push_rel_context ctx env in let inst = Univ.make_abstract_instance univs in let ty = Inductive.type_of_inductive ((mind, oneind), inst) in - let r = Inductive.relevance_of_inductive env ind in + let r = oneind.mind_relevance in { cl_univs = univs; cl_impl = GlobRef.IndRef ind; cl_context = ctx; diff --git a/vernac/record.mli b/vernac/record.mli index 7a40af048c..feb257da3c 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -11,6 +11,7 @@ open Names open Vernacexpr open Constrexpr +open Structures module Ast : sig type t = @@ -51,8 +52,8 @@ module Internal : sig -> projection_flags list -> Impargs.manual_implicits list -> Constr.rel_context - -> Recordops.proj_kind list * Names.Constant.t option list + -> Structure.projection list - val declare_structure_entry : Recordops.struc_typ -> unit + val declare_structure_entry : Structure.t -> unit end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e8d84a67a3..54f034c74e 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -413,7 +413,7 @@ let sort_universes g = let levels = traverse LMap.empty [normalize Level.set, 0] in let max_level = LMap.fold (fun _ n accu -> max n accu) levels 0 in let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let ulevels = Array.init max_level (fun i -> Level.(make (UGlobal.make dummy_mp i))) in + let ulevels = Array.init max_level (fun i -> Level.(make (UGlobal.make dummy_mp "" i))) in let ulevels = Array.cons Level.set ulevels in (* Add the normal universes *) let fold (cur, ans) u = @@ -1934,10 +1934,9 @@ let vernac_search ~pstate ~atts s gopt r = let open ComSearch in let gopt = query_command_selector gopt in let sigma, env = - match gopt with | None -> - (* 1st goal by default if it exists, otherwise no goal at all *) - (try get_goal_or_global_context ~pstate 1 - with _ -> let env = Global.env () in (Evd.from_env env, env)) + match gopt with + (* 1st goal by default if it exists, otherwise no goal at all *) + | None -> get_goal_or_global_context ~pstate 1 (* if goal selector is given and wrong, then let exceptions be raised. *) | Some g -> get_goal_or_global_context ~pstate g in interp_search env sigma s r |