diff options
521 files changed, 6751 insertions, 12014 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 56bd34f6fd..56f48aaa4f 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -16,8 +16,6 @@ /META.coq.in @coq/legacy-build-maintainers -/dev/build/windows @coq/windows-build-maintainers - ########## CI infrastructure ########## /dev/ci/ @coq/ci-maintainers @@ -230,6 +228,7 @@ /toplevel/ @coq/toplevel-maintainers /topbin/ @coq/toplevel-maintainers +/sysinit/ @coq/toplevel-maintainers ########## Vernacular ########## diff --git a/.gitignore b/.gitignore index aab1d1ede7..7d05a12cfe 100644 --- a/.gitignore +++ b/.gitignore @@ -152,6 +152,7 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +kernel/byterun/coq_arity.h kernel/genOpcodeFiles.exe kernel/vmopcodes.ml kernel/uint63.ml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 749b74d584..6a8217674a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,8 +18,9 @@ stages: # some default values variables: # Format: $IMAGE-V$DATE-$hash - # The $hash is the first 10 characters of the md5 of the dockerfile - CACHEKEY: "bionic_coq-V2020-11-26-50e9456f22" + # 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" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -255,23 +256,18 @@ before_script: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" -.windows-template: +.platform-template: stage: stage-1 interruptible: true + variables: + PLATFORM: "https://github.com/coq/platform/archive/master.zip" artifacts: - name: "%CI_JOB_NAME%" + name: "$CI_JOB_NAME" paths: - artifacts when: always expire_in: 1 week - tags: - - windows-inria - before_script: [] - script: - - call dev/ci/gitlab.bat - only: - variables: - - $WINDOWS =~ /enabled/ + before_script: [] # We don't want to use the shared 'before_script' .deploy-template: stage: deploy @@ -348,16 +344,16 @@ build:quick: when: always windows64: - extends: .windows-template + extends: .platform-template variables: ARCH: "64" - -windows32: - extends: .windows-template - variables: - ARCH: "32" - except: - - /^pr-.*$/ + script: + - call dev/ci/platform-windows.bat + tags: + - windows-inria + only: + variables: + - $WINDOWS =~ /enabled/ lint: stage: stage-1 @@ -835,7 +831,7 @@ plugin:ci-coq_dpdgraph: extends: .ci-template plugin:ci-coqhammer: - extends: .ci-template + extends: .ci-template-flambda plugin:ci-elpi: extends: .ci-template diff --git a/META.coq.in b/META.coq.in index 68ab0733ee..7a9818da08 100644 --- a/META.coq.in +++ b/META.coq.in @@ -207,10 +207,10 @@ package "vernac" ( package "stm" ( - description = "Coq State Transactional Machine" + description = "Coq State Transaction Machine" version = "8.14" - requires = "coq.vernac" + requires = "coq.sysinit" directory = "stm" archive(byte) = "stm.cma" @@ -218,6 +218,19 @@ package "stm" ( ) +package "sysinit" ( + + description = "Coq initialization" + version = "8.14" + + requires = "coq.vernac" + directory = "sysinit" + + archive(byte) = "sysinit.cma" + archive(native) = "sysinit.cmxa" + +) + package "toplevel" ( description = "Coq Toplevel" diff --git a/Makefile.build b/Makefile.build index b307bde5df..d619fd3c85 100644 --- a/Makefile.build +++ b/Makefile.build @@ -367,6 +367,10 @@ kernel/byterun/coq_jumptbl.h: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< jump > $@ +kernel/byterun/coq_arity.h: kernel/genOpcodeFiles.exe + $(SHOW)'WRITE $@' + $(HIDE)$< arity > $@ + kernel/vmopcodes.ml: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< copml > $@ diff --git a/Makefile.common b/Makefile.common index 82d9b89c4f..415454df79 100644 --- a/Makefile.common +++ b/Makefile.common @@ -99,7 +99,7 @@ CORESRCDIRS:=\ coqpp \ config clib lib kernel kernel/byterun library \ engine pretyping interp proofs gramlib/.pack parsing printing \ - tactics vernac stm toplevel + tactics vernac stm sysinit toplevel PLUGINDIRS:=\ omega micromega \ @@ -132,7 +132,7 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ gramlib/.pack/gramlib.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma + sysinit/sysinit.cma stm/stm.cma toplevel/toplevel.cma ########################################################################### # plugins object files diff --git a/Makefile.dev b/Makefile.dev index 5825a884c2..cfb02b6d80 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -91,10 +91,11 @@ interp: interp/interp.cma parsing: parsing/parsing.cma pretyping: pretyping/pretyping.cma stm: stm/stm.cma +sysinit: sysinit/sysinit.cma toplevel: toplevel/toplevel.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine stm toplevel +.PHONY: engine stm sysinit toplevel ###################### ### 3) theories files diff --git a/Makefile.ide b/Makefile.ide index 9964a474f8..6e3713c7bf 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -233,7 +233,6 @@ install-ide-info: .PHONY: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents: - rm -rdf $@ $(MKDIR) $@ sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/coqide/MacOS/Info.plist.template > $@/Info.plist $(MKDIR) "$@/MacOS" @@ -282,6 +281,10 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(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; \ @@ -298,7 +301,7 @@ $(COQIDEAPP):$(COQIDEAPP)/Contents/Resources ########################################################################### # This is either x86_64-w64-mingw32 or i686-w64-mingw32 -TARGET_ARCH=$(shell $CC -dumpmachine) +TARGET_ARCH=$(shell $(CC) -dumpmachine) %.o: %.rc $(SHOW)'WINDRES $<' diff --git a/Makefile.make b/Makefile.make index 2f6781439c..5e45e71c8c 100644 --- a/Makefile.make +++ b/Makefile.make @@ -109,7 +109,7 @@ GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml no GENMLGFILES:= $(MLGFILES:.mlg=.ml) GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/vmopcodes.ml kernel/uint63.ml kernel/float64.ml GENMLIFILES:=$(GRAMMLIFILES) -GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +GENHFILES:=$(addprefix kernel/byterun/, coq_instruct.h coq_jumptbl.h coq_arity.h) GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe COQ_EXPORTED += GRAMFILES GRAMMLFILES GRAMMLIFILES GENMLFILES GENHFILES GENFILES @@ -274,7 +274,7 @@ depclean: find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + cacheclean: - find theories test-suite -name '.*.aux' -exec rm -f {} + + find theories user-contrib test-suite -name '.*.aux' -exec rm -f {} + cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-coq config/Info-*.plist @@ -282,12 +282,12 @@ cleanconfig: distclean: clean cleanconfig cacheclean timingclean voclean: - find theories plugins test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.glob' -o -name "*.cmxs" \ + find theories plugins user-contrib test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.glob' -o -name "*.cmxs" \ -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + - find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} + + find theories plugins user-contrib test-suite -name .coq-native -empty -exec rm -rf {} + timingclean: - find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ + find theories plugins user-contrib test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" \ -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + diff --git a/checker/check.ml b/checker/check.ml index 1ff1425dea..587bb90d43 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -149,7 +149,7 @@ let remove_load_path dir = load_paths := List.filter2 (fun p d -> p <> dir) physical logical let add_load_path (phys_path,coq_path) = - if !Flags.debug then + if CDebug.(get_flag misc) then Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = CUnix.canonical_path_name phys_path in diff --git a/checker/checker.ml b/checker/checker.ml index 08d92bb7b3..ba5e3c6d1a 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -48,19 +48,17 @@ let path_of_string s = let ( / ) = Filename.concat -let get_version_date () = +let get_version () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in - (ver,rev) - with _ -> (Coq_config.version,Coq_config.date) + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let print_header () = - let (ver,rev) = (get_version_date ()) in - Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; - flush stdout + Printf.printf "Welcome to Chicken %s\n%!" (get_version ()) (* Adding files to Coq loadpath *) @@ -132,8 +130,6 @@ let init_load_path () = includes := [] -let set_debug () = Flags.debug := true - let impredicative_set = ref Declarations.PredicativeSet let set_impredicative_set () = impredicative_set := Declarations.ImpredicativeSet @@ -170,9 +166,7 @@ let compile_files senv = ~check:(List.rev !compile_list) let version () = - Printf.printf "The Coq Proof Checker, version %s (%s)\n" - Coq_config.version Coq_config.date; - Printf.printf "compiled on %s\n" Coq_config.compile_date; + Printf.printf "The Coq Proof Checker, version %s\n" Coq_config.version; exit 0 (* print the usage of coqtop (or coqc) on channel co *) @@ -222,7 +216,7 @@ let guill s = str "\"" ++ str s ++ str "\"" let where = function | None -> mt () | Some s -> - if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) + if CDebug.(get_flag misc) then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let explain_exn = function | Stream.Failure -> @@ -251,7 +245,7 @@ let explain_exn = function hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency i -> let msg = - if !Flags.debug then + if CDebug.(get_flag misc) then str "." ++ spc() ++ Univ.explain_universe_inconsistency Univ.Level.pr i else @@ -289,7 +283,7 @@ let explain_exn = function Constr.debug_print a ++ fnl ()); Feedback.msg_notice (str"====== universes ====" ++ fnl () ++ (UGraph.pr_universes Univ.Level.pr - (ctx.Environ.env_stratification.Environ.env_universes))); + (UGraph.repr (ctx.Environ.env_stratification.Environ.env_universes)))); str "CantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" | IllFormedRecBody _ -> str"IllFormedRecBody" @@ -339,7 +333,7 @@ let parse_args argv = | ("-Q"|"-R") :: d :: p :: rem -> set_include d p;parse rem | ("-Q"|"-R") :: ([] | [_]) -> usage () - | "-debug" :: rem -> set_debug (); parse rem + | "-debug" :: rem -> CDebug.set_debug_all true; parse rem | "-where" :: _ -> Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); @@ -377,7 +371,7 @@ let init_with_argv argv = try parse_args argv; CWarnings.set_flags ("+"^Typeops.warn_bad_relevance_name); - if !Flags.debug then Printexc.record_backtrace true; + if CDebug.(get_flag misc) then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); init_load_path (); @@ -392,7 +386,7 @@ let run senv = let senv = compile_files senv in flush_all(); senv with e -> - if !Flags.debug then Printexc.print_backtrace stderr; + if CDebug.(get_flag misc) then Printexc.print_backtrace stderr; fatal_error (explain_exn e) (is_anomaly e) let start () = diff --git a/checker/values.ml b/checker/values.ml index 4e99d087df..907f9f7e32 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -147,7 +147,7 @@ let rec v_constr = [|v_puniverses v_cst|]; (* Const *) [|v_puniverses v_ind|]; (* Ind *) [|v_puniverses v_cons|]; (* Construct *) - [|v_caseinfo;v_constr;v_case_invert;v_constr;Array v_constr|]; (* Case *) + [|v_caseinfo;v_instance; Array v_constr; v_case_return; v_case_invert; v_constr; Array v_case_branch|]; (* Case *) [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) @@ -160,7 +160,11 @@ and v_prec = Tuple ("prec_declaration", [|Array (v_binder_annot v_name); Array v_constr; Array v_constr|]) and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) -and v_case_invert = Sum ("case_inversion", 1, [|[|v_instance;Array v_constr|]|]) +and v_case_invert = Sum ("case_inversion", 1, [|[|Array v_constr|]|]) + +and v_case_branch = Tuple ("case_branch", [|Array (v_binder_annot v_name); v_constr|]) + +and v_case_return = Tuple ("case_return", [|Array (v_binder_annot v_name); v_constr|]) let v_rdecl = v_sum "rel_declaration" 0 [| [|v_binder_annot v_name; v_constr|]; (* LocalAssum *) diff --git a/config/coq_config.mli b/config/coq_config.mli index 809fa3d758..035574475d 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -33,8 +33,6 @@ val arch_is_win32 : bool val version : string (* version number of Coq *) val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) -val date : string (* release date *) -val compile_date : string (* compile date *) val vo_version : int32 val state_magic_number : int diff --git a/configure.ml b/configure.ml index 40d77ed109..7814204e42 100644 --- a/configure.ml +++ b/configure.ml @@ -196,31 +196,6 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false -let build_date = - try - float_of_string (Sys.getenv "SOURCE_DATE_EPOCH") - with - Not_found -> Unix.time () - -(** * Date *) - -(** The short one is displayed when starting coqtop, - The long one is used as compile date *) - -let months = - [| "January";"February";"March";"April";"May";"June"; - "July";"August";"September";"October";"November";"December" |] - -let get_date () = - let now = Unix.gmtime build_date in - let year = 1900+now.Unix.tm_year in - let month = months.(now.Unix.tm_mon) in - sprintf "%s %d" month year, - sprintf "%s %d %d %d:%02d:%02d" (String.sub month 0 3) now.Unix.tm_mday year - now.Unix.tm_hour now.Unix.tm_min now.Unix.tm_sec - -let short_date, full_date = get_date () - (** * Command-line parsing *) type ide = Opt | Byte | No @@ -1096,8 +1071,6 @@ let write_configml f = pr_s "version" coq_version; pr_s "caml_version" caml_version; pr_li "caml_version_nums" caml_version_nums; - pr_s "date" short_date; - pr_s "compile_date" full_date; pr_s "arch" arch; pr_b "arch_is_win32" arch_is_win32; pr_s "exec_extension" exe; diff --git a/coq-doc.opam b/coq-doc.opam index 3a872db33d..9b0d562c45 100644 --- a/coq-doc.opam +++ b/coq-doc.opam @@ -17,6 +17,7 @@ doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ "dune" {build & >= "2.5.0"} + "conf-python-3" {build} "coq" {build & = version} ] build: [ @@ -24,6 +24,7 @@ depends: [ "dune" {>= "2.5.0"} "ocamlfind" {>= "1.8.1"} "zarith" {>= "1.10"} + "ounit2" {with-test} ] build: [ # Disabled until Dune 2.8 is available diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8affe58824..2de103a2ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -360,7 +360,7 @@ let print_body_fun state fmt r = print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_state state) r let print_body state fmt r = - fprintf fmt "@[(%afun %a~atts@ -> coqpp_body %a%a)@]" + fprintf fmt "@[(%afun %a?loc ~atts@ -> coqpp_body %a%a)@]" (print_body_fun state) r print_binders r.vernac_toks print_binders r.vernac_toks print_atts_right r.vernac_atts diff --git a/dev/base_include b/dev/base_include index daee2d97c5..f375a867bc 100644 --- a/dev/base_include +++ b/dev/base_include @@ -134,7 +134,6 @@ open ComDefinition open Indschemes open Ind_tables open Auto_ind_decl -open Coqinit open Coqtop open Himsg open Metasyntax diff --git a/dev/bench/gitlab-bench.yml b/dev/bench/gitlab-bench.yml index 25545cf565..69136ee773 100644 --- a/dev/bench/gitlab-bench.yml +++ b/dev/bench/gitlab-bench.yml @@ -4,9 +4,7 @@ bench: when: manual before_script: - printenv -0 | sort -z | tr '\0' '\n' - script: - - . ~/.opam/opam-init/init.sh - - ./dev/bench/gitlab.sh + script: dev/bench/gitlab.sh tags: - timing variables: diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh index b616371ef8..569977f76b 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -52,7 +52,7 @@ check_variable "CI_JOB_URL" : "${new_coq_opam_archive_git_branch:=master}" : "${old_coq_opam_archive_git_branch:=master}" : "${num_of_iterations:=1}" -: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-perennial}" +: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-perennial coq-vst}" new_coq_commit=$(git rev-parse HEAD^2) old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index 35d0379008..2550cbb31c 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -8,12 +8,12 @@ DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app -# Create a .app file with CoqIDE, without signing it -make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" - -# Add Coq to the .app file +# 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" diff --git a/dev/build/windows/CAVEATS.txt b/dev/build/windows/CAVEATS.txt deleted file mode 100644 index cb1ae3aaaf..0000000000 --- a/dev/build/windows/CAVEATS.txt +++ /dev/null @@ -1,22 +0,0 @@ -===== Environemt SIZE =====
-
-find and xargs can fail if the environment is to large. I think the limit is 8k.
-
-xargs --show-limits
-
-shows the actual environment size
-
-The configure_profile.sh script sets ORIGINAL_PATH (set by cygwin) to "" to
-avoid issues
-
-===== OCAMLLIB =====
-
-If the environment variable OCAMLLIB is defined, it takes precedence over the
-internal paths of ocaml tools. This usually messes up things considerably. A
-typical failure is
-
-Error: Error on dynamically loaded library: .\dlllablgtk2.dll: %1 is not a valid Win32 application.
-
-The configure_profile.sh script clears OCAMLLIB, but if you use the ocaml
-compiler from outside the provided cygwin shell, OCAMLLIB might be defined.
-
diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat deleted file mode 100755 index 8eff2cf577..0000000000 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ /dev/null @@ -1,499 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== NOTES ==========
-
-REM For Cygwin setup command line options
-REM see https://cygwin.com/faq/faq.html#faq.setup.cli
-
-REM ========== DEFAULT VALUES FOR PARAMETERS ==========
-
-REM For a description of all parameters, see ReadMe.txt
-
-SET BATCHFILE=%~0
-SET BATCHDIR=%~dp0
-
-REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32)
-SET ARCH=x86_64
-
-REM see -mode in ReadMe.txt
-SET INSTALLMODE=absolute
-
-REM see -installer in ReadMe.txt
-SET MAKEINSTALLER=N
-
-REM see -ocaml in ReadMe.txt
-SET INSTALLOCAML=N
-
-REM see -make in ReadMe.txt
-SET INSTALLMAKE=N
-
-REM see -destcyg in ReadMe.txt
-SET DESTCYG=C:\bin\cygwin_coq
-
-REM see -destcoq in ReadMe.txt
-SET DESTCOQ=C:\bin\coq
-
-REM see -setup in ReadMe.txt
-SET SETUP=setup-x86_64.exe
-
-REM see -proxy in ReadMe.txt
-IF DEFINED HTTP_PROXY (
- SET PROXY=%HTTP_PROXY:http://=%
-) else (
- REM One can't set a variable to empty in DOS, but you can set it to a space this way.
- REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
- SET "PROXY= "
-)
-
-REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=https://mirrors.kernel.org/sourceware/cygwin
-
-REM see -cygcache in ReadMe.txt
-SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
-
-REM see -cyglocal in ReadMe.txt
-SET CYGWIN_FROM_CACHE=N
-
-REM see -cygquiet in ReadMe.txt
-SET CYGWIN_QUIET=Y
-
-REM see -srccache in ReadMe.txt
-SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache
-
-REM see -coqver in ReadMe.txt
-SET COQ_VERSION=8.5pl3
-
-REM see -gtksrc in ReadMe.txt
-SET GTK_FROM_SOURCES=N
-
-REM see -threads in ReadMe.txt
-SET MAKE_THREADS=8
-
-REM see -addon in ReadMe.txt
-SET "COQ_ADDONS= "
-
-REM ========== PARSE COMMAND LINE PARAMETERS ==========
-
-SHIFT
-
-:Parse
-
-IF "%~0" == "-arch" (
- IF "%~1" == "32" (
- SET ARCH=i686
- SET SETUP=setup-x86.exe
- ) ELSE (
- IF "%~1" == "64" (
- SET ARCH=x86_64
- SET SETUP=setup-x86_64.exe
- ) ELSE (
- ECHO "Invalid -arch, valid are 32 and 64"
- GOTO :EOF
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-mode" (
- IF "%~1" == "mingwincygwin" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "absolute" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "relocatable" (
- SET INSTALLMODE=%~1
- ) ELSE (
- ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable"
- GOTO :EOF
- )
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-installer" (
- SET MAKEINSTALLER=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-ocaml" (
- SET INSTALLOCAML=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-make" (
- SET INSTALLMAKE=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcyg" (
- SET DESTCYG=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcoq" (
- SET DESTCOQ=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-setup" (
- SET SETUP=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-proxy" (
- SET PROXY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygrepo" (
- SET CYGWIN_REPOSITORY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygcache" (
- SET CYGWIN_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cyglocal" (
- SET CYGWIN_FROM_CACHE=%~1
- CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygquiet" (
- SET CYGWIN_QUIET=%~1
- CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-srccache" (
- SET SOURCE_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-coqver" (
- SET COQ_VERSION=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-gtksrc" (
- SET GTK_FROM_SOURCES=%~1
- CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-threads" (
- SET MAKE_THREADS=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-addon" (
- SET "COQ_ADDONS=%COQ_ADDONS% %~1"
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-
-IF NOT "%~0" == "" (
- ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
- ECHO !!! Illegal parameter %~0
- ECHO Usage:
- ECHO MakeCoq_MinGW
- CALL :PrintPars
- GOTO :EOF
-)
-
-IF NOT EXIST %SETUP% (
- ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html.
- ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option.
- GOTO :EOF
-)
-
-REM ========== ADJUST PARAMETERS ==========
-
-IF "%INSTALLMODE%" == "mingwincygwin" (
- SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw
-)
-
-IF "%MAKEINSTALLER%" == "Y" (
- SET INSTALLMODE=relocatable
-)
-
-REM ========== CONFIRM PARAMETERS ==========
-
-CALL :PrintPars
-REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block
-IF "%COQREGTESTING%"=="Y" (GOTO DontAsk)
- SET /p ANSWER="Is this correct? y/n "
- IF NOT "%ANSWER%"=="y" (GOTO :EOF)
-:DontAsk
-
-REM ========== DERIVED VARIABLES ==========
-
-SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG%
-SET RESULT_INSTALLDIR_WFMT=%DESTCOQ%
-SET TARGET_ARCH=%ARCH%-w64-mingw32
-SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
-
-REM Convert paths to various formats
-REM WFMT = windows format (C:\..) Used in this batch file.
-REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH variable, which is : separated, so C: doesn't work.
-REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
-
-SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
-SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/%
-SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/%
-
-ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT%
-ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT%
-ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT%
-ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT%
-ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT%
-ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT%
-
-REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset
-SET MAKE_OPT=-j %MAKE_THREADS%
-
-REM ========== DERIVED CYGWIN SETUP OPTIONS ==========
-
-REM One can't set a variable to empty in DOS, but you can set it to a space this way.
-REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
-SET "CYGWIN_OPT= "
-
-IF "%CYGWIN_FROM_CACHE%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -L
-)
-
-IF "%CYGWIN_QUIET%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin
-)
-
-IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-libxml2
- REM gtksourceview3 is always built from sources until the bug in DLLMain is fixed in cygwin
- REM SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtksourceview3.0
-)
-
-REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
-REM Otherwise chmod won't work and e.g. the ocaml build will fail.
-REM Cygwin setup does not touch the ACLs of existing folders.
-
-REM Run Cygwin Setup
-
-SET RUNSETUP=Y
-IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" (
- SET RUNSETUP=N
-)
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- SET RUNSETUP=Y
-)
-
-IF "%COQREGTESTING%" == "Y" (
- ECHO "========== REMOVE EXISTING CYGWIN =========="
- DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL
- SET RUNSETUP=Y
-)
-
-SET "EXTRAPACKAGES= "
-
-IF NOT "%APPVEYOR%" == "True" (
- SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5
-)
-
-ECHO "========== INSTALL CYGWIN =========="
-
-REM If you need to add packages, see https://cygwin.com/packages/package_list.html for package names
-REM In the description of each package you also find the file list and maintainer there
-
-IF "%RUNSETUP%"=="Y" (
- %SETUP% ^
- --proxy "%PROXY%" ^
- --site "%CYGWIN_REPOSITORY%" ^
- --root "%CYGWIN_INSTALLDIR_WFMT%" ^
- --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^
- --no-shortcuts ^
- %CYGWIN_OPT% ^
- -P make,unzip ^
- -P gdb,liblzma5 ^
- -P patch,automake1.14 ^
- -P pkg-config ^
- -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-windows_default_manifest ^
- -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
- -P mingw64-%ARCH%-gmp,mingw64-%ARCH%-mpfr ^
- -P adwaita-icon-theme ^
- -P libiconv-devel,libunistring-devel,libncurses-devel ^
- -P gettext-devel,libgettextpo-devel ^
- -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
- -P libfontconfig1 ^
- -P gtk-update-icon-cache ^
- -P libtool,automake ^
- -P libgmp-devel ^
- -P intltool ^
- -P bison,flex ^
- %EXTRAPACKAGES% ^
- || GOTO ErrorExit
-
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs"
-)
-
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it.
- REM This is not required with the -cygquiet=Y and the resulting --no-admin option.
- :waitsetup
- tasklist /fi "imagename eq %SETUP%" | find ":" > NUL
- IF ERRORLEVEL 1 GOTO waitsetup
-)
-
-ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ==========
-
-REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear
-REM HOME (otherwise we get to the home directory of the other installation)
-REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user)
-SET "HOME="
-SET "PROFILEREAD="
-
-copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit
-
-ECHO ========== BUILD COQ ==========
-
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
-RMDIR /S /Q "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-
-COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
-COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit
-
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit
-
-ECHO ========== FINISHED ==========
-
-GOTO :EOF
-
-ECHO ========== BATCH FUNCTIONS ==========
-
-:PrintPars
- REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
- ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
- ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
- ECHO ^<absolute = install coq in -destcoq absolute path^>
- ECHO ^<relocatable = install relocatable coq in -destcoq path^>
- ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
- ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
- ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
- ECHO -destcyg ^<path to cygwin destination folder^>
- ECHO -destcoq ^<path to coq destination folder (mode=absolute/relocatable)^>
- ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
- ECHO -proxy ^<internet proxy^>
- ECHO -cygrepo ^<cygwin download repository^>
- ECHO -cygcache ^<local cygwin repository/cache^>
- ECHO -cyglocal ^<Y or N^> install cygwin from cache
- ECHO -cygquiet ^<Y or N^> install cygwin without user interaction
- ECHO -srccache ^<local source code repository/cache^>
- ECHO -coqver ^<Coq version to install^>
- ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version
- ECHO -threads ^<1..N^> Number of make threads
- ECHO -addon ^<name^> Enable building selected addon (can be repeated)
- ECHO(
- ECHO See ReadMe.txt for a detailed description of all parameters
- ECHO(
- ECHO Parameter values (default or currently set):
- ECHO -arch = %ARCH%
- ECHO -mode = %INSTALLMODE%
- ECHO -ocaml = %INSTALLOCAML%
- ECHO -installer= %MAKEINSTALLER%
- ECHO -make = %INSTALLMAKE%
- ECHO -destcyg = %DESTCYG%
- ECHO -destcoq = %DESTCOQ%
- ECHO -setup = %SETUP%
- ECHO -proxy = %PROXY%
- ECHO -cygrepo = %CYGWIN_REPOSITORY%
- ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT%
- ECHO -cyglocal = %CYGWIN_FROM_CACHE%
- ECHO -cygquiet = %CYGWIN_QUIET%
- ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT%
- ECHO -coqver = %COQ_VERSION%
- ECHO -gtksrc = %GTK_FROM_SOURCES%
- ECHO -threads = %MAKE_THREADS%
- ECHO -addon = %COQ_ADDONS%
- GOTO :EOF
-
-:CheckYN
- REM Reset errorlevel to 0
- CMD /c "EXIT /b 0"
- IF "%2" == "Y" (
- REM OK Y
- ) ELSE IF "%2" == "N" (
- REM OK N
- ) ELSE (
- ECHO ERROR Parameter %1 must be Y or N, but is %2
- GOTO ErrorExit
- )
- GOTO :EOF
-
-:ErrorExit
- ECHO ERROR MakeCoq_MinGW.bat failed
- EXIT /b 1
diff --git a/dev/build/windows/MakeCoq_SetRootPath.bat b/dev/build/windows/MakeCoq_SetRootPath.bat deleted file mode 100644 index bcb104772c..0000000000 --- a/dev/build/windows/MakeCoq_SetRootPath.bat +++ /dev/null @@ -1,27 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== CHOOSE A SENSIBLE ROOT PATH ========== - -@ ECHO OFF - -REM Figure out a root path for coq and cygwin - -REM For the \nul trick for testing folders see -REM https://support.microsoft.com/en-us/kb/65994 - -IF EXIST D:\bin\nul ( - SET ROOTPATH=D:\bin -) else if EXIST C:\bin ( - SET ROOTPATH=C:\bin -) else ( - SET ROOTPATH=C: -) - -ECHO ROOTPATH set to %ROOTPATH% diff --git a/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat b/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat deleted file mode 100755 index d7d3c5b9d3..0000000000 --- a/dev/build/windows/MakeCoq_explicitcachefolders_installer.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_cachefolder_inst" ^
- -destcoq="%ROOTPATH%\coq64_cachefolder_inst" ^
- -cygcache="%ROOTPATH%\cache\cygwin" ^
- -srccache="%ROOTPATH%\cache\source"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_explicitcachefolders_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_local_installer.bat b/dev/build/windows/MakeCoq_local_installer.bat deleted file mode 100755 index 752b73c10a..0000000000 --- a/dev/build/windows/MakeCoq_local_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=/cygdrive/d/coqgit/coq-8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_local_inst" ^
- -destcoq="%ROOTPATH%\coq64_local_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_local_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_master_installer.bat b/dev/build/windows/MakeCoq_master_installer.bat deleted file mode 100755 index 72640d5d79..0000000000 --- a/dev/build/windows/MakeCoq_master_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-master ^
- -destcyg="%ROOTPATH%\cygwin_coq64_trunk_inst" ^
- -destcoq="%ROOTPATH%\coq64_trunk_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_regtest_noproxy.bat b/dev/build/windows/MakeCoq_regtest_noproxy.bat deleted file mode 100644 index 7140a7c619..0000000000 --- a/dev/build/windows/MakeCoq_regtest_noproxy.bat +++ /dev/null @@ -1,29 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-SET HTTP_PROXY=
-SET HTTPS_PROXY=
-MKDIR C:\Temp\srccache
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver 8.5pl2 ^
- -srccache C:\Temp\srccache ^
- -cygquiet=Y ^
- -destcyg %ROOTPATH%\cygwin_coq64_85pl2_abs ^
- -destcoq %ROOTPATH%\coq64_85pl2_abs
-
-pause
diff --git a/dev/build/windows/MakeCoq_regtests.bat b/dev/build/windows/MakeCoq_regtests.bat deleted file mode 100644 index 74c26456b4..0000000000 --- a/dev/build/windows/MakeCoq_regtests.bat +++ /dev/null @@ -1,36 +0,0 @@ -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== RUN REGRESSION TESTS FOR COQ BUILD SCRIPTS ========== - -SET COQREGTESTING=Y - -REM Current stable -call MakeCoq_86git_abs_ocaml.bat || GOTO Error -call MakeCoq_86git_installer.bat || GOTO Error -call MakeCoq_86git_installer_32.bat || GOTO Error - -REM Old but might still be used -call MakeCoq_85pl3_abs_ocaml.bat || GOTO Error -call MakeCoq_84pl6_abs_ocaml.bat || GOTO Error - -REM Special variants, e.g. for debugging -call MakeCoq_86git_abs_ocaml_gtksrc.bat || GOTO Error -call MakeCoq_local_installer.bat || GOTO Error -call MakeCoq_explicitcachefolders_installer.bat || GOTO Error - -REM Bleeding edge -call MakeCoq_trunk_installer.bat || GOTO Error - -ECHO MakeCoq_regtests.bat: All tests finished successfully -GOTO :EOF - -:Error -ECHO MakeCoq_regtests.bat failed with error code %ERRORLEVEL% -EXIT /b %ERRORLEVEL% diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt deleted file mode 100644 index f34bbea4e9..0000000000 --- a/dev/build/windows/ReadMe.txt +++ /dev/null @@ -1,442 +0,0 @@ -(C) 2016 Intel Deutschland GmbH -Author: Michael Soegtrop - -Released to the public by Intel under the -GNU Lesser General Public License Version 2.1 or later -See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -This license also applies to all files in the patches_coq subfolder. - -==================== Purpose / Goal ==================== - -The main purpose of these scripts is to build Coq for Windows in a reproducible -and at least by this script documented way without using binary libraries and -executables from various sources. These scripts use only MinGW libraries -provided by Cygwin or compile things from sources. For some libraries there are -options to build them from sources or to use the Cygwin version. - -Another goal (which is not yet achieved) is to have a Coq installer for -Windows, which includes all tools required for native compute and Coq plugin -development without Cygwin. - -Coq requires OCaml for this and OCaml requires binutils, gcc and a posix shell. -Since the standard Windows OCaml installation requires Cygwin to deliver some of -these components, you might be able to imagine that this is not so easy. - -These scripts can produce the following: - -- Coq running on MinGW - -- OCaml producing MinGW code and running on MinGW - -- GCC producing MinGW code and running on MinGW - -- binutils producing MinGW code and running on MinGW - -With "running on MinGW" I mean that the tools accept paths like -"C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The -MinGW gcc and binutils provided by Cygwin produce MinGW code, but they run only -on Cygwin. - -With "producing MinGW code" I mean that the programs created by the tools accept -paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys -DLL. - -The missing piece is a posix shell running on plain Windows (without msys or -Cygwin DLL) and not being a binary from obscure sources. I am working on it ... - -Since compiling gcc and binutils takes a while and it is not of much use without -a shell, the building of these components is currently disabled. OCaml is built -anyway, because this MinGW/MinGW OCaml (rather than a Cygwin/MinGW OCaml) is -used to compile Coq. - -Until the shell is there, the Cygwin created by these scripts is required to run -OCaml tools. When everything is finished, this will no longer be required. - -==================== Usage ==================== - -The Script MakeCoq_MinGW does: -- download Cygwin (except the Setup.exe or Setup64.exe) -- install Cygwin -- either installs MinGW GTK via Cygwin or compiles it fom sources -- download, compile and install OCaml, CamlP5, Menhir, lablgtk -- download, compile and install Coq -- download, compile and install selected addons -- create a Windows installer (NSIS based) - -The parameters are described below. Mostly paths and the HTTP proxy need to be -set. - -There are two main usages: - -- Compile and install OCaml and Coq in a given folder - - This works reliably, because absolute library paths can be compiled into Coq - and OCaml. - - WARNING: See the "Purpose / Goal" section above for status. - - See MakeCoq_85pl2_abs_ocaml.bat for parameters. - -- Create a Windows installer. - - This works well for Coq but not so well for OCaml. - - WARNING: See the "Purpose / Goal" section above for status. - - See MakeCoq_85pl2_installer.bat for parameters. - -There is also an option to compile OCaml and Coq inside Cygwin, but this is -currently not recommended. The resulting Coq and OCaml work, but Coq is slow -because it scans the largish Cygwin share folder. This will be fixed in a future -version. - -Procedure: - -- Unzip contents of CoqSetup.zip in a folder - -- Adjust parameters in MakeCoq_85pl2_abs_ocaml.bat or in MakeCoq_85pl2_installer.bat. - -- Download Cygwin setup from https://Cygwin.com/install.html - For 32 bit Coq : setup-x86.exe (https://Cygwin.com/setup-x86.exe) - For 64 bit Coq : setup-x86_64.exe (https://Cygwin.com/setup-x86_64.exe) - -- Run MakeCoq_85pl3_abs_ocaml.bat or MakeCoq_85pl3_installer.bat - -- Check MakeCoq_regtests.bat to see what combinations of options are tested - -==================== MakeCoq_MinGW Parameters ==================== - -===== -arch ===== - -Set the target architecture. - -Possible values: - -32: Install/build Cygwin, ocaml and coq for 32 bit windows - -64: Install/build Cygwin, ocaml and coq for 64 bit windows - -Default value: 64 - - -===== -mode ===== - -Set the installation mode / target folder structure. - -Possible values: - -mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder. - This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. - Todo: The coq share folder should be configured to e.g. /share/coq. - As is, coqc scans the complete share folder, which slows it down 5x for short files. - -absolute: Install coq in the absolute path given with -destcoq. - The resulting Coq will not be relocatable. - That is the root folder must not be renamed/moved. - -relocatable: Install coq in the absolute path given with -destcoq. - The resulting Coq will be relocatable. - That is the root folder may be renamed/moved. - If OCaml is installed, please note that OCaml cannot be build really relocatable. - If the root folder is moved, the environment variable OCAMLLIB must be set to the libocaml sub folder. - Also the file <root>\libocaml\ld.conf must be adjusted. - -Default value: absolute - - -===== -installer ===== - -Create a Windows installer (it will be in build/coq-8.xplx/dev/nsis) - -Possible values: - -Y: Create a windows installer - this forces -mode=relocatable. - -N: Don't create a windows installer - use the created Coq installation as is. - -Default value: N - - -===== -ocaml ===== - -Install OCaml for later use with Coq or just for building. - -Possible values: - -Y: Install OCaml in the same root as Coq (as given with -coqdest) - This also copies all .o, .cmo, .a, .cmxa files in the lib folder required for compiling plugins. - -N: Install OCaml in the default Cygwin mingw sysroot folder. - This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. - -Default value: N - - -===== -make ===== - -Build and install MinGW GNU make - -Possible values: - -Y: Install MinGW GNU make in the same root as Coq (as given with -coqdest). - -N: Don't build or install MinGW GNU make. - For building everything always Cygwin GNU make is used. - -Default value: Y - - -===== -destcyg ===== - -Destination folder in which Cygwin is installed. - -This must be an absolute path in Windows format (with drive letter and \\). - ->>>>> This folder may be deleted after the Coq build is finished! <<<<< - -Default value: C:\bin\Cygwin_coq - - -===== -destcoq ===== - -Destination folder in which Coq is installed. - -This must be an absolute path in Windows format (with drive letter and \\). - -This option is not required if -mode mingwinCygwin is used. - -Default value: C:\bin\coq - - -===== -setup ===== - -Name/path of the Cygwin setup program. - -The Cygwin setup program is called setup-x86.exe or setup-x86_64.exe. -It can be downloaded from: https://Cygwin.com/install.html. - -Default value: setup-x86.exe or setup-x86_64.exe, depending on -arch. - - -===== -proxy ===== - -Internet proxy setting for downloading Cygwin, ocaml and coq. - -The format is <server>:<port>, e.g. proxy.mycompany.com:911 - -The same proxy is used for HTTP, HTTPS and FTP. -If you need separate proxies for separate protocols, you please put your proxies directly into configure_profile.sh (line 11..13). - -Default value: Value of HTTP_PROXY environment variable or none if this variable does not exist. - -ATTENTION: With the --proxy setting of the Cygwin setup, it is possible to -supply a proxy server, but if this parameter is "", Cygwin setup might use proxy -settings from previous setups. If you once did a Cygwin setup behind a firewall -and now want to do a Cygwin setup without a firewall, use the -cygquiet=N -setting to perform a GUI install, where you can adjust the proxy setting. - -===== -cygrepo ===== - -The online repository, from which Cygwin packages are downloaded. - -Note: although most repositories end with Cygwin32, they are good for 32 and 64 bit Cygwin. - -Default value: http://ftp.inf.tu-dresden.de/software/windows/Cygwin32 - ->>>>> If you are not in Europe, you might want to change this! <<<<< - - -===== -cygcache ===== - -The local cache folder for Cygwin repositories. - -You can also copy files here from a backup/reference and set -cyglocal. -The setup will then not download/update from the internet but only use the local cache. - -Default value: <folder of MakeCoq_MinGW.bat>\Cygwin_cache - - -===== -cyglocal ===== - -Control if the Cygwin setup uses the latest version from the internet or the version as is in the local folder. - -Possible values: - -Y: Install exactly the Cygwin version from the local repository cache. - Don't update from the internet. - -N: Download the latest Cygwin version from the internet. - Update the local repository cache with the latest version. - -Default value: N - - -===== -cygquiet ===== - -Control if the Cygwin setup runs quietly or interactive. - -Possible values: - -Y: Install Cygwin quietly without user interaction. - -N: Install Cygwin interactively (allows to select additional packages). - -Default value: Y - - -===== -srccache ===== - -The local cache folder for ocaml/coq/... sources. - -Default value: <folder of MakeCoq_MinGW.bat>\source_cache - - -===== -coqver ===== - -The version of Coq to download and compile. - -Possible values: 8.4pl6, 8.5pl2, 8.5pl3, 8.6 - (download from https://coq.inria.fr/distrib/V$COQ_VERSION/files/coq-<version>.tar.gz) - Others versions might work, but are untested. - 8.4 is only tested in mode=absolute - - git-v8.6, git-trunk - (download from https://github.com/coq/coq/archive/<version without git->.zip) - - /cygdrive/.... - Use local folder. The sources are archived as coq-local.tar.gz - -Default value: 8.5pl3 - -If git- is prepended, the Coq sources are loaded from git. - -ATTENTION: with default options, the scripts cache source tar balls in two -places, the <destination>/build/tarballs folder and the <scripts>/source_cache -folder. If you modified something in git, you need to delete the cached tar ball -in both places! - -===== -gtksrc ===== - -Control if GTK and its prerequisites are build from sources or if binary MinGW packages from Cygwin are used - -Possible values: - -Y: Build GTK from sources, takes about 90 minutes extra. - This is useful, if you want to debug/fix GTK or library issues. - -N: Use prebuilt MinGW libraries from Cygwin - - -===== -threads ===== - -Control the maximum number of make threads for modules which support parallel make. - -Possible values: 1..N. - Should not be more than 1.5x the number of cores. - Should not be more than available RAM/2GB (e.g. 4 for 8GB) - -===== -addon ===== - -Enable build and installation of selected Coq package (can be repeated for -selecting more packages) - -==================== TODO ==================== - -- Check for spaces in destination paths -- Check for = signs in all paths (DOS commands don't work with paths with = in it, possibly even when quoted) -- Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) -- CoqIDE doesn't find theme files -- Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) -- Possibly create/login as specific user to bash (not sure if it makes sense - need to create additional bash login link then) -- maybe move share/doc/menhir somewhere else (reduces coqc startup time) -- Use original installed file list for removing files in uninstaller - -==================== Issues with relocation ==================== - -Coq and OCaml are built in a specific folder and are not really intended for relocation e.g. by an installer. -Some absolute paths in config files are patched in coq_new.nsi. - -Coq is made fairly relocatable by first configuring it with PREFIX=./ and then PREFIX=<installdir>. -OCaml is made relocatable mostly by defining the OCAMLLIB environment variable and by patching some files. -If you have issues with one of the remaining (unpatched) files below, please let me know. - -Text files patched by the installer: - -./ocamllib/ld.conf -./etc/findlib.conf:destdir="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" -./etc/findlib.conf:path="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" - -Text files containing the install folder path after install: - -./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20 -./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml -./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin -./libocaml/site-lib/findlib/Makefile.config:OCAML_SITELIB=D:/bin/coq64_buildtest_reloc_ocaml20\libocaml\site-lib -./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_BIN=D:/bin/coq64_buildtest_reloc_ocaml20\bin -./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_CONF=D:/bin/coq64_buildtest_reloc_ocaml20\etc\findlib.conf -./libocaml/topfind:#directory "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib";; -./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma"; -./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma"; -./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *) -./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *) - -Binary files containing the build folder path after install: - -$ find . -type f -exec grep "Cygwin_coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/coqtop.byte.exe matches -Binary file ./bin/coqtop.exe matches -Binary file ./bin/ocamldoc.exe matches -Binary file ./bin/ocamldoc.opt.exe matches -Binary file ./libocaml/ocamldoc/odoc_info.a matches -Binary file ./libocaml/ocamldoc/odoc_info.cma matches - -Binary files containing the install folder path after install: - -$ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/coqc.exe matches -Binary file ./bin/coqchk.exe matches -Binary file ./bin/coqdep.exe matches -Binary file ./bin/coqdoc.exe matches -Binary file ./bin/coqide.exe matches -Binary file ./bin/coqtop.byte.exe matches -Binary file ./bin/coqtop.exe matches -Binary file ./bin/coqworkmgr.exe matches -Binary file ./bin/coq_makefile.exe matches -Binary file ./bin/menhir matches -Binary file ./bin/ocaml.exe matches -Binary file ./bin/ocamlc.exe matches -Binary file ./bin/ocamlc.opt.exe matches -Binary file ./bin/ocamldebug.exe matches -Binary file ./bin/ocamldep.exe matches -Binary file ./bin/ocamldep.opt.exe matches -Binary file ./bin/ocamldoc.exe matches -Binary file ./bin/ocamldoc.opt.exe matches -Binary file ./bin/ocamlfind.exe matches -Binary file ./bin/ocamlmklib.exe matches -Binary file ./bin/ocamlobjinfo.exe matches -Binary file ./bin/ocamlopt.exe matches -Binary file ./bin/ocamlopt.opt.exe matches -Binary file ./bin/ocamlprof.exe matches -Binary file ./bin/ocamlrun.exe matches -Binary file ./bin/ocpp5.exe matches -Binary file ./lib/config/coq_config.cmo matches -Binary file ./lib/config/coq_config.o matches -Binary file ./lib/grammar/grammar.cma matches -Binary file ./lib/ide/coqide/ide_win32_stubs.o matches -Binary file ./lib/lib/clib.a matches -Binary file ./lib/lib/clib.cma matches -Binary file ./lib/libcoqrun.a matches -Binary file ./libocaml/compiler-libs/ocamlcommon.a matches -Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches -Binary file ./libocaml/dynlink.cma matches -Binary file ./libocaml/expunge.exe matches -Binary file ./libocaml/extract_crc.exe matches -Binary file ./libocaml/libcamlrun.a matches -Binary file ./libocaml/ocamlbuild/ocamlbuildlib.a matches -Binary file ./libocaml/ocamlbuild/ocamlbuildlib.cma matches -Binary file ./libocaml/ocamldoc/odoc_info.a matches -Binary file ./libocaml/ocamldoc/odoc_info.cma matches -Binary file ./libocaml/site-lib/findlib/findlib.a matches -Binary file ./libocaml/site-lib/findlib/findlib.cma matches -Binary file ./libocaml/site-lib/findlib/findlib.cmxs matches diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh deleted file mode 100644 index 7e606b5544..0000000000 --- a/dev/build/windows/configure_profile.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -###################### CONFIGURE CYGWIN USER PROFILE FOR BUILDING COQ ###################### - -rcfile=~/.bash_profile -donefile=~/.bash_profile.upated - -# to learn about `exec >> $file`, see https://www.tldp.org/LDP/abs/html/x17974.html -exec >> $rcfile - -if [ ! -f $donefile ] ; then - - if [ "$1" != "" ] && [ "$1" != " " ]; then - echo export http_proxy="http://$1" - echo export https_proxy="http://$1" - echo export ftp_proxy="http://$1" - fi - - mkdir -p "$RESULT_INSTALLDIR_CFMT/bin" - - # A tightly controlled path helps to avoid issues - # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path! - # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH - # See cat /proc/mounts - echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" - - # find and xargs complain if the environment is larger than (I think) 8k. - # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit - echo unset ORIGINAL_PATH - # Other installations of OCaml will mess up things - echo unset OCAMLLIB - - touch $donefile -fi diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh deleted file mode 100644 index 543ca972cd..0000000000 --- a/dev/build/windows/difftar-folder.sh +++ /dev/null @@ -1,89 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -###################### DIFF A TAR FILE AND A FOLDER ###################### - -set -o nounset - -# Print usage - -if [ "$#" -lt 2 ] ; then - echo 'Diff a tar (or compressed tar) file with a folder' - echo 'difftar-folder.sh <tarfile> <folder> [strip]' - echo '<tarfile> is the name of the tar file do diff with (required)' - echo '<folder> is the name of the folder to diff with (required)' - echo '<strip> is the number of path components to strip from tar file (default is 0)' - echo 'All files in the tar file must have at least <strip> path components.' - echo 'This also adds new files from folder.new, if folder.new exists' - exit 1 -fi - -# Parse parameters - -tarfile=$1 -folder=$2 - -if [ "$#" -ge 3 ] ; then - strip=$3 -else - strip=0 -fi - -# Get path prefix if --strip is used - -if [ "$strip" -gt 0 ] ; then - # Get the path/name of the first file from the tar and extract the first $strip path components - # This assumes that the first file in the tar file has at least $strip many path components - prefix=$(tar -t -f "$tarfile" | head -1 | cut -d / -f -$strip)/ -else - prefix= -fi - -# Original folder - -orig=$folder.orig -mkdir -p "$orig" - -# New amd empty filefolder - -new=$folder.new -empty=$folder.empty -mkdir -p "$empty" - -# Print information (this is ignored by patch) - -echo diff/patch file created on "$(date)" with: -echo difftar-folder.sh "$@" -echo TARFILE= "$tarfile" -echo FOLDER= "$folder" -echo TARSTRIP= "$strip" -echo TARPREFIX= "$prefix" -echo ORIGFOLDER= "$orig" - -# Make sure tar uses english output (for Mod time differs) -export LC_ALL=C - -# Search all files with a deviating modification time using tar --diff -tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod time differs" | while read -r file ; do - # Substitute ': Mod time differs' with nothing - file=${file/: Mod time differs/} - # Check if file exists - if [ -f "$folder/$file" ] ; then - # Extract original file - tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file" - # Compute diff - diff -u "$orig/$file" "$folder/$file" - fi -done - -if [ -d "$new" ] ; then - diff -u -r --unidirectional-new-file "$empty" "$new" -fi diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh deleted file mode 100755 index ebbf10f548..0000000000 --- a/dev/build/windows/makecoq_mingw.sh +++ /dev/null @@ -1,2031 +0,0 @@ -#!/bin/bash - -###################### COPYRIGHT/COPYLEFT ###################### - -# (C) 2016..2018 Intel Deutschland GmbH -# Author: Michael Soegtrop -# -# Released to the public by Intel under the -# GNU Lesser General Public License Version 2.1 or later -# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html -# -# With very valuable help on building GTK from -# https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack -# http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html - -###################### Script safety and debugging settings ###################### - -set -o nounset -set -o errexit -set -x -# Print current wall time as part of the xtrace -export PS4='+\t ' - -# Set this to 1 if all module directories shall be removed before build (no incremental make) -RMDIR_BEFORE_BUILD=1 - -###################### NOTES ##################### - -# - This file goes together with MakeCoq_ForMignGW.bat, which sets up cygwin -# with all required packages and then calls this script. -# -# - This script uses set -o errexit, so if anything fails, the script will stop -# -# - cygwin provided mingw64 packages like mingw64-x86_64-zlib are installed to -# /usr/$TARGET_ARCH/sys-root/mingw, so we use this as install prefix -# -# - if mingw64-x86_64-pkg-config is installed BEFORE building libpng or pixman, -# the .pc files are properly created in /usr/$TARGET_ARCH/sys-root/mingw/lib/pkgconfig -# -# - pango and some others uses pkg-config executable names without path, which doesn't work in cross compile mode -# There are several possible solutions -# 1.) patch build files to get the prefix from pkg-config and use $prefix/bin/ as path -# - doesn't work for pango because automake goes wild -# - mingw tools are not able to handle cygwin path (they need absolute windows paths) -# 2.) export PATH=$PATH:/usr/$TARGET_ARCH/sys-root/mingw/bin -# - a bit dangerous because this exposes much more than required -# - mingw tools are not able to handle cygwin path (they need absolute windows paths) -# 3.) Install required tools via cygwin modules libglib2.0-devel and libgdk_pixbuf2.0-devel -# - Possibly version compatibility issues -# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases -# 4.) Build required tools for mingw and cygwin -# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases -# -# We use method 3 below -# Method 2 can be tried by putting the cross tools in the path before the cygwin tools (in configure_profile.sh) -# -# - It is tricky to build 64 bit binaries with 32 bit cross tools and vice versa. -# This is because the linker needs to load DLLs from C:\windows\system32, which contains -# both 32 bit and 64 bit DLLs, and which one you get depends by some black magic on if the using -# app is a 32 bit or 64 bit app. So better build 32 bit mingw with 32 bit cygwin and 64 with 64. -# Alternatively the required 32 bit or 64 bit DLLs need to be copied with a 32 bit/64bit cp to some -# folder without such black magic. -# -# - The file selection for the Coq Windows Installer is done with make install (unlike the original script) -# Relocatble builds are first configured with prefix=./ then build and then -# reconfigured with prefix=<installroot> before make install. - - -###################### ARCHITECTURES ##################### - -# The OS on which the build of the tool/lib runs -BUILD=$(gcc -dumpmachine) - -# The OS on which the tool runs -# "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine -HOST=$TARGET_ARCH - -# The OS for which the tool creates code/for which the libs are -TARGET=$TARGET_ARCH - -# Cygwin uses different arch name for 32 bit than mingw/gcc -case $ARCH in - x86_64) CYGWINARCH=x86_64 ;; - i686) CYGWINARCH=x86 ;; - *) false ;; -esac - -###################### PATHS ##################### - -# Name and create some 'global' folders -PATCHES=/build/patches -BUILDLOGS=/build/buildlogs -FLAGFILES=/build/flagfiles -TARBALLS=/build/tarballs -FILELISTS=/build/filelists - -mkdir -p $BUILDLOGS -mkdir -p $FLAGFILES -mkdir -p $TARBALLS -mkdir -p $FILELISTS -cd /build - -# Create source cache folder -mkdir -p "$SOURCE_LOCAL_CACHE_CFMT" - -# sysroot prefix for the above /build/host/target combination -# This must be in MFMT (C:/.../) because the OCaml library path is based on it and OCaml is a MinGW application. -PREFIXMINGW=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw - -# Install / Prefix folder for COQ -PREFIXCOQ=$RESULT_INSTALLDIR_MFMT - -# Install / Prefix folder for OCaml -if [ "$INSTALLOCAML" == "Y" ]; then - PREFIXOCAML=$PREFIXCOQ -else - PREFIXOCAML=$PREFIXMINGW -fi - -mkdir -p "$PREFIXMINGW/bin" -mkdir -p "$PREFIXCOQ/bin" -mkdir -p "$PREFIXOCAML/bin" - -# This is required for building addons and plugins -# This must be CFMT (/cygdrive/c/...) otherwise coquelicot 3.0.2 configure fails. -# coquelicot uses which ${COQBIN}/coqc to check if coqc exists. This does not work with COQBIN in MFMT. -export COQBIN=$RESULT_INSTALLDIR_CFMT/bin/ -# This must be MFMT (C:/) otherwise bignums 68a7a3d7e0b21985913a6c3ee12067f4c5ac4e20 fails -export COQLIB=$RESULT_INSTALLDIR_MFMT/lib/coq/ - -###################### Copy Cygwin Setup Info ##################### - -# Copy Cygwin repo ini file and installed files db to tarballs folder. -# Both files together document the exact selection and version of cygwin packages. -# Do this as early as possible to avoid changes by other setups (the repo folder is shared). - -# Escape URL to folder name -CYGWIN_REPO_FOLDER=${CYGWIN_REPOSITORY}/ -CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//:/%3a} -CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f} - -# Copy files -cp "$CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini" $TARBALLS -cp /etc/setup/installed.db $TARBALLS - -###################### LOGGING ##################### - -# The folder which receives log files -mkdir -p buildlogs -LOGS=$(pwd)/buildlogs - -# The current log target (first part of the log file name) -LOGTARGET=other - -# For an explanation of ${COQREGTESTING:-N} search for ${parameter:-word} in -# http://pubs.opengroup.org/onlinepubs/009695399/utilities/xcu_chap02.html - -if [ "${COQREGTESTING:-N}" == "Y" ] ; then - # If COQREGTESTING, log to log files only - # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") - log1() { - { local -; set +x; } 2> /dev/null - "$@" >"$LOGS/$LOGTARGET-$1_log.txt" 2>"$LOGS/$LOGTARGET-$1_err.txt" - } - - # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") - log2() { - { local -; set +x; } 2> /dev/null - "$@" >"$LOGS/$LOGTARGET-$1-$2_log.txt" 2>"$LOGS/$LOGTARGET-$1-$2_err.txt" - } - - # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") - log_1_3() { - { local -; set +x; } 2> /dev/null - "$@" >"$LOGS/$LOGTARGET-$1-$3_log.txt" 2>"$LOGS/$LOGTARGET-$1-$3_err.txt" - } - - # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") - logn() { - { local -; set +x; } 2> /dev/null - LOGTARGETEX=$1 - shift - "$@" >"$LOGS/$LOGTARGET-${LOGTARGETEX}_log.txt" 2>"$LOGS/$LOGTARGET-${LOGTARGETEX}_err.txt" - } -else - # If COQREGTESTING, log to log files and console - # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") - log1() { - { local -; set +x; } 2> /dev/null - "$@" > >(tee "$LOGS/$LOGTARGET-$1_log.txt" | sed -e "s/^/$LOGTARGET-$1_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1_err.txt" | sed -e "s/^/$LOGTARGET-$1_err.txt: /" 1>&2) - } - - # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") - log2() { - { local -; set +x; } 2> /dev/null - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2_log.txt" | sed -e "s/^/$LOGTARGET-$1-$2_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2_err.txt" | sed -e "s/^/$LOGTARGET-$1-$2_err.txt: /" 1>&2) - } - - # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") - log_1_3() { - { local -; set +x; } 2> /dev/null - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3_log.txt" | sed -e "s/^/$LOGTARGET-$1-$3_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3_err.txt" | sed -e "s/^/$LOGTARGET-$1-$3_err.txt: /" 1>&2) - } - - # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") - logn() { - { local -; set +x; } 2> /dev/null - LOGTARGETEX=$1 - shift - "$@" > >(tee "$LOGS/$LOGTARGET-${LOGTARGETEX}_log.txt" | sed -e "s/^/$LOGTARGET-${LOGTARGETEX}_log.txt: /") 2> >(tee "$LOGS/$LOGTARGET-${LOGTARGETEX}_err.txt" | sed -e "s/^/$LOGTARGET-${LOGTARGETEX}_err.txt: /" 1>&2) - } -fi - -###################### 'UNFIX' SED ##################### - -# In Cygwin SED used to do CR-LF to LF conversion, but since sed 4.4-1 this was changed -# We replace sed with a shell script which restores the old behavior for piped input - -#if [ -f /bin/sed.exe ] -#then -# mv /bin/sed.exe /bin/sed_orig.exe -#fi -#cat > /bin/sed << EOF -##!/bin/sh -#dos2unix | /bin/sed_orig.exe "$@" -#EOF -#chmod a+x /bin/sed - -###################### UTILITY FUNCTIONS ##################### - -# ------------------------------------------------------------------------------ -# Get a source tar ball, expand and patch it -# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget -# - create build folder -# - extract source archive -# - patch source file if patch exists -# -# Parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 [optional] number of path levels to strip from tar (usually 1) -# $5 [optional] module name (if different from archive) -# $6 [optional] expand folder name (if different from module name) -# $7 [optional] module base name (used as 2nd choice for patches, defaults to $5) -# ------------------------------------------------------------------------------ - -function get_expand_source_tar { - # Handle optional parameters - if [ "$#" -ge 4 ] ; then - strip=$4 - else - strip=1 - fi - - if [ "$#" -ge 5 ] ; then - name=$5 - else - name=$2 - fi - - if [ "$#" -ge 6 ] ; then - folder=$6 - else - folder=$name - fi - - if [ "$#" -ge 7 ] ; then - basename=$7 - else - basename=$name - fi - - # Set logging target - logtargetold=$LOGTARGET - LOGTARGET=$name - - # Get the source archive either from the source cache or online - if [ ! -f "$TARBALLS/$name.$3" ] ; then - if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" - else - wget --progress=dot:giga "$1/$2.$3" - if file -i "$2.$3" | grep text/html; then - echo Download failed: "$1/$2.$3" - echo The file wget downloaded is an html file: - cat "$2.$3" - exit 1 - fi - if [ ! "$2.$3" == "$name.$3" ] ; then - mv "$2.$3" "$name.$3" - fi - mv "$name.$3" "$TARBALLS" - # Save the source archive in the source cache - if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp "$TARBALLS/$name.$3" "$SOURCE_LOCAL_CACHE_CFMT" - fi - fi - fi - - # Remove build directory (clean build) - if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then - rm -f -r "$folder" - fi - - # Create build directory and cd - mkdir -p "$folder" - cd "$folder" - - # Extract source archive - if [ "$3" == "zip" ] ; then - log1 unzip "$TARBALLS/$name.$3" - if [ "$strip" == "1" ] ; then - # move subfolders of root folders one level up - find "$(ls)" -mindepth 1 -maxdepth 1 -exec mv -- "{}" . \; - else - echo "Unzip strip count not supported" - exit 1 - fi - else - logn untar tar xvaf "$TARBALLS/$name.$3" --strip $strip - fi - - # Patch if patch file exists - # First try specific patch file name then generic patch file name - # Note: set -o errexit does not work inside a function called in an if, so exit explicity. - if [ -f "$PATCHES/$name.patch" ] ; then - log1 patch -p1 -i "$PATCHES/$name.patch" || exit 1 - elif [ -f "$PATCHES/$basename.patch" ] ; then - log1 patch -p1 -i "$PATCHES/$basename.patch" || exit 1 - fi - - # Go back to base folder - cd .. - - LOGTARGET=$logtargetold -} - -# ------------------------------------------------------------------------------ -# Prepare a module build -# - check if build is already done (name.finished file exists) - if so return 1 -# - create name.started -# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget -# - create build folder -# - cd to build folder and extract source archive -# - create bin_special subfolder and add it to $PATH -# - remember things for build_post -# -# Parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 [optional] number of path levels to strip from tar (usually 1) -# $5 [optional] module name (if different from archive) -# $6 [optional] module base name (used as 2nd choice for patches, defaults to $5) -# ------------------------------------------------------------------------------ - -function build_prep { - # Handle optional parameters - if [ "$#" -ge 4 ] ; then - strip=$4 - else - strip=1 - fi - - if [ "$#" -ge 5 ] ; then - name=$5 - else - name=$2 - fi - - if [ "$#" -ge 6 ] ; then - basename=$6 - else - basename=$name - fi - - # Set installer section to not set by default - installersection= - - # Check if build is already done - if [ ! -f "$FLAGFILES/$name.finished" ] ; then - BUILD_PACKAGE_NAME=$name - BUILD_OLDPATH=$PATH - BUILD_OLDPWD=$(pwd) - LOGTARGET=$name - - touch "$FLAGFILES/$name.started" - - get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" "$name" "$basename" - - cd "$name" - - # Create a folder and add it to path, where we can put special binaries - # The path is restored in build_post - mkdir bin_special - PATH=$(pwd)/bin_special:$PATH - - return 0 - else - return 1 - fi -} - -# ------------------------------------------------------------------------------ -# Like build_prep, but gets the data from an entry in ci-basic-overlay.sh -# This assumes the following definitions exist in ci-basic-overlay.sh -# $1_CI_REF -# $1_CI_ARCHIVEURL -# $1_CI_GITURL -# ATTENTION: variables in ci-basic-overlay.sh are loaded by load_overlay_data. -# load_overlay_data is is called at the end of make_coq (even if the build is skipped) -# -# Parameters -# $1 base name of module in ci-basic-overlay.sh, e.g. mathcomp, bignums, ... -# ------------------------------------------------------------------------------ - -function build_prep_overlay { - urlvar=$1_CI_ARCHIVEURL - gitvar=$1_CI_GITURL - refvar=$1_CI_REF - url=${!urlvar} - git=${!gitvar} - ref=${!refvar} - ver=$(git ls-remote "$git" "refs/heads/$ref" | cut -f 1) - if [[ "$ver" == "" ]]; then - # $1_CI_REF must have been a tag or hash, not a branch - ver="$ref" - fi - build_prep "$url" "$ver" tar.gz 1 "$1-$ver" "$1" -} - -# ------------------------------------------------------------------------------ -# Load overlay version variables from ci-basic-overlay.sh -# ------------------------------------------------------------------------------ - -function load_overlay_data { - if [ -n "${GITLAB_CI-}" ]; then - export CI_BRANCH="$CI_COMMIT_REF_NAME" - if [[ ${CI_BRANCH#pr-} =~ ^[0-9]*$ ]]; then - export CI_PULL_REQUEST="${CI_BRANCH#pr-}" - else - export CI_PULL_REQUEST="" - fi - else - export CI_BRANCH="" - export CI_PULL_REQUEST="" - fi - - . /build/ci-basic-overlay.sh -} - -# ------------------------------------------------------------------------------ -# Finalize a module build -# - create name.finished -# - go back to base folder -# ------------------------------------------------------------------------------ - -function build_post { - if [ ! -f "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" ]; then - cd "$BUILD_OLDPWD" - touch "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" - PATH=$BUILD_OLDPATH - LOGTARGET=other - installer_addon_end - fi -} - -# ------------------------------------------------------------------------------ -# Build and install a module using the standard configure/make/make install process -# - prepare build (as above) -# - configure -# - make -# - make install -# - finalize build (as above) -# -# parameters -# $1 file server name including protocol prefix -# $2 file name (without extension) -# $3 file extension -# $4 patch function to call between untar and configure (or true if none) -# $5.. extra configure arguments -# ------------------------------------------------------------------------------ - -function build_conf_make_inst { - if build_prep "$1" "$2" "$3" ; then - $4 - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" "${@:5}" - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - log2 make clean - build_post - fi -} - -# ------------------------------------------------------------------------------ -# Install all files given by a glob pattern to a given folder -# -# parameters -# $1 source path -# $2 pattern (in '') -# $3 target folder -# ------------------------------------------------------------------------------ - -function install_glob { - SRCDIR=$(realpath -m $1) - DESTDIR=$(realpath -m $3) - ( cd "$SRCDIR" && find . -maxdepth 1 -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) -} - -# ------------------------------------------------------------------------------ -# Recursively Install all files given by a glob pattern to a given folder -# -# parameters -# $1 source path -# $2 pattern (in '') -# $3 target folder -# ------------------------------------------------------------------------------ - -function install_rec { - SRCDIR=$(realpath -m $1) - DESTDIR=$(realpath -m $3) - ( cd "$SRCDIR" && find . -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) -} - -# ------------------------------------------------------------------------------ -# Write a file list of the target folder -# The file lists are used to create file lists for the windows installer -# Don't overwrite an existing file list -# -# parameters -# $1 name of file list -# ------------------------------------------------------------------------------ - -function list_files { - if [ ! -e "/build/filelists/$1" ] ; then - ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) - fi -} - -# ------------------------------------------------------------------------------ -# Write a file list of the target folder -# The file lists are used to create file lists for the windows installer -# Do overwrite an existing file list -# -# parameters -# $1 name of file list -# ------------------------------------------------------------------------------ - -function list_files_always { - ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) -} - -# ------------------------------------------------------------------------------ -# Compute the set difference of two file lists -# -# parameters -# $1 name of list A-B (set difference of set A minus set B) -# $2 name of list A -# $3 name of list B -# ------------------------------------------------------------------------------ - -function diff_files { - # See http://www.catonmat.net/blog/set-operations-in-unix-shell/ for file list set operations - comm -23 <(sort "/build/filelists/$2") <(sort "/build/filelists/$3") > "/build/filelists/$1" -} - -# ------------------------------------------------------------------------------ -# Filter a list of files with a regular expression -# -# parameters -# $1 name of output file list -# $2 name of input file list -# $3 name of filter regexp -# ------------------------------------------------------------------------------ - -function filter_files { - grep -E "$3" "/build/filelists/$2" > "/build/filelists/$1" -} - -# ------------------------------------------------------------------------------ -# Convert a file list to NSIS installer format -# -# parameters -# $1 name of file list file (output file is the same with extension .nsi) -# ------------------------------------------------------------------------------ - -function files_to_nsis { - # Split the path in the file list into path and filename and create SetOutPath and File instructions - # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does - # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time - tr '/' '\\' < "/build/filelists/$1" | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" -} - -# ------------------------------------------------------------------------------ -# Create an nsis installer addon section -# -# parameters -# $1 identifier of installer section and base name of file list files -# $2 human readable name of section -# $3 description of section -# $4 flags (space separated list of keywords): off = default off -# -# $1 must be a valid NSIS identifier! -# ------------------------------------------------------------------------------ - -function installer_addon_section { - installersection=$1 - list_files "addon_pre_$installersection" - - echo 'LangString' "DESC_$1" '${LANG_ENGLISH}' "\"$3\"" >> "/build/filelists/addon_strings.nsh" - - echo '!insertmacro MUI_DESCRIPTION_TEXT' '${'"Sec_$1"'}' '$('"DESC_$1"')' >> "/build/filelists/addon_descriptions.nsh" - - local sectionoptions= - if [[ "$4" == *off* ]] ; then sectionoptions+=" /o" ; fi - - echo "Section $sectionoptions \"$2\" Sec_$1" >> "/build/filelists/addon_sections.nsh" - echo 'SetOutPath "$INSTDIR\"' >> "/build/filelists/addon_sections.nsh" - echo '!include "..\..\..\filelists\addon_'"$1"'.nsh"' >> "/build/filelists/addon_sections.nsh" - echo 'SectionEnd' >> "/build/filelists/addon_sections.nsh" -} - -# ------------------------------------------------------------------------------ -# Start an installer addon dependency group -# -# parameters -# $1 identifier of the section which depends on other sections -# The parameters must match the $1 parameter of a installer_addon_section call -# ------------------------------------------------------------------------------ - -dependencysections= - -function installer_addon_dependency_beg { - installer_addon_dependency "$1" - dependencysections="$1 $dependencysections" -} - -# ------------------------------------------------------------------------------ -# End an installer addon dependency group -# ------------------------------------------------------------------------------ - -function installer_addon_dependency_end { - set -- $dependencysections - shift - dependencysections="$*" -} - -# ------------------------------------------------------------------------------ -# Create an nsis installer addon dependency entry -# This needs to be bracketed with installer_addon_dependencies_beg/end -# -# parameters -# $1 identifier of the section on which other sections might depend -# The parameters must match the $1 parameter of a installer_addon_section call -# ------------------------------------------------------------------------------ - -function installer_addon_dependency { - for section in $dependencysections ; do - echo '${CheckSectionDependency} ${Sec_'"$section"'} ${Sec_'"$1"'} '"'$section' '$1'" >> "/build/filelists/addon_dependencies.nsh" - done -} - -# ------------------------------------------------------------------------------ -# Finish an installer section after an addon build -# -# This creates the file list files -# -# parameters: none -# ------------------------------------------------------------------------------ - -function installer_addon_end { - if [ -n "$installersection" ]; then - list_files "addon_post_$installersection" - diff_files "addon_$installersection" "addon_post_$installersection" "addon_pre_$installersection" - files_to_nsis "addon_$installersection" - fi -} - -# ------------------------------------------------------------------------------ -# Set all timeouts in all .v files to 1000 -# Since timeouts can lead to CI failures, this is useful -# -# parameters: none -# ------------------------------------------------------------------------------ - -function coq_set_timeouts_1000 { - find . -type f -name '*.v' -print0 | xargs -0 sed -i 's/timeout\s\+[0-9]\+/timeout 1000/g' -} - -###################### MODULE BUILD FUNCTIONS ##################### - -##### SED ##### - -function make_sed { - if build_prep https://ftp.gnu.org/gnu/sed/ sed-4.2.2 tar.gz ; then - logn configure ./configure - log1 make $MAKE_OPT - log2 make install - log2 make clean - build_post - fi -} - -##### LIBPNG ##### - -function make_libpng { - build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.34 tar.gz true -} - -##### PIXMAN ##### - -function make_pixman { - build_conf_make_inst http://cairographics.org/releases pixman-0.34.0 tar.gz true -} - -##### FREETYPE ##### - -function make_freetype { - build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.9.1 freetype-2.9.1 tar.bz2 true -} - -##### EXPAT ##### - -function make_expat { - build_conf_make_inst http://sourceforge.net/projects/expat/files/expat/2.1.0 expat-2.1.0 tar.gz true -} - -##### FONTCONFIG ##### - -function make_fontconfig { - make_freetype - make_expat - # CONFIGURE PARAMETERS - # build/install fails without --disable-docs - build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.12.93 tar.gz true --disable-docs -} - -##### ICONV ##### - -function make_libiconv { - build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.15 tar.gz true -} - -##### UNISTRING ##### - -function make_libunistring { - build_conf_make_inst http://ftp.gnu.org/gnu/libunistring libunistring-0.9.5 tar.xz true -} - -##### NCURSES ##### - -function make_ncurses { - # NOTE: ncurses is not required below. This is just kept for documentary purposes in case I need it later. - # - # NOTE: make install fails building the terminfo database because - # : ${TIC_PATH:=unknown} in run_tic.sh - # As a result pkg-config .pc files are not generated - # Also configure of gettext gives two "considers" - # checking where terminfo library functions come from... not found, consider installing GNU ncurses - # checking where termcap library functions come from... not found, consider installing GNU ncurses - # gettext make/make install work anyway - # - # CONFIGURE PARAMETERS - # --enable-term-driver --enable-sp-funcs is required for mingw (see README.MinGW) - # additional changes - # ADD --with-pkg-config - # ADD --enable-pc-files - # ADD --without-manpages - # REM --with-pthread - build_conf_make_inst http://ftp.gnu.org/gnu/ncurses ncurses-5.9 tar.gz true --disable-home-terminfo --enable-reentrant --enable-sp-funcs --enable-term-driver --enable-interop --with-pkg-config --enable-pc-files --without-manpages -} - -##### GETTEXT ##### - -function make_gettext { - # Cygwin packet dependencies: (not 100% sure) libiconv-devel,libunistring-devel,libncurses-devel - # Cygwin packet dependencies for gettext users: (not 100% sure) gettext-devel,libgettextpo-devel - # gettext configure complains that ncurses is also required, but it builds without it - # Ncurses is tricky to install/configure for mingw64, so I dropped ncurses - make_libiconv - make_libunistring - build_conf_make_inst http://ftp.gnu.org/pub/gnu/gettext gettext-0.19 tar.gz true -} - -##### LIBFFI ##### - -function make_libffi { - # NOTE: The official download server is down ftp://sourceware.org/pub/libffi/libffi-3.2.1.tar.gz - build_conf_make_inst http://www.mirrorservice.org/sites/sourceware.org/pub/libffi libffi-3.2.1 tar.gz true -} - -##### LIBEPOXY ##### - -function make_libepoxy { - build_conf_make_inst https://github.com/anholt/libepoxy/releases/download/v1.3.1 libepoxy-1.3.1 tar.bz2 true -} - -##### LIBPCRE ##### - -function make_libpcre { - build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre-8.39 tar.bz2 true -} - -function make_libpcre2 { - build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre2-10.22 tar.bz2 true -} - -##### GLIB ##### - -function make_glib { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_gettext - make_libffi - make_libpcre - - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true - -} - -##### ATK ##### - -function make_atk { - make_gettext - make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.30 atk-2.30.0 tar.xz true -} - -##### PIXBUF ##### - -function make_gdk-pixbuf { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_libpng - make_gettext - make_glib - # CONFIGURE PARAMETERS - # --with-included-loaders=yes statically links the image file format handlers - # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.38 gdk-pixbuf-2.38.0 tar.xz true --with-included-loaders=yes -} - -##### CAIRO ##### - -function make_cairo { - # Cygwin packet dependencies: mingw64-x86_64-zlib - make_libpng - make_glib - make_pixman - make_fontconfig - build_conf_make_inst http://cairographics.org/releases rcairo-1.16.2 tar.xz true -} - -##### PANGO ##### - -function make_pango { - make_cairo - make_glib - make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.4 tar.xz true -} - -##### GTK3 ##### - -function make_gtk3 { - - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.24 gtk+-3.24.5 tar.xz true - fi - - # make all incl. tests and examples runs through fine - # make install fails with issue with - # - # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' - # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor" - # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory - # Makefile:1373: recipe for target 'install-update-icon-cache' failed - # make[5]: *** [install-update-icon-cache] Error 1 - # make[5]: Leaving directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' -} - -##### LIBXML2 ##### - -function make_libxml2 { - # Cygwin packet dependencies: libtool automake - # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1 - # Note: python binding requires <sys/select.h> which doesn't exist on cygwin - if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then - # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIXMINGW" --disable-shared --without-python - # shared library required by gtksourceview - ./autogen.sh --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" --without-python - # shellcheck disable=SC2086 - log1 make $MAKE_OPT all - log2 make install - log2 make clean - build_post - fi -} - -##### GTK-SOURCEVIEW3 ##### - -function make_gtk_sourceview3 { - # Cygwin packet dependencies: intltool - # Note: this is always built from sources cause of a bug in the cygwin delivery. - # Just dependencies are only built if we build from sources - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_gtk3 - make_libxml2 - fi - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.11 tar.xz make_arch_pkg_config -} - -##### LN replacement ##### - -# Note: this does support symlinks, but symlinks require special user rights on Windows. -# ocamlbuild uses symlinks to link the executables in the build folder to the base folder. -# For this purpose hard links are better. - -function make_ln { - if [ ! -f $FLAGFILES/myln.finished ] ; then - touch $FLAGFILES/myln.started - mkdir -p myln - ( cd myln - cp $PATCHES/ln.c . - "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c - install -D ln.exe "$PREFIXCOQ/bin/ln.exe" - ) - touch $FLAGFILES/myln.finished - fi -} - -##### ARCH-pkg-config replacement ##### - -# cygwin replaced ARCH-pkg-config with a shell script, which doesn't work e.g. for dune on Windows. -# This builds a binary replacement for the shell script and puts it into the bin_special folder. -# There is no global installation since it is module specific what pkg-config is needed under what name. - -function make_arch_pkg_config { - gcc -DARCH="$TARGET_ARCH" -o bin_special/pkg-config.exe $PATCHES/pkg-config.c -} - -##### OCAML ##### - -function make_ocaml { - if build_prep https://github.com/ocaml/ocaml/archive 4.08.1 tar.gz 1 ocaml-4.08.1 ; then - # see https://github.com/ocaml/ocaml/blob/4.08/README.win32.adoc - - # get flexdll sources into folder ./flexdll - get_expand_source_tar https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 flexdll - - # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder - logn configure ./configure --build=i686-pc-cygwin --host="$TARGET_ARCH" --prefix="$PREFIXOCAML" --libdir="$PREFIXOCAML/libocaml" - - log2 make flexdll $MAKE_OPT - # Note the next command might change after 4.09.x to just make - # see https://github.com/ocaml/ocaml/blob/4.09/README.win32.adoc - # compare to https://github.com/ocaml/ocaml/blob/4.10/README.win32.adoc - log2 make world.opt $MAKE_OPT - log2 make flexlink.opt $MAKE_OPT - log2 make install $MAKE_OPT - - # Move license files and other into into special folder - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - mkdir -p "$PREFIXOCAML/license_readme/ocaml" - # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources. - rm -f ./*.txt - cp LICENSE "$PREFIXOCAML/license_readme/ocaml/License.txt" - cp INSTALL.adoc "$PREFIXOCAML/license_readme/ocaml/Install.txt" - cp README.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMe.txt" - cp README.win32.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt" - cp VERSION "$PREFIXOCAML/license_readme/ocaml/Version.txt" - cp Changes "$PREFIXOCAML/license_readme/ocaml/Changes.txt" - fi - - # Since 4.07 this library is part of ocaml - mkdir -p "$PREFIXOCAML/libocaml/site-lib/seq/" - cat > "$PREFIXOCAML/libocaml/site-lib/seq/META" <<EOT -name="seq" -version="[distributed with OCaml 4.07 or above]" -description="dummy backward-compatibility package for iterators" -requires="" -EOT - - build_post - fi -} - -##### OCAML EXTRA TOOLS ##### - -function make_ocaml_tools { - make_findlib -} - -##### OCAML EXTRA LIBRARIES ##### - -function make_ocaml_libs { - make_num - make_zarith - make_findlib - make_lablgtk -} - -##### Ocaml num library ##### -function make_num { - make_ocaml - # We need this commit due to windows fixed, IMHO this is better than patching v1.1. - if build_prep https://github.com/ocaml/num/archive 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then - log2 make all - # log2 make test - log2 make install - log2 make clean - build_post - fi -} - -function make_zarith { - make_ocaml - if build_prep https://github.com/ocaml/Zarith/archive release-1.10 tar.gz 1 zarith-1.10; then - logn configure ./configure - log1 make - log2 make install - build_post - fi -} - -##### OCAMLBUILD ##### - -function make_ocamlbuild { - make_ocaml - if build_prep https://github.com/ocaml/ocamlbuild/archive 0.14.0 tar.gz 1 ocamlbuild-0.14.0; then - log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -##### FINDLIB Ocaml library manager ##### - -function make_findlib { - make_ocaml - make_ocamlbuild - # Note: latest is 1.8.1 but http://projects.camlcity.org/projects/dl/findlib-1.8.1/doc/README says this is for OCaml 4.09 - if build_prep https://opam.ocaml.org/1.2.2/archives ocamlfind.1.8.0+opam tar.gz 1 ; then - logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" - # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT - log2 make all - log2 make opt - log2 make install - log2 make clean - # Add Coq install library path to ocamlfind config file - # $(ocamlfind printconf conf | tr -d '\r') is the name of the config file - # printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g' is the coq lib path double escaped for sed - sed -i -e 's|path="\(.*\)"|path="\1;'$(printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g')'"|' $(ocamlfind printconf conf | tr -d '\r') - build_post - fi -} - -##### Dune build system ##### - -function make_dune { - make_ocaml - - if build_prep https://github.com/ocaml/dune/archive/ 2.0.0 tar.gz 1 dune-2.0.0 ; then - - log2 make release - log2 make install - - # Dune support libs, we don't install glob and action-plugin as - # they are not needed by Coq - logn dune-private-build dune build -p dune-private-libs @install - logn dune-private-install dune install dune-private-libs - - logn dune-configurator-build dune build -p dune-configurator @install - logn dune-configurator-install dune install dune-configurator - - logn dune-build-info dune build -p dune-build-info @install - logn dune-build-info dune install dune-build-info - - build_post - fi -} - -##### MENHIR Ocaml Parser Generator ##### - -function make_menhir { - make_ocaml - make_findlib - make_ocamlbuild - if build_prep https://gitlab.inria.fr/fpottier/menhir/-/archive/20200525 menhir-20200525 tar.gz 1 ; then - # ToDo: don't know if this is the intended / most reliable to do it, but it works - log2 dune build @install - log2 dune install menhir menhirSdk menhirLib - build_post - fi -} - -##### CAMLP5 Ocaml Preprocessor ##### - -function make_camlp5 { - make_ocaml - make_findlib - - if build_prep https://github.com/camlp5/camlp5/archive rel711 tar.gz 1 camlp5-rel711; then - logn configure ./configure - # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success - sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile - # shellcheck disable=SC2086 - log1 make world.opt $MAKE_OPT - log2 make install - cp lib/*.a "$PREFIXOCAML/libocaml/camlp5/" - log2 make clean - # For some reason META is not built / copied, but it is required - log2 make -C etc META - mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" - cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" - log2 make clean - build_post - fi -} - -##### LABLGTK Ocaml GTK binding ##### - -# Note: when rebuilding lablgtk by deleting the .finished file, -# also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib -# Otherwise make install fails - -function make_ocaml_cairo2 { - if build_prep https://github.com/Chris00/ocaml-cairo/archive 0.6 tar.gz 1 ocaml_cairo2-0.6; then - make_arch_pkg_config - - log2 dune build cairo2.install - log2 dune install cairo2 - # See https://github.com/ocaml/dune/issues/2921 - # log2 dune clean - build_post - - fi -} - -function make_lablgtk { - make_ocaml - make_findlib - make_dune - make_gtk3 - make_gtk_sourceview3 - make_ocaml_cairo2 - - if build_prep https://github.com/garrigue/lablgtk/archive 3.0.beta5 tar.gz 1 lablgtk-3.0.beta5 ; then - make_arch_pkg_config - - # lablgtk3 includes more packages that are not relevant for Coq, - # such as gtkspell - log2 dune build -p lablgtk3 - log2 dune install lablgtk3 - - log2 dune build -p lablgtk3-sourceview3 - log2 dune install lablgtk3-sourceview3 - - # See https://github.com/ocaml/dune/issues/2921 - # log2 dune clean - build_post - fi -} - -##### Elpi ##### - -function make_seq { - make_ocaml - # since 4.07 this package is part of ocaml - -} - -function make_re { - make_ocaml - make_dune - make_seq - - if build_prep https://github.com/ocaml/ocaml-re/archive 1.9.0 tar.gz 1 ocaml-re; then - - log2 dune build -p re - log2 dune install re - - build_post - fi - -} - -function make_elpi { - make_ocaml - make_findlib - make_camlp5 - make_dune - make_re - - if build_prep https://github.com/LPCIC/elpi/archive v1.12.0 tar.gz 1 elpi; then - - log2 dune build -p elpi - log2 dune install elpi - - build_post - - fi - -} - -##### COQ ##### - -# Copy one DLLfrom cygwin MINGW packages to Coq install folder - -function copy_coq_dll { - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - cp "$PREFIXMINGW/bin/$1" "$PREFIXCOQ/bin/$1" - fi -} - -# Copy required DLLs from cygwin MINGW packages to Coq install folder - -function copy_coq_dlls { - # HOW TO CREATE THE DLL LIST - # With the list empty, after the build/install is finished, open coqide in dependency walker. - # See http://www.dependencywalker.com/ - # Make sure to use the 32 bit / 64 bit version of depends matching the target architecture. - # Select all missing DLLs from the module list, right click "copy filenames" - # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) - # Do this recursively until there are no further missing DLLs (File close + reopen) - # For running this quickly, just do "cd coq-<ver> ; copy_coq_dlls ; cd .." at the end of this script. - # Do the same for coqc and ocamlc (usually doesn't result in additional files) - - copy_coq_dll LIBCAIRO-2.DLL - copy_coq_dll LIBFONTCONFIG-1.DLL - copy_coq_dll LIBFREETYPE-6.DLL - copy_coq_dll LIBGDK-3-0.DLL - copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL - copy_coq_dll LIBGLIB-2.0-0.DLL - copy_coq_dll LIBGOBJECT-2.0-0.DLL - copy_coq_dll LIBGTK-3-0.DLL - copy_coq_dll LIBGTKSOURCEVIEW-3.0-1.DLL - copy_coq_dll LIBPANGO-1.0-0.DLL - copy_coq_dll LIBATK-1.0-0.DLL - copy_coq_dll LIBBZ2-1.DLL - copy_coq_dll LIBCAIRO-GOBJECT-2.DLL - copy_coq_dll LIBEPOXY-0.DLL - copy_coq_dll LIBEXPAT-1.DLL - copy_coq_dll LIBFFI-6.DLL - copy_coq_dll LIBGIO-2.0-0.DLL - copy_coq_dll LIBGMODULE-2.0-0.DLL - copy_coq_dll LIBINTL-8.DLL - copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL - copy_coq_dll LIBPANGOWIN32-1.0-0.DLL - copy_coq_dll LIBPCRE-1.DLL - copy_coq_dll LIBPIXMAN-1-0.DLL - copy_coq_dll LIBPNG16-16.DLL - copy_coq_dll LIBXML2-2.DLL - copy_coq_dll ZLIB1.DLL - copy_coq_dll ICONV.DLL - copy_coq_dll LIBLZMA-5.DLL - copy_coq_dll LIBPANGOFT2-1.0-0.DLL - copy_coq_dll LIBHARFBUZZ-0.DLL - - # Depends on if GTK is built from sources - if [ "$GTK_FROM_SOURCES" == "Y" ]; then - echo "Building GTK from sources is currently not supported" - exit 1 - fi; - - # Architecture dependent files - case $ARCH in - x86_64) copy_coq_dll LIBGCC_S_SEH-1.DLL ;; - i686) copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;; - *) false ;; - esac - - # Win pthread version change - copy_coq_dll LIBWINPTHREAD-1.DLL -} - -function copy_coq_objects { - # copy objects only from folders which exist in the target lib directory - find . -type d | while read -r FOLDER ; do - if [ -e "$PREFIXCOQ/lib/coq/$FOLDER" ] ; then - install_glob "$FOLDER" '*.cmxa' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.cmi' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.cma' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.cmo' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.a' "$PREFIXCOQ/lib/coq/$FOLDER" - install_glob "$FOLDER" '*.o' "$PREFIXCOQ/lib/coq/$FOLDER" - fi - done -} - -# Copy required GTK config and support files -# This must be called from inside the coq build folder! - -function copy_coq_gtk { - - glib-compile-schemas $PREFIXMINGW/share/glib-2.0/schemas/ - echo 'gtk-theme-name = "Default"' > "$PREFIXMINGW/etc/gtk-3.0/gtkrc" - - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIXMINGW/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" - install -D -T "$PREFIXMINGW/share/glib-2.0/schemas/gschemas.compiled" "$PREFIXCOQ/share/glib-2.0/schemas/gschemas.compiled" - - install_glob "$PREFIXMINGW/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" - install -D -T "ide/coqide/coq.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq.lang" - install -D -T "ide/coqide/coq-ssreflect.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq-ssreflect.lang" - - install_glob "$PREFIXMINGW/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" - install -D -T "ide/coqide/coq_style.xml" "$PREFIXCOQ/share/gtksourceview-3.0/styles/coq_style.xml" - - install_rec "$PREFIXMINGW/share/themes" '*' "$PREFIXCOQ/share/themes" - - FOLDERS="" - # The sizes include all default sizes given in index.theme - # The types used haven been recorded with ProcMon in an installation with all icons present - for SIZE in 16x16 22x22 32x32 48x48; do - for TYPE in \ - actions/bookmark actions/document devices/drive actions/format-text actions/go actions/list \ - actions/media actions/pan actions/process actions/system actions/window \ - mimetypes/text places/folder places/user status/dialog - do - CLASS=$(dirname $TYPE) - ICON=$(basename $TYPE) - if [[ ! "$FOLDERS" =~ "$SIZE/$CLASS" ]] ;then - FOLDERS="$FOLDERS$SIZE/$CLASS," - fi - install_rec "/usr/share/icons/Adwaita/$SIZE/$CLASS" "$ICON*" "$PREFIXCOQ/share/icons/Adwaita/$SIZE/$CLASS" - done - done - echo Folders=$FOLDERS - install -D -T "/usr/share/icons/Adwaita/index.theme" "$PREFIXCOQ/share/icons/Adwaita/index.theme" - sed -i "s|^Directories=.*|Directories=$FOLDERS|" "$PREFIXCOQ/share/icons/Adwaita/index.theme" - gtk-update-icon-cache -f "$PREFIXCOQ/share/icons/Adwaita/" - - # This below item look like a bug in make install - # if [ -d "$PREFIXCOQ/share/coq/" ] ; then - # COQSHARE="$PREFIXCOQ/share/coq/" - # else - # COQSHARE="$PREFIXCOQ/share/" - # fi - - # mkdir -p "$PREFIXCOQ/ide/coqide" - # mv "$COQSHARE"*.png "$PREFIXCOQ/ide/coqide" - # rmdir "$PREFIXCOQ/share/coq" || true - fi -} - -# Copy license and other info files - -function copy_coq_license { - if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install -D doc/LICENSE "$PREFIXCOQ/license_readme/coq/LicenseDoc.txt" - install -D LICENSE "$PREFIXCOQ/license_readme/coq/License.txt" - install -D plugins/micromega/LICENSE.sos "$PREFIXCOQ/license_readme/coq/LicenseMicromega.txt" - # FIXME: this is not the micromega license - # It only applies to code that was copied into one single file! - install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D INSTALL.md "$PREFIXCOQ/license_readme/coq/Install.txt" - install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true - fi -} - -# Main function for creating Coq - -function make_coq { - make_ocaml - make_num - make_findlib - make_lablgtk - if - case $COQ_VERSION in - # e.g. git-v8.6 => download from https://github.com/coq/coq/archive/v8.6.zip - # e.g. git-trunk => download from https://github.com/coq/coq/archive/trunk.zip - git-*) - COQ_BUILD_PATH=/build/coq-${COQ_VERSION} - build_prep https://github.com/coq/coq/archive "${COQ_VERSION##git-}" zip 1 "coq-${COQ_VERSION}" - ;; - - # e.g. /cygdrive/d/coqgit - /*) - # Todo: --exclude-vcs-ignores doesn't work because tools/coqdoc/coqdoc.sty is excluded => fix .gitignore - # But this is not a big deal, only 2 files are removed with --exclude-vcs-ignores from a fresch clone - COQ_BUILD_PATH=/build/coq-local - tar -zcf $TARBALLS/coq-local.tar.gz --exclude-vcs -C "${COQ_VERSION%/*}" "${COQ_VERSION##*/}" - build_prep NEVER-DOWNLOADED coq-local tar.gz - ;; - - # e.g. 8.6 => https://coq.inria.fr/distrib/8.6/files/coq-8.6.tar.gz - *) - COQ_BUILD_PATH=/build/coq-$COQ_VERSION - build_prep "https://coq.inria.fr/distrib/V$COQ_VERSION/files" "coq-$COQ_VERSION" tar.gz - ;; - esac - then - if [ "$INSTALLMODE" == "relocatable" ]; then - # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - logn configure ./configure -with-doc no -prefix ./ -libdir ./lib/coq -mandir ./man - elif [ "$INSTALLMODE" == "absolute" ]; then - logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" - else - logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" - fi - - # 8.4x doesn't support parallel make - if [[ $COQ_VERSION == 8.4* ]] ; then - log1 make - else - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - fi - - if [ "$INSTALLMODE" == "relocatable" ]; then - logn reconfigure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" - fi - - log2 make install - log1 copy_coq_dlls - log1 copy_coq_gtk - - if [ "$INSTALLOCAML" == "Y" ]; then - copy_coq_objects - fi - - log1 copy_coq_license - - # make clean seems to be broken for 8.5pl2 - # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile - # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)" - # make clean - - # Copy these files somewhere the plugin builds can find them - logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ - - build_post - fi - - load_overlay_data -} - -##### GNU Make for MinGW ##### - -function make_mingw_make { - if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then - # The config.h.win32 file is fine - don't edit it - # We need to copy the mingw gcc here as "gcc" - then the batch file will use it - cp "/usr/bin/${ARCH}-w64-mingw32-gcc-6.4.0.exe" ./gcc.exe - # By some magic cygwin bash can run batch files - logn build ./build_w32.bat gcc - # Copy make to Coq folder - cp GccRel/gnumake.exe "$PREFIXCOQ/bin/make.exe" - build_post - fi -} - -##### GNU binutils for native OCaml ##### - -function make_binutils { - if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - # log2 make clean - build_post - fi -} - -##### GNU GCC for native OCaml ##### - -function make_gcc { - # Note: the bz2 file is smaller, but decompressing bz2 really takes ages - if build_prep ftp://ftp.fu-berlin.de/unix/languages/gcc/releases/gcc-5.4.0 gcc-5.4.0 tar.gz ; then - # This is equivalent to "contrib/download_prerequisites" but uses caching - # Update versions when updating gcc version - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpfr-2.4.2 tar.bz2 1 mpfr-2.4.2 mpfr - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure gmp-4.3.2 tar.bz2 1 gmp-4.3.2 gmp - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpc-0.8.1 tar.gz 1 mpc-0.8.1 mpc - get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure isl-0.14 tar.bz2 1 isl-0.14 isl - - # For whatever reason gcc needs this (although it never puts anything into it) - # Error: "The directory that should contain system headers does not exist:" - # mkdir -p /mingw/include without --with-sysroot - mkdir -p "$PREFIXCOQ/mingw/include" - - # See https://gcc.gnu.org/install/configure.html - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" \ - --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" --disable-win32-registry --with-sysroot="$PREFIXCOQ" \ - --enable-languages=c --disable-nls \ - --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto - # --disable-decimal-float seems to be required - # --with-sysroot="$PREFIXMINGW" results in configure error that this is not an absolute path - # shellcheck disable=SC2086 - log1 make $MAKE_OPT - log2 make install - # log2 make clean - build_post - fi -} - -##### Get sources for Cygwin MinGW packages ##### - -function get_cygwin_mingw_sources { - if [ ! -f $FLAGFILES/cygwin_mingw_sources.finished ] ; then - touch $FLAGFILES/cygwin_mingw_sources.started - - # Find all installed files with mingw in the name and download the corresponding source code file from cygwin - # Steps: - # grep /etc/setup/installed.db for mingw => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2.tar.bz2 1 - # remove archive ending and trailing number => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2 - # replace space with / => ${ARCHIVE} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2 - # escape + signs using ${var//pattern/replace} => ${ARCHIVEESC} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g\+\+-5.4.0-2 - # grep cygwin setup.ini for installed line + next line (the -A 1 option includes and "after context" of 1 line) - # Note that the folders of the installed binaries and source are different. So we cannot grep just for the source line. - # We could strip off the path and just grep for the file, though. - # => install: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2.tar.xz 10163848 2f8cb7ba3e16ac8ce0455af01de490ded09061b1b06a9a8e367426635b5a33ce230e04005f059d4ea7b52580757da1f6d5bae88eba6b9da76d1bd95e8844b705 - # source: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz 95565368 03f22997b7173b243fff65ea46a39613a2e4e75fc7e6cf0fa73b7bcb86071e15ba6d0ca29d330c047fb556a5e684cad57cd2f5adb6e794249e4b01fe27f92c95 - # Take the 2nd field of the last line => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - # Remove that path part => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - - grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read -r ARCHIVE ; do - local ARCHIVEESC=${ARCHIVE//+/\\+} - local SOURCE - SOURCE=$(grep -E -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2) - local SOURCEFILE=${SOURCE##*/} - - # Get the source file (either from the source cache or online) - if [ ! -f "$TARBALLS/$SOURCEFILE" ] ; then - if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS - else - wget --progress=dot:giga "$CYGWIN_REPOSITORY/$SOURCE" - mv "$SOURCEFILE" "$TARBALLS" - # Save the source archive in the source cache - if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp "$TARBALLS/$SOURCEFILE" "$SOURCE_LOCAL_CACHE_CFMT" - fi - fi - fi - - done - - touch $FLAGFILES/cygwin_mingw_sources.finished - fi -} - -##### Coq Windows Installer ##### - -function make_coq_installer { - make_coq - get_cygwin_mingw_sources - - # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: - # ocaml: ocaml + menhir + camlp5 + findlib - # ocaml_coq: as above + coq - # ocaml_coq_addons: as above + lib/user-contrib/* - - # Create coq file list as ocaml_coq / ocaml - diff_files coq ocaml_coq ocaml - - # Filter out object files - filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' - - # Filter out plugin object files - filter_files coq_objects_plugins coq_objects '/lib/coq/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' - - # Coq objects objects required for plugin development = coq objects except those for pre installed plugins - diff_files coq_plugindev coq_objects coq_objects_plugins - - # Addons (TODO: including objects that could go to the plugindev thing, but - # then one would have to make that package depend on this one, so not - # implemented yet) - diff_files coq_addons ocaml_coq_addons ocaml_coq - - # Coq files, except objects needed only for plugin development - diff_files coq_base coq coq_plugindev - - # Convert section files to NSIS format - files_to_nsis coq_base - files_to_nsis coq_addons - files_to_nsis coq_plugindev - files_to_nsis ocaml - - # Get and extract NSIS Binaries - if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then - NSIS=$(pwd)/makensis.exe - chmod u+x "$NSIS" - # Change to Coq folder - cd "$COQ_BUILD_PATH" - # Copy patched nsi file - cp ../patches/coq_new.nsi dev/nsis - cp ../patches/StrRep.nsh dev/nsis - cp ../patches/ReplaceInFile.nsh dev/nsis - VERSION=$(grep '^VERSION=' config/Makefile | cut -d = -f 2 | tr -d '\r') - cd dev/nsis - logn nsis-installer "$NSIS" -DVERSION="$VERSION" -DARCH="$ARCH" -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coqide\\coq.ico -DCOQ_ADDONS="$COQ_ADDONS" coq_new.nsi - - build_post - fi -} - -###################### ADDON COQ LIBRARIES / PLUGINS / TOOLS ##################### - -# The bignums library -# Provides BigN, BigZ, BigQ that used to be part of Coq standard library - -function make_addon_bignums { - installer_addon_dependency bignums - if build_prep_overlay bignums; then - installer_addon_section bignums "Bignums" "Coq library for fast arbitrary size numbers" "" - # To make command lines shorter :-( - echo 'COQ_SRC_SUBDIRS:=$(filter-out plugins/%,$(COQ_SRC_SUBDIRS)) plugins/syntax' >> Makefile.coq.local - log1 make $MAKE_OPT all - log2 make install - build_post - fi -} - -# Equations plugin -# A function definition plugin - -function make_addon_equations { - installer_addon_dependency equations - if build_prep_overlay equations; then - installer_addon_section equations "Equations" "Coq plugin for defining functions by equations" "" - # Note: PATH is automatically saved/restored by build_prep / build_post - PATH=$COQBIN:$PATH - logn coq_makefile ${COQBIN}coq_makefile -f _CoqProject -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# mathcomp - ssreflect and mathematical components library - -function make_addon_mathcomp { - installer_addon_dependency mathcomp - if build_prep_overlay mathcomp; then - installer_addon_section mathcomp "Math-Components" "Coq library with mathematical components" "" - cd mathcomp - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# ssreflect part of mathcomp - -function make_addon_ssreflect { - # if mathcomp addon is requested, build this instead - if [[ "$COQ_ADDONS" == *mathcomp* ]]; then - make_addon_mathcomp - else - # Note: since either mathcomp or ssreflect is defined, it is fine to name both mathcomp - installer_addon_dependency ssreflect - if build_prep_overlay mathcomp; then - installer_addon_section ssreflect "SSReflect" "Coq support library for small scale reflection plugin" "" - cd mathcomp - logn make-makefile make Makefile.coq - logn make-ssreflect make $MAKE_OPT -f Makefile.coq ssreflect/all_ssreflect.vo - logn make-install make -f Makefile.coq install - build_post - fi - fi -} - -# UniCoq plugin -# An alternative unification algorithm -function make_addon_unicoq { - installer_addon_dependency unicoq - if build_prep_overlay unicoq; then - installer_addon_section unicoq "Unicoq" "Coq plugin for an enhanced unification algorithm" "" - log1 coq_makefile -f Make -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Mtac2 plugin -# An alternative typed tactic language -function make_addon_mtac2 { - installer_addon_dependency_beg mtac2 - make_addon_unicoq - installer_addon_dependency_end - if build_prep_overlay mtac2; then - installer_addon_section mtac2 "Mtac-2" "Coq plugin for a typed tactic language for Coq." "" - log1 coq_makefile -f _CoqProject -o Makefile - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Menhir parser generator - -function make_addon_menhir { - make_menhir - # If COQ and OCaml are installed to the same folder, there is nothing to do - installer_addon_dependency menhir - if [ "$PREFIXOCAML" != "$PREFIXCOQ" ] ; then - # Just install menhir files required for COQ to COQ target folder - if [ ! -f "$FLAGFILES/menhir-addon.finished" ] ; then - installer_addon_section menhir "Menhir" "Menhir parser generator windows executable and libraries" "" - LOGTARGET=menhir-addon - touch "$FLAGFILES/menhir-addon.started" - # Menhir executable - install_glob "$PREFIXOCAML/bin" 'menhir.exe' "$PREFIXCOQ/bin/" - # Menhir PDF doc - install_glob "$PREFIXOCAML/doc/menhir/" '*.pdf' "$PREFIXCOQ/doc/menhir/" - touch "$FLAGFILES/menhir-addon.finished" - LOGTARGET=other - installer_addon_end - fi - fi -} - -# COQ library for Menhir - -function make_addon_menhirlib { - installer_addon_dependency menhirlib - if build_prep_overlay menhirlib; then - installer_addon_section menhirlib "Menhirlib" "Coq support library for using Menhir generated parsers in Coq" "" - # The supplied makefiles don't work in any way on cygwin - # ToDo: dune also doesn't seem to work for the coq files - cd coq-menhirlib/src - echo -R . MenhirLib > _CoqProject - ls -1 *.v >> _CoqProject - log1 coq_makefile -f _CoqProject -o Makefile.coq - log1 make -f Makefile.coq $MAKE_OPT all - logn make-install make -f Makefile.coq install - build_post - fi -} - -# CompCert - -function make_addon_compcert { - installer_addon_dependency_beg compcert - make_menhir - make_addon_menhirlib - installer_addon_dependency_end - if build_prep_overlay compcert; then - installer_addon_section compcert "CompCert" "ATTENTION: THIS IS NOT OPEN SOURCE! CompCert verified C compiler and Clightgen (required for using VST for your own code)" "off" - logn configure ./configure -ignore-coq-version -clightgen -prefix "$PREFIXCOQ" -coqdevdir "$PREFIXCOQ/lib/coq/user-contrib/compcert" x86_32-cygwin -use-external-MenhirLib -use-external-Flocq - log1 make $MAKE_OPT - log2 make install - logn install-license-1 install -D -T "LICENSE" "$PREFIXCOQ/lib/coq/user-contrib/compcert/LICENSE" - logn install-license-2 install -D -T "LICENSE" "$PREFIXCOQ/lib/compcert/LICENSE" - build_post - fi -} - -# Princeton VST - -function install_addon_vst { - VSTDEST="$PREFIXCOQ/lib/coq/user-contrib/VST" - - # Install VST .v, .vo, .c and .h files - install_rec compcert '*.v' "$VSTDEST/compcert/" - install_rec compcert '*.vo' "$VSTDEST/compcert/" - install_glob "msl" '*.v' "$VSTDEST/msl/" - install_glob "msl" '*.vo' "$VSTDEST/msl/" - install_glob "sepcomp" '*.v' "$VSTDEST/sepcomp/" - install_glob "sepcomp" '*.vo' "$VSTDEST/sepcomp/" - install_glob "floyd" '*.v' "$VSTDEST/floyd/" - install_glob "floyd" '*.vo' "$VSTDEST/floyd/" - install_glob "progs" '*.v' "$VSTDEST/progs/" - install_glob "progs" '*.c' "$VSTDEST/progs/" - install_glob "progs" '*.h' "$VSTDEST/progs/" - install_glob "veric" '*.v' "$VSTDEST/veric/" - install_glob "veric" '*.vo' "$VSTDEST/veric/" - - # Install VST documentation files - install_glob "." 'LICENSE' "$VSTDEST" - install_glob "." '*.md' "$VSTDEST" - install_glob "compcert" '*' "$VSTDEST/compcert" - install_glob "doc" '*.pdf' "$VSTDEST/doc" - - # Install VST _CoqProject files - install_glob "." '_CoqProject*' "$VSTDEST" - install_glob "." '_CoqProject-export' "$VSTDEST/progs" -} - -function vst_patch_compcert_refs { - find . -type f -name '*.v' -print0 | xargs -0 sed -E -i \ - -e 's/(Require\s+(Import\s+|Export\s+)*)compcert\./\1VST.compcert./g' \ - -e 's/From compcert Require/From VST.compcert Require/g' -} - -function make_addon_vst { - installer_addon_dependency vst - if build_prep_overlay vst; then - installer_addon_section vst "VST" "ATTENTION: SOME INCLUDED COMPCERT PARTS ARE NOT OPEN SOURCE! Verified Software Toolchain for verifying C code" "off" - # log1 coq_set_timeouts_1000 - log1 vst_patch_compcert_refs - # The usage of the shell variable ARCH in VST collides with the usage in this shellscript - logn make env -u ARCH make IGNORECOQVERSION=true $MAKE_OPT - log1 install_addon_vst - build_post - fi -} - -# coquelicot Real analysis - -function make_addon_coquelicot { - installer_addon_dependency_beg coquelicot - make_addon_ssreflect - installer_addon_dependency_end - if build_prep_overlay coquelicot; then - installer_addon_section coquelicot "Coquelicot" "Coq library for real analysis" "" - log1 autoreconf -i -s - logn configure ./configure --libdir="$PREFIXCOQ/lib/coq/user-contrib/Coquelicot" - logn remake ./remake - logn remake-install ./remake install - build_post - fi -} - -# AAC associative / commutative rewriting - -function make_addon_aactactics { - installer_addon_dependency aac - if build_prep_overlay aac_tactics; then - installer_addon_section aac "AAC" "Coq plugin for extensible associative and commutative rewriting" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# extlib - -function make_addon_extlib { - installer_addon_dependency extlib - if build_prep_overlay ext_lib; then - installer_addon_section extlib "Ext-Lib" "Coq library with many reusable general purpose components" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# SimpleIO - -function make_addon_simple_io { - installer_addon_dependency simpleIO - if build_prep_overlay simple_io; then - installer_addon_section simpleIO "SimpleIO" "Coq plugin for reading and writing files directly from Coq code" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Quickchick Randomized Property-Based Testing Plugin for Coq - -function make_addon_quickchick { - installer_addon_dependency_beg quickchick - make_addon_ssreflect - make_addon_extlib - make_addon_simple_io - make_ocamlbuild - installer_addon_dependency_end - if build_prep_overlay quickchick; then - installer_addon_section quickchick "QuickChick" "Coq plugin for randomized testing and counter example search" "" - log1 make $MAKE_OPT - log2 make install - build_post - fi -} - -# Flocq: Floating point library - -function make_addon_flocq { - if build_prep_overlay flocq; then - installer_addon_section flocq "Flocq" "Coq library for floating point arithmetic" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake install - build_post - fi -} - -# Coq-Interval: interval arithmetic and inequality proofs - -function make_addon_interval { - installer_addon_dependency_beg interval - make_addon_mathcomp - make_addon_coquelicot - make_addon_bignums - make_addon_flocq - installer_addon_dependency_end - if build_prep_overlay interval; then - installer_addon_section interval "Interval" "Coq library and tactic for proving real inequalities" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake install - build_post - fi -} - -# Gappa: Automatic generation of arithmetic proofs (mostly on limited precision arithmetic) - -function install_boost { - # The extra tar parameter extracts only the boost headers, not the boost library source code (which is huge and takes a long time) - if build_prep https://dl.bintray.com/boostorg/release/1.69.0/source boost_1_69_0 tar.gz 1 boost_1_69_0 boost boost_1_69_0/boost; then - # Move extracted boost folder where mingw-gcc can find it - mv boost /usr/$TARGET_ARCH/sys-root/mingw/include - build_post - fi -} - -function copy_gappa_dlls { - copy_coq_dll LIBGMP-10.DLL - copy_coq_dll LIBMPFR-6.DLL - copy_coq_dll LIBSTDC++-6.DLL -} - -function make_addon_gappa_tool { - install_boost - if build_prep_overlay gappa_tool; then - installer_addon_section gappa_tool "Gappa tool" "Stand alone tool for automated generation of numerical arithmetic proofs" "" - log1 autoreconf - # Note: configure.in seems to reference this file - touch stamp-config_h.in - logn configure ./configure --build="$HOST" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" - logn remake ./remake --jobs=$MAKE_THREADS - logn install ./remake -d install - log1 copy_gappa_dlls - build_post - fi -} - -function make_addon_gappa { - make_camlp5 - installer_addon_dependency_beg gappa - make_addon_gappa_tool - make_addon_flocq - installer_addon_dependency_end - if build_prep_overlay gappa_plugin ; then - installer_addon_section gappa "Gappa plugin" "Coq plugin for the Gappa tool" "" - log1 autoreconf - logn configure ./configure - logn remake ./remake - logn install ./remake install - build_post - fi -} - -# Elpi: extension language for Coq based. It lets one define commands in tactics -# in a high level programming language with support for binders and unification -# variables. - -function make_addon_elpi { - make_elpi - installer_addon_dependency elpi - if build_prep_overlay elpi ; then - installer_addon_section elpi "Elpi extension language" "Coq plugin for the Elpi extension language" "" - logn build make - logn installe make install - build_post - fi -} - -# Hierarchy Builder: high level language to declare a hierarchy of structures -# compiled down to records and canonical structures. - -function make_addon_HB { - installer_addon_dependency_beg elpi_hb - make_addon_elpi - installer_addon_dependency_end - if build_prep_overlay elpi_hb ; then - installer_addon_section elpi_hb "Hierarchy Builder" "Coq library to declare algebraic hierarchies" "" - logn build make - logn install make install VFILES=structures.v - build_post - fi -} - -# Main function for building addons - -function make_addons { - # Note: ':' is the empty command, which does not produce any output - : > "/build/filelists/addon_dependencies.nsh" - : > "/build/filelists/addon_strings.nsh" - : > "/build/filelists/addon_descriptions.nsh" - : > "/build/filelists/addon_sections.nsh" - - for addon in $COQ_ADDONS; do - "make_addon_$addon" - done - - sort -u -o "/build/filelists/addon_dependencies.nsh" "/build/filelists/addon_dependencies.nsh" -} - -###################### TOP LEVEL BUILD ##################### - -ocamlfind list || true - -make_sed -make_ocaml -make_ocaml_tools -make_ocaml_libs - -list_files ocaml - -make_coq - -if [ "$INSTALLMAKE" == "Y" ] ; then - make_mingw_make -fi - -list_files ocaml_coq - -make_addons - -list_files_always ocaml_coq_addons - -if [ "$MAKEINSTALLER" == "Y" ] ; then - make_coq_installer -fi diff --git a/dev/build/windows/patches_coq/ReplaceInFile.nsh b/dev/build/windows/patches_coq/ReplaceInFile.nsh deleted file mode 100644 index 27c7eb2fd9..0000000000 --- a/dev/build/windows/patches_coq/ReplaceInFile.nsh +++ /dev/null @@ -1,67 +0,0 @@ -; From NSIS Wiki http://nsis.sourceforge.net/ReplaceInFile -; Modifications: -; - Replace only once per line -; - Don't keep original as .old -; - Use StrRep instead of StrReplace (seems to be cleaner) - -Function Func_ReplaceInFile - ClearErrors - - Exch $0 ; REPLACEMENT - Exch - Exch $1 ; SEARCH_TEXT - Exch 2 - Exch $2 ; SOURCE_FILE - - Push $R0 ; SOURCE_FILE file handle - Push $R1 ; temporary file handle - Push $R2 ; unique temporary file name - Push $R3 ; a line to search and replace / save - Push $R4 ; shift puffer - - IfFileExists $2 +1 error ; Check if file exists and open it - FileOpen $R0 $2 "r" - - GetTempFileName $R2 ; Create temporary output file - FileOpen $R1 $R2 "w" - - loop: ; Loop over lines of file - FileRead $R0 $R3 ; Read line - IfErrors finished - Push "$R3" ; Replacine string in line once - Push "$1" - Push "$0" - Call Func_StrRep - Pop $R3 - FileWrite $R1 "$R3" ; Write result - Goto loop - - finished: - FileClose $R1 ; Close files - FileClose $R0 - Delete "$2" ; Delete original file and rename temporary file to target - Rename "$R2" "$2" - ClearErrors - Goto out - - error: - SetErrors - - out: - Pop $R4 - Pop $R3 - Pop $R2 - Pop $R1 - Pop $R0 - Pop $2 - Pop $0 - Pop $1 -FunctionEnd - -!macro ReplaceInFile SOURCE_FILE SEARCH_TEXT REPLACEMENT - Push "${SOURCE_FILE}" - Push "${SEARCH_TEXT}" - Push "${REPLACEMENT}" - Call Func_ReplaceInFile -!macroend - diff --git a/dev/build/windows/patches_coq/StrRep.nsh b/dev/build/windows/patches_coq/StrRep.nsh deleted file mode 100644 index d94a9f88b4..0000000000 --- a/dev/build/windows/patches_coq/StrRep.nsh +++ /dev/null @@ -1,60 +0,0 @@ -; From NSIS Wiki http://nsis.sourceforge.net/StrRep -; Slightly modified - -Function Func_StrRep - Exch $R2 ;new - Exch 1 - Exch $R1 ;old - Exch 2 - Exch $R0 ;string - Push $R3 - Push $R4 - Push $R5 - Push $R6 - Push $R7 - Push $R8 - Push $R9 - - StrCpy $R3 0 - StrLen $R4 $R1 - StrLen $R6 $R0 - StrLen $R9 $R2 - loop: - StrCpy $R5 $R0 $R4 $R3 - StrCmp $R5 $R1 found - StrCmp $R3 $R6 done - IntOp $R3 $R3 + 1 ;move offset by 1 to check the next character - Goto loop - found: - StrCpy $R5 $R0 $R3 - IntOp $R8 $R3 + $R4 - StrCpy $R7 $R0 "" $R8 - StrCpy $R0 $R5$R2$R7 - StrLen $R6 $R0 - IntOp $R3 $R3 + $R9 ;move offset by length of the replacement string - Goto loop - done: - - Pop $R9 - Pop $R8 - Pop $R7 - Pop $R6 - Pop $R5 - Pop $R4 - Pop $R3 - Push $R0 - Push $R1 - Pop $R0 - Pop $R1 - Pop $R0 - Pop $R2 - Exch $R1 -FunctionEnd - -!macro StrRep output string old new - Push `${string}` - Push `${old}` - Push `${new}` - Call Func_StrRep - Pop ${output} -!macroend diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch deleted file mode 100644 index d047eb107f..0000000000 --- a/dev/build/windows/patches_coq/VST.patch +++ /dev/null @@ -1,14 +0,0 @@ -diff --git a/Makefile b/Makefile ---- a/Makefile -+++ b/Makefile -@@ -82,8 +82,8 @@ endif - - COMPCERTDIRS=lib common $(ARCHDIRS) cfrontend flocq exportclight $(BACKEND) - --COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) compcert.$(d)) --EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) compcert.$(d)) -+COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) VST.compcert.$(d)) -+EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) VST.compcert.$(d)) - # for ITrees - ifeq ($(wildcard InteractionTrees/the?ries),"InteractionTrees/theories") - EXTFLAGS:=$(EXTFLAGS) -Q InteractionTrees/theories ITree diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi deleted file mode 100644 index 9947965c28..0000000000 --- a/dev/build/windows/patches_coq/coq_new.nsi +++ /dev/null @@ -1,330 +0,0 @@ -; This script is used to build the Windows install program for Coq. - -; NSIS Modern User Interface -; Written by Joost Verburg -; Modified by Julien Narboux, Pierre Letouzey, Enrico Tassi and Michael Soegtrop - -; The following command line defines are expected: -; VERSION Coq version, e.g. 8.5-pl2 -; ARCH The target architecture, either x86_64 or i686 -; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter) -; COQ_ICON path of Coq icon file in Windows or MinGW format -; COQ_ADDONS list of addons that are shipped - -; Enable compression after debugging. -; SetCompress off -SetCompressor lzma - -!define MY_PRODUCT "Coq" ;Define your own software name here -!define OUTFILE "coq-${VERSION}-installer-windows-${ARCH}.exe" - -!include "MUI2.nsh" -!include "FileAssociation.nsh" -!include "StrRep.nsh" -!include "ReplaceInFile.nsh" -!include "winmessages.nsh" - -Var COQ_SRC_PATH_BS ; COQ_SRC_PATH with \ instead of / -Var COQ_SRC_PATH_DBS ; COQ_SRC_PATH with \\ instead of / -Var INSTDIR_DBS ; INSTDIR with \\ instead of \ - -;-------------------------------- -;Configuration - - Name "Coq" - - ;General - OutFile "${OUTFILE}" - - ;Folder selection page - InstallDir "C:\${MY_PRODUCT}" - - ;Remember install folder - InstallDirRegKey HKCU "Software\${MY_PRODUCT}" "" - -;-------------------------------- -;Extra license pages - -!macro MUI_PAGE_LICENSE_EXTRA Licensefile Header Subheader Bottom SelFunc - !define MUI_PAGE_HEADER_TEXT "${Header}" - !define MUI_PAGE_HEADER_SUBTEXT "${Subheader}" - !define MUI_LICENSEPAGE_TEXT_BOTTOM "${Bottom}" - !define MUI_PAGE_CUSTOMFUNCTION_PRE ${SelFunc} - !insertmacro MUI_PAGE_LICENSE "${Licensefile}" -!macroend - -;-------------------------------- -; Check for white spaces -Function .onVerifyInstDir - StrLen $0 "$INSTDIR" - StrCpy $1 0 - ${While} $1 < $0 - StrCpy $3 $INSTDIR 1 $1 - StrCmp $3 " " SpacesInPath - IntOp $1 $1 + 1 - ${EndWhile} - Goto done - SpacesInPath: - Abort - done: -FunctionEnd - -;-------------------------------- -;Installer Sections - -Section "Coq" Sec1 - - SetOutPath "$INSTDIR\" - !include "..\..\..\filelists\coq_base.nsh" - - ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File" - - ;Store install folder - WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR - - ;Create uninstaller - WriteUninstaller "$INSTDIR\Uninstall.exe" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "DisplayName" "Coq Version ${VERSION}" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "UninstallString" '"$INSTDIR\Uninstall.exe"' - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "DisplayVersion" "${VERSION}" - WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "NoModify" "1" - WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "NoRepair" "1" - WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ - "URLInfoAbout" "http://coq.inria.fr" - - ; Create start menu entries - ; SetOutPath is required for the path in the .lnk files - SetOutPath "$INSTDIR" - CreateDirectory "$SMPROGRAMS\Coq" - ; The first shortcut set here is treated as main application by Windows 7/8. - ; Use CoqIDE as main application - CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe" - CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe" - WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr" - WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library" - CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0 - -SectionEnd - -;OCAML Section "Ocaml for native compute and plugin development" Sec2 -;OCAML SetOutPath "$INSTDIR\" -;OCAML !include "..\..\..\filelists\ocaml.nsh" -;OCAML -;OCAML ; Create a few slash / backslash variants of the source and install path -;OCAML ; Note: NSIS has variables, written as $VAR and defines, written as ${VAR} -;OCAML !insertmacro StrRep $COQ_SRC_PATH_BS ${COQ_SRC_PATH} "/" "\" -;OCAML !insertmacro StrRep $COQ_SRC_PATH_DBS ${COQ_SRC_PATH} "/" "\\" -;OCAML !insertmacro StrRep $INSTDIR_DBS $INSTDIR "\" "\\" -;OCAML -;OCAML ; Replace absolute paths in some OCaml config files -;OCAML ; These are not all, see ReadMe.txt -;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "/" "\" -;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "$COQ_SRC_PATH_BS" "$INSTDIR" -;OCAML !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS" -;OCAML SectionEnd - -SectionGroup "Coq addons" Sec2 - !include "..\..\..\filelists\addon_sections.nsh" -SectionGroupEnd - -Section "Coq files for plugin developers" Sec3 - SetOutPath "$INSTDIR\" - !include "..\..\..\filelists\coq_plugindev.nsh" -SectionEnd - -;OCAML Section "OCAMLLIB current user" Sec4 -;OCAML WriteRegStr HKCU "Environment" "OCAMLLIB" "$INSTDIR\libocaml" -;OCAML ; This is required, so that a newly started shell gets the new environment variable -;OCAML ; But it really takes a few seconds -;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (current user)" -;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 -;OCAML SectionEnd - -;OCAML Section "OCAMLLIB all users" Sec5 -;OCAML WriteRegStr HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment" "OCAMLLIB" "$INSTDIR\libocaml" -;OCAML ; This is required, so that a newly started shell gets the new environment variable -;OCAML ; But it really takes a few seconds -;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (all users)" -;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 -;OCAML SectionEnd - -;-------------------------------- -;Section dependencies - -; Parameters on the stack: -; top-0 : section B on which section A dependencies -; top-1 : section A, which depends on section B -; top-2 : name of section B -; top-3 : name of section A - -Function CheckSectionDependency - ; stack=nameB nameA secB secA rest - Exch $R3 ; stack=$R3 nameA secB secA rest; $R3=nameB - Exch ; stack=nameA $R3 secB secA rest - Exch $R2 ; stack=$R2 $R3 secB secA rest; $R2=nameA - Exch 2 ; stack=secB $R3 $R2 secA rest - Exch $R1 ; stack=$R1 $R3 $R2 secA rest; $R1=secB - Exch 3 ; stack=secA $R3 $R2 $R1 rest; - Exch $R0 ; stack=$R0 $R3 $R2 $R1 rest; $R0=secA - ; Take care of save order when popping the stack! - Push $R4 - Push $R5 - - SectionGetFlags $R0 $R0 - IntOp $R0 $R0 & ${SF_SELECTED} - - SectionGetFlags $R1 $R4 - IntOp $R5 $R4 & ${SF_SELECTED} - - ${If} $R0 == ${SF_SELECTED} - ${AndIf} $R5 != ${SF_SELECTED} - - IntOp $R5 $R4 | ${SF_SELECTED} - SectionSetFlags $R1 $R5 - MessageBox MB_OK '"$R3" has been selected, because "$R2" depends on it' - - ${EndIf} - - Pop $R5 - Pop $R4 - Pop $R0 - Pop $R3 - Pop $R2 - Pop $R1 -FunctionEnd - -!macro CheckSectionDependency secA secB nameA nameB - Push "${secA}" - Push "${secB}" - Push "${nameA}" - Push "${nameB}" - Call CheckSectionDependency -!macroend - -!define CheckSectionDependency "!insertmacro CheckSectionDependency" - -Function .onSelChange - !include "..\..\..\filelists\addon_dependencies.nsh" -FunctionEnd - -;-------------------------------- -;Modern UI Configuration - -; Note: this must be placed after the sections, because below we need to check at compile time -; if sections exist (by !ifdef <section_index_var>) to decide if the license page must be included. -; The section index variables are only defined after the section definitions. - - !define MUI_ICON "${COQ_ICON}" - - !insertmacro MUI_PAGE_WELCOME - !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/license_readme/coq/License.txt" - !insertmacro MUI_PAGE_COMPONENTS - - !ifdef Sec_compcert - !define LicCompCert_Title "CompCert License Agreement" - !define LicCompCert_SubTitle "You selected the CompCert addon. CompCert is not open source. Please review the license terms before installing CompCert!" - !define LicCompCert_Bottom "If you accept the terms of the agreement, click I Agree to continue. Otherwise go back and unselect the CompCert addon." - !insertmacro MUI_PAGE_LICENSE_EXTRA "${COQ_SRC_PATH}/lib/coq/user-contrib/compcert/LICENSE" "${LicCompCert_Title}" "${LicCompCert_SubTitle}" "${LicCompCert_Bottom}" SelFuncCompCert - - Function SelFuncCompCert - ${Unless} ${SectionIsSelected} ${Sec_compcert} - Abort - ${EndUnless} - FunctionEnd - !endif - - !ifdef Sec_vst - !define LicVST_Title "Princeton VST License Agreement" - !define LicVST_SubTitle "You selected the VST addon. VST contains parts of CompCert which are not open source. Please review the license terms before installing VST!" - !define LicVST_Bottom "If you accept the terms of the agreement, click I Agree to continue. Otherwise go back and unselect the VST addon." - !insertmacro MUI_PAGE_LICENSE_EXTRA "${COQ_SRC_PATH}/lib/coq/user-contrib/VST/LICENSE" "${LicVST_Title}" "${LicVST_SubTitle}" "${LicVST_Bottom}" SelFuncVST - - Function SelFuncVST - ${Unless} ${SectionIsSelected} ${Sec_vst} - Abort - ${EndUnless} - FunctionEnd - !endif - - !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq. The path MUST NOT include spaces." - !insertmacro MUI_PAGE_DIRECTORY - !insertmacro MUI_PAGE_INSTFILES - !insertmacro MUI_PAGE_FINISH - - !insertmacro MUI_UNPAGE_WELCOME - !insertmacro MUI_UNPAGE_CONFIRM - !insertmacro MUI_UNPAGE_INSTFILES - !insertmacro MUI_UNPAGE_FINISH - -;-------------------------------- -;Languages - - !insertmacro MUI_LANGUAGE "English" - -;-------------------------------- -;Language Strings - - ;Description - LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE." - LangString DESC_2 ${LANG_ENGLISH} "This package contains the following extra Coq packages: ${COQ_ADDONS}" - LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq." - ; LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user." - ; LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users." - !include "..\..\..\filelists\addon_strings.nsh" - -;-------------------------------- -;Descriptions - -!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN - !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1) - !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2) - !insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3) - ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4) - ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5) - !include "..\..\..\filelists\addon_descriptions.nsh" -!insertmacro MUI_FUNCTION_DESCRIPTION_END - -;-------------------------------- -;Uninstaller Section - -Section "Uninstall" - ; Files and folders - RMDir /r "$INSTDIR\bin" - RMDir /r "$INSTDIR\doc" - RMDir /r "$INSTDIR\etc" - RMDir /r "$INSTDIR\lib" - RMDir /r "$INSTDIR\libocaml" - RMDir /r "$INSTDIR\share" - RMDir /r "$INSTDIR\ide" - RMDir /r "$INSTDIR\gtk-2.0" - RMDir /r "$INSTDIR\latex" - RMDir /r "$INSTDIR\license_readme" - RMDir /r "$INSTDIR\man" - RMDir /r "$INSTDIR\emacs" - - ; Start Menu - Delete "$SMPROGRAMS\Coq\Coq.lnk" - Delete "$SMPROGRAMS\Coq\CoqIde.lnk" - Delete "$SMPROGRAMS\Coq\Uninstall.lnk" - Delete "$SMPROGRAMS\Coq\The Coq HomePage.url" - Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url" - Delete "$INSTDIR\Uninstall.exe" - - ; Registry keys - DeleteRegKey HKCU "Software\${MY_PRODUCT}" - DeleteRegKey HKLM "SOFTWARE\Coq" - DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq" - DeleteRegKey HKCU "Environment\OCAMLLIB" - DeleteRegKey HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\OCAMLLIB" - ${unregisterExtension} ".v" "Coq Script File" - - ; Root folders - RMDir "$INSTDIR" - RMDir "$SMPROGRAMS\Coq" - -SectionEnd diff --git a/dev/build/windows/patches_coq/flexdll-0.37.patch b/dev/build/windows/patches_coq/flexdll-0.37.patch deleted file mode 100644 index 82806f9ea4..0000000000 --- a/dev/build/windows/patches_coq/flexdll-0.37.patch +++ /dev/null @@ -1,19 +0,0 @@ -diff/patch file created on Tue, Feb 19, 2019 9:41:26 PM with: -difftar-folder.sh tarballs/flexdll-0.37.tar.gz flexdll-0.37 1 -TARFILE= tarballs/flexdll-0.37.tar.gz -FOLDER= flexdll-0.37 -TARSTRIP= 1 -TARPREFIX= flexdll-0.37/ -ORIGFOLDER= flexdll-0.37.orig ---- flexdll-0.37.orig/cmdline.ml 2017-10-25 10:40:46.000000000 +0200 -+++ flexdll-0.37/cmdline.ml 2019-02-19 21:41:18.157024900 +0100 -@@ -248,6 +248,9 @@ - String.sub s 0 2 :: String.sub s 2 (String.length s - 2) :: tr rest - | s :: rest when String.length s >= 5 && String.sub s 0 5 = "/link" -> - "-link" :: String.sub s 5 (String.length s - 5) :: tr rest -+ (* Convert gcc linker option prefix -Wl, to flexlink linker prefix -link *) -+ | s :: rest when String.length s >= 6 && String.sub s 0 5 = "-Wl,-" -> -+ "-link" :: String.sub s 4 (String.length s - 4) :: tr rest - | "-arg" :: x :: rest -> - tr (Array.to_list (Arg.read_arg x)) @ rest - | "-arg0" :: x :: rest -> diff --git a/dev/build/windows/patches_coq/isl-0.14.patch b/dev/build/windows/patches_coq/isl-0.14.patch deleted file mode 100644 index f3b8ead1ab..0000000000 --- a/dev/build/windows/patches_coq/isl-0.14.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- orig.isl-0.14/configure 2014-10-26 08:36:32.000000000 +0100 -+++ isl-0.14/configure 2016-10-10 18:16:01.430224500 +0200 -@@ -8134,7 +8134,7 @@ - lt_sysroot=`$CC --print-sysroot 2>/dev/null` - fi - ;; #( -- /*) -+ /*|[A-Z]:\\*|[A-Z]:/*) - lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` - ;; #( - no|'') diff --git a/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch deleted file mode 100644 index 1c6a038da9..0000000000 --- a/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch +++ /dev/null @@ -1,76 +0,0 @@ -diff/patch file created on Wed, Feb 20, 2019 11:29:48 AM with: -difftar-folder.sh tarballs/lablgtk-3.0.beta4.tar.gz lablgtk-3.0.beta4 1 -TARFILE= tarballs/lablgtk-3.0.beta4.tar.gz -FOLDER= lablgtk-3.0.beta4 -TARSTRIP= 1 -TARPREFIX= lablgtk-3.0.beta4/ -ORIGFOLDER= lablgtk-3.0.beta4.orig ---- lablgtk-3.0.beta4.orig/src/glib.ml 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/glib.ml 2019-02-20 11:28:28.439137100 +0100 -@@ -72,6 +72,8 @@ - type id - external channel_of_descr : Unix.file_descr -> channel - = "ml_g_io_channel_unix_new" -+ external channel_of_descr_socket : Unix.file_descr -> channel -+ = "ml_g_io_channel_unix_new_socket" - external remove : id -> unit = "ml_g_source_remove" - external add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-3.0.beta4.orig/src/glib.mli 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/glib.mli 2019-02-20 11:28:28.423592200 +0100 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-3.0.beta4.orig/src/ml_glib.c 2019-02-11 07:08:17.000000000 +0100 -+++ lablgtk-3.0.beta4/src/ml_glib.c 2019-02-20 11:28:28.455395900 +0100 -@@ -25,6 +25,8 @@ - #include <string.h> - #include <locale.h> - #ifdef _WIN32 -+/* to kill a #warning: include winsock2.h before windows.h */ -+#include <winsock2.h> - #include "win32.h" - #include <wtypes.h> - #include <io.h> -@@ -38,6 +40,11 @@ - #include <caml/callback.h> - #include <caml/threads.h> - -+#ifdef _WIN32 -+/* for Socket_val */ -+#include <caml/unixsupport.h> -+#endif -+ - #include "wrappers.h" - #include "ml_glib.h" - #include "glib_tags.h" -@@ -326,14 +333,23 @@ - - #ifndef _WIN32 - ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) -+CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { -+ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); -+} - - #else - CAMLprim value ml_g_io_channel_unix_new(value wh) - { - return Val_GIOChannel_noref -- (g_io_channel_unix_new -+ (g_io_channel_win32_new_fd - (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); - } -+ -+CAMLprim value ml_g_io_channel_unix_new_socket(value wh) -+{ -+ return Val_GIOChannel_noref -+ (g_io_channel_win32_new_socket(Socket_val(wh))); -+} - #endif - - static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, diff --git a/dev/build/windows/patches_coq/ln.c b/dev/build/windows/patches_coq/ln.c deleted file mode 100644 index 41f64f98b2..0000000000 --- a/dev/build/windows/patches_coq/ln.c +++ /dev/null @@ -1,137 +0,0 @@ -// (C) 2016 Intel Deutschland GmbH -// Author: Michael Soegtrop -// Released to the public under CC0 -// See https://creativecommons.org/publicdomain/zero/1.0/ - -// Windows drop in repacement for Linux ln -// Supports command form "ln TARGET LINK_NAME" -// Supports -s and -f options -// Does not support hard links to folders (but symlinks are ok) - -#include <windows.h> -#include <stdio.h> -#include <tchar.h> - -// Cygwin MinGW doesn't have this Vista++ function in windows.h -#ifdef UNICODE - WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkW ( LPCWSTR, LPCWSTR, DWORD ); - #define CreateSymbolicLink CreateSymbolicLinkW - #define CommandLineToArgv CommandLineToArgvW -#else - WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkA ( LPCSTR, LPCSTR, DWORD ); - #define CreateSymbolicLink CreateSymbolicLinkA - #define CommandLineToArgv CommandLineToArgvA -#endif -#define SYMBOLIC_LINK_FLAG_DIRECTORY 1 - -int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLineA, int nShowCmd ) -{ - int iarg; - BOOL symbolic = FALSE; - BOOL force = FALSE; - BOOL folder; - const _TCHAR *target; - const _TCHAR *link; - LPTSTR lpCmdLine; - int argc; - LPTSTR *argv; - - // Parse command line - // This is done explicitly here for two reasons - // 1.) MinGW doesn't seem to support _tmain, wWinMain and the like - // 2.) We want to make sure that CommandLineToArgv is used - lpCmdLine = GetCommandLine(); - argv = CommandLineToArgv( lpCmdLine, &argc ); - - // Get target and link name - if( argc<3 ) - { - _ftprintf( stderr, _T("Expecting at least 2 arguments, got %d\n"), argc-1 ); - return 1; - } - target = argv[argc-2]; - link = argv[argc-1]; - - // Parse options - // The last two arguments are interpreted as file names - // All other arguments must be -s or -f os multi letter options like -sf - for(iarg=1; iarg<argc-2; iarg++ ) - { - const _TCHAR *pos = argv[iarg]; - if( *pos != _T('-') ) - { - _ftprintf( stderr, _T("Command line option expected in argument %d\n"), iarg ); - return 1; - } - pos ++; - - while( *pos ) - { - switch( *pos ) - { - case _T('s') : symbolic = TRUE; break; - case _T('f') : force = TRUE; break; - default : - _ftprintf( stderr, _T("Unknown option '%c'\n"), *pos ); - return 1; - } - pos ++; - } - } - - #ifdef IGNORE_SYMBOLIC - symbolic = FALSE; - #endif - - // Check if link already exists - delete it if force is given or abort - { - if( GetFileAttributes(link) != INVALID_FILE_ATTRIBUTES ) - { - if( force ) - { - if( !DeleteFile( link ) ) - { - _ftprintf( stderr, _T("Error deleting file '%s'\n"), link ); - return 1; - } - } - else - { - _ftprintf( stderr, _T("File '%s' exists!\n"), link ); - return 1; - } - } - } - - // Check if target is a folder - folder = ( (GetFileAttributes(target) & FILE_ATTRIBUTE_DIRECTORY) ) != 0; - - // Create link - if(symbolic) - { - if( !CreateSymbolicLink( link, target, folder ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0 ) ) - { - _ftprintf( stderr, _T("Error creating symbolic link '%s' -> '%s'!\n"), link, target ); - return 1; - } - } - else - { - if( folder ) - { - _ftprintf( stderr, _T("Cannot create hard link to folder") ); - return 1; - } - else - { - if( !CreateHardLink( link, target, NULL ) ) - { - _ftprintf( stderr, _T("Error creating hard link '%s' -> '%s'!\n"), link, target ); - return 1; - } - } - } - - // Everything is fine - return 0; -} diff --git a/dev/build/windows/patches_coq/ocaml-4.07.1.patch b/dev/build/windows/patches_coq/ocaml-4.07.1.patch deleted file mode 100644 index 2d61b5b838..0000000000 --- a/dev/build/windows/patches_coq/ocaml-4.07.1.patch +++ /dev/null @@ -1,97 +0,0 @@ -diff/patch file created on Tue, Jun 11, 2019 10:15:38 AM with: -difftar-folder.sh tarballs/ocaml-4.07.1.tar.gz ocaml-4.07.1 1 -TARFILE= tarballs/ocaml-4.07.1.tar.gz -FOLDER= ocaml-4.07.1/ -TARSTRIP= 1 -TARPREFIX= ocaml-4.07.1/ -ORIGFOLDER= ocaml-4.07.1.orig ---- ocaml-4.07.1.orig/byterun/caml/osdeps.h 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/caml/osdeps.h 2019-06-11 10:13:50.766997600 +0200 -@@ -98,6 +98,11 @@ - */ - extern char_os *caml_secure_getenv(char_os const *var); - -+/* Modify or delete environment variable. -+ Returns 0 on success or an error code. -+*/ -+extern int caml_putenv(char_os const *var, char_os const *value); -+ - /* If [fd] refers to a terminal or console, return the number of rows - (lines) that it displays. Otherwise, or if the number of rows - cannot be determined, return -1. */ ---- ocaml-4.07.1.orig/byterun/debugger.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/debugger.c 2019-06-11 10:14:02.706013700 +0200 -@@ -180,6 +180,7 @@ - if (address == NULL) return; - if (dbg_addr != NULL) caml_stat_free(dbg_addr); - dbg_addr = address; -+ caml_putenv(_T("CAML_DEBUG_SOCKET"),_T("")); - - #ifdef _WIN32 - winsock_startup(); ---- ocaml-4.07.1.orig/byterun/unix.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/unix.c 2019-06-11 10:14:11.252438800 +0200 -@@ -430,6 +430,19 @@ - #endif - } - -+int caml_putenv(char_os const *var, char_os const *value) -+{ -+ char_os * s; -+ int ret; -+ -+ s = caml_stat_strconcat_os(3, var, _T("="), value); -+ ret = putenv_os(s); -+ if (ret == -1) { -+ caml_stat_free(s); -+ } -+ return ret; -+} -+ - int caml_num_rows_fd(int fd) - { - #ifdef TIOCGWINSZ ---- ocaml-4.07.1.orig/byterun/win32.c 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1/byterun/win32.c 2019-06-11 10:14:19.485640700 +0200 -@@ -727,6 +727,19 @@ - return _wgetenv(var); - } - -+int caml_putenv(char_os const *var, char_os const *value) -+{ -+ char_os * s; -+ int ret; -+ -+ s = caml_stat_strconcat_os(3, var, _T("="), value); -+ ret = putenv_os(s); -+ if (ret == -1) { -+ caml_stat_free(s); -+ } -+ return ret; -+} -+ - /* caml_win32_getenv is used to implement Sys.getenv and Unix.getenv in such a - way that they get direct access to the Win32 environment rather than to the - copy that is cached by the C runtime system. The result of caml_win32_getenv ---- ocaml-4.07.1.orig/config/Makefile.mingw 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1//config/Makefile.mingw 2019-06-11 10:14:44.492969800 +0200 -@@ -89,7 +89,7 @@ - NATDYNLINK=true - NATDYNLINKOPTS= - CMXS=cmxs --RUNTIMED=false -+RUNTIMED=true - ASM_CFI_SUPPORTED=false - WITH_FRAME_POINTERS=false - UNIX_OR_WIN32=win32 ---- ocaml-4.07.1.orig/config/Makefile.mingw64 2018-10-04 15:38:56.000000000 +0200 -+++ ocaml-4.07.1//config/Makefile.mingw64 2019-06-11 10:14:53.664784900 +0200 -@@ -89,7 +89,7 @@ - NATDYNLINK=true - NATDYNLINKOPTS= - CMXS=cmxs --RUNTIMED=false -+RUNTIMED=true - ASM_CFI_SUPPORTED=false - WITH_FRAME_POINTERS=false - UNIX_OR_WIN32=win32 diff --git a/dev/build/windows/patches_coq/ocaml-4.08.1.patch b/dev/build/windows/patches_coq/ocaml-4.08.1.patch deleted file mode 100644 index a79033a061..0000000000 --- a/dev/build/windows/patches_coq/ocaml-4.08.1.patch +++ /dev/null @@ -1,25 +0,0 @@ -diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h -index 6aa98516b..8184c2797 100644 ---- a/runtime/caml/misc.h -+++ b/runtime/caml/misc.h -@@ -327,7 +327,6 @@ extern void caml_set_fields (intnat v, uintnat, uintnat); - - #if defined(_WIN32) && !defined(_UCRT) - extern int caml_snprintf(char * buf, size_t size, const char * format, ...); --#define snprintf caml_snprintf - #endif - - #ifdef CAML_INSTR -@@ -336,6 +335,12 @@ extern int caml_snprintf(char * buf, size_t size, const char * format, ...); - #include <time.h> - #include <stdio.h> - -+/* snprintf emulation for Win32 - do define after stdio.h, in case snprintf is defined */ -+ -+#if defined(_WIN32) && !defined(_UCRT) -+#define snprintf caml_snprintf -+#endif -+ - extern intnat caml_stat_minor_collections; - extern intnat caml_instr_starttime, caml_instr_stoptime; - diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c deleted file mode 100644 index c4c7ec2bff..0000000000 --- a/dev/build/windows/patches_coq/pkg-config.c +++ /dev/null @@ -1,29 +0,0 @@ -// MinGW personality wrapper for pkgconf -// This is an executable replacement for the shell scripts /bin/ARCH-pkg-config -// Compile with e.g. -// gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe -// gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe -// ATTENTION: Do not compile with MinGW-gcc, compile with cygwin gcc! -// -// To test it execute e.g. -// $ ./pkg-config --path zlib -// /usr/x86_64-w64-mingw32/sys-root/mingw/lib/pkgconfig/zlib.pc - -#include <unistd.h> - -#define STRINGIFY1(arg) #arg -#define STRINGIFY(arg) STRINGIFY1(arg) - -int main(int argc, char *argv[]) -{ - // +1 for extra argument, +1 for trailing NULL - char * argvnew[argc+2]; - int id=0, is=0; - - argvnew[id++] = argv[is++]; - argvnew[id++] = "--personality="STRINGIFY(ARCH); - while( is<argc ) argvnew[id++] = argv[is++]; - argvnew[id++] = 0; - - return execv("/usr/bin/pkgconf", argvnew); -} diff --git a/dev/build/windows/patches_coq/quickchick.patch b/dev/build/windows/patches_coq/quickchick.patch deleted file mode 100644 index 4b7b86ff05..0000000000 --- a/dev/build/windows/patches_coq/quickchick.patch +++ /dev/null @@ -1,47 +0,0 @@ -diff/patch file created on Wed, Jul 17, 2019 8:06:45 PM with: -difftar-folder.sh tarballs/quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.tar.gz quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0 1 -TARFILE= tarballs/quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.tar.gz -FOLDER= quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0 -TARSTRIP= 1 -TARPREFIX= QuickChick-741fb98eb865129a70c4ef7a64db2739c4a5eab0/ -ORIGFOLDER= quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.orig ---- quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0.orig/Makefile 2019-06-26 12:09:01.000000000 +0200 -+++ quickchick-741fb98eb865129a70c4ef7a64db2739c4a5eab0/Makefile 2019-07-17 20:05:44.322251200 +0200 -@@ -2,7 +2,7 @@ - .PHONY: plugin install install-plugin clean quickChickTool - - QCTOOL_DIR=quickChickTool --QCTOOL_EXE=quickChickTool.byte -+QCTOOL_EXE=quickChickTool.native - QCTOOL_SRC=$(QCTOOL_DIR)/quickChickTool.ml \ - $(QCTOOL_DIR)/quickChickToolTypes.ml \ - $(QCTOOL_DIR)/quickChickToolLexer.mll \ -@@ -20,8 +20,8 @@ - - all: quickChickTool plugin documentation-check - --plugin: Makefile.coq -- $(MAKE) -f Makefile.coq -+plugin: Makefile.coq -+ $(MAKE) -f Makefile.coq - - documentation-check: plugin - coqc -R src QuickChick -I src QuickChickInterface.v -@@ -32,7 +32,7 @@ - install: all - $(V)$(MAKE) -f Makefile.coq install > $(TEMPFILE) - # Manually copying the remaining files -- $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) $(shell opam config var bin)/quickChick -+ $(V)cp $(QCTOOL_DIR)/$(QCTOOL_EXE) "$(COQBIN)/quickChick" - # $(V)cp src/quickChickLib.cmx $(COQLIB)/user-contrib/QuickChick - # $(V)cp src/quickChickLib.o $(COQLIB)/user-contrib/QuickChick - -@@ -56,7 +56,7 @@ - $(MAKE) -C examples/RedBlack test - # cd examples/stlc; make clean && make - $(MAKE) -C examples/multifile-mutation test --# This takes too long. -+# This takes too long. - # $(MAKE) -C examples/c-mutation test - # coqc examples/BSTTest.v - coqc examples/DependentTest.v diff --git a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch b/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch deleted file mode 100644 index d210a04153..0000000000 --- a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch +++ /dev/null @@ -1,1301 +0,0 @@ ---- origsrc/sed-4.2.2/doc/sed.1 2012-12-22 15:27:13.000000000 +0100 -+++ src/sed-4.2.2/doc/sed.1 2013-06-27 18:10:47.974060492 +0200 -@@ -1,5 +1,5 @@ - .\" DO NOT MODIFY THIS FILE! It was generated by help2man 1.28. --.TH SED "1" "December 2012" "sed 4.2.2" "User Commands" -+.TH SED "1" "June 2013" "sed 4.2.2" "User Commands" - .SH NAME - sed \- stream editor for filtering and transforming text - .SH SYNOPSIS -@@ -40,6 +40,10 @@ follow symlinks when processing in place - .IP - edit files in place (makes backup if SUFFIX supplied) - .HP -+\fB\-b\fR, \fB\-\-binary\fR -+.IP -+open files in binary mode (CR+LFs are not processed specially) -+.HP - \fB\-l\fR N, \fB\-\-line\-length\fR=\fIN\fR - .IP - specify the desired line-wrap length for the `l' command ---- origsrc/sed-4.2.2/lib/regcomp.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regcomp.c 2013-06-27 18:05:27.044448044 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, - size_t length, reg_syntax_t syntax); -@@ -95,20 +94,20 @@ static reg_errcode_t build_charclass (RE - bitset_t sbcset, - re_charset_t *mbcset, - Idx *char_class_alloc, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #else /* not RE_ENABLE_I18N */ - static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); - static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #endif /* not RE_ENABLE_I18N */ - static bin_tree_t *build_charclass_op (re_dfa_t *dfa, - RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, -+ const char *class_name, -+ const char *extra, - bool non_match, reg_errcode_t *err); - static bin_tree_t *create_tree (re_dfa_t *dfa, - bin_tree_t *left, bin_tree_t *right, -@@ -293,7 +292,7 @@ weak_alias (__re_compile_fastmap, re_com - #endif - - static inline void --__attribute ((always_inline)) -+__attribute__ ((always_inline)) - re_set_fastmap (char *fastmap, bool icase, int ch) - { - fastmap[ch] = 1; -@@ -587,7 +586,7 @@ weak_alias (__regerror, regerror) - static const bitset_t utf8_sb_map = - { - /* Set the first 128 bits. */ --# ifdef __GNUC__ -+# if defined __GNUC__ && !defined __STRICT_ANSI__ - [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX - # else - # if 4 * BITSET_WORD_BITS < ASCII_CHARS -@@ -664,7 +663,10 @@ regfree (preg) - { - re_dfa_t *dfa = preg->buffer; - if (BE (dfa != NULL, 1)) -- free_dfa_content (dfa); -+ { -+ lock_fini (dfa->lock); -+ free_dfa_content (dfa); -+ } - preg->buffer = NULL; - preg->allocated = 0; - -@@ -785,6 +787,8 @@ re_compile_internal (regex_t *preg, cons - preg->used = sizeof (re_dfa_t); - - err = init_dfa (dfa, length); -+ if (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0)) -+ err = REG_ESPACE; - if (BE (err != REG_NOERROR, 0)) - { - free_dfa_content (dfa); -@@ -798,8 +802,6 @@ re_compile_internal (regex_t *preg, cons - strncpy (dfa->re_str, pattern, length + 1); - #endif - -- __libc_lock_init (dfa->lock); -- - err = re_string_construct (®exp, pattern, length, preg->translate, - (syntax & RE_ICASE) != 0, dfa); - if (BE (err != REG_NOERROR, 0)) -@@ -807,6 +809,7 @@ re_compile_internal (regex_t *preg, cons - re_compile_internal_free_return: - free_workarea_compile (preg); - re_string_destruct (®exp); -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -839,6 +842,7 @@ re_compile_internal (regex_t *preg, cons - - if (BE (err != REG_NOERROR, 0)) - { -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -954,10 +958,10 @@ static void - internal_function - init_word_char (re_dfa_t *dfa) - { -- dfa->word_ops_used = 1; - int i = 0; - int j; - int ch = 0; -+ dfa->word_ops_used = 1; - if (BE (dfa->map_notascii == 0, 1)) - { - bitset_word_t bits0 = 0x00000000; -@@ -2423,8 +2427,8 @@ parse_expression (re_string_t *regexp, r - case OP_WORD: - case OP_NOTWORD: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "alnum", -- (const unsigned char *) "_", -+ "alnum", -+ "_", - token->type == OP_NOTWORD, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2432,8 +2436,8 @@ parse_expression (re_string_t *regexp, r - case OP_SPACE: - case OP_NOTSPACE: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "space", -- (const unsigned char *) "", -+ "space", -+ "", - token->type == OP_NOTSPACE, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2713,7 +2717,6 @@ build_range_exp (const reg_syntax_t synt - wchar_t wc; - wint_t start_wc; - wint_t end_wc; -- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - - start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] -@@ -2727,11 +2730,7 @@ build_range_exp (const reg_syntax_t synt - ? __btowc (end_ch) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; -- cmp_buf[0] = start_wc; -- cmp_buf[4] = end_wc; -- -- if (BE ((syntax & RE_NO_EMPTY_RANGES) -- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) -+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. -@@ -2772,9 +2771,7 @@ build_range_exp (const reg_syntax_t synt - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { -- cmp_buf[2] = wc; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -@@ -2843,40 +2840,29 @@ parse_bracket_exp (re_string_t *regexp, - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. -- Return the index of the symbol in the SYMB_TABLE. */ -+ Return the index of the symbol in the SYMB_TABLE, -+ or -1 if not found. */ - - auto inline int32_t -- __attribute ((always_inline)) -- seek_collating_symbol_entry (name, name_len) -- const unsigned char *name; -- size_t name_len; -- { -- int32_t hash = elem_hash ((const char *) name, name_len); -- int32_t elem = hash % table_size; -- if (symb_table[2 * elem] != 0) -- { -- int32_t second = hash % (table_size - 2) + 1; -- -- do -- { -- /* First compare the hashing value. */ -- if (symb_table[2 * elem] == hash -- /* Compare the length of the name. */ -- && name_len == extra[symb_table[2 * elem + 1]] -- /* Compare the name. */ -- && memcmp (name, &extra[symb_table[2 * elem + 1] + 1], -- name_len) == 0) -- { -- /* Yep, this is the entry. */ -- break; -- } -+ __attribute__ ((always_inline)) -+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len) -+ { -+ int32_t elem; - -- /* Next entry. */ -- elem += second; -- } -- while (symb_table[2 * elem] != 0); -- } -- return elem; -+ for (elem = 0; elem < table_size; elem++) -+ if (symb_table[2 * elem] != 0) -+ { -+ int32_t idx = symb_table[2 * elem + 1]; -+ /* Skip the name of collating element name. */ -+ idx += 1 + extra[idx]; -+ if (/* Compare the length of the name. */ -+ name_len == extra[idx] -+ /* Compare the name. */ -+ && memcmp (name, &extra[idx + 1], name_len) == 0) -+ /* Yep, this is the entry. */ -+ return elem; -+ } -+ return -1; - } - - /* Local function for parse_bracket_exp used in _LIBC environment. -@@ -2884,9 +2870,8 @@ parse_bracket_exp (re_string_t *regexp, - Return the value if succeeded, UINT_MAX otherwise. */ - - auto inline unsigned int -- __attribute ((always_inline)) -- lookup_collation_sequence_value (br_elem) -- bracket_elem_t *br_elem; -+ __attribute__ ((always_inline)) -+ lookup_collation_sequence_value (bracket_elem_t *br_elem) - { - if (br_elem->type == SB_CHAR) - { -@@ -2914,7 +2899,7 @@ parse_bracket_exp (re_string_t *regexp, - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; -@@ -2932,7 +2917,7 @@ parse_bracket_exp (re_string_t *regexp, - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } -- else if (symb_table[2 * elem] == 0 && sym_name_len == 1) -+ else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ -@@ -2953,12 +2938,9 @@ parse_bracket_exp (re_string_t *regexp, - update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_range_exp (sbcset, mbcset, range_alloc, start_elem, end_elem) -- re_charset_t *mbcset; -- Idx *range_alloc; -- bitset_t sbcset; -- bracket_elem_t *start_elem, *end_elem; -+ __attribute__ ((always_inline)) -+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, -+ bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; -@@ -2971,6 +2953,7 @@ parse_bracket_exp (re_string_t *regexp, - 0)) - return REG_ERANGE; - -+ /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ -@@ -3036,26 +3019,23 @@ parse_bracket_exp (re_string_t *regexp, - pointer argument since we may update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_collating_symbol (sbcset, mbcset, coll_sym_alloc, name) -- re_charset_t *mbcset; -- Idx *coll_sym_alloc; -- bitset_t sbcset; -- const unsigned char *name; -+ __attribute__ ((always_inline)) -+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, -+ Idx *coll_sym_alloc, const unsigned char *name) - { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) - { - elem = seek_collating_symbol_entry (name, name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } -- else if (symb_table[2 * elem] == 0 && name_len == 1) -+ else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ -@@ -3298,7 +3278,8 @@ parse_bracket_exp (re_string_t *regexp, - #ifdef RE_ENABLE_I18N - mbcset, &char_class_alloc, - #endif /* RE_ENABLE_I18N */ -- start_elem.opr.name, syntax); -+ (const char *) start_elem.opr.name, -+ syntax); - if (BE (*err != REG_NOERROR, 0)) - goto parse_bracket_exp_free_return; - break; -@@ -3578,14 +3559,14 @@ static reg_errcode_t - #ifdef RE_ENABLE_I18N - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - re_charset_t *mbcset, Idx *char_class_alloc, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #else /* not RE_ENABLE_I18N */ - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #endif /* not RE_ENABLE_I18N */ - { - int i; -- const char *name = (const char *) class_name; -+ const char *name = class_name; - - /* In case of REG_ICASE "upper" and "lower" match the both of - upper and lower cases. */ -@@ -3659,8 +3640,8 @@ build_charclass (RE_TRANSLATE_TYPE trans - - static bin_tree_t * - build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, bool non_match, -+ const char *class_name, -+ const char *extra, bool non_match, - reg_errcode_t *err) - { - re_bitset_ptr_t sbcset; ---- origsrc/sed-4.2.2/lib/regex-quote.c 1970-01-01 01:00:00.000000000 +0100 -+++ src/sed-4.2.2/lib/regex-quote.c 2013-06-27 18:05:27.081447884 +0200 -@@ -0,0 +1,216 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <config.h> -+ -+/* Specification. */ -+#include "regex-quote.h" -+ -+#include <string.h> -+ -+#include "mbuiter.h" -+#include "xalloc.h" -+ -+/* Characters that are special in a BRE. */ -+static const char bre_special[] = "$^.*[]\\"; -+ -+/* Characters that are special in an ERE. */ -+static const char ere_special[] = "$^.*[]\\+?{}()|"; -+ -+struct regex_quote_spec -+regex_quote_spec_posix (int cflags, bool anchored) -+{ -+ struct regex_quote_spec result; -+ -+ strcpy (result.special, cflags != 0 ? ere_special : bre_special); -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Syntax bit values, defined in GNU <regex.h>. We don't include it here, -+ otherwise this module would need to depend on gnulib module 'regex'. */ -+#define RE_BK_PLUS_QM 0x00000002 -+#define RE_INTERVALS 0x00000200 -+#define RE_LIMITED_OPS 0x00000400 -+#define RE_NEWLINE_ALT 0x00000800 -+#define RE_NO_BK_BRACES 0x00001000 -+#define RE_NO_BK_PARENS 0x00002000 -+#define RE_NO_BK_VBAR 0x00008000 -+ -+struct regex_quote_spec -+regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (bre_special) - 1); -+ p += sizeof (bre_special) - 1; -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_BK_PLUS_QM) == 0) -+ { -+ *p++ = '+'; -+ *p++ = '?'; -+ } -+ if ((syntax & RE_INTERVALS) != 0 && (syntax & RE_NO_BK_BRACES) != 0) -+ { -+ *p++ = '{'; -+ *p++ = '}'; -+ } -+ if ((syntax & RE_NO_BK_PARENS) != 0) -+ { -+ *p++ = '('; -+ *p++ = ')'; -+ } -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_NO_BK_VBAR) != 0) -+ *p++ = '|'; -+ if ((syntax & RE_NEWLINE_ALT) != 0) -+ *p++ = '\n'; -+ *p = '\0'; -+ -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Characters that are special in a PCRE. */ -+static const char pcre_special[] = "$^.*[]\\+?{}()|"; -+ -+/* Options bit values, defined in <pcre.h>. We don't include it here, because -+ it is not a standard header. */ -+#define PCRE_ANCHORED 0x00000010 -+#define PCRE_EXTENDED 0x00000008 -+ -+struct regex_quote_spec -+regex_quote_spec_pcre (int options, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (pcre_special) - 1); -+ p += sizeof (pcre_special) - 1; -+ if (options & PCRE_EXTENDED) -+ { -+ *p++ = ' '; -+ *p++ = '\t'; -+ *p++ = '\n'; -+ *p++ = '\v'; -+ *p++ = '\f'; -+ *p++ = '\r'; -+ *p++ = '#'; -+ } -+ *p = '\0'; -+ -+ /* PCRE regular expressions consist of UTF-8 characters of options contains -+ PCRE_UTF8 and of single bytes otherwise. */ -+ result.multibyte = false; -+ /* If options contains PCRE_ANCHORED, the anchoring is implicit. */ -+ result.anchored = (options & PCRE_ANCHORED ? 0 : anchored); -+ -+ return result; -+} -+ -+size_t -+regex_quote_length (const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ size_t length; -+ -+ length = 0; -+ if (spec->anchored) -+ length += 2; /* for '^' at the beginning and '$' at the end */ -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ length += 1; -+ length += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ length += 1; -+ length += 1; -+ } -+ } -+ -+ return length; -+} -+ -+char * -+regex_quote_copy (char *p, const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ -+ if (spec->anchored) -+ *p++ = '^'; -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ *p++ = '\\'; -+ memcpy (p, mbui_cur_ptr (iter), mb_len (mbui_cur (iter))); -+ p += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ *p++ = '\\'; -+ *p++ = *iter++; -+ } -+ } -+ if (spec->anchored) -+ *p++ = '$'; -+ -+ return p; -+} -+ -+char * -+regex_quote (const char *string, const struct regex_quote_spec *spec) -+{ -+ size_t length = regex_quote_length (string, spec); -+ char *result = XNMALLOC (length + 1, char); -+ char *p; -+ -+ p = result; -+ p = regex_quote_copy (p, string, spec); -+ *p = '\0'; -+ return result; -+} ---- origsrc/sed-4.2.2/lib/regex-quote.h 1970-01-01 01:00:00.000000000 +0100 -+++ src/sed-4.2.2/lib/regex-quote.h 2013-06-27 18:05:27.112447751 +0200 -@@ -0,0 +1,88 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _REGEX_QUOTE_H -+#define _REGEX_QUOTE_H -+ -+#include <stddef.h> -+#include <stdbool.h> -+ -+ -+/* Specifies a quotation task for converting a fixed string to a regular -+ expression pattern. */ -+struct regex_quote_spec -+{ -+ /* True if the regular expression pattern consists of multibyte characters -+ (in the encoding given by the LC_CTYPE category of the locale), -+ false if it consists of single bytes or UTF-8 characters. */ -+ unsigned int /*bool*/ multibyte : 1; -+ /* True if the regular expression pattern shall match only entire lines. */ -+ unsigned int /*bool*/ anchored : 1; -+ /* Set of characters that need to be escaped (all ASCII), as a -+ NUL-terminated string. */ -+ char special[30 + 1]; -+}; -+ -+ -+/* Creates a quotation task that produces a POSIX regular expression, that is, -+ a pattern that can be compiled with regcomp(). -+ CFLAGS can be 0 or REG_EXTENDED. -+ If it is 0, the result is a Basic Regular Expression (BRE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_03>. -+ If it is REG_EXTENDED, the result is an Extended Regular Expression (ERE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_04>. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_posix (int cflags, bool anchored); -+ -+/* Creates a quotation task that produces a regular expression that can be -+ compiled with the GNU API function re_compile_pattern(). -+ SYNTAX describes the syntax of the regular expression (such as -+ RE_SYNTAX_POSIX_BASIC, RE_SYNTAX_POSIX_EXTENDED, RE_SYNTAX_EMACS, all -+ defined in <regex.h>). It must be the same value as 're_syntax_options' -+ at the moment of the re_compile_pattern() call. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored); -+ -+/* Creates a quotation task that produces a PCRE regular expression, that is, -+ a pattern that can be compiled with pcre_compile(). -+ OPTIONS is the same value as the second argument passed to pcre_compile(). -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_pcre (int options, bool anchored); -+ -+ -+/* Returns the number of bytes needed for the quoted string. */ -+extern size_t -+ regex_quote_length (const char *string, const struct regex_quote_spec *spec); -+ -+/* Copies the quoted string to p and returns the incremented p. -+ There must be room for regex_quote_length (string, spec) + 1 bytes at p. */ -+extern char * -+ regex_quote_copy (char *p, -+ const char *string, const struct regex_quote_spec *spec); -+ -+/* Returns the freshly allocated quoted string. */ -+extern char * -+ regex_quote (const char *string, const struct regex_quote_spec *spec); -+ -+ -+#endif /* _REGEX_QUOTE_H */ ---- origsrc/sed-4.2.2/lib/regex.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex.c 2013-06-27 18:05:27.138447639 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _LIBC - # include <config.h> -@@ -25,6 +24,7 @@ - # pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" - # endif - # if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ -+# pragma GCC diagnostic ignored "-Wold-style-definition" - # pragma GCC diagnostic ignored "-Wtype-limits" - # endif - #endif ---- origsrc/sed-4.2.2/lib/regex.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex.h 2013-06-27 18:05:27.168447509 +0200 -@@ -1,23 +1,22 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Definitions for data structures and routines for the regular - expression library. -- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 -- Free Software Foundation, Inc. -+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software -+ Foundation, Inc. - This file is part of the GNU C Library. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_H - #define _REGEX_H 1 ---- origsrc/sed-4.2.2/lib/regex_internal.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex_internal.c 2013-06-27 18:05:27.199447375 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static void re_string_construct_common (const char *str, Idx len, - re_string_t *pstr, -@@ -835,7 +834,7 @@ re_string_reconstruct (re_string_t *pstr - } - - static unsigned char --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_string_peek_byte_case (const re_string_t *pstr, Idx idx) - { - int ch; -@@ -975,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx - set->alloc = size; - set->nelem = 0; - set->elems = re_malloc (Idx, size); -- if (BE (set->elems == NULL, 0)) -+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) - return REG_ESPACE; - return REG_NOERROR; - } -@@ -1355,7 +1354,7 @@ re_node_set_insert_last (re_node_set *se - Return true if SET1 and SET2 are equivalent. */ - - static bool --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_compare (const re_node_set *set1, const re_node_set *set2) - { - Idx i; -@@ -1370,7 +1369,7 @@ re_node_set_compare (const re_node_set * - /* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */ - - static Idx --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_contains (const re_node_set *set, Idx elem) - { - __re_size_t idx, right, mid; -@@ -1444,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token - dfa->nodes[dfa->nodes_len] = token; - dfa->nodes[dfa->nodes_len].constraint = 0; - #ifdef RE_ENABLE_I18N -- { -- int type = token.type; - dfa->nodes[dfa->nodes_len].accept_mb = -- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; -- } -+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) -+ || token.type == COMPLEX_BRACKET); - #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; - re_node_set_init_empty (dfa->edests + dfa->nodes_len); ---- origsrc/sed-4.2.2/lib/regex_internal.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regex_internal.h 2013-06-27 18:05:27.230447242 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_INTERNAL_H - #define _REGEX_INTERNAL_H 1 -@@ -28,21 +27,54 @@ - #include <string.h> - - #include <langinfo.h> --#ifndef _LIBC --# include "localcharset.h" --#endif - #include <locale.h> - #include <wchar.h> - #include <wctype.h> - #include <stdbool.h> - #include <stdint.h> --#if defined _LIBC -+ -+#ifdef _LIBC - # include <bits/libc-lock.h> -+# define lock_define(name) __libc_lock_define (, name) -+# define lock_init(lock) (__libc_lock_init (lock), 0) -+# define lock_fini(lock) 0 -+# define lock_lock(lock) __libc_lock_lock (lock) -+# define lock_unlock(lock) __libc_lock_unlock (lock) -+#elif defined GNULIB_LOCK -+# include "glthread/lock.h" -+ /* Use gl_lock_define if empty macro arguments are known to work. -+ Otherwise, fall back on less-portable substitutes. */ -+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \ -+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__)) -+# define lock_define(name) gl_lock_define (, name) -+# elif USE_POSIX_THREADS -+# define lock_define(name) pthread_mutex_t name; -+# elif USE_PTH_THREADS -+# define lock_define(name) pth_mutex_t name; -+# elif USE_SOLARIS_THREADS -+# define lock_define(name) mutex_t name; -+# elif USE_WINDOWS_THREADS -+# define lock_define(name) gl_lock_t name; -+# else -+# define lock_define(name) -+# endif -+# define lock_init(lock) glthread_lock_init (&(lock)) -+# define lock_fini(lock) glthread_lock_destroy (&(lock)) -+# define lock_lock(lock) glthread_lock_lock (&(lock)) -+# define lock_unlock(lock) glthread_lock_unlock (&(lock)) -+#elif defined GNULIB_PTHREAD -+# include <pthread.h> -+# define lock_define(name) pthread_mutex_t name; -+# define lock_init(lock) pthread_mutex_init (&(lock), 0) -+# define lock_fini(lock) pthread_mutex_destroy (&(lock)) -+# define lock_lock(lock) pthread_mutex_lock (&(lock)) -+# define lock_unlock(lock) pthread_mutex_unlock (&(lock)) - #else --# define __libc_lock_define(CLASS,NAME) --# define __libc_lock_init(NAME) do { } while (0) --# define __libc_lock_lock(NAME) do { } while (0) --# define __libc_lock_unlock(NAME) do { } while (0) -+# define lock_define(name) -+# define lock_init(lock) 0 -+# define lock_fini(lock) 0 -+# define lock_lock(lock) ((void) 0) -+# define lock_unlock(lock) ((void) 0) - #endif - - /* In case that the system doesn't have isblank(). */ -@@ -65,7 +97,7 @@ - # ifdef _LIBC - # undef gettext - # define gettext(msgid) \ -- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) -+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) - # endif - #else - # define gettext(msgid) (msgid) -@@ -101,6 +133,8 @@ - - /* Rename to standard API for using out of glibc. */ - #ifndef _LIBC -+# undef __wctype -+# undef __iswctype - # define __wctype wctype - # define __iswctype iswctype - # define __btowc btowc -@@ -110,10 +144,8 @@ - # define attribute_hidden - #endif /* not _LIBC */ - --#if __GNUC__ >= 4 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1) --# define __attribute(arg) __attribute__ (arg) --#else --# define __attribute(arg) -+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1) -+# define __attribute__(arg) - #endif - - typedef __re_idx_t Idx; -@@ -429,7 +461,7 @@ static void build_upper_buffer (re_strin - static void re_string_translate_buffer (re_string_t *pstr) internal_function; - static unsigned int re_string_context_at (const re_string_t *input, Idx idx, - int eflags) -- internal_function __attribute ((pure)); -+ internal_function __attribute__ ((pure)); - #endif - #define re_string_peek_byte(pstr, offset) \ - ((pstr)->mbs[(pstr)->cur_idx + offset]) -@@ -448,7 +480,9 @@ static unsigned int re_string_context_at - #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) - #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) - --#include <alloca.h> -+#if defined _LIBC || HAVE_ALLOCA -+# include <alloca.h> -+#endif - - #ifndef _LIBC - # if HAVE_ALLOCA -@@ -465,6 +499,12 @@ static unsigned int re_string_context_at - # endif - #endif - -+#ifdef _LIBC -+# define MALLOC_0_IS_NONNULL 1 -+#elif !defined MALLOC_0_IS_NONNULL -+# define MALLOC_0_IS_NONNULL 0 -+#endif -+ - #ifndef MAX - # define MAX(a,b) ((a) < (b) ? (b) : (a)) - #endif -@@ -695,7 +735,7 @@ struct re_dfa_t - #ifdef DEBUG - char* re_str; - #endif -- __libc_lock_define (, lock) -+ lock_define (lock) - }; - - #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) -@@ -767,7 +807,7 @@ bitset_copy (bitset_t dest, const bitset - memcpy (dest, src, sizeof (bitset_t)); - } - --static void -+static void __attribute__ ((unused)) - bitset_not (bitset_t set) - { - int bitset_i; -@@ -779,7 +819,7 @@ bitset_not (bitset_t set) - & ~set[BITSET_WORDS - 1]); - } - --static void -+static void __attribute__ ((unused)) - bitset_merge (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -787,7 +827,7 @@ bitset_merge (bitset_t dest, const bitse - dest[bitset_i] |= src[bitset_i]; - } - --static void -+static void __attribute__ ((unused)) - bitset_mask (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -798,7 +838,7 @@ bitset_mask (bitset_t dest, const bitset - #ifdef RE_ENABLE_I18N - /* Functions for re_string. */ - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_char_size_at (const re_string_t *pstr, Idx idx) - { - int byte_idx; -@@ -811,7 +851,7 @@ re_string_char_size_at (const re_string_ - } - - static wint_t --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_wchar_at (const re_string_t *pstr, Idx idx) - { - if (pstr->mb_cur_max == 1) -@@ -821,7 +861,7 @@ re_string_wchar_at (const re_string_t *p - - # ifndef NOT_IN_libc - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_elem_size_at (const re_string_t *pstr, Idx idx) - { - # ifdef _LIBC ---- origsrc/sed-4.2.2/lib/regexec.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/sed-4.2.2/lib/regexec.c 2013-06-27 18:05:27.268447078 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, - Idx n) internal_function; -@@ -200,7 +199,7 @@ static Idx group_nodes_into_DFAstates (c - static bool check_node_accept (const re_match_context_t *mctx, - const re_token_t *node, Idx idx) - internal_function; --static reg_errcode_t extend_buffers (re_match_context_t *mctx) -+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) - internal_function; - - /* Entry point for POSIX code. */ -@@ -229,9 +228,7 @@ regexec (preg, string, nmatch, pmatch, e - { - reg_errcode_t err; - Idx start, length; --#ifdef _LIBC - re_dfa_t *dfa = preg->buffer; --#endif - - if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND)) - return REG_BADPAT; -@@ -247,14 +244,14 @@ regexec (preg, string, nmatch, pmatch, e - length = strlen (string); - } - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - if (preg->no_sub) - err = re_search_internal (preg, string, length, start, length, - length, 0, NULL, eflags); - else - err = re_search_internal (preg, string, length, start, length, - length, nmatch, pmatch, eflags); -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return err != REG_NOERROR; - } - -@@ -422,9 +419,7 @@ re_search_stub (struct re_pattern_buffer - Idx nregs; - regoff_t rval; - int eflags = 0; --#ifdef _LIBC - re_dfa_t *dfa = bufp->buffer; --#endif - Idx last_start = start + range; - - /* Check for out-of-range. */ -@@ -435,7 +430,7 @@ re_search_stub (struct re_pattern_buffer - else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0)) - last_start = 0; - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - - eflags |= (bufp->not_bol) ? REG_NOTBOL : 0; - eflags |= (bufp->not_eol) ? REG_NOTEOL : 0; -@@ -499,7 +494,7 @@ re_search_stub (struct re_pattern_buffer - } - re_free (pmatch); - out: -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return rval; - } - -@@ -1065,7 +1060,7 @@ prune_impossible_nodes (re_match_context - since initial states may have constraints like "\<", "^", etc.. */ - - static inline re_dfastate_t * --__attribute ((always_inline)) internal_function -+__attribute__ ((always_inline)) internal_function - acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, - Idx idx) - { -@@ -1177,7 +1172,7 @@ check_matching (re_match_context_t *mctx - || (BE (next_char_idx >= mctx->input.valid_len, 0) - && mctx->input.valid_len < mctx->input.len)) - { -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_char_idx + 1); - if (BE (err != REG_NOERROR, 0)) - { - assert (err == REG_ESPACE); -@@ -1757,7 +1752,7 @@ clean_state_log_if_needed (re_match_cont - && mctx->input.valid_len < mctx->input.len)) - { - reg_errcode_t err; -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_state_log_idx + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - } -@@ -2814,7 +2809,7 @@ get_subexp (re_match_context_t *mctx, Id - if (bkref_str_off >= mctx->input.len) - break; - -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, bkref_str_off + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - -@@ -3937,6 +3932,7 @@ check_node_accept_bytes (const re_dfa_t - in_collseq = find_collation_sequence_value (pin, elem_len); - } - /* match with range expression? */ -+ /* FIXME: Implement rational ranges here, too. */ - for (i = 0; i < cset->nranges; ++i) - if (cset->range_starts[i] <= in_collseq - && in_collseq <= cset->range_ends[i]) -@@ -3988,18 +3984,9 @@ check_node_accept_bytes (const re_dfa_t - # endif /* _LIBC */ - { - /* match with range expression? */ --#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) -- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; --#else -- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; -- cmp_buf[2] = wc; --#endif - for (i = 0; i < cset->nranges; ++i) - { -- cmp_buf[0] = cset->range_starts[i]; -- cmp_buf[4] = cset->range_ends[i]; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) - { - match_len = char_len; - goto check_node_accept_bytes_match; -@@ -4137,7 +4124,7 @@ check_node_accept (const re_match_contex - - static reg_errcode_t - internal_function __attribute_warn_unused_result__ --extend_buffers (re_match_context_t *mctx) -+extend_buffers (re_match_context_t *mctx, int min_len) - { - reg_errcode_t ret; - re_string_t *pstr = &mctx->input; -@@ -4147,8 +4134,10 @@ extend_buffers (re_match_context_t *mctx - <= pstr->bufs_len, 0)) - return REG_ESPACE; - -- /* Double the lengths of the buffers. */ -- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); -+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ -+ ret = re_string_realloc_buffers (pstr, -+ MAX (min_len, -+ MIN (pstr->len, pstr->bufs_len * 2))); - if (BE (ret != REG_NOERROR, 0)) - return ret; - ---- origsrc/sed-4.2.2/sed/sed.c 2012-03-16 10:13:31.000000000 +0100 -+++ src/sed-4.2.2/sed/sed.c 2013-06-27 18:06:25.592195456 +0200 -@@ -57,7 +57,11 @@ bool follow_symlinks = false; - char *in_place_extension = NULL; - - /* The mode to use to read/write files, either "r"/"w" or "rb"/"wb". */ -+#ifdef HAVE_FOPEN_RT -+char *read_mode = "rt"; -+#else - char *read_mode = "r"; -+#endif - char *write_mode = "w"; - - /* Do we need to be pedantically POSIX compliant? */ diff --git a/dev/build/windows/patches_coq/sed-4.2.2.patch b/dev/build/windows/patches_coq/sed-4.2.2.patch deleted file mode 100644 index c7ccd53c7f..0000000000 --- a/dev/build/windows/patches_coq/sed-4.2.2.patch +++ /dev/null @@ -1,1301 +0,0 @@ ---- origsrc/doc/sed.1 2012-12-22 15:27:13.000000000 +0100 -+++ src/doc/sed.1 2013-06-27 18:10:47.974060492 +0200 -@@ -1,5 +1,5 @@ - .\" DO NOT MODIFY THIS FILE! It was generated by help2man 1.28. --.TH SED "1" "December 2012" "sed 4.2.2" "User Commands" -+.TH SED "1" "June 2013" "sed 4.2.2" "User Commands" - .SH NAME - sed \- stream editor for filtering and transforming text - .SH SYNOPSIS -@@ -40,6 +40,10 @@ follow symlinks when processing in place - .IP - edit files in place (makes backup if SUFFIX supplied) - .HP -+\fB\-b\fR, \fB\-\-binary\fR -+.IP -+open files in binary mode (CR+LFs are not processed specially) -+.HP - \fB\-l\fR N, \fB\-\-line\-length\fR=\fIN\fR - .IP - specify the desired line-wrap length for the `l' command ---- origsrc/lib/regcomp.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regcomp.c 2013-06-27 18:05:27.044448044 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, - size_t length, reg_syntax_t syntax); -@@ -95,20 +94,20 @@ static reg_errcode_t build_charclass (RE - bitset_t sbcset, - re_charset_t *mbcset, - Idx *char_class_alloc, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #else /* not RE_ENABLE_I18N */ - static reg_errcode_t build_equiv_class (bitset_t sbcset, - const unsigned char *name); - static reg_errcode_t build_charclass (RE_TRANSLATE_TYPE trans, - bitset_t sbcset, -- const unsigned char *class_name, -+ const char *class_name, - reg_syntax_t syntax); - #endif /* not RE_ENABLE_I18N */ - static bin_tree_t *build_charclass_op (re_dfa_t *dfa, - RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, -+ const char *class_name, -+ const char *extra, - bool non_match, reg_errcode_t *err); - static bin_tree_t *create_tree (re_dfa_t *dfa, - bin_tree_t *left, bin_tree_t *right, -@@ -293,7 +292,7 @@ weak_alias (__re_compile_fastmap, re_com - #endif - - static inline void --__attribute ((always_inline)) -+__attribute__ ((always_inline)) - re_set_fastmap (char *fastmap, bool icase, int ch) - { - fastmap[ch] = 1; -@@ -587,7 +586,7 @@ weak_alias (__regerror, regerror) - static const bitset_t utf8_sb_map = - { - /* Set the first 128 bits. */ --# ifdef __GNUC__ -+# if defined __GNUC__ && !defined __STRICT_ANSI__ - [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX - # else - # if 4 * BITSET_WORD_BITS < ASCII_CHARS -@@ -664,7 +663,10 @@ regfree (preg) - { - re_dfa_t *dfa = preg->buffer; - if (BE (dfa != NULL, 1)) -- free_dfa_content (dfa); -+ { -+ lock_fini (dfa->lock); -+ free_dfa_content (dfa); -+ } - preg->buffer = NULL; - preg->allocated = 0; - -@@ -785,6 +787,8 @@ re_compile_internal (regex_t *preg, cons - preg->used = sizeof (re_dfa_t); - - err = init_dfa (dfa, length); -+ if (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0)) -+ err = REG_ESPACE; - if (BE (err != REG_NOERROR, 0)) - { - free_dfa_content (dfa); -@@ -798,8 +802,6 @@ re_compile_internal (regex_t *preg, cons - strncpy (dfa->re_str, pattern, length + 1); - #endif - -- __libc_lock_init (dfa->lock); -- - err = re_string_construct (®exp, pattern, length, preg->translate, - (syntax & RE_ICASE) != 0, dfa); - if (BE (err != REG_NOERROR, 0)) -@@ -807,6 +809,7 @@ re_compile_internal (regex_t *preg, cons - re_compile_internal_free_return: - free_workarea_compile (preg); - re_string_destruct (®exp); -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -839,6 +842,7 @@ re_compile_internal (regex_t *preg, cons - - if (BE (err != REG_NOERROR, 0)) - { -+ lock_fini (dfa->lock); - free_dfa_content (dfa); - preg->buffer = NULL; - preg->allocated = 0; -@@ -954,10 +958,10 @@ static void - internal_function - init_word_char (re_dfa_t *dfa) - { -- dfa->word_ops_used = 1; - int i = 0; - int j; - int ch = 0; -+ dfa->word_ops_used = 1; - if (BE (dfa->map_notascii == 0, 1)) - { - bitset_word_t bits0 = 0x00000000; -@@ -2423,8 +2427,8 @@ parse_expression (re_string_t *regexp, r - case OP_WORD: - case OP_NOTWORD: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "alnum", -- (const unsigned char *) "_", -+ "alnum", -+ "_", - token->type == OP_NOTWORD, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2432,8 +2436,8 @@ parse_expression (re_string_t *regexp, r - case OP_SPACE: - case OP_NOTSPACE: - tree = build_charclass_op (dfa, regexp->trans, -- (const unsigned char *) "space", -- (const unsigned char *) "", -+ "space", -+ "", - token->type == OP_NOTSPACE, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; -@@ -2713,7 +2717,6 @@ build_range_exp (const reg_syntax_t synt - wchar_t wc; - wint_t start_wc; - wint_t end_wc; -- wchar_t cmp_buf[6] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; - - start_ch = ((start_elem->type == SB_CHAR) ? start_elem->opr.ch - : ((start_elem->type == COLL_SYM) ? start_elem->opr.name[0] -@@ -2727,11 +2730,7 @@ build_range_exp (const reg_syntax_t synt - ? __btowc (end_ch) : end_elem->opr.wch); - if (start_wc == WEOF || end_wc == WEOF) - return REG_ECOLLATE; -- cmp_buf[0] = start_wc; -- cmp_buf[4] = end_wc; -- -- if (BE ((syntax & RE_NO_EMPTY_RANGES) -- && wcscoll (cmp_buf, cmp_buf + 4) > 0, 0)) -+ else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) - return REG_ERANGE; - - /* Got valid collation sequence values, add them as a new entry. -@@ -2772,9 +2771,7 @@ build_range_exp (const reg_syntax_t synt - /* Build the table for single byte characters. */ - for (wc = 0; wc < SBC_MAX; ++wc) - { -- cmp_buf[2] = wc; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (start_wc <= wc && wc <= end_wc) - bitset_set (sbcset, wc); - } - } -@@ -2843,40 +2840,29 @@ parse_bracket_exp (re_string_t *regexp, - - /* Local function for parse_bracket_exp used in _LIBC environment. - Seek the collating symbol entry corresponding to NAME. -- Return the index of the symbol in the SYMB_TABLE. */ -+ Return the index of the symbol in the SYMB_TABLE, -+ or -1 if not found. */ - - auto inline int32_t -- __attribute ((always_inline)) -- seek_collating_symbol_entry (name, name_len) -- const unsigned char *name; -- size_t name_len; -- { -- int32_t hash = elem_hash ((const char *) name, name_len); -- int32_t elem = hash % table_size; -- if (symb_table[2 * elem] != 0) -- { -- int32_t second = hash % (table_size - 2) + 1; -- -- do -- { -- /* First compare the hashing value. */ -- if (symb_table[2 * elem] == hash -- /* Compare the length of the name. */ -- && name_len == extra[symb_table[2 * elem + 1]] -- /* Compare the name. */ -- && memcmp (name, &extra[symb_table[2 * elem + 1] + 1], -- name_len) == 0) -- { -- /* Yep, this is the entry. */ -- break; -- } -+ __attribute__ ((always_inline)) -+ seek_collating_symbol_entry (const unsigned char *name, size_t name_len) -+ { -+ int32_t elem; - -- /* Next entry. */ -- elem += second; -- } -- while (symb_table[2 * elem] != 0); -- } -- return elem; -+ for (elem = 0; elem < table_size; elem++) -+ if (symb_table[2 * elem] != 0) -+ { -+ int32_t idx = symb_table[2 * elem + 1]; -+ /* Skip the name of collating element name. */ -+ idx += 1 + extra[idx]; -+ if (/* Compare the length of the name. */ -+ name_len == extra[idx] -+ /* Compare the name. */ -+ && memcmp (name, &extra[idx + 1], name_len) == 0) -+ /* Yep, this is the entry. */ -+ return elem; -+ } -+ return -1; - } - - /* Local function for parse_bracket_exp used in _LIBC environment. -@@ -2884,9 +2870,8 @@ parse_bracket_exp (re_string_t *regexp, - Return the value if succeeded, UINT_MAX otherwise. */ - - auto inline unsigned int -- __attribute ((always_inline)) -- lookup_collation_sequence_value (br_elem) -- bracket_elem_t *br_elem; -+ __attribute__ ((always_inline)) -+ lookup_collation_sequence_value (bracket_elem_t *br_elem) - { - if (br_elem->type == SB_CHAR) - { -@@ -2914,7 +2899,7 @@ parse_bracket_exp (re_string_t *regexp, - int32_t elem, idx; - elem = seek_collating_symbol_entry (br_elem->opr.name, - sym_name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; -@@ -2932,7 +2917,7 @@ parse_bracket_exp (re_string_t *regexp, - /* Return the collation sequence value. */ - return *(unsigned int *) (extra + idx); - } -- else if (symb_table[2 * elem] == 0 && sym_name_len == 1) -+ else if (sym_name_len == 1) - { - /* No valid character. Match it as a single byte - character. */ -@@ -2953,12 +2938,9 @@ parse_bracket_exp (re_string_t *regexp, - update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_range_exp (sbcset, mbcset, range_alloc, start_elem, end_elem) -- re_charset_t *mbcset; -- Idx *range_alloc; -- bitset_t sbcset; -- bracket_elem_t *start_elem, *end_elem; -+ __attribute__ ((always_inline)) -+ build_range_exp (bitset_t sbcset, re_charset_t *mbcset, int *range_alloc, -+ bracket_elem_t *start_elem, bracket_elem_t *end_elem) - { - unsigned int ch; - uint32_t start_collseq; -@@ -2971,6 +2953,7 @@ parse_bracket_exp (re_string_t *regexp, - 0)) - return REG_ERANGE; - -+ /* FIXME: Implement rational ranges here, too. */ - start_collseq = lookup_collation_sequence_value (start_elem); - end_collseq = lookup_collation_sequence_value (end_elem); - /* Check start/end collation sequence values. */ -@@ -3036,26 +3019,23 @@ parse_bracket_exp (re_string_t *regexp, - pointer argument since we may update it. */ - - auto inline reg_errcode_t -- __attribute ((always_inline)) -- build_collating_symbol (sbcset, mbcset, coll_sym_alloc, name) -- re_charset_t *mbcset; -- Idx *coll_sym_alloc; -- bitset_t sbcset; -- const unsigned char *name; -+ __attribute__ ((always_inline)) -+ build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset, -+ Idx *coll_sym_alloc, const unsigned char *name) - { - int32_t elem, idx; - size_t name_len = strlen ((const char *) name); - if (nrules != 0) - { - elem = seek_collating_symbol_entry (name, name_len); -- if (symb_table[2 * elem] != 0) -+ if (elem != -1) - { - /* We found the entry. */ - idx = symb_table[2 * elem + 1]; - /* Skip the name of collating element name. */ - idx += 1 + extra[idx]; - } -- else if (symb_table[2 * elem] == 0 && name_len == 1) -+ else if (name_len == 1) - { - /* No valid character, treat it as a normal - character. */ -@@ -3298,7 +3278,8 @@ parse_bracket_exp (re_string_t *regexp, - #ifdef RE_ENABLE_I18N - mbcset, &char_class_alloc, - #endif /* RE_ENABLE_I18N */ -- start_elem.opr.name, syntax); -+ (const char *) start_elem.opr.name, -+ syntax); - if (BE (*err != REG_NOERROR, 0)) - goto parse_bracket_exp_free_return; - break; -@@ -3578,14 +3559,14 @@ static reg_errcode_t - #ifdef RE_ENABLE_I18N - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, - re_charset_t *mbcset, Idx *char_class_alloc, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #else /* not RE_ENABLE_I18N */ - build_charclass (RE_TRANSLATE_TYPE trans, bitset_t sbcset, -- const unsigned char *class_name, reg_syntax_t syntax) -+ const char *class_name, reg_syntax_t syntax) - #endif /* not RE_ENABLE_I18N */ - { - int i; -- const char *name = (const char *) class_name; -+ const char *name = class_name; - - /* In case of REG_ICASE "upper" and "lower" match the both of - upper and lower cases. */ -@@ -3659,8 +3640,8 @@ build_charclass (RE_TRANSLATE_TYPE trans - - static bin_tree_t * - build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, -- const unsigned char *class_name, -- const unsigned char *extra, bool non_match, -+ const char *class_name, -+ const char *extra, bool non_match, - reg_errcode_t *err) - { - re_bitset_ptr_t sbcset; ---- origsrc/lib/regex-quote.c 1970-01-01 01:00:00.000000000 +0100 -+++ src/lib/regex-quote.c 2013-06-27 18:05:27.081447884 +0200 -@@ -0,0 +1,216 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <config.h> -+ -+/* Specification. */ -+#include "regex-quote.h" -+ -+#include <string.h> -+ -+#include "mbuiter.h" -+#include "xalloc.h" -+ -+/* Characters that are special in a BRE. */ -+static const char bre_special[] = "$^.*[]\\"; -+ -+/* Characters that are special in an ERE. */ -+static const char ere_special[] = "$^.*[]\\+?{}()|"; -+ -+struct regex_quote_spec -+regex_quote_spec_posix (int cflags, bool anchored) -+{ -+ struct regex_quote_spec result; -+ -+ strcpy (result.special, cflags != 0 ? ere_special : bre_special); -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Syntax bit values, defined in GNU <regex.h>. We don't include it here, -+ otherwise this module would need to depend on gnulib module 'regex'. */ -+#define RE_BK_PLUS_QM 0x00000002 -+#define RE_INTERVALS 0x00000200 -+#define RE_LIMITED_OPS 0x00000400 -+#define RE_NEWLINE_ALT 0x00000800 -+#define RE_NO_BK_BRACES 0x00001000 -+#define RE_NO_BK_PARENS 0x00002000 -+#define RE_NO_BK_VBAR 0x00008000 -+ -+struct regex_quote_spec -+regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (bre_special) - 1); -+ p += sizeof (bre_special) - 1; -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_BK_PLUS_QM) == 0) -+ { -+ *p++ = '+'; -+ *p++ = '?'; -+ } -+ if ((syntax & RE_INTERVALS) != 0 && (syntax & RE_NO_BK_BRACES) != 0) -+ { -+ *p++ = '{'; -+ *p++ = '}'; -+ } -+ if ((syntax & RE_NO_BK_PARENS) != 0) -+ { -+ *p++ = '('; -+ *p++ = ')'; -+ } -+ if ((syntax & RE_LIMITED_OPS) == 0 && (syntax & RE_NO_BK_VBAR) != 0) -+ *p++ = '|'; -+ if ((syntax & RE_NEWLINE_ALT) != 0) -+ *p++ = '\n'; -+ *p = '\0'; -+ -+ result.multibyte = true; -+ result.anchored = anchored; -+ -+ return result; -+} -+ -+/* Characters that are special in a PCRE. */ -+static const char pcre_special[] = "$^.*[]\\+?{}()|"; -+ -+/* Options bit values, defined in <pcre.h>. We don't include it here, because -+ it is not a standard header. */ -+#define PCRE_ANCHORED 0x00000010 -+#define PCRE_EXTENDED 0x00000008 -+ -+struct regex_quote_spec -+regex_quote_spec_pcre (int options, bool anchored) -+{ -+ struct regex_quote_spec result; -+ char *p; -+ -+ p = result.special; -+ memcpy (p, bre_special, sizeof (pcre_special) - 1); -+ p += sizeof (pcre_special) - 1; -+ if (options & PCRE_EXTENDED) -+ { -+ *p++ = ' '; -+ *p++ = '\t'; -+ *p++ = '\n'; -+ *p++ = '\v'; -+ *p++ = '\f'; -+ *p++ = '\r'; -+ *p++ = '#'; -+ } -+ *p = '\0'; -+ -+ /* PCRE regular expressions consist of UTF-8 characters of options contains -+ PCRE_UTF8 and of single bytes otherwise. */ -+ result.multibyte = false; -+ /* If options contains PCRE_ANCHORED, the anchoring is implicit. */ -+ result.anchored = (options & PCRE_ANCHORED ? 0 : anchored); -+ -+ return result; -+} -+ -+size_t -+regex_quote_length (const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ size_t length; -+ -+ length = 0; -+ if (spec->anchored) -+ length += 2; /* for '^' at the beginning and '$' at the end */ -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ length += 1; -+ length += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ length += 1; -+ length += 1; -+ } -+ } -+ -+ return length; -+} -+ -+char * -+regex_quote_copy (char *p, const char *string, const struct regex_quote_spec *spec) -+{ -+ const char *special = spec->special; -+ -+ if (spec->anchored) -+ *p++ = '^'; -+ if (spec->multibyte) -+ { -+ mbui_iterator_t iter; -+ -+ for (mbui_init (iter, string); mbui_avail (iter); mbui_advance (iter)) -+ { -+ /* We know that special contains only ASCII characters. */ -+ if (mb_len (mbui_cur (iter)) == 1 -+ && strchr (special, * mbui_cur_ptr (iter))) -+ *p++ = '\\'; -+ memcpy (p, mbui_cur_ptr (iter), mb_len (mbui_cur (iter))); -+ p += mb_len (mbui_cur (iter)); -+ } -+ } -+ else -+ { -+ const char *iter; -+ -+ for (iter = string; *iter != '\0'; iter++) -+ { -+ if (strchr (special, *iter)) -+ *p++ = '\\'; -+ *p++ = *iter++; -+ } -+ } -+ if (spec->anchored) -+ *p++ = '$'; -+ -+ return p; -+} -+ -+char * -+regex_quote (const char *string, const struct regex_quote_spec *spec) -+{ -+ size_t length = regex_quote_length (string, spec); -+ char *result = XNMALLOC (length + 1, char); -+ char *p; -+ -+ p = result; -+ p = regex_quote_copy (p, string, spec); -+ *p = '\0'; -+ return result; -+} ---- origsrc/lib/regex-quote.h 1970-01-01 01:00:00.000000000 +0100 -+++ src/lib/regex-quote.h 2013-06-27 18:05:27.112447751 +0200 -@@ -0,0 +1,88 @@ -+/* Construct a regular expression from a literal string. -+ Copyright (C) 1995, 2010-2013 Free Software Foundation, Inc. -+ Written by Bruno Haible <haible@clisp.cons.org>, 2010. -+ -+ This program is free software: you can redistribute it and/or modify -+ it under the terms of the GNU General Public License as published by -+ the Free Software Foundation; either version 3 of the License, or -+ (at your option) any later version. -+ -+ This program is distributed in the hope that it will be useful, -+ but WITHOUT ANY WARRANTY; without even the implied warranty of -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -+ GNU General Public License for more details. -+ -+ You should have received a copy of the GNU General Public License -+ along with this program. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _REGEX_QUOTE_H -+#define _REGEX_QUOTE_H -+ -+#include <stddef.h> -+#include <stdbool.h> -+ -+ -+/* Specifies a quotation task for converting a fixed string to a regular -+ expression pattern. */ -+struct regex_quote_spec -+{ -+ /* True if the regular expression pattern consists of multibyte characters -+ (in the encoding given by the LC_CTYPE category of the locale), -+ false if it consists of single bytes or UTF-8 characters. */ -+ unsigned int /*bool*/ multibyte : 1; -+ /* True if the regular expression pattern shall match only entire lines. */ -+ unsigned int /*bool*/ anchored : 1; -+ /* Set of characters that need to be escaped (all ASCII), as a -+ NUL-terminated string. */ -+ char special[30 + 1]; -+}; -+ -+ -+/* Creates a quotation task that produces a POSIX regular expression, that is, -+ a pattern that can be compiled with regcomp(). -+ CFLAGS can be 0 or REG_EXTENDED. -+ If it is 0, the result is a Basic Regular Expression (BRE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_03>. -+ If it is REG_EXTENDED, the result is an Extended Regular Expression (ERE) -+ <http://www.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap09.html#tag_09_04>. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_posix (int cflags, bool anchored); -+ -+/* Creates a quotation task that produces a regular expression that can be -+ compiled with the GNU API function re_compile_pattern(). -+ SYNTAX describes the syntax of the regular expression (such as -+ RE_SYNTAX_POSIX_BASIC, RE_SYNTAX_POSIX_EXTENDED, RE_SYNTAX_EMACS, all -+ defined in <regex.h>). It must be the same value as 're_syntax_options' -+ at the moment of the re_compile_pattern() call. -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_gnu (unsigned long /*reg_syntax_t*/ syntax, bool anchored); -+ -+/* Creates a quotation task that produces a PCRE regular expression, that is, -+ a pattern that can be compiled with pcre_compile(). -+ OPTIONS is the same value as the second argument passed to pcre_compile(). -+ If ANCHORED is false, the regular expression will match substrings of lines. -+ If ANCHORED is true, it will match only complete lines, */ -+extern struct regex_quote_spec -+ regex_quote_spec_pcre (int options, bool anchored); -+ -+ -+/* Returns the number of bytes needed for the quoted string. */ -+extern size_t -+ regex_quote_length (const char *string, const struct regex_quote_spec *spec); -+ -+/* Copies the quoted string to p and returns the incremented p. -+ There must be room for regex_quote_length (string, spec) + 1 bytes at p. */ -+extern char * -+ regex_quote_copy (char *p, -+ const char *string, const struct regex_quote_spec *spec); -+ -+/* Returns the freshly allocated quoted string. */ -+extern char * -+ regex_quote (const char *string, const struct regex_quote_spec *spec); -+ -+ -+#endif /* _REGEX_QUOTE_H */ ---- origsrc/lib/regex.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex.c 2013-06-27 18:05:27.138447639 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2003, 2005-2006, 2009-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _LIBC - # include <config.h> -@@ -25,6 +24,7 @@ - # pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" - # endif - # if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__ -+# pragma GCC diagnostic ignored "-Wold-style-definition" - # pragma GCC diagnostic ignored "-Wtype-limits" - # endif - #endif ---- origsrc/lib/regex.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex.h 2013-06-27 18:05:27.168447509 +0200 -@@ -1,23 +1,22 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Definitions for data structures and routines for the regular - expression library. -- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012 -- Free Software Foundation, Inc. -+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2013 Free Software -+ Foundation, Inc. - This file is part of the GNU C Library. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_H - #define _REGEX_H 1 ---- origsrc/lib/regex_internal.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex_internal.c 2013-06-27 18:05:27.199447375 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static void re_string_construct_common (const char *str, Idx len, - re_string_t *pstr, -@@ -835,7 +834,7 @@ re_string_reconstruct (re_string_t *pstr - } - - static unsigned char --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_string_peek_byte_case (const re_string_t *pstr, Idx idx) - { - int ch; -@@ -975,7 +974,7 @@ re_node_set_alloc (re_node_set *set, Idx - set->alloc = size; - set->nelem = 0; - set->elems = re_malloc (Idx, size); -- if (BE (set->elems == NULL, 0)) -+ if (BE (set->elems == NULL, 0) && (MALLOC_0_IS_NONNULL || size != 0)) - return REG_ESPACE; - return REG_NOERROR; - } -@@ -1355,7 +1354,7 @@ re_node_set_insert_last (re_node_set *se - Return true if SET1 and SET2 are equivalent. */ - - static bool --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_compare (const re_node_set *set1, const re_node_set *set2) - { - Idx i; -@@ -1370,7 +1369,7 @@ re_node_set_compare (const re_node_set * - /* Return (idx + 1) if SET contains the element ELEM, return 0 otherwise. */ - - static Idx --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure)) - re_node_set_contains (const re_node_set *set, Idx elem) - { - __re_size_t idx, right, mid; -@@ -1444,11 +1443,9 @@ re_dfa_add_node (re_dfa_t *dfa, re_token - dfa->nodes[dfa->nodes_len] = token; - dfa->nodes[dfa->nodes_len].constraint = 0; - #ifdef RE_ENABLE_I18N -- { -- int type = token.type; - dfa->nodes[dfa->nodes_len].accept_mb = -- (type == OP_PERIOD && dfa->mb_cur_max > 1) || type == COMPLEX_BRACKET; -- } -+ ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) -+ || token.type == COMPLEX_BRACKET); - #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; - re_node_set_init_empty (dfa->edests + dfa->nodes_len); ---- origsrc/lib/regex_internal.h 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regex_internal.h 2013-06-27 18:05:27.230447242 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - #ifndef _REGEX_INTERNAL_H - #define _REGEX_INTERNAL_H 1 -@@ -28,21 +27,54 @@ - #include <string.h> - - #include <langinfo.h> --#ifndef _LIBC --# include "localcharset.h" --#endif - #include <locale.h> - #include <wchar.h> - #include <wctype.h> - #include <stdbool.h> - #include <stdint.h> --#if defined _LIBC -+ -+#ifdef _LIBC - # include <bits/libc-lock.h> -+# define lock_define(name) __libc_lock_define (, name) -+# define lock_init(lock) (__libc_lock_init (lock), 0) -+# define lock_fini(lock) 0 -+# define lock_lock(lock) __libc_lock_lock (lock) -+# define lock_unlock(lock) __libc_lock_unlock (lock) -+#elif defined GNULIB_LOCK -+# include "glthread/lock.h" -+ /* Use gl_lock_define if empty macro arguments are known to work. -+ Otherwise, fall back on less-portable substitutes. */ -+# if ((defined __GNUC__ && !defined __STRICT_ANSI__) \ -+ || (defined __STDC_VERSION__ && 199901L <= __STDC_VERSION__)) -+# define lock_define(name) gl_lock_define (, name) -+# elif USE_POSIX_THREADS -+# define lock_define(name) pthread_mutex_t name; -+# elif USE_PTH_THREADS -+# define lock_define(name) pth_mutex_t name; -+# elif USE_SOLARIS_THREADS -+# define lock_define(name) mutex_t name; -+# elif USE_WINDOWS_THREADS -+# define lock_define(name) gl_lock_t name; -+# else -+# define lock_define(name) -+# endif -+# define lock_init(lock) glthread_lock_init (&(lock)) -+# define lock_fini(lock) glthread_lock_destroy (&(lock)) -+# define lock_lock(lock) glthread_lock_lock (&(lock)) -+# define lock_unlock(lock) glthread_lock_unlock (&(lock)) -+#elif defined GNULIB_PTHREAD -+# include <pthread.h> -+# define lock_define(name) pthread_mutex_t name; -+# define lock_init(lock) pthread_mutex_init (&(lock), 0) -+# define lock_fini(lock) pthread_mutex_destroy (&(lock)) -+# define lock_lock(lock) pthread_mutex_lock (&(lock)) -+# define lock_unlock(lock) pthread_mutex_unlock (&(lock)) - #else --# define __libc_lock_define(CLASS,NAME) --# define __libc_lock_init(NAME) do { } while (0) --# define __libc_lock_lock(NAME) do { } while (0) --# define __libc_lock_unlock(NAME) do { } while (0) -+# define lock_define(name) -+# define lock_init(lock) 0 -+# define lock_fini(lock) 0 -+# define lock_lock(lock) ((void) 0) -+# define lock_unlock(lock) ((void) 0) - #endif - - /* In case that the system doesn't have isblank(). */ -@@ -65,7 +97,7 @@ - # ifdef _LIBC - # undef gettext - # define gettext(msgid) \ -- INTUSE(__dcgettext) (_libc_intl_domainname, msgid, LC_MESSAGES) -+ __dcgettext (_libc_intl_domainname, msgid, LC_MESSAGES) - # endif - #else - # define gettext(msgid) (msgid) -@@ -101,6 +133,8 @@ - - /* Rename to standard API for using out of glibc. */ - #ifndef _LIBC -+# undef __wctype -+# undef __iswctype - # define __wctype wctype - # define __iswctype iswctype - # define __btowc btowc -@@ -110,10 +144,8 @@ - # define attribute_hidden - #endif /* not _LIBC */ - --#if __GNUC__ >= 4 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 1) --# define __attribute(arg) __attribute__ (arg) --#else --# define __attribute(arg) -+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1) -+# define __attribute__(arg) - #endif - - typedef __re_idx_t Idx; -@@ -429,7 +461,7 @@ static void build_upper_buffer (re_strin - static void re_string_translate_buffer (re_string_t *pstr) internal_function; - static unsigned int re_string_context_at (const re_string_t *input, Idx idx, - int eflags) -- internal_function __attribute ((pure)); -+ internal_function __attribute__ ((pure)); - #endif - #define re_string_peek_byte(pstr, offset) \ - ((pstr)->mbs[(pstr)->cur_idx + offset]) -@@ -448,7 +480,9 @@ static unsigned int re_string_context_at - #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) - #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) - --#include <alloca.h> -+#if defined _LIBC || HAVE_ALLOCA -+# include <alloca.h> -+#endif - - #ifndef _LIBC - # if HAVE_ALLOCA -@@ -465,6 +499,12 @@ static unsigned int re_string_context_at - # endif - #endif - -+#ifdef _LIBC -+# define MALLOC_0_IS_NONNULL 1 -+#elif !defined MALLOC_0_IS_NONNULL -+# define MALLOC_0_IS_NONNULL 0 -+#endif -+ - #ifndef MAX - # define MAX(a,b) ((a) < (b) ? (b) : (a)) - #endif -@@ -695,7 +735,7 @@ struct re_dfa_t - #ifdef DEBUG - char* re_str; - #endif -- __libc_lock_define (, lock) -+ lock_define (lock) - }; - - #define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set)) -@@ -767,7 +807,7 @@ bitset_copy (bitset_t dest, const bitset - memcpy (dest, src, sizeof (bitset_t)); - } - --static void -+static void __attribute__ ((unused)) - bitset_not (bitset_t set) - { - int bitset_i; -@@ -779,7 +819,7 @@ bitset_not (bitset_t set) - & ~set[BITSET_WORDS - 1]); - } - --static void -+static void __attribute__ ((unused)) - bitset_merge (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -787,7 +827,7 @@ bitset_merge (bitset_t dest, const bitse - dest[bitset_i] |= src[bitset_i]; - } - --static void -+static void __attribute__ ((unused)) - bitset_mask (bitset_t dest, const bitset_t src) - { - int bitset_i; -@@ -798,7 +838,7 @@ bitset_mask (bitset_t dest, const bitset - #ifdef RE_ENABLE_I18N - /* Functions for re_string. */ - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_char_size_at (const re_string_t *pstr, Idx idx) - { - int byte_idx; -@@ -811,7 +851,7 @@ re_string_char_size_at (const re_string_ - } - - static wint_t --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_wchar_at (const re_string_t *pstr, Idx idx) - { - if (pstr->mb_cur_max == 1) -@@ -821,7 +861,7 @@ re_string_wchar_at (const re_string_t *p - - # ifndef NOT_IN_libc - static int --internal_function __attribute ((pure)) -+internal_function __attribute__ ((pure, unused)) - re_string_elem_size_at (const re_string_t *pstr, Idx idx) - { - # ifdef _LIBC ---- origsrc/lib/regexec.c 2012-12-22 14:21:52.000000000 +0100 -+++ src/lib/regexec.c 2013-06-27 18:05:27.268447078 +0200 -@@ -1,22 +1,21 @@ --/* -*- buffer-read-only: t -*- vi: set ro: */ --/* DO NOT EDIT! GENERATED AUTOMATICALLY! */ - /* Extended regular expression matching and search library. -- Copyright (C) 2002-2012 Free Software Foundation, Inc. -+ Copyright (C) 2002-2013 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Isamu Hasegawa <isamu@yamato.ibm.com>. - -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 3, or (at your option) -- any later version. -+ The GNU C Library is free software; you can redistribute it and/or -+ modify it under the terms of the GNU Lesser General Public -+ License as published by the Free Software Foundation; either -+ version 2.1 of the License, or (at your option) any later version. - -- This program is distributed in the hope that it will be useful, -+ The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -+ Lesser General Public License for more details. - -- You should have received a copy of the GNU General Public License along -- with this program; if not, see <http://www.gnu.org/licenses/>. */ -+ You should have received a copy of the GNU Lesser General Public -+ License along with the GNU C Library; if not, see -+ <http://www.gnu.org/licenses/>. */ - - static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags, - Idx n) internal_function; -@@ -200,7 +199,7 @@ static Idx group_nodes_into_DFAstates (c - static bool check_node_accept (const re_match_context_t *mctx, - const re_token_t *node, Idx idx) - internal_function; --static reg_errcode_t extend_buffers (re_match_context_t *mctx) -+static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) - internal_function; - - /* Entry point for POSIX code. */ -@@ -229,9 +228,7 @@ regexec (preg, string, nmatch, pmatch, e - { - reg_errcode_t err; - Idx start, length; --#ifdef _LIBC - re_dfa_t *dfa = preg->buffer; --#endif - - if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND)) - return REG_BADPAT; -@@ -247,14 +244,14 @@ regexec (preg, string, nmatch, pmatch, e - length = strlen (string); - } - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - if (preg->no_sub) - err = re_search_internal (preg, string, length, start, length, - length, 0, NULL, eflags); - else - err = re_search_internal (preg, string, length, start, length, - length, nmatch, pmatch, eflags); -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return err != REG_NOERROR; - } - -@@ -422,9 +419,7 @@ re_search_stub (struct re_pattern_buffer - Idx nregs; - regoff_t rval; - int eflags = 0; --#ifdef _LIBC - re_dfa_t *dfa = bufp->buffer; --#endif - Idx last_start = start + range; - - /* Check for out-of-range. */ -@@ -435,7 +430,7 @@ re_search_stub (struct re_pattern_buffer - else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0)) - last_start = 0; - -- __libc_lock_lock (dfa->lock); -+ lock_lock (dfa->lock); - - eflags |= (bufp->not_bol) ? REG_NOTBOL : 0; - eflags |= (bufp->not_eol) ? REG_NOTEOL : 0; -@@ -499,7 +494,7 @@ re_search_stub (struct re_pattern_buffer - } - re_free (pmatch); - out: -- __libc_lock_unlock (dfa->lock); -+ lock_unlock (dfa->lock); - return rval; - } - -@@ -1065,7 +1060,7 @@ prune_impossible_nodes (re_match_context - since initial states may have constraints like "\<", "^", etc.. */ - - static inline re_dfastate_t * --__attribute ((always_inline)) internal_function -+__attribute__ ((always_inline)) internal_function - acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, - Idx idx) - { -@@ -1177,7 +1172,7 @@ check_matching (re_match_context_t *mctx - || (BE (next_char_idx >= mctx->input.valid_len, 0) - && mctx->input.valid_len < mctx->input.len)) - { -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_char_idx + 1); - if (BE (err != REG_NOERROR, 0)) - { - assert (err == REG_ESPACE); -@@ -1757,7 +1752,7 @@ clean_state_log_if_needed (re_match_cont - && mctx->input.valid_len < mctx->input.len)) - { - reg_errcode_t err; -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, next_state_log_idx + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - } -@@ -2814,7 +2809,7 @@ get_subexp (re_match_context_t *mctx, Id - if (bkref_str_off >= mctx->input.len) - break; - -- err = extend_buffers (mctx); -+ err = extend_buffers (mctx, bkref_str_off + 1); - if (BE (err != REG_NOERROR, 0)) - return err; - -@@ -3937,6 +3932,7 @@ check_node_accept_bytes (const re_dfa_t - in_collseq = find_collation_sequence_value (pin, elem_len); - } - /* match with range expression? */ -+ /* FIXME: Implement rational ranges here, too. */ - for (i = 0; i < cset->nranges; ++i) - if (cset->range_starts[i] <= in_collseq - && in_collseq <= cset->range_ends[i]) -@@ -3988,18 +3984,9 @@ check_node_accept_bytes (const re_dfa_t - # endif /* _LIBC */ - { - /* match with range expression? */ --#if __GNUC__ >= 2 && ! (__STDC_VERSION__ < 199901L && defined __STRICT_ANSI__) -- wchar_t cmp_buf[] = {L'\0', L'\0', wc, L'\0', L'\0', L'\0'}; --#else -- wchar_t cmp_buf[] = {L'\0', L'\0', L'\0', L'\0', L'\0', L'\0'}; -- cmp_buf[2] = wc; --#endif - for (i = 0; i < cset->nranges; ++i) - { -- cmp_buf[0] = cset->range_starts[i]; -- cmp_buf[4] = cset->range_ends[i]; -- if (wcscoll (cmp_buf, cmp_buf + 2) <= 0 -- && wcscoll (cmp_buf + 2, cmp_buf + 4) <= 0) -+ if (cset->range_starts[i] <= wc && wc <= cset->range_ends[i]) - { - match_len = char_len; - goto check_node_accept_bytes_match; -@@ -4137,7 +4124,7 @@ check_node_accept (const re_match_contex - - static reg_errcode_t - internal_function __attribute_warn_unused_result__ --extend_buffers (re_match_context_t *mctx) -+extend_buffers (re_match_context_t *mctx, int min_len) - { - reg_errcode_t ret; - re_string_t *pstr = &mctx->input; -@@ -4147,8 +4134,10 @@ extend_buffers (re_match_context_t *mctx - <= pstr->bufs_len, 0)) - return REG_ESPACE; - -- /* Double the lengths of the buffers. */ -- ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2)); -+ /* Double the lengths of the buffers, but allocate at least MIN_LEN. */ -+ ret = re_string_realloc_buffers (pstr, -+ MAX (min_len, -+ MIN (pstr->len, pstr->bufs_len * 2))); - if (BE (ret != REG_NOERROR, 0)) - return ret; - ---- origsrc/sed/sed.c 2012-03-16 10:13:31.000000000 +0100 -+++ src/sed/sed.c 2013-06-27 18:06:25.592195456 +0200 -@@ -57,7 +57,11 @@ bool follow_symlinks = false; - char *in_place_extension = NULL; - - /* The mode to use to read/write files, either "r"/"w" or "rb"/"wb". */ -+#ifdef HAVE_FOPEN_RT -+char *read_mode = "rt"; -+#else - char *read_mode = "r"; -+#endif - char *write_mode = "w"; - - /* Do we need to be pedantically POSIX compliant? */ diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 97d9537508..8bcbd90f0b 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -101,7 +101,7 @@ project geocoq "https://github.com/GeoCoq/GeoCoq" "master" ######################################################################## # Flocq ######################################################################## -project flocq "https://gitlab.inria.fr/flocq/flocq" "master" +project flocq "https://gitlab.inria.fr/flocq/flocq" "flocq-3" ######################################################################## # coq-performance-tests diff --git a/dev/ci/ci-coq_performance_tests.sh b/dev/ci/ci-coq_performance_tests.sh index fde8df8e3d..2fa4d5c776 100755 --- a/dev/ci/ci-coq_performance_tests.sh +++ b/dev/ci/ci-coq_performance_tests.sh @@ -5,4 +5,9 @@ ci_dir="$(dirname "$0")" git_download coq_performance_tests -( cd "${CI_BUILD_DIR}/coq_performance_tests" && make coq perf-Sanity && make validate && make install ) +# run make -k; make again if make fails so that the failing file comes last, so that it's easier to find the error messages in the CI log +function make_full() { + if ! make -k "$@"; then make -k "$@"; exit 1; fi +} + +( cd "${CI_BUILD_DIR}/coq_performance_tests" && make_full coq perf-Sanity && make validate && make install ) diff --git a/dev/ci/docker/README.md b/dev/ci/docker/README.md index 16c4ac37d9..ed51c8afd3 100644 --- a/dev/ci/docker/README.md +++ b/dev/ci/docker/README.md @@ -4,31 +4,29 @@ This directory provides Docker images to be used by Coq's CI. The images do support Docker autobuild on `hub.docker.com` and Gitlab's private registry. -The Gitlab CI will build a docker image unless the CI environment variable +The Gitlab CI will build a Docker image unless the CI environment variable `SKIP_DOCKER` is set to `true`. This image will be stored in the [Gitlab container registry](https://gitlab.com/coq/coq/container_registry) under the name given by the `CACHEKEY` variable from the [Gitlab CI configuration file](../../../.gitlab-ci.yml). -In Coq's default CI, `SKIP_DOCKER` is set so as to avoid running a lengthy redundant job. +`SKIP_DOCKER` is set to "true" in `https://gitlab.com/coq/coq` to avoid running +a lengthy redundant job. For efficiency, users should enable that setting +in forked repositories after the initial Docker build in the fork succeeds. -It can be used to regenerate a fresh Docker image on Gitlab through the following steps. -- Change the `CACHEKEY` variable to a fresh name in the CI configuration in a new commit. -- Push this commit to a Github PR. This will trigger a Gitlab CI run that will - immediately fail, as the Docker image is missing and the `SKIP_DOCKER` +The steps to generate a new Docker image are: +- Update the `CACHEKEY` variable in .gitlab-ci.yml with the date and md5. +- Submit the change in a PR. This triggers a Gitlab CI run that + immediately fails, as the Docker image is missing and the `SKIP_DOCKER` default value prevents rebuilding the image. -- Run a new pipeline on Gitlab with that PR branch, using the green "Run pipeline" - button on the [web interface](https://gitlab.com/coq/coq/pipelines), - with the `SKIP_DOCKER` environment variable set to `false`. This will run a `docker-boot` process, and - once completed, a new Docker image will be available in the container registry, - with the name set in `CACHEKEY`. +- Run a new pipeline on Gitlab with that PR branch (e.g. "pr-99999"), using the green + "Run pipeline" button on the [web interface](https://gitlab.com/coq/coq/pipelines), + with the `SKIP_DOCKER` environment variable set to `false`. This will run a + `docker-boot` process, and once completed, a new Docker image will be available in + the container registry, with the name set in `CACHEKEY`. - Any pipeline with the same `CACHEKEY` will now automatically reuse that image without rebuilding it from scratch. -For documentation purposes, we also require keeping in sync the `CACHEKEY` comment -from the first line of the [Dockerfile](bionic_coq/Dockerfile) in the same -commit. - In case you do not have the rights to run Gitlab CI pipelines, you should ask the ci-maintainers Github team to do it for you. diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 1aefebb007..8f14625c63 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -44,7 +44,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages ENV BASE_OPAM="zarith.1.10 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.1" \ CI_OPAM="ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.12.0" + BASE_ONLY_OPAM="elpi.1.13.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" @@ -71,3 +71,6 @@ RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM $CI_OPAM RUN opam clean -a -c + +# set the locale for the benefit of Python +ENV LANG C.UTF-8 diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat deleted file mode 100755 index dc6423332f..0000000000 --- a/dev/ci/gitlab.bat +++ /dev/null @@ -1,141 +0,0 @@ -@ECHO OFF
-
-REM This script builds and signs the Windows packages on Gitlab
-
-ECHO "Start Time"
-TIME /T
-
-REM List currently used cygwin and target folders for debugging / maintenance purposes
-
-ECHO "Currently used cygwin folders"
-DIR C:\ci\cygwin*
-ECHO "Currently used target folders"
-DIR C:\ci\coq*
-ECHO "Root folders"
-DIR C:\
-
-if %ARCH% == 32 (
- SET ARCHLONG=i686
- SET SETUP=setup-x86.exe
-)
-
-if %ARCH% == 64 (
- SET ARCHLONG=x86_64
- SET SETUP=setup-x86_64.exe
-)
-
-SET CYGROOT=C:\ci\cygwin%ARCH%
-SET DESTCOQ=C:\ci\coq%ARCH%
-SET CYGCACHE=C:\ci\cache\cgwin
-
-CALL :MakeUniqueFolder %CYGROOT% CYGROOT
-CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ
-
-powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')"
-SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
-SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
-SET COQREGTESTING=Y
-SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin
-
-IF "%WINDOWS%" == "enabled_all_addons" (
- SET EXTRA_ADDONS=^
- -addon=bignums ^
- -addon=equations ^
- -addon=mtac2 ^
- -addon=mathcomp ^
- -addon=menhir ^
- -addon=menhirlib ^
- -addon=compcert ^
- -addon=extlib ^
- -addon=quickchick ^
- -addon=coquelicot ^
- -addon=vst ^
- -addon=aactactics ^
- -addon=flocq ^
- -addon=interval ^
- -addon=gappa_tool ^
- -addon=gappa ^
- -addon=elpi ^
- -addon=HB
-) ELSE (
- SET "EXTRA_ADDONS= "
-)
-
-call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
- -arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^
- -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
- %EXTRA_ADDONS% ^
- -make=N ^
- -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit
-
-ECHO "Start Artifact Creation"
-TIME /T
-
-mkdir artifacts
-
-CALL :CopyLogFiles
-
-copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" artifacts || GOTO ErrorExit
-REM The open source archive is only required for release builds
-IF DEFINED WIN_CERTIFICATE_PATH (
- 7z a artifacts\coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit
-) ELSE (
- REM In non release builds, create a dummy file
- ECHO "This is not a release build - open source archive not created / uploaded" > artifacts\coq-opensource-info.txt
-)
-
-REM DO NOT echo the signing command below, as this would leak secrets in the logs
-IF DEFINED WIN_CERTIFICATE_PATH (
- IF DEFINED WIN_CERTIFICATE_PASSWORD (
- ECHO Signing package
- @signtool sign /f %WIN_CERTIFICATE_PATH% /p %WIN_CERTIFICATE_PASSWORD% dev\nsis\*.exe
- signtool verify /pa dev\nsis\*.exe
- )
-)
-
-ECHO "Finished Artifact Creation"
-TIME /T
-
-CALL :CleanupFolders
-
-ECHO "Finished Cleanup"
-TIME /T
-
-GOTO :EOF
-
-:CopyLogFiles
- ECHO Copy log files for artifact upload
- MKDIR artifacts\buildlogs
- COPY %CYGROOT%\build\buildlogs\* artifacts\buildlogs
- MKDIR artifacts\filelists
- COPY %CYGROOT%\build\filelists\* artifacts\filelists
- MKDIR artifacts\flagfiles
- COPY %CYGROOT%\build\flagfiles\* artifacts\flagfiles
- GOTO :EOF
-
-:CleanupFolders
- ECHO "Cleaning %CYGROOT%"
- RMDIR /S /Q "%CYGROOT%"
- ECHO "Cleaning %DESTCOQ%"
- RMDIR /S /Q "%DESTCOQ%"
- GOTO :EOF
-
-:MakeUniqueFolder
- REM Create a uniquely named folder
- REM This script is safe because folder creation is atomic - either we create it or fail
- REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this)
- REM %2 = name of the variable which receives the unique folder name
- SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%"
- MKDIR "%UNIQUENAME%"
- IF ERRORLEVEL 1 GOTO :MakeUniqueFolder
- SET "%2=%UNIQUENAME%"
- GOTO :EOF
-
-:ErrorCopyLogFilesAndExit
- CALL :CopyLogFiles
- REM fall through
-
-:ErrorExit
- CALL :CleanupFolders
- ECHO ERROR %0 failed
- EXIT /b 1
diff --git a/dev/ci/platform-windows.bat b/dev/ci/platform-windows.bat new file mode 100755 index 0000000000..513aec5f94 --- /dev/null +++ b/dev/ci/platform-windows.bat @@ -0,0 +1,105 @@ +REM @ECHO OFF
+
+REM SET ARCH=64
+REM SET PLATFORM=https://github.com/coq/platform/archive/v8.13.zip
+REM SET CI_PROJECT_DIR=C:\root
+
+REM This script builds a minimal Windows platform on Gitlab
+
+ECHO "Start Time"
+TIME /T
+
+REM List currently used cygwin and target folders for debugging / maintenance purposes
+
+ECHO "Currently used cygwin folders"
+DIR C:\ci\cygwin*
+ECHO "Currently used target folders"
+DIR C:\ci\coq*
+ECHO "Root folders"
+DIR C:\
+ECHO "Powershell version"
+powershell -Command "Get-Host"
+ECHO "Git installation of Mingw"
+DIR "C:\Program Files\Git\mingw64\bin\*.exe"
+
+ECHO "--------- START -------"
+
+SET CYGROOT=C:\ci\cygwin%ARCH%
+SET CYGCACHE=C:\ci\cache\cgwin
+
+CALL :MakeUniqueFolder %CYGROOT% CYGROOT
+
+SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
+SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
+SET COQREGTESTING=y
+SET PATH=%PATH%;C:\Program Files\7-Zip;C:\Program Files\Git\mingw64\bin
+
+
+ECHO "Downloading %PLATFORM%"
+curl -L -o platform.zip "%PLATFORM%"
+7z x platform.zip
+
+cd platform-*
+
+call coq_platform_make_windows.bat ^
+ -arch=%ARCH% ^
+ -destcyg=%CYGROOT% ^
+ -cygcache=%CYGCACHE% ^
+ -extent=i ^
+ -parallel=p ^
+ -jobs=2 ^
+ -switch=d || GOTO ErrorCopyLogFilesAndExit
+
+cd ..
+
+SET BASH=%CYGROOT%\bin\bash
+
+ECHO "Start Artifact Creation"
+TIME /T
+
+MKDIR %CI_PROJECT_DIR%\artifacts
+%BASH% --login -c "cd coq-platform && windows/create_installer_windows.sh && cp windows_installer/*.exe %CI_PROJECT_DIR_CFMT%/artifacts" || GOTO ErrorCopyLogFilesAndExit
+TIME /T
+
+CALL :CopyLogFiles
+
+ECHO "Finished Artifact Creation"
+TIME /T
+
+CALL :CleanupFolders
+
+ECHO "Finished Cleanup"
+TIME /T
+
+GOTO :EOF
+
+:CopyLogFiles
+ ECHO Copy log files for artifact upload
+ REM This is currently not supported by the opam based build scripts
+ GOTO :EOF
+
+:CleanupFolders
+ ECHO "Cleaning %CYGROOT%"
+ RMDIR /S /Q "%CYGROOT%"
+ GOTO :EOF
+
+:MakeUniqueFolder
+ REM Create a uniquely named folder
+ REM This script is safe because folder creation is atomic - either we create it or fail
+ REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this)
+ REM %2 = name of the variable which receives the unique folder name
+ SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%"
+ MKDIR "%UNIQUENAME%"
+ IF ERRORLEVEL 1 GOTO :MakeUniqueFolder
+ RMDIR "%UNIQUENAME%"
+ SET "%2=%UNIQUENAME%"
+ GOTO :EOF
+
+:ErrorCopyLogFilesAndExit
+ CALL :CopyLogFiles
+ REM fall through
+
+:ErrorExit
+ CALL :CleanupFolders
+ ECHO ERROR %0 failed
+ EXIT /b 1
diff --git a/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh b/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh new file mode 100644 index 0000000000..dc57e6efb9 --- /dev/null +++ b/dev/ci/user-overlays/09710-ppedrot-compact-case-repr.sh @@ -0,0 +1,9 @@ +overlay coq_dpdgraph https://github.com/ppedrot/coq-dpdgraph compact-case-repr 13563 +overlay coqhammer https://github.com/ppedrot/coqhammer compact-case-repr 13563 +overlay elpi https://github.com/ppedrot/coq-elpi compact-case-repr 13563 +overlay equations https://github.com/ppedrot/Coq-Equations compact-case-repr 13563 +overlay metacoq https://github.com/ppedrot/metacoq compact-case-repr 13563 +overlay mtac2 https://github.com/ppedrot/Mtac2 compact-case-repr 13563 +overlay paramcoq https://github.com/ppedrot/paramcoq compact-case-repr 13563 +overlay relation_algebra https://github.com/ppedrot/relation-algebra compact-case-repr 13563 +overlay unicoq https://github.com/ppedrot/unicoq compact-case-repr 13563 diff --git a/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh b/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh new file mode 100644 index 0000000000..d80363c49f --- /dev/null +++ b/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/SkySkimmer/coq-elpi debug-infra 13202 diff --git a/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh b/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh new file mode 100644 index 0000000000..27e7cee42e --- /dev/null +++ b/dev/ci/user-overlays/13299-jashug-preserve-universes-notation.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13299" ] || [ "$CI_BRANCH" = "preserve-universes-notation" ]; then + + elpi_CI_REF=overlay-universes-in-notations + elpi_CI_GITURL=https://github.com/jashug/coq-elpi + +fi diff --git a/dev/ci/user-overlays/13321-ppedrot-mv-evaluable-global-ref-out-of-kernel.sh b/dev/ci/user-overlays/13321-ppedrot-mv-evaluable-global-ref-out-of-kernel.sh new file mode 100644 index 0000000000..0f62d0ee9f --- /dev/null +++ b/dev/ci/user-overlays/13321-ppedrot-mv-evaluable-global-ref-out-of-kernel.sh @@ -0,0 +1 @@ +overlay equations https://github.com/ppedrot/Coq-Equations mv-evaluable-global-ref-out-of-kernel 13321 diff --git a/dev/ci/user-overlays/13512-herbelin-master+fix13413-apply-on-intro-pattern-fresh-names.sh b/dev/ci/user-overlays/13512-herbelin-master+fix13413-apply-on-intro-pattern-fresh-names.sh new file mode 100644 index 0000000000..4c8cdbbb45 --- /dev/null +++ b/dev/ci/user-overlays/13512-herbelin-master+fix13413-apply-on-intro-pattern-fresh-names.sh @@ -0,0 +1,5 @@ +if [ "$CI_PULL_REQUEST" = "13415" ] || [ "$CI_BRANCH" = "intern-univs" ]; then + + overlay perennial https://github.com/herbelin/perennial master+adapt13512-fresness-names-apply-in-introduction-pattern + +fi diff --git a/dev/ci/user-overlays/13725-SkySkimmer-hint-rw-local.sh b/dev/ci/user-overlays/13725-SkySkimmer-hint-rw-local.sh new file mode 100644 index 0000000000..69bd038b78 --- /dev/null +++ b/dev/ci/user-overlays/13725-SkySkimmer-hint-rw-local.sh @@ -0,0 +1 @@ +overlay equations https://github.com/SkySkimmer/Coq-Equations hint-rw-local 13725 diff --git a/dev/ci/user-overlays/13844-gares-command-loc.sh b/dev/ci/user-overlays/13844-gares-command-loc.sh new file mode 100644 index 0000000000..d9a1736532 --- /dev/null +++ b/dev/ci/user-overlays/13844-gares-command-loc.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/LPCIC/coq-elpi command-loc 13844 diff --git a/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh b/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh new file mode 100644 index 0000000000..6847bde6d8 --- /dev/null +++ b/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/LPCIC/coq-elpi coq-master+1.9.0 13847 diff --git a/dev/core.dbg b/dev/core.dbg index 6d52bae773..dcf9910b0b 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -16,5 +16,6 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/core_dune.dbg b/dev/core_dune.dbg index 3f73cf126a..da3022644d 100644 --- a/dev/core_dune.dbg +++ b/dev/core_dune.dbg @@ -17,5 +17,6 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/doc/case-repr.md b/dev/doc/case-repr.md new file mode 100644 index 0000000000..e1a78797bd --- /dev/null +++ b/dev/doc/case-repr.md @@ -0,0 +1,122 @@ +## Case representation + +Starting from Coq 8.14, the term representation of pattern-matching uses a +so-called *compact form*. Compared to the previous representation, the major +difference is that all type and term annotations on lambda and let abstractions +that were present in branches and return clause of pattern-matchings were +removed. In order to keep the ability to construct the old expanded form out of +the new compact form, the case node also makes explicit data that was stealthily +present in the expanded return clause, namely universe instances and parameters +of the inductive type being eliminated. + +### ML Representation + +The case node now looks like +``` +Case of + case_info * + Instance.t * (* universe instances of the inductive *) + constr array * (* parameters of the inductive *) + case_return * (* erased return clause *) + case_invert * (* SProp inversion data *) + constr * (* scrutinee *) + case_branch array (* erased branches *) +``` +where +``` +type case_branch = Name.t binder_annot array * constr +type case_return = Name.t binder_annot array * types +``` + +For comparison, pre-8.14 case nodes were defined as follows. +``` +Case of + case_info * + constr * (* annotated return clause *) + case_invert * (* SProp inversion data *) + constr * (* scrutinee *) + constr array (* annotated branches *) +``` + +### Typing Rules and Invariants + +Disregarding the `case_info` cache and the SProp inversion, the typing rules for +the case node can be given as follows. + +Provided +- Γ ⊢ c : Ind@{u} pms Indices +- Inductive Ind@{i} Δ : forall Θ, Type := cᵢ : forall Ξᵢ, Ind Δ Aᵢ +- Γ, Θ@{i := u}{Δ := pms} ⊢ p : Type +- Γ, Ξᵢ@{i := u}{Δ := pms} ⊢ snd brᵢ : p{Θ := Aᵢ{Δ := pms}} + +Then Γ ⊢ Case (_, u, pms, ( _, p), _, c, br) : p{Θ := Indices} + +In particular, this implies that Γ ⊢ pms : Δ@{i := u}. Parameters are stored in +the same order as in the application node. + +The u universe instance must be a valid instance for the corresponding +inductive type, in particular their length must coincide. + +The `Name.t binder_annot array` appearing both in the return clause and +in the branches must satisfy these invariants: +- For branches, it must have the same length as the corresponding Ξᵢ context +(including let-ins) +- For the return clause, it must have the same length as the context +Θ, self : Ind@{u} pms Θ (including let-ins). The last variable appears as +the term being destructed and corresponds to the variable introduced by the +"as" clause of the user-facing syntax. +- The relevance annotations must match with the corresponding sort of the +variable from the context. + +Note that the annotated variable array is reversed w.r.t. the context, +i.e. variables appear left to right as in standard practice. + +Let-bindings can appear in Δ, Θ or Ξᵢ, since they are arbitrary +contexts. As a general rule, let bindings appear as binders but not as +instances. That is, they MUST appear in the variable array, but they MUST NOT +appear in the parameter array. + +Example: +``` +Inductive foo (X := tt) : forall (Y := X), Type := Foo : forall (Z := X), foo. + +Definition case (x : foo) : unit := match x as x₀ in foo with Foo _ z => z end +``` +The case node of the `case` function is represented as +``` +Case ( + _, + Instance.empty, + [||], + ([|(Y, Relevant); (x₀, Relevant)|], unit), (* let (Y := tt) in fun (x₀ : foo) => unit *) + NoInvert, + #1, + [| + ([|(z, Relevant)|], #1) (* let z := tt in z *) + |] +) +``` + +This choice of representation for let-bindings requires access to the +environment in some cases, e.g. to compute branch reduction. There is a +fast-path for non-let-containing inductive types though, which are the vast +majority. + +### Porting plugins + +The conversion functions from and to the expanded form are: +- `[Inductive, EConstr].expand_case` which goes from the compact to the expanded +form and cannot fail (assuming the term was well-typed) +- `[Inductive, EConstr].contract_case` which goes the other way and will +raise anomalies if the expanded forms are not fully eta-expanded. + +As such, it is always painless to convert to the old representation. Converting +the other way, you must ensure that all the terms you provide the +compatibility function with are fully eta-expanded, **including let-bindings**. +This works as expected for the common case with eta-expanded branches but will +fail for plugins that generate non-eta-expanded branches. + +Some other useful variants of these functions are: +- `Inductive.expand_case_specif` +- `EConstr.annotate_case` +- `EConstr.expand_branch` diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 79c2155823..4452baf513 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -332,6 +332,18 @@ Conversion machines GH issue number: ocaml/ocaml#6385, #11170 risk: unlikely to be activated by chance, might happen for autogenerated code + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow, arbitrary code execution on floating-point operations + introduced: 8.13 + impacted released versions: 8.13.0 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.1 + found by: Melquiond + GH issue number: #13867 + risk: none, unless using floating-point operations; high otherwise; + noticeable if activated by chance, since it usually breaks + control-flow integrity + Side-effects component: side-effects diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 19562b60a2..57c325f698 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -1,176 +1,162 @@ -# Release process # - -## As soon as the previous version branched off master ## - -In principle, these steps should be undertaken by the RM of the next -release. Unfortunately, we have not yet been able to nominate RMs -early enough in the process for this person to be known at that point -in time. - -- [ ] Create a new issue to track the release process where you can copy-paste - the present checklist from `dev/doc/release-process.md`. -- [ ] Change the version name to the next major version and the magic - numbers (see [#7008](https://github.com/coq/coq/pull/7008/files)). +# Release checklist # + +## When the release managers for version `X.X` get nominated ## + +- [ ] Create a new issue to track the release process where you can + copy-paste the present checklist from `dev/doc/release-process.md`. +- [ ] Decide the release calendar with the team (date of branching, + preview and final release). +- [ ] Create a wiki page that you link to from + https://github.com/coq/coq/wiki/Release-Plan with this information + and the link to the issue. + +## About one month before the branching date ## + +- [ ] Create both the upcoming final release (`X.X.0`) and the + following major release (`Y.Y+rc1`) milestones if they do not + already exist. +- [ ] Send an announcement of the upcoming branching date on Coqdev + + the Coq development category on Discourse (coqdev@inria.fr + + coq+coq-development@discoursemail.com) and ask people to remove from + the `X.X+rc1` milestone any feature and clean up PRs that they + already know won't be ready on time. +- [ ] In a PR on `master`, call + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--release` flag; this sets up Coq to support three `-compat` flag + arguments including the upcoming one (instead of four). To ensure + that CI passes, you will have to decide what to do about all + test-suite files which mention `-compat U.U` or `Coq.Comapt.CoqUU` + (which is no longer valid, since we only keep compatibility against + the two previous versions), and you may have to ping maintainers of + projects that are still relying on the old compatibility flag so + that they fix this. +- [ ] Make sure that this change is merged in time for the branching + date. + +## On the branching date ## + +- [ ] In a PR on `master`, change the version name to the next major + version and the magic numbers (see + [#7008](https://github.com/coq/coq/pull/7008/files)). Additionally, in the same commit, update the compatibility infrastructure, which consists of invoking [`dev/tools/update-compat.py`](../tools/update-compat.py) with the `--master` flag. - Note that the `update-compat.py` script must be run twice: once - *immediately after* branching with the `--master` flag (which sets - up Coq to support four `-compat` flag arguments), *in the same - commit* as the one that updates `coq_version` in - [`configure.ml`](../../configure.ml), and once again later on before - the next branch point with the `--release` flag (see next section). -- [ ] Put the corresponding alpha tag using `git tag -s`. - The `VX.X+alpha` tag marks the first commit to be in `master` and not in the - branch of the previous version. Note that this commit is the first commit + Note that the `update-compat.py` script must be run twice: once in + preparation of the release with the `--release` flag (see previous + section) and once on the branching date with the `--master` flag to + mark the start of the next version. +- [ ] Merge the above PR and create the `vX.X` branch from the last + merge commit before this one (using this name will ensure that the + branch will be automatically protected). +- [ ] Set the next major version alpha tag using `git tag -s`. The + `VY.Y+alpha` tag marks the first commit to be in `master` and not in + the `vX.X` release branch. Note that this commit is the first commit in the first PR merged in master, not the merge commit for that PR. - After tagging double check that `git describe` picks up - the tag you just made (if not, you tagged the wrong commit). -- [ ] Create the `X.X+beta1` milestone if it did not already exist. -- [ ] Decide the release calendar with the team (freeze date, beta date, final - release date) and put this information in the milestone (using the - description and due date fields). - -## Anytime after the previous version is branched off master ## - -- [ ] Update the compatibility infrastructure to the next release, - which consists of invoking - [`dev/tools/update-compat.py`](../tools/update-compat.py) with the - `--release` flag; this sets up Coq to support three `-compat` flag - arguments. To ensure that CI passes, you will have to decide what - to do about all test-suite files which mention `-compat U.U` or - `Coq.Comapt.CoqUU` (which is no longer valid, since we only keep - compatibility against the two previous versions on releases), and - you may have to prepare overlays for projects using the - compatibility flags. - -## About one month before the beta ## - -- [ ] Create the `X.X.0` milestone and set its due date. -- [ ] Send an announcement of the upcoming freeze on Coqdev and ask people to - remove from the beta milestone what they already know won't be ready on time - (possibly postponing to the `X.X.0` milestone for minor bug fixes, - infrastructure and documentation updates). -- [ ] Determine which issues should / must be fixed before the beta, add them - to the beta milestone, possibly with a - ["priority: blocker"](https://github.com/coq/coq/labels/priority%3A%20blocker) - label. Make sure that all these issues are assigned (and that the assignee - provides an ETA). -- [ ] Ping the development coordinator (**@mattam82**) to get him started on - the update to the Credits chapter of the reference manual. - See also [#7058](https://github.com/coq/coq/issues/7058). - - The command that was used in the previous versions to get the list - of contributors for this version is `git shortlog -s -n - VX.X+alpha..master | cut -f2 | sort -k 2`. Note that the ordering is - approximative as it will misplace people with middle names. It is - also probably not correctly handling `Co-authored-by` info that we - have been using more lately, so should probably be updated to - account for this. - -## On the date of the feature freeze ## - -- [ ] Create the new version branch `vX.X` (using this name will ensure that - the branch will be automatically protected). -- [ ] Pin the versions of libraries and plugins in - `dev/ci/ci-basic-overlays.sh` to use commit hashes or tag (or, if it - exists, a branch dedicated to compatibility with the corresponding - Coq branch). You can use the `dev/tools/pin-ci.sh` script to do this - semi-automatically. - - [ ] Notify upstream authors about the pinning, see - `dev/tools/notify-upstream-pins.sh`. As of today there is no automated - way to track these issues. -- [ ] Remove all remaining unmerged feature PRs from the beta milestone. + Therefore, if you proceeded as described above, this should be the + commit updating the version, magic numbers and compatibility + infrastructure. After tagging, double-check that `git describe` + picks up the tag you just made (if not, you tagged the wrong + commit). +- [ ] Push the new tag with `git push upstream VY.Y+alpha --dry-run` + (remove the `--dry-run` and redo if everything looks OK). - [ ] Start a new project to track PR backporting. The project should - have a "Request X.X+beta1 inclusion" column for the PRs that were + have a `Request X.X+rc1 inclusion` column for the PRs that were merged in `master` that are to be considered for backporting, and a - "Shipped in X.X+beta1" columns to put what was backported. A message - to **@coqbot** in the milestone description tells it to - automatically add merged PRs to the "Request ... inclusion" column - and backported PRs to the "Shipped in ..." column. See previous - milestones for examples. When moving to the next milestone - (e.g. X.X.0), you can clear and remove the "Request X.X+beta1 - inclusion" column and create new "Request X.X.0 inclusion" and - "Shipped in X.X.0" columns. + `Shipped in X.X+rc1` columns to put what was backported. A message + to `@coqbot` in the milestone description tells it to automatically + add merged PRs to the `Request ... inclusion` column and backported + PRs to the `Shipped in ...` column. See previous milestones for + examples. When moving to the next milestone (e.g. `X.X.0`), you can + clear and remove the `Request X.X+rc1 inclusion` column and create + new `Request X.X.0 inclusion` and `Shipped in X.X.0` columns. The release manager is the person responsible for merging PRs that - target the version branch and backporting appropriate PRs that are - merged into `master`. -- [ ] Delay non-blocking issues to the appropriate milestone and ensure - blocking issues are solved. If required to solve some blocking issues, - it is possible to revert some feature PRs in the version branch only. -- [ ] Add a new link to the ``'versions'`` list of the refman (in - ``html_context`` in ``doc/sphinx/conf.py``). - -## Before the beta release date ## - -- [ ] Ensure the Credits chapter has been updated. -- [ ] Prepare the release notes (see e.g., - [#10833](https://github.com/coq/coq/pull/10833)): in a PR against the `master` - branch, move the contents from all files of `doc/changelog/` that appear in - the release branch into the manual `doc/sphinx/changes.rst`. Merge that PR - into the `master` branch and backport it to the version branch. -- [ ] Ensure that an appropriate version of the plugins we will distribute with - Coq has been tagged. -- [ ] Have some people test the recently auto-generated Windows and MacOS - packages. + target the release branch and backporting appropriate PRs (mostly + safe bug fixes, user message improvements and documentation updates) + that are merged into `master`. +- [ ] Pin the versions of libraries and plugins in + [`dev/ci/ci-basic-overlay.sh`](../ci/ci-basic-overlay.sh) to use + commit hashes. You can use the + [`dev/tools/pin-ci.sh`](../tools/pin-ci.sh) script to do this + semi-automatically. +- [ ] In a PR on `master` to be backported, add a new link to the + `'versions'` list of the refman (in `html_context` in + [`doc/sphinx/conf.py`](../../doc/sphinx/conf.py)). + +## In the days following the branching ## + +- [ ] Make sure that all the last feature PRs that you want to include + in the release are finished and backported quickly and clean up the + milestone. We recommend backporting as few feature PRs as possible + after branching. In particular, any PR with overlays will require + manually bumping the pinned commits when backporting. +- [ ] Delay non-blocking issues to the appropriate milestone and + ensure blocking issues are solved. If required to solve some + blocking issues, it is possible to revert some feature PRs in the + release branch only (but in this case, the blocking issue should be + postponed to the next major release instead of being closed). +- [ ] Once the final list of features is known, in a PR on `master` to + be backported, generate the release changelog by calling + [`dev/tools/generate-release-changelog.sh`](../tools/generate-release-changelog.sh) + and include it in a new section in + [`doc/sphinx/changes.rst`](../../doc/sphinx/changes.rst). + + At the moment, the script doesn't do it automatically, but we + recommend reordering the entries to show first the **Changed**, then + the **Removed**, **Deprecated**, **Added** and last the **Fixed**. +- [ ] Ping the development coordinator (`@mattam82`) to get him + started on writing the release summary. + + The `dev/tools/list-contributors.sh` script computes the number and + list of contributors between Coq revisions. Typically used with + `VX.X+alpha..vX.X` to check the contributors of version `VX.X`. + +## For each release (preview, final, patch-level) ## + +- [ ] Ensure that there exists a milestone for the following version. +- [ ] Ensure the release changelog has been merged (the release + summary is required for the final release). - [ ] In a PR against `vX.X` (for testing): - - Change the version name from alpha to beta1 (see - [#7009](https://github.com/coq/coq/pull/7009/files)). - - We generally do not update the magic numbers at this point. + - Update the version number. + - Only update the magic numbers for the final release (see + [#7271](https://github.com/coq/coq/pull/7271/files)). - Set `is_a_released_version` to `true` in `configure.ml`. -- [ ] Put the `VX.X+beta1` tag using `git tag -s`. -- [ ] Push the new tag with `git push upstream VX.X+beta1 --dry-run` - (remove the `--dry-run` and redo if all looks OK). -- [ ] Set `is_a_released_version` to `false` in `configure.ml` - (if you forget about it, you'll be reminded whenever you try to - backport a PR with a changelog entry). - -### These steps are the same for all releases (beta, final, patch-level) ### - -- [ ] Send an e-mail on Coqdev announcing that the tag has been put so that - package managers can start preparing package updates (including a - `coq-bignums` compatible version). -- [ ] When opening the corresponding PR for `coq` in the opam repository ([`coq/opam-coq-archive`](https://github.com/coq/opam-coq-archive) or [`ocaml/opam-repository`](https://github.com/ocaml/opam-repository)), - the package managers can Cc `@erikmd` to request that he prepare the necessary configuration for the Docker release in [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) - (namely, he'll need to make sure a `coq-bignums` opam package is available in [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), respectively [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), so the Docker image gathering `coq` and `coq-bignums` can be built). -- [ ] Draft a release on GitHub. -- [ ] Sign the Windows and MacOS packages and upload them on GitHub. - + The Windows packages must be signed by the Inria IT security service. They - should be sent as a link to the binary (via [filesender](https://filesender.renater.fr) for example) - together with its SHA256 hash in a signed e-mail to `dsi.securite` @ `inria.fr` - putting `@maximedenes` in carbon copy. - + The MacOS packages should be signed with our own certificate. A detailed step-by-step guide can be found [on the wiki](https://github.com/coq/coq/wiki/SigningReleases). -- [ ] Prepare a page of news on the website with the link to the GitHub release - (see [coq/www#63](https://github.com/coq/www/pull/63)). -- [ ] Merge the website update, publish the release - and send announcement e-mails, typically on - the `coq-club@inria.fr` mailing list and the discourse forum - ([posting by mail](https://github.com/coq/coq/wiki/Discourse)) +- [ ] Set the tag `VX.X...` using `git tag -s`. +- [ ] Push the new tag with `git push upstream VX.X... --dry-run` + (remove the `--dry-run` and redo if everything looks OK). +- [ ] Set `is_a_released_version` to `false` in `configure.ml` (if you + forget about it, you'll be reminded by the test-suite failing + whenever you try to backport a PR with a changelog entry). - [ ] Close the milestone - -## At the final release time ## - -- [ ] Prepare the release notes (see above) -- [ ] In a PR against `vX.X` (for testing): - - Change the version name from X.X.0 and the magic numbers (see - [#7271](https://github.com/coq/coq/pull/7271/files)). - - Set `is_a_released_version` to `true` in `configure.ml`. -- [ ] Put the `VX.X.0` tag. -- [ ] Push the new tag with `git push upstream VX.X.0 --dry-run` - (remove the `--dry-run` and redo if all looks OK). -- [ ] Set `is_a_released_version` to `false` in `configure.ml` - (if you forget about it, you'll be reminded whenever you try to - backport a PR with a changelog entry). - -Repeat the generic process documented above for all releases. - -Ping `@Zimmi48` to: - -- [ ] Switch the default version of the reference manual on the website. +- [ ] Send an e-mail on Coqdev + the Coq development category on + Discourse (coqdev@inria.fr + coq+coq-development@discoursemail.com) + announcing that the tag has been set so that package managers can + start preparing package updates (including a `coq-bignums` + compatible version). +- [ ] In particular, ensure that someone is working on providing an + opam package (either in the main + [ocaml/opam-repository](https://github.com/ocaml/opam-repository) + for standard releases or in the `core-dev` category of the + [coq/opam-coq-archive](https://github.com/coq/opam-coq-archive) + for preview releases. +- [ ] Make sure to cc `@erikmd` to request that he prepare the + necessary configuration for the Docker release in + [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) (namely, he'll + need to make sure a `coq-bignums` opam package is available in + [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), + respectively + [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), + so the Docker image gathering `coq` and `coq-bignums` can be built). +- [ ] Publish a release on GitHub with the PDF version of the + reference manual attached. + +## For each non-preview release ## + +- [ ] Ping `@Zimmi48` to switch the default version of the reference + manual on the website. This is done by logging into the server (`vps697916.ovh.net`), editing two `ProxyPass` lines (one for the refman and one for the @@ -181,11 +167,30 @@ Ping `@Zimmi48` to: repository. See [coq/www#111](https://github.com/coq/www/issues/111) and [coq/www#131](https://github.com/coq/www/issues/131). -- [ ] Publish a new version on Zenodo (only once per major version). +## Only for the final release of each major version ## + +- [ ] Ping `@Zimmi48` to publish a new version on Zenodo. *TODO:* automate this with coqbot. -## At the patch-level release time ## +## This is now delegated to the platform maintainers ## -We generally do not update the magic numbers at this point (see -[`2881a18`](https://github.com/coq/coq/commit/2881a18)). +- [ ] Sign the Windows and MacOS packages and upload them on GitHub. + + The Windows packages must be signed by the Inria IT security + service. They should be sent as a link to the binary (via + [filesender](https://filesender.renater.fr) for example) together + with its SHA256 hash in a signed e-mail to `dsi.securite` @ + `inria.fr` putting `@maximedenes` in carbon copy. + + The MacOS packages should be signed with our own certificate. A + detailed step-by-step guide can be found [on the + wiki](https://github.com/coq/coq/wiki/SigningReleases). + + The Snap package has to be built and uploaded to the snap store by + running a [platform CI job + manually](https://github.com/coq/platform/tree/v8.13/linux/snap/github_actions). + Then ask `@gares` to publish the upload or give you the password + for the `coq-team` account on the store so that you can do it + yourself. +- [ ] Prepare a PR on [coq/www](https://github.com/coq/www) adding a + page of news on the website. +- [ ] Announce the release to Coq-Club and Discourse + (coq-club@inria.fr + coq+announcements@discoursemail.com). @@ -34,6 +34,7 @@ %{lib:coq.tactics:tactics.cma} %{lib:coq.vernac:vernac.cma} %{lib:coq.stm:stm.cma} + %{lib:coq.sysinit:sysinit.cma} %{lib:coq.toplevel:toplevel.cma} %{lib:coq.plugins.ltac:ltac_plugin.cma} %{lib:coq.top_printers:top_printers.cmi} diff --git a/dev/dune_db_408 b/dev/dune_db_408 index 5f826fe383..bc86020d56 100644 --- a/dev/dune_db_408 +++ b/dev/dune_db_408 @@ -17,6 +17,7 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/dune_db_409 b/dev/dune_db_409 index 2e58272c75..adb1f76872 100644 --- a/dev/dune_db_409 +++ b/dev/dune_db_409 @@ -16,6 +16,7 @@ load_printer parsing.cma load_printer printing.cma load_printer tactics.cma load_printer vernac.cma +load_printer sysinit.cma load_printer stm.cma load_printer toplevel.cma diff --git a/dev/include_printers b/dev/include_printers index 7583762970..414468ca65 100644 --- a/dev/include_printers +++ b/dev/include_printers @@ -54,4 +54,6 @@ #install_printer (* fconstr *) ppfconstr;; +#install_printer (* fsubst *) ppfsubst;; + #install_printer (* Future.computation *) ppfuture;; diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 534f20f85b..db15d9705a 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -19,7 +19,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar -I $COQTOP/clib \ -I $COQTOP/gramlib/.pack \ -I $COQTOP/lib -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ - -I $COQTOP/library -I $COQTOP/engine \ + -I $COQTOP/library -I $COQTOP/engine -I $COQTOP/sysinit \ -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ diff --git a/dev/tools/list-contributors.sh b/dev/tools/list-contributors.sh new file mode 100644 index 0000000000..c968f2e952 --- /dev/null +++ b/dev/tools/list-contributors.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash +# For compat with OSX which has a non-gnu sed which doesn't support -z +SED=`which gsed || which sed` + +if [ $# != 1 ]; then + error "usage: $0 rev0..rev1" + exit 1 +fi + +git shortlog -s -n --group=author --group=trailer:Co-authored-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > contributors.tmp + +cat contributors.tmp | wc -l | xargs echo "Contributors:" +cat contributors.tmp | gsed -z "s/\n/, /g" +echo +rm contributors.tmp diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index 666fb6cc91..a14b98c73c 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -64,7 +64,7 @@ DEFAULT_NUMBER_OF_OLD_VERSIONS = 2 RELEASE_NUMBER_OF_OLD_VERSIONS = 2 MASTER_NUMBER_OF_OLD_VERSIONS = 3 EXTRA_HEADER = '\n(** Compatibility file for making Coq act similar to Coq v%s *)\n' -COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') +COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'sysinit', 'coqargs.ml') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index bfc186c862..fe95a59d9b 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -23,6 +23,7 @@ install_printer Top_printers.ppconstr_expr install_printer Top_printers.ppglob_constr install_printer Top_printers.pppattern install_printer Top_printers.ppfconstr +install_printer Top_printers.ppfsubst install_printer Top_printers.ppnumtokunsigned install_printer Top_printers.ppnumtokunsignednat install_printer Top_printers.ppintset diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 4faa12af79..f8fd8b3d5b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -85,6 +85,15 @@ let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x)) let pptype = (fun x -> try pp(envpp (fun env evm t -> pr_ltype_env env evm t) x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) +let ppfsubst s = + let (s, k) = Esubst.Internal.repr s in + let sep () = str ";" ++ spc () in + let pr = function + | Esubst.Internal.REL n -> str "<#" ++ int n ++ str ">" + | Esubst.Internal.VAL (k, x) -> pr_constr (Vars.lift k (CClosure.term_of_fconstr x)) + in + pp @@ str "[" ++ prlist_with_sep sep pr s ++ str "| " ++ int k ++ str "]" + let ppnumtokunsigned n = pp (NumTok.Unsigned.print n) let ppnumtokunsignednat n = pp (NumTok.UnsignedNat.print n) @@ -231,7 +240,7 @@ let ppuniverseconstraints c = pp (UnivProblem.Set.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx -let ppuniverses u = pp (UGraph.pr_universes Level.pr u) +let ppuniverses u = pp (UGraph.pr_universes Level.pr (UGraph.repr u)) let ppnamedcontextval e = let env = Global.env () in let sigma = Evd.from_env env in @@ -298,9 +307,9 @@ let constr_display csr = "MutConstruct(("^(MutInd.to_string sp)^","^(string_of_int i)^")," ^","^(universes_display u)^(string_of_int j)^")" | Proj (p, c) -> "Proj("^(Constant.to_string (Projection.constant p))^","^term_display c ^")" - | Case (ci,p,iv,c,bl) -> + | Case (ci,u,pms,(_,p),iv,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," - ^(array_display bl)^")" + ^(array_display (Array.map snd bl))^")" | Fix ((t,i),(lna,tl,bl)) -> "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="") then (";"^i) else "")) t "")^"|],"^(string_of_int i)^")," @@ -411,13 +420,25 @@ let print_pure_constr csr = print_int i; print_string ","; print_int j; print_string ","; universes_display u; print_string ")" - | Case (ci,p,iv,c,bl) -> + | Case (ci,u,pms,p,iv,c,bl) -> + let pr_ctx (nas, c) = + Array.iter (fun na -> print_cut (); name_display na) nas; + print_string " |- "; + box_display c + in open_vbox 0; - print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; - print_space(); box_display c; print_space (); print_string "of"; + print_space(); box_display c; print_space (); + print_cut(); print_string "in"; + print_cut(); print_string "Ind("; + sp_display (fst ci.ci_ind); + print_string ","; print_int (snd ci.ci_ind); print_string ")"; + print_string "@{"; universes_display u; print_string "}"; + Array.iter (fun x -> print_space (); box_display x) pms; + print_cut(); print_string "return <"; pr_ctx p; print_string ">"; + print_cut(); print_string "with"; open_vbox 0; - Array.iter (fun x -> print_cut(); box_display x) bl; + Array.iter (fun x -> print_cut(); pr_ctx x) bl; close_box(); print_cut(); print_string "end"; @@ -555,7 +576,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts = VtDefault (fun () -> in_current_context econstr_display c) in + let cmd_fn c ?loc:_ ~atts = VtDefault (fun () -> in_current_context econstr_display c) in let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintConstr" [cmd] @@ -564,7 +585,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in + let cmd_fn c ?loc:_ ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintPureConstr" [cmd] diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 50495dc0a4..e8ed6c709e 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -52,6 +52,7 @@ val ppconstr_expr : Constrexpr.constr_expr -> unit val ppglob_constr : 'a Glob_term.glob_constr_g -> unit val pppattern : Pattern.constr_pattern -> unit val ppfconstr : CClosure.fconstr -> unit +val ppfsubst : CClosure.fconstr Esubst.subs -> unit val ppnumtokunsigned : NumTok.Unsigned.t -> unit val ppnumtokunsignednat : NumTok.UnsignedNat.t -> unit diff --git a/doc/README.md b/doc/README.md index 79d1e1b756..440b104c16 100644 --- a/doc/README.md +++ b/doc/README.md @@ -69,6 +69,16 @@ Or if you want to use less disk space: apt install texlive-latex-extra texlive-fonts-recommended texlive-xetex \ latexmk fonts-freefont-otf +### Setting the locale for Python + +Make sure that the locale is configured on your platform so that Python encodes +printed messages with utf-8 rather than generating runtime exceptions +for non-ascii characters. The `.UTF-8` in `export LANG=C.UTF-8` sets UTF-8 encoding. +The `C` can be replaced with any supported language code. You can set the default +for a Docker build with `ENV LANG C.UTF-8`. (Python may look at other +environment variables to determine the locale; see the +[Python documentation](https://docs.python.org/3/library/locale.html#locale.getdefaultlocale)). + Compilation ----------- diff --git a/doc/changelog/01-kernel/13563-compact-case-repr.rst b/doc/changelog/01-kernel/13563-compact-case-repr.rst new file mode 100644 index 0000000000..c8ee9bc1e6 --- /dev/null +++ b/doc/changelog/01-kernel/13563-compact-case-repr.rst @@ -0,0 +1,15 @@ +- **Changed:** + The term representation of pattern-matchings now uses a compact form that + provides a few static guarantees such as eta-expansion of branches and return + clauses and is usually more efficient. The most visible user change is that for + the time being, the :tacn:`destruct` tactic and its variants generate dummy + cuts (β redexes) in the branches of the generated proof. + This can also generate very uncommon backwards incompatibilities, such as a + change of occurrence numbering for subterms, or breakage of unification in + complex situations involving pattern-matchings whose underlying inductive type + declares let-bindings in parameters, arity or constructor types. For ML plugin + developers, an in-depth description of the new representation, as well as + porting tips, can be found in dev/doc/case-repr.md + (`#13563 <https://github.com/coq/coq/pull/13563>`_, + fixes `#3166 <https://github.com/coq/coq/issues/3166>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/13469-no-int-in-fail.rst b/doc/changelog/04-tactics/13469-no-int-in-fail.rst new file mode 100644 index 0000000000..e0fcbb924e --- /dev/null +++ b/doc/changelog/04-tactics/13469-no-int-in-fail.rst @@ -0,0 +1,5 @@ +- **Removed:** + :tacn:`fail` and :tacn:`gfail`, which formerly accepted negative + values as a parameter, now give syntax errors for negative + values (`#13469 <https://github.com/coq/coq/pull/13469>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13512-master+fix13413-apply-on-intro-pattern-fresh-names.rst b/doc/changelog/04-tactics/13512-master+fix13413-apply-on-intro-pattern-fresh-names.rst new file mode 100644 index 0000000000..aaacb2aadf --- /dev/null +++ b/doc/changelog/04-tactics/13512-master+fix13413-apply-on-intro-pattern-fresh-names.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Possible collision between a user-level name and an internal name when + using the :n:`%` introduction pattern + (`#13512 <https://github.com/coq/coq/pull/13512>`_, + fixes `#13413 <https://github.com/coq/coq/issues/13413>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst b/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst new file mode 100644 index 0000000000..306fe8052d --- /dev/null +++ b/doc/changelog/04-tactics/13696-deprecate_at_in_conversion.rst @@ -0,0 +1,7 @@ +- **Deprecated:** + In :tacn:`change` and :tacn:`change_no_check`, the + `at ... with ...` form is deprecated. Use + `with ... at ...` instead. For `at ... with ... in H |-`, + use `with ... in H at ... |-`. + (`#13696 <https://github.com/coq/coq/pull/13696>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13699-fix13579.rst b/doc/changelog/04-tactics/13699-fix13579.rst new file mode 100644 index 0000000000..9cf62fb595 --- /dev/null +++ b/doc/changelog/04-tactics/13699-fix13579.rst @@ -0,0 +1,6 @@ +- **Fixed:** + :tacn:`simpl` and :tacn:`hnf` now reduce primitive functions + on primitive integers, floats and arrays + (`#13699 <https://github.com/coq/coq/pull/13699>`_, + fixes `#13579 <https://github.com/coq/coq/issues/13579>`_, + by Pierre Roux). diff --git a/doc/changelog/04-tactics/13715-lia_implb.rst b/doc/changelog/04-tactics/13715-lia_implb.rst new file mode 100644 index 0000000000..dd61872342 --- /dev/null +++ b/doc/changelog/04-tactics/13715-lia_implb.rst @@ -0,0 +1,2 @@ +- **Added:** + :tacn:`lia` supports the boolean operator `Bool.implb` (`#13715 <https://github.com/coq/coq/pull/13715>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst b/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst new file mode 100644 index 0000000000..1aa57ff8b1 --- /dev/null +++ b/doc/changelog/04-tactics/13761-remove_convert_concl_nc.rst @@ -0,0 +1,4 @@ +- **Removed:** + convert_concl_no_check. Use :tacn:`change_no_check` instead + (`#13761 <https://github.com/coq/coq/pull/13761>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13762-remove_double_induction.rst b/doc/changelog/04-tactics/13762-remove_double_induction.rst new file mode 100644 index 0000000000..4ea54a1ab6 --- /dev/null +++ b/doc/changelog/04-tactics/13762-remove_double_induction.rst @@ -0,0 +1,9 @@ +- **Removed:** + double induction tactic. Replace :n:`double induction @ident @ident` + with :n:`induction @ident; induction @ident` (or + :n:`induction @ident ; destruct @ident` depending on the exact needs). + Replace :n:`double induction @natural__1 @natural__2` with + :n:`induction @natural__1; induction natural__3` where :n:`natural__3` is the result + of :n:`natural__2 - natural__1` + (`#13762 <https://github.com/coq/coq/pull/13762>`_, + by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13781-deprecate_micromega_options.rst b/doc/changelog/04-tactics/13781-deprecate_micromega_options.rst new file mode 100644 index 0000000000..e3375bd875 --- /dev/null +++ b/doc/changelog/04-tactics/13781-deprecate_micromega_options.rst @@ -0,0 +1,3 @@ +- **Deprecated:** + The micromega option :flag:`Simplex`, which is currently set by default + (`#13781 <https://github.com/coq/coq/pull/13781>`_, by Frédéric Besson). diff --git a/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst b/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst new file mode 100644 index 0000000000..cd1ac3a35a --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst @@ -0,0 +1,19 @@ +- **Added:** + :opt:`Debug` to control debug messages, functioning similarly to the warning system + (`#13202 <https://github.com/coq/coq/pull/13202>`_, + by Maxime Dénès and Gaëtan Gilbert). + The following flags have been converted (such that ``Set Flag`` becomes ``Set Debug "flag"``): + + - ``Debug Unification`` to ``unification`` + + - ``Debug HO Unification`` to ``ho-unification`` + + - ``Debug Tactic Unification`` to ``tactic-unification`` + + - ``Congruence Verbose`` to ``congruence`` + + - ``Debug Cbv`` to ``cbv`` + + - ``Debug RAKAM`` to ``RAKAM`` + + - ``Debug Ssreflect`` to ``ssreflect`` diff --git a/doc/changelog/07-vernac-commands-and-options/13556-master.rst b/doc/changelog/07-vernac-commands-and-options/13556-master.rst deleted file mode 100644 index 05a60026a3..0000000000 --- a/doc/changelog/07-vernac-commands-and-options/13556-master.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** - The warning `custom-entry-overriden` has been renamed to `custom-entry-overridden` (with two d's). - (`#13556 <https://github.com/coq/coq/pull/13556>`_, - by Simon Friis Vindum). diff --git a/doc/changelog/07-vernac-commands-and-options/13725-hint-rw-local.rst b/doc/changelog/07-vernac-commands-and-options/13725-hint-rw-local.rst new file mode 100644 index 0000000000..653e9cd0cd --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13725-hint-rw-local.rst @@ -0,0 +1,5 @@ +- **Changed:** + :cmd:`Hint Rewrite` now supports locality attributes (including :attr:`export`) like other :ref:`Hint <creating_hints>` commands + (`#13725 <https://github.com/coq/coq/pull/13725>`_, + fixes `#13724 <https://github.com/coq/coq/issues/13724>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/07-vernac-commands-and-options/13758-remove_hide_obligations.rst b/doc/changelog/07-vernac-commands-and-options/13758-remove_hide_obligations.rst new file mode 100644 index 0000000000..84d6bdea89 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13758-remove_hide_obligations.rst @@ -0,0 +1,4 @@ +- **Removed:** + The Hide Obligations flag, deprecated in 8.12 + (`#13758 <https://github.com/coq/coq/pull/13758>`_, + by Jim Fehrle). diff --git a/doc/changelog/07-vernac-commands-and-options/13763-remove_searchhead.rst b/doc/changelog/07-vernac-commands-and-options/13763-remove_searchhead.rst new file mode 100644 index 0000000000..7f0650d8ee --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13763-remove_searchhead.rst @@ -0,0 +1,4 @@ +- **Removed:** + SearchHead command. Use the `headconcl:` clause of :cmd:`Search` instead + (`#13763 <https://github.com/coq/coq/pull/13763>`_, + by Jim Fehrle). diff --git a/doc/changelog/07-vernac-commands-and-options/13764-remove_add_injtyp.rst b/doc/changelog/07-vernac-commands-and-options/13764-remove_add_injtyp.rst new file mode 100644 index 0000000000..fc6c88eab6 --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13764-remove_add_injtyp.rst @@ -0,0 +1,6 @@ +- **Removed:** + `Show Zify Spec`, `Add InjTyp` and 11 similar `Add *` commands. + For `Show Zify Spec`, use `Show Zify UnOpSpec` or `Show Zify BinOpSpec` instead. + For `Add *`, `Use Add Zify *` intead of `Add *` + (`#13764 <https://github.com/coq/coq/pull/13764>`_, + by Jim Fehrle). diff --git a/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst b/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst new file mode 100644 index 0000000000..e3333f8a9a --- /dev/null +++ b/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst @@ -0,0 +1,4 @@ +- **Removed:** previously deprecated command line options + ``-sprop-cumulative`` and ``-input-state`` and its alias ``-is`` + (`#13822 <https://github.com/coq/coq/pull/13822>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst b/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst new file mode 100644 index 0000000000..e78280d91d --- /dev/null +++ b/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst @@ -0,0 +1,3 @@ +- **Added:** + Shift-return in the Find dialog now searches backwards (`#13810 <https://github.com/coq/coq/pull/13810>`_, + by slrnsc). diff --git a/doc/changelog/10-standard-library/13080-ascii.rst b/doc/changelog/10-standard-library/13080-ascii.rst new file mode 100644 index 0000000000..167002283e --- /dev/null +++ b/doc/changelog/10-standard-library/13080-ascii.rst @@ -0,0 +1,4 @@ +- **Added:** + ``leb`` and ``ltb`` functions for ``ascii`` + (`#13080 <https://github.com/coq/coq/pull/13080>`_, + by Yishuai Li). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index bfdbc4c4db..9495fd0e45 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -107,7 +107,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica .. cmd:: Axiom @ident : @term. This command links :token:`term` to the name :token:`term` as its specification in - the global context. The fact asserted by :token:`term` is thus assumed as a + the global environment. The fact asserted by :token:`term` is thus assumed as a postulate. .. cmdv:: Parameter @ident : @term. diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 3662822a5e..8e72bb4ffd 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -100,7 +100,6 @@ Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Extraction Language @language - :name: Extraction Language .. insertprodn language language @@ -431,12 +430,10 @@ Additional settings ~~~~~~~~~~~~~~~~~~~ .. opt:: Extraction File Comment @string - :name: Extraction File Comment Provides a comment that is included at the beginning of the output files. .. opt:: Extraction Flag @natural - :name: Extraction Flag Controls which optimizations are used during extraction, providing a finer-grained control than :flag:`Extraction Optimize`. The bits of :token:`natural` are used as a bit mask. diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 039a23e8c2..9ac05fab2e 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -101,7 +101,7 @@ morphisms, that are required to be simultaneously monotone on every argument. Morphisms can also be contravariant in one or more of their arguments. -A morphism is contravariant on an argument associated to the relation +A morphism is contravariant on an argument associated with the relation instance :math:`R` if it is covariant on the same argument when the inverse relation :math:`R^{−1}` (``inverse R`` in Coq) is considered. The special arrow ``-->`` is used in signatures for contravariant morphisms. @@ -336,7 +336,7 @@ respective relation instances. in the previous example). Applying ``union_compat`` by hand we are left with the goal ``eq_set (union S S) (union S S)``. -When the relations associated to some arguments are not reflexive, the +When the relations associated with some arguments are not reflexive, the tactic cannot automatically prove the reflexivity goals, that are left to the user. @@ -477,8 +477,8 @@ documentation on :ref:`typeclasses` and the theories files in Classes for further explanations. One can inform the rewrite tactic about morphisms and relations just -by using the typeclass mechanism to declare them using Instance and -Context vernacular commands. Any object of type Proper (the type of +by using the typeclass mechanism to declare them using the :cmd:`Instance` and +:cmd:`Context` commands. Any object of type Proper (the type of morphism declarations) in the local context will also be automatically used by the rewriting tactic to solve constraints. @@ -553,7 +553,7 @@ pass additional arguments such as ``using relation``. be used to replace the first tactic argument with the second one. If omitted, it defaults to the ``DefaultRelation`` instance on the type of the objects. By default, it means the most recent ``Equivalence`` instance - in the environment, but it can be customized by declaring + in the global environment, but it can be customized by declaring new ``DefaultRelation`` instances. As Leibniz equality is a declared equivalence, it will fall back to it if no other relation is declared on a given type. @@ -608,7 +608,6 @@ Deprecated syntax and backward incompatibilities an old development to the new semantics is usually quite simple. .. cmd:: Declare Morphism @one_term : @ident - :name: Declare Morphism Declares a parameter in a module type that is a morphism. @@ -686,7 +685,7 @@ Note that when one does rewriting with a lemma under a binder using variable, as the semantics are different from rewrite where the lemma is first matched on the whole term. With the new :tacn:`setoid_rewrite`, matching is done on each subterm separately and in its local -environment, and all matches are rewritten *simultaneously* by +context, and all matches are rewritten *simultaneously* by default. The semantics of the previous :tacn:`setoid_rewrite` implementation can almost be recovered using the ``at 1`` modifier. @@ -727,6 +726,30 @@ declare your constant as rigid for proof search using the command Strategies for rewriting ------------------------ +Usage +~~~~~ + +.. tacn:: rewrite_strat @rewstrategy {? in @ident } + :name: rewrite_strat + + Rewrite using :n:`@rewstrategy` in the conclusion or in the hypothesis :n:`@ident`. + + .. exn:: Nothing to rewrite. + + The strategy didn't find any matches. + + .. exn:: No progress made. + + If the strategy succeeded but made no progress. + + .. exn:: Unable to satisfy the rewriting constraints. + + If the strategy succeeded and made progress but the + corresponding rewriting constraints are not satisfied. + + :tacn:`setoid_rewrite` :n:`@one_term` is basically equivalent to + :n:`rewrite_strat outermost @one_term`. + Definitions ~~~~~~~~~~~ @@ -774,7 +797,7 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. failure :n:`id` - identity + identity :n:`refl` reflexivity @@ -804,10 +827,16 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. all subterms :n:`innermost @rewstrategy` - innermost first + Innermost first. + When there are multiple nested matches in a subterm, the innermost subterm + is rewritten. For :ref:`example <rewrite_strat_innermost_outermost>`, + rewriting :n:`(a + b) + c` with Nat.add_comm gives :n:`(b + a) + c`. :n:`outermost @rewstrategy` - outermost first + Outermost first. + When there are multiple nested matches in a subterm, the outermost subterm + is rewritten. For :ref:`example <rewrite_strat_innermost_outermost>`, + rewriting :n:`(a + b) + c` with Nat.add_comm gives :n:`c + (a + b)`. :n:`bottomup @rewstrategy` bottom-up @@ -834,8 +863,8 @@ are applied using the tactic :n:`rewrite_strat @rewstrategy`. to be documented -A few of these are defined in terms of the others using a -primitive fixpoint operator: +Conceptually, a few of these are defined in terms of the others using a +primitive fixpoint operator `fix`, which the tactic doesn't currently support: - :n:`try @rewstrategy := choice @rewstrategy id` - :n:`any @rewstrategy := fix @ident. try (@rewstrategy ; @ident)` @@ -877,30 +906,30 @@ if it reduces the subterm under consideration. The ``fold`` strategy takes a :token:`term` and tries to *unify* it to the current subterm, converting it to :token:`term` on success. It is stronger than the tactic ``fold``. +.. _rewrite_strat_innermost_outermost: -Usage -~~~~~ - - -.. tacn:: rewrite_strat @rewstrategy {? in @ident } - :name: rewrite_strat +.. example:: :n:`innermost` and :n:`outermost` - Rewrite using the strategy s in hypothesis ident or the conclusion. + The type of `Nat.add_comm` is `forall n m : nat, n + m = m + n`. - .. exn:: Nothing to rewrite. + .. coqtop:: all - If the strategy failed. + Require Import Coq.Arith.Arith. + Set Printing Parentheses. + Goal forall a b c: nat, a + b + c = 0. + rewrite_strat innermost Nat.add_comm. - .. exn:: No progress made. + .. coqtop:: none - If the strategy succeeded but made no progress. + Abort. + Goal forall a b c: nat, a + b + c = 0. - .. exn:: Unable to satisfy the rewriting constraints. + Using :n:`outermost` instead gives this result: - If the strategy succeeded and made progress but the - corresponding rewriting constraints are not satisfied. + .. coqtop:: all + rewrite_strat outermost Nat.add_comm. - The ``setoid_rewrite c`` tactic is basically equivalent to - ``rewrite_strat (outermost c)``. + .. coqtop:: none + Abort. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 0f0ccd6a20..09b2bb003a 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -202,7 +202,6 @@ Use :n:`:>` instead of :n:`:` before the :undocumented: .. cmd:: SubClass @ident_decl @def_body - :name: SubClass If :n:`@type` is a class :n:`@ident'` applied to some arguments then :n:`@ident` is defined and an identity coercion of name @@ -243,7 +242,6 @@ Activating the Printing of Coercions By default, coercions are not printed. .. table:: Printing Coercion @qualid - :name: Printing Coercion Specifies a set of qualids for which coercions are always displayed. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 28b60878d2..5d471c695c 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -31,9 +31,11 @@ tactics for solving arithmetic goals over :math:`\mathbb{Q}`, .. flag:: Simplex + .. deprecated:: 8.14 + This flag (set by default) instructs the decision procedures to - use the Simplex method for solving linear goals. If it is not set, - the decision procedures are using Fourier elimination. + use the Simplex method for solving linear goals instead of the + deprecated Fourier elimination. .. opt:: Dump Arith @@ -140,7 +142,6 @@ and checked to be :math:`-1`. ------------------------------------------------------------------- .. tacn:: lra - :name: lra This tactic is searching for *linear* refutations. As a result, this tactic explores a subset of the *Cone* defined as @@ -154,7 +155,6 @@ and checked to be :math:`-1`. --------------------------------------------- .. tacn:: lia - :name: lia 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. @@ -220,7 +220,6 @@ a proof. -------------------------------------------------- .. tacn:: nra - :name: nra This tactic is an *experimental* proof procedure for non-linear arithmetic. The tactic performs a limited amount of non-linear @@ -241,7 +240,6 @@ proof by abstracting monomials by variables. ---------------------------------------------------------- .. tacn:: nia - :name: nia This tactic is a proof procedure for non-linear integer arithmetic. It performs a pre-processing similar to :tacn:`nra`. The obtained goal is @@ -251,7 +249,6 @@ proof by abstracting monomials by variables. ---------------------------------------------------- .. tacn:: psatz @one_term {? @nat_or_var } - :name: psatz This tactic explores the *Cone* by increasing degrees – hence the depth parameter :token:`nat_or_var`. In theory, such a proof search is complete – if the @@ -281,7 +278,6 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. ------------------------------------------ .. tacn:: zify - :name: zify This tactic is internally called by :tacn:`lia` to support additional types, e.g., :g:`nat`, :g:`positive` and :g:`N`. Additional support is provided by the following modules: @@ -321,68 +317,6 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. prints the list of types that supported by :tacn:`zify` i.e., :g:`Z`, :g:`nat`, :g:`positive` and :g:`N`. -.. cmd:: Show Zify Spec - - .. deprecated:: 8.13 - Use :cmd:`Show Zify` ``UnOpSpec`` or :cmd:`Show Zify` ``BinOpSpec`` instead. - -.. cmd:: Add InjTyp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``InjTyp`` instead. - -.. cmd:: Add BinOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``BinOp`` instead. - -.. cmd:: Add BinOpSpec @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``BinOpSpec`` instead. - -.. cmd:: Add UnOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``UnOp`` instead. - -.. cmd:: Add UnOpSpec @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``UnOpSpec`` instead. - -.. cmd:: Add CstOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``CstOp`` instead. - -.. cmd:: Add BinRel @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``BinRel`` instead. - -.. cmd:: Add PropOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``PropOp`` instead. - -.. cmd:: Add PropBinOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``PropBinOp`` instead. - -.. cmd:: Add PropUOp @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``PropUOp`` instead. - -.. cmd:: Add Saturate @one_term - - .. deprecated:: 8.13 - Use :cmd:`Add Zify` ``Saturate`` instead. - - - .. [#csdp] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#fnpsatz] Variants deal with equalities and strict inequalities. diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 2b10f5671d..0997c5e868 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -28,7 +28,6 @@ Description of ``omega`` ------------------------ .. tacn:: omega - :name: omega .. deprecated:: 8.12 diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index e824ae152d..ea506cec84 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -70,7 +70,7 @@ Coq 8.6 introduced a mechanism for error resilience: in interactive mode Coq is able to completely check a document containing errors instead of bailing out at the first failure. -Two kind of errors are supported: errors occurring in vernacular +Two kind of errors are supported: errors occurring in commands and errors occurring in proofs. To properly recover from a failing tactic, Coq needs to recognize the @@ -89,8 +89,8 @@ kind of proof blocks, and an ML API to add new ones. Caveats ```````` -When a vernacular command fails the subsequent error messages may be -bogus, i.e. caused by the first error. Error resilience for vernacular +When a command fails the subsequent error messages may be +bogus, i.e. caused by the first error. Error resilience for commands can be switched off by passing ``-async-proofs-command-error-resilience off`` to CoqIDE. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 104f84a253..8f2b51ccce 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -161,7 +161,7 @@ Program Definition A :cmd:`Definition` command with the :attr:`program` attribute types the value term in Russell and generates proof obligations. Once solved using the commands shown below, it binds the -final Coq term to the name :n:`@ident` in the environment. +final Coq term to the name :n:`@ident` in the global environment. :n:`Program Definition @ident : @type := @term` @@ -268,7 +268,6 @@ obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. .. cmd:: Obligation Tactic := @ltac_expr - :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations automatically, whether to solve them or when starting to prove one, @@ -321,14 +320,6 @@ optional tactic is replaced by the default one if not specified. (the default), or if the system should infer which obligations can be declared opaque. -.. flag:: Hide Obligations - - .. deprecated:: 8.12 - - Controls whether obligations appearing in the - term should be hidden as implicit arguments of the special - constant ``Program.Tactics.obligation``. - The module :g:`Coq.Program.Tactics` defines the default tactic for solving obligations called :g:`program_simpl`. Importing :g:`Coq.Program.Program` also adds some useful notations, as documented in the file itself. diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index c93d621048..954c2c1446 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -421,7 +421,7 @@ Error messages: .. exn:: Ring operation should be declared as a morphism. - A setoid associated to the carrier of the ring structure has been found, + A setoid associated with the carrier of the ring structure has been found, but the ring operation should be declared as morphism. See :ref:`tactics-enabled-on-user-provided-relations`. How does it work? diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 2b1f343e14..8c20e08154 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -19,7 +19,6 @@ Use of |SProp| may be disabled by passing ``-disallow-sprop`` to the Coq program or by turning the :flag:`Allow StrictProp` flag off. .. flag:: Allow StrictProp - :name: Allow StrictProp Enables or disables the use of |SProp|. It is enabled by default. The command-line flag ``-disallow-sprop`` disables |SProp| at @@ -283,7 +282,6 @@ This means that some errors will be delayed until ``Qed``: Abort. .. flag:: Elaboration StrictProp Cumulativity - :name: Elaboration StrictProp Cumulativity Unset this flag (it is on by default) to be strict with regard to :math:`\SProp` cumulativity during elaboration. @@ -320,7 +318,6 @@ so correctly converts ``x`` and ``y``. it to find when your tactics are producing incorrect marks. .. flag:: Cumulative StrictProp - :name: Cumulative StrictProp Set this flag (it is off by default) to make the kernel accept cumulativity between |SProp| and other universes. This makes diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 4143d836c4..8dc0030115 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -160,7 +160,7 @@ Sections and contexts --------------------- To ease developments parameterized by many instances, one can use the -:cmd:`Context` command to introduce these parameters into section contexts, +:cmd:`Context` command to introduce the parameters into the :term:`local context`, it works similarly to the command :cmd:`Variable`, except it accepts any binding context as an argument, so variables can be implicit, and :ref:`implicit-generalization` can be used. @@ -422,7 +422,7 @@ Summary of the commands resolution with the local hypotheses use full conversion during unification. - + The mode hints (see :cmd:`Hint Mode`) associated to a class are + + The mode hints (see :cmd:`Hint Mode`) associated with a class are taken into account by :tacn:`typeclasses eauto`. When a goal does not match any of the declared modes for its head (if any), instead of failing like :tacn:`eauto`, the goal is suspended and @@ -470,7 +470,6 @@ Summary of the commands refinement engine will be able to backtrack. .. tacn:: autoapply @one_term with @ident - :name: autoapply The tactic ``autoapply`` applies :token:`one_term` using the transparency information of the hint database :token:`ident`, and does *no* typeclass resolution. This can @@ -590,7 +589,6 @@ Settings :cmd:`Typeclasses eauto` is another way to set this flag. .. opt:: Typeclasses Depth @natural - :name: Typeclasses Depth Sets the maximum proof search depth. The default is unbounded. :cmd:`Typeclasses eauto` is another way to set this option. @@ -602,7 +600,6 @@ Settings is another way to set this flag. .. opt:: Typeclasses Debug Verbosity @natural - :name: Typeclasses Debug Verbosity Determines how much information is shown for typeclass resolution steps during search. 1 is the default level. 2 shows additional information such as tried tactics and shelving @@ -613,7 +610,6 @@ Typeclasses eauto ~~~~~~~~~~~~~~~~~ .. cmd:: Typeclasses eauto := {? debug } {? ( {| bfs | dfs } ) } {? @natural } - :name: Typeclasses eauto Allows more global customization of the :tacn:`typeclasses eauto` tactic. The options are: diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index bb78b142ca..d0b05a03f9 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -328,7 +328,7 @@ Cumulativity Weak Constraints Global and local universes --------------------------- -Each universe is declared in a global or local environment before it +Each universe is declared in a global or local context before it can be used. To ensure compatibility, every *global* universe is set to be strictly greater than :g:`Set` when it is introduced, while every *local* (i.e. polymorphically quantified) universe is introduced as @@ -617,7 +617,7 @@ definitions in the section sharing a common variable will both get parameterized by the universes produced by the variable declaration. This is in contrast to a “mononorphic” variable which introduces global universes and constraints, making the two definitions depend on -the *same* global universes associated to the variable. +the *same* global universes associated with the variable. It is possible to mix universe polymorphism and monomorphism in sections, except in the following ways: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index fcb150e3da..ea099eb52e 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -531,11 +531,11 @@ Commands and options .. _813HintWarning: - **Deprecated:** - The default value for hint locality is currently :attr:`local` in a section and - :attr:`global` otherwise, but is scheduled to change in a future release. For the - time being, adding hints outside of sections without specifying an explicit - locality is therefore triggering a deprecation warning. It is recommended to - use :attr:`export` whenever possible + Hint locality currently defaults to :attr:`local` in a section and + :attr:`global` otherwise, but this will change in a future release. + Hints added outside of sections without an explicit + locality now generate a deprecation warning. We recommend + using :attr:`export` where possible (`#13384 <https://github.com/coq/coq/pull/13384>`_, by Pierre-Marie Pédrot). - **Deprecated:** @@ -690,6 +690,38 @@ Infrastructure and dependencies by Emilio Jesus Gallego Arias and Vicent Laporte, with help from Frédéric Besson). +Changes in 8.13.0 +~~~~~~~~~~~~~~~~~ + +Commands and options +^^^^^^^^^^^^^^^^^^^^ + +- **Changed:** + The warning `custom-entry-overriden` has been renamed to `custom-entry-overridden` (with two d's). + (`#13556 <https://github.com/coq/coq/pull/13556>`_, + by Simon Friis Vindum). + +Changes in 8.13.1 +~~~~~~~~~~~~~~~~~ + +Kernel +^^^^^^ + +- **Fixed:** + Fix arities of VM opcodes for some floating-point operations + that could cause memory corruption + (`#13867 <https://github.com/coq/coq/pull/13867>`_, + by Guillaume Melquiond). + +CoqIDE +^^^^^^ + +- **Added:** + Option ``-v`` and ``--version`` to CoqIDE + (`#13870 <https://github.com/coq/coq/pull/13870>`_, + by Guillaume Melquiond). + + Version 8.12 ------------ @@ -943,7 +975,7 @@ Notations by Hugo Herbelin). - **Fixed:** Different interpretations in different scopes of the same notation - string can now be associated to different printing formats (`#10832 + string can now be associated with different printing formats (`#10832 <https://github.com/coq/coq/pull/10832>`_, by Hugo Herbelin, fixes `#6092 <https://github.com/coq/coq/issues/6092>`_ and `#7766 <https://github.com/coq/coq/issues/7766>`_). @@ -1219,7 +1251,7 @@ Flags, options and attributes :attr:`universes(template)` and ``universes(notemplate)`` instead (`#11663 <https://github.com/coq/coq/pull/11663>`_, by Théo Zimmermann). - **Deprecated:** - :flag:`Hide Obligations` flag + `Hide Obligations` flag (`#11828 <https://github.com/coq/coq/pull/11828>`_, by Emilio Jesus Gallego Arias). - **Added:** Handle the :attr:`local` attribute in :cmd:`Canonical @@ -1290,7 +1322,7 @@ Commands Declaration of arbitrary terms as hints. Global references are now preferred (`#7791 <https://github.com/coq/coq/pull/7791>`_, by Pierre-Marie Pédrot). -- **Deprecated:** :cmd:`SearchHead` in favor of the new `headconcl:` +- **Deprecated:** `SearchHead` in favor of the new `headconcl:` clause of :cmd:`Search` (part of `#8855 <https://github.com/coq/coq/pull/8855>`_, by Théo Zimmermann). - **Added:** @@ -2222,7 +2254,7 @@ Changes in 8.11+beta1 documentation. (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) - **Added:** - The :cmd:`Section` vernacular command now accepts the "universes" attribute. In + The :cmd:`Section` command now accepts the "universes" attribute. In addition to setting the section universe polymorphism, it also locally sets the universe polymorphic option inside the section. (`#10441 <https://github.com/coq/coq/pull/10441>`_, by Pierre-Marie Pédrot) @@ -3180,7 +3212,7 @@ Other changes in 8.10+beta1 by Maxime Dénès, review by Pierre-Marie Pédrot). - New variant :tacn:`change_no_check` of :tacn:`change`, usable as a - documented replacement of :tacn:`convert_concl_no_check` + documented replacement of `convert_concl_no_check` (`#10012 <https://github.com/coq/coq/pull/10012>`_, `#10017 <https://github.com/coq/coq/pull/10017>`_, `#10053 <https://github.com/coq/coq/pull/10053>`_, and @@ -3221,7 +3253,7 @@ Other changes in 8.10+beta1 New `relpre R f` definition for the preimage of a relation R under f (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). -- Vernacular commands: +- Commands: - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. Names may not be repeated, and may not overlap with section variable names @@ -3553,7 +3585,7 @@ Changes in 8.10.2 **Notations** -- Fixed an 8.10 regression related to the printing of coercions associated to notations +- Fixed an 8.10 regression related to the printing of coercions associated with notations (`#11090 <https://github.com/coq/coq/pull/11090>`_, fixes `#11033 <https://github.com/coq/coq/issues/11033>`_, by Hugo Herbelin). @@ -3794,7 +3826,7 @@ Focusing - Focusing bracket `{` now supports named goal selectors, e.g. `[x]: {` will focus on a goal (existential variable) named `x`. - As usual, unfocus with `}` once the sub-goal is fully solved. + As usual, unfocus with `}` once the subgoal is fully solved. Specification language @@ -3859,7 +3891,7 @@ Tools please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. -Vernacular Commands +Commands - Removed deprecated commands `Arguments Scope` and `Implicit Arguments` (not the option). Use the `Arguments` command instead. @@ -4130,11 +4162,11 @@ Tactics Focusing - Focusing bracket `{` now supports single-numbered goal selector, - e.g. `2: {` will focus on the second sub-goal. As usual, unfocus - with `}` once the sub-goal is fully solved. + e.g. `2: {` will focus on the second subgoal. As usual, unfocus + with `}` once the subgoal is fully solved. The `Focus` and `Unfocus` commands are now deprecated. -Vernacular Commands +Commands - Proofs ending in "Qed exporting ident, .., ident" are not supported anymore. Constants generated during `abstract` are kept private to the @@ -4508,7 +4540,7 @@ Gallina - Now supporting all kinds of binders, including 'pat, in syntax of record fields. -Vernacular Commands +Commands - Goals context can be printed in a more compact way when `Set Printing Compact Contexts` is activated. @@ -5340,7 +5372,7 @@ Logic the dependent one. To recover the old behavior, explicitly define your inductive types in Set. -Vernacular commands +Commands - A command "Variant" allows to define non-recursive variant types. - The command "Record foo ..." does not generate induction principles @@ -5797,7 +5829,7 @@ API Details of changes in 8.5beta3 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - New command "Redirect" to redirect the output of a command to a file. - New command "Undelimit Scope" to remove the delimiter of a scope. @@ -6176,7 +6208,7 @@ Regarding decision tactics, Loïc Pottier maintained nsatz, moving in particular to a typeclass based reification of goals while Frédéric Besson maintained Micromega, adding in particular support for division. -Regarding vernacular commands, Stéphane Glondu provided new commands to +Regarding commands, Stéphane Glondu provided new commands to analyze the structure of type universes. Regarding libraries, a new library about lists of a given length (called @@ -6373,7 +6405,7 @@ Tactics constructor. Last one can mark a constant so that it is unfolded only if the simplified term does not expose a match in head position. -Vernacular commands +Commands - It is now mandatory to have a space (or tabulation or newline or end-of-file) after a "." ending a sentence. @@ -6563,7 +6595,7 @@ Tools Details of changes in 8.4beta2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - Commands "Back" and "BackTo" are now handling the proof states. They may perform some extra steps of backtrack to avoid states where the proof @@ -6612,7 +6644,7 @@ CoqIDE Details of changes in 8.4 ~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - The "Reset" command is now supported again in files given to coqc or Load. - "Show Script" now indents again the displayed scripts. It can also work @@ -6916,7 +6948,7 @@ Type classes anonymous instances, declarations giving terms, better handling of sections and [Context]. -Vernacular commands +Commands - New command "Timeout <n> <command>." interprets a command and a timeout interrupts the execution after <n> seconds. @@ -7089,7 +7121,7 @@ implement a new resolution-based version of the tactics dedicated to rewriting on arbitrary transitive relations. Another major improvement of Coq 8.2 is the evolution of the arithmetic -libraries and of the tools associated to them. Benjamin Grégoire and +libraries and of the tools associated with them. Benjamin Grégoire and Laurent Théry contributed a modular library for building arbitrarily large integers from bounded integers while Evgeny Makarov contributed a modular library of abstract natural and integer arithmetic together @@ -7197,7 +7229,7 @@ Language of easily fixed incompatibility in case of manual definition of a recursor in a recursive singleton inductive type]. -Vernacular commands +Commands - Added option Global to "Arguments Scope" for section surviving. - Added option "Unset Elimination Schemes" to deactivate the automatic @@ -7797,7 +7829,7 @@ Syntax - Support for primitive interpretation of string literals - Extended support for Unicode ranges -Vernacular commands +Commands - Added "Print Ltac qualid" to print a user defined tactic. - Added "Print Rewrite HintDb" to print the content of a DB used by @@ -7975,7 +8007,7 @@ Libraries - Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on the allowance for recursively non uniform parameters (possible source of incompatibilities: explicit pattern-matching on these - types may require to remove the occurrence associated to their + types may require to remove the occurrence associated with their recursively non uniform parameter). - Coq.List.In_dec has been set transparent (this may exceptionally break proof scripts, set it locally opaque for compatibility). @@ -8194,7 +8226,7 @@ Syntax for arithmetic - Locate applied to a simple string (e.g. "+") searches for all notations containing this string -Vernacular commands +Commands - "Declare ML Module" now allows to import .cma files. This avoids to use a bunch of "Declare ML Module" statements when using several ML files. @@ -8355,7 +8387,7 @@ New concrete syntax - A completely new syntax for terms - A more uniform syntax for tactics and the tactic language -- A few syntactic changes for vernacular commands +- A few syntactic changes for commands - A smart automatic translator translating V8.0 files in old syntax to files valid for V8.0 @@ -8426,7 +8458,7 @@ Known problems of the automatic translation Details of changes in 8.0 ~~~~~~~~~~~~~~~~~~~~~~~~~ -Vernacular commands +Commands - New option "Set Printing All" to deactivate all high-level forms of printing (implicit arguments, coercions, destructing let, diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index bce88cebde..edbc89aad8 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,11 +183,8 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'tactic', 'induction_clause', - 'conversion', 'where', - 'oriented_rewriter', 'bindings_with_parameters', 'destruction_arg' ]] @@ -493,3 +490,6 @@ epub_exclude_files = ['search.html'] # navtree options navtree_shift = True + +# since sphinxcontrib-bibtex version 2 we need this +bibtex_bibfiles = [ "biblio.bib" ] diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index c5ef92a1bf..44f2d23801 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -954,7 +954,7 @@ Parsing and grammar extension for Time and to write grammar rules abbreviating several commands) (+) - The default parser for actions in the grammar rules (and for - patterns in the pretty-printing rules) is now the one associated to + patterns in the pretty-printing rules) is now the one associated with the grammar (i.e. vernac, tactic or constr); no need then for quotations as in <:vernac:<...>>; to return an "ast", the grammar must be explicitly typed with tag ": ast" or ": ast list", or if a @@ -1346,12 +1346,12 @@ Language instead to simulate the old behaviour of Local (the section part of the name is not kept though) -ML tactic and vernacular commands +ML tactics and commands - "Grammar tactic" and "Grammar vernac" of type "ast" are no longer supported (only "Grammar tactic simple_tactic" of type "tactic" remains available). -- Concrete syntax for ML written vernacular commands and tactics is +- Concrete syntax for ML written commands and tactics is now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC COMMAND EXTEND. - "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..." diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index 06a677d837..0b183d3f3f 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -45,9 +45,9 @@ This manual is organized in three main parts, plus an appendix: translated down to the language of the kernel by means of an "elaboration process". -- **The second part presents the interactive proof mode**, the central +- **The second part presents proof mode**, the central feature of Coq. :ref:`writing-proofs` introduces this interactive - proof mode and the available proof languages. + mode and the available proof languages. :ref:`automatic-tactics` presents some more advanced tactics, while :ref:`writing-tactics` is about the languages that allow a user to combine tactics together and develop new ones. diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 85b04f6df0..1cfd8dac50 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -101,7 +101,7 @@ and it can be applied to any expression of type :math:`\nat`, say :math:`t`, to object :math:`P~t` of type :math:`\Prop`, namely a proposition. Furthermore :g:`forall x:nat, P x` will represent the type of functions -which associate to each natural number :math:`n` an object of type :math:`(P~n)` and +which associate with each natural number :math:`n` an object of type :math:`(P~n)` and consequently represent the type of proofs of the formula “:math:`∀ x.~P(x)`”. @@ -111,51 +111,49 @@ Typing rules ---------------- As objects of type theory, terms are subjected to *type discipline*. -The well typing of a term depends on a global environment and a local -context. - +The well typing of a term depends on a local context and a global environment. .. _Local-context: **Local context.** -A *local context* is an ordered list of *local declarations* of names -which we call *variables*. The declaration of some variable :math:`x` is -either a *local assumption*, written :math:`x:T` (:math:`T` is a type) or a *local -definition*, written :math:`x:=t:T`. We use brackets to write local contexts. -A typical example is :math:`[x:T;~y:=u:U;~z:V]`. Notice that the variables +A :term:`local context` is an ordered list of declarations of *variables*. +The declaration of a variable :math:`x` is +either an *assumption*, written :math:`x:T` (where :math:`T` is a type) or a +*definition*, written :math:`x:=t:T`. Local contexts are written in brackets, +for example :math:`[x:T;~y:=u:U;~z:V]`. The variables declared in a local context must be distinct. If :math:`Γ` is a local context -that declares some :math:`x`, we -write :math:`x ∈ Γ`. By writing :math:`(x:T) ∈ Γ` we mean that either :math:`x:T` is an -assumption in :math:`Γ` or that there exists some :math:`t` such that :math:`x:=t:T` is a -definition in :math:`Γ`. If :math:`Γ` defines some :math:`x:=t:T`, we also write :math:`(x:=t:T) ∈ Γ`. +that declares :math:`x`, we +write :math:`x ∈ Γ`. Writing :math:`(x:T) ∈ Γ` means there is an assumption +or a definition giving the type :math:`T` to :math:`x` in :math:`Γ`. +If :math:`Γ` defines :math:`x:=t:T`, we also write :math:`(x:=t:T) ∈ Γ`. For the rest of the chapter, :math:`Γ::(y:T)` denotes the local context :math:`Γ` enriched with the local assumption :math:`y:T`. Similarly, :math:`Γ::(y:=t:T)` denotes the local context :math:`Γ` enriched with the local definition :math:`(y:=t:T)`. The -notation :math:`[]` denotes the empty local context. By :math:`Γ_1 ; Γ_2` we mean +notation :math:`[]` denotes the empty local context. Writing :math:`Γ_1 ; Γ_2` means concatenation of the local context :math:`Γ_1` and the local context :math:`Γ_2`. - .. _Global-environment: **Global environment.** -A *global environment* is an ordered list of *global declarations*. -Global declarations are either *global assumptions* or *global -definitions*, but also declarations of inductive objects. Inductive -objects themselves declare both inductive or coinductive types and -constructors (see Section :ref:`inductive-definitions`). - -A *global assumption* will be represented in the global environment as -:math:`(c:T)` which assumes the name :math:`c` to be of some type :math:`T`. A *global -definition* will be represented in the global environment as :math:`c:=t:T` -which defines the name :math:`c` to have value :math:`t` and type :math:`T`. We shall call +A :term:`global environment` is an ordered list of *declarations*. +Global declarations are either *assumptions*, *definitions* +or declarations of inductive objects. Inductive +objects declare both constructors and inductive or +coinductive types (see Section :ref:`inductive-definitions`). + +In the global environment, +*assumptions* are written as +:math:`(c:T)`, indicating that :math:`c` is of the type :math:`T`. *Definitions* +are written as :math:`c:=t:T`, indicating that :math:`c` has the value :math:`t` +and type :math:`T`. We shall call such names *constants*. For the rest of the chapter, the :math:`E;~c:T` denotes -the global environment :math:`E` enriched with the global assumption :math:`c:T`. +the global environment :math:`E` enriched with the assumption :math:`c:T`. Similarly, :math:`E;~c:=t:T` denotes the global environment :math:`E` enriched with the -global definition :math:`(c:=t:T)`. +definition :math:`(c:=t:T)`. The rules for inductive definitions (see Section :ref:`inductive-definitions`) have to be considered as assumption -rules to which the following definitions apply: if the name :math:`c` +rules in which the following definitions apply: if the name :math:`c` is declared in :math:`E`, we write :math:`c ∈ E` and if :math:`c:T` or :math:`c:=t:T` is declared in :math:`E`, we write :math:`(c : T) ∈ E`. @@ -315,7 +313,7 @@ following rules. .. note:: We may have :math:`\letin{x}{t:T}{u}` well-typed without having :math:`((λ x:T.~u)~t)` well-typed (where :math:`T` is a type of - :math:`t`). This is because the value :math:`t` associated to + :math:`t`). This is because the value :math:`t` associated with :math:`x` may be used in a conversion rule (see Section :ref:`Conversion-rules`). diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index d061ed41f1..4f54e33758 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -902,7 +902,6 @@ In addition to the powerful ``ring``, ``field`` and ``lra`` tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: discrR - :name: discrR Proves that two real integer constants are different. @@ -916,7 +915,6 @@ tactics (see Chapter :ref:`tactics`), there are also: discrR. .. tacn:: split_Rabs - :name: split_Rabs Allows unfolding the ``Rabs`` constant and splits corresponding conjunctions. @@ -930,7 +928,6 @@ tactics (see Chapter :ref:`tactics`), there are also: intro; split_Rabs. .. tacn:: split_Rmult - :name: split_Rmult Splits a condition that a product is non null into subgoals corresponding to the condition on each operand of the product. diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index e86a6f4a67..7566996ef6 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -9,7 +9,7 @@ Binders .. insertprodn open_binders binder .. prodn:: - open_binders ::= {+ @name } : @term + open_binders ::= {+ @name } : @type | {+ @binder } name ::= _ | @ident @@ -115,10 +115,10 @@ Section :ref:`explicit-applications`). Assumptions ----------- -Assumptions extend the environment with axioms, parameters, hypotheses +Assumptions extend the global environment with axioms, parameters, hypotheses or variables. An assumption binds an :n:`@ident` to a :n:`@type`. It is accepted -by Coq if and only if this :n:`@type` is a correct type in the environment -preexisting the declaration and if :n:`@ident` was not previously defined in +by Coq only if :n:`@type` is a correct type in the global environment +before the declaration and if :n:`@ident` was not previously defined in the same module. This :n:`@type` is considered to be the type (or specification, or statement) assumed by :n:`@ident` and we say that :n:`@ident` has type :n:`@type`. @@ -141,7 +141,7 @@ has type :n:`@type`. of_type ::= {| : | :> } @type These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in - the global context. The fact asserted by :n:`@type` (or, equivalently, the existence + the global environment. The fact asserted by :n:`@type` (or, equivalently, the existence of an object of this type) is accepted as a postulate. They accept the :attr:`program` attribute. :cmd:`Axiom`, :cmd:`Conjecture`, :cmd:`Parameter` and their plural forms diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 2b262b89c0..2b50d4c420 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -64,7 +64,7 @@ appending the level to the nonterminal name (as in :n:`@term100` or populated by notations or plugins. Furthermore, some parsing rules are only activated in certain - contexts (:ref:`interactive proof mode <proofhandling>`, + contexts (:ref:`proof mode <proofhandling>`, :ref:`custom entries <custom-entries>`...). .. warning:: @@ -332,9 +332,9 @@ rest of the Coq manual: :term:`terms <term>` and :term:`types tactic - Tactics specify how to transform the current proof state as a + A :production:`tactic` specifies how to transform the current proof state as a step in creating a proof. They are syntactically valid only when - Coq is in proof mode, such as after a :cmd:`Theorem` command + Coq is in :term:`proof mode`, such as after a :cmd:`Theorem` command and before any subsequent proof-terminating command such as :cmd:`Qed`. See :ref:`proofhandling` for more on proof mode. @@ -450,7 +450,6 @@ they appear after a boldface label. They are listed in the :ref:`options_index`. .. cmd:: Set @setting_name {? {| @integer | @string } } - :name: Set If :n:`@setting_name` is a flag, no value may be provided; the flag is set to on. @@ -471,7 +470,6 @@ they appear after a boldface label. They are listed in the Coq versions. .. cmd:: Unset @setting_name - :name: Unset If :n:`@setting_name` is a flag, it is set to off. If :n:`@setting_name` is an option, it is set to its default value. @@ -525,31 +523,20 @@ they appear after a boldface label. They are listed in the Locality attributes supported by :cmd:`Set` and :cmd:`Unset` ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -The :cmd:`Set` and :cmd:`Unset` commands support the :attr:`local`, -:attr:`global` and :attr:`export` locality attributes: - -* no attribute: the original setting is *not* restored at the end of - the current module or section. -* :attr:`local` (or alternatively, the ``Local`` prefix): the setting - is applied within the current module or section. The original value - of the setting is restored at the end of the current module or - section. -* :attr:`export` (or alternatively, the ``Export`` prefix): similar to - :attr:`local`, the original value of the setting is restored at the - end of the current module or section. In addition, if the value is - set in a module, then :cmd:`Import`\-ing the module sets the option - or flag. -* :attr:`global` (or alternatively, the ``Global`` prefix): the - original setting is *not* restored at the end of the current module - or section. In addition, if the value is set in a file, then - :cmd:`Require`\-ing the file sets the option. +The :cmd:`Set` and :cmd:`Unset` commands support the mutually +exclusive :attr:`local`, :attr:`export` and :attr:`global` locality +attributes (or the ``Local``, ``Export`` or ``Global`` prefixes). + +If no attribute is specified, the original value of the flag or option +is restored at the end of the current module but it is *not* restored +at the end of the current section. Newly opened modules and sections inherit the current settings. .. note:: - We discourage using the :attr:`global` attribute with the :cmd:`Set` and - :cmd:`Unset` commands. If your goal is to define + We discourage using the :attr:`global` locality attribute with the + :cmd:`Set` and :cmd:`Unset` commands. If your goal is to define project-wide settings, you should rather use the command-line arguments ``-set`` and ``-unset`` for setting flags and options (see :ref:`command-line-options`). diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index cf46580bdb..e742139134 100644 --- a/doc/sphinx/language/core/coinductive.rst +++ b/doc/sphinx/language/core/coinductive.rst @@ -194,7 +194,7 @@ Top-level definitions of co-recursive functions As in the :cmd:`Fixpoint` command, the :n:`with` clause allows simultaneously defining several mutual cofixpoints. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 7395b12339..09c619338b 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -47,7 +47,7 @@ refer the interested reader to :cite:`Coq85`. ι-reduction ~~~~~~~~~~~ -A specific conversion rule is associated to the inductive objects in +A specific conversion rule is associated with the inductive objects in the global environment. We shall give later on (see Section :ref:`Well-formed-inductive-definitions`) the precise rules but it just says that a destructor applied to an object built from a @@ -159,7 +159,8 @@ relation :math:`t` reduces to :math:`u` in the global environment reductions β, δ, ι or ζ. We say that two terms :math:`t_1` and :math:`t_2` are -*βδιζη-convertible*, or simply :gdef:`convertible`, or *equivalent*, in the +*βδιζη-convertible*, or simply :gdef:`convertible`, or +:term:`definitionally equal <definitional equality>`, in the global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 6da1f90ecb..7196c082ed 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -56,7 +56,7 @@ has type :n:`@type`. Top-level definitions --------------------- -Definitions extend the environment with associations of names to terms. +Definitions extend the global environment with associations of names to terms. A definition can be seen as a way to give a meaning to a name or as a way to abbreviate a term. In any case, the name can later be replaced at any time by its definition. @@ -82,7 +82,7 @@ Section :ref:`typing-rules`. | {* @binder } : @type reduce ::= Eval @red_expr in - These commands bind :n:`@term` to the name :n:`@ident` in the environment, + These commands bind :n:`@term` to the name :n:`@ident` in the global environment, provided that :n:`@term` is well-typed. They can take the :attr:`local` :term:`attribute`, which makes the defined :n:`@ident` accessible by :cmd:`Import` and its variants only through their fully qualified names. @@ -94,7 +94,7 @@ Section :ref:`typing-rules`. :attr:`bypass_check(universes)`, :attr:`bypass_check(guard)`, and :attr:`using` attributes. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -120,10 +120,11 @@ Section :ref:`typing-rules`. Assertions and proofs --------------------- -An assertion states a proposition (or a type) of which the proof (or an -inhabitant of the type) is interactively built using tactics. The interactive -proof mode is described in Chapter :ref:`proofhandling` and the tactics in -Chapter :ref:`Tactics`. The basic assertion command is: +An assertion states a proposition (or a type) for which the proof (or an +inhabitant of the type) is interactively built using :term:`tactics <tactic>`. +Assertions cause Coq to enter :term:`proof mode` (see :ref:`proofhandling`). +Common tactics are described in the :ref:`writing-proofs` chapter. +The basic assertion command is: .. cmd:: @thm_token @ident_decl {* @binder } : @type {* with @ident_decl {* @binder } : @type } :name: Theorem; Lemma; Fact; Remark; Corollary; Proposition; Property @@ -142,7 +143,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: After the statement is asserted, Coq needs a proof. Once a proof of :n:`@type` under the assumptions represented by :n:`@binder`\s is given and validated, the proof is generalized into a proof of :n:`forall {* @binder }, @type` and - the theorem is bound to the name :n:`@ident` in the environment. + the theorem is bound to the name :n:`@ident` in the global environment. These commands accept the :attr:`program` attribute. See :ref:`program_lemma`. @@ -159,7 +160,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: have to be used on *structurally smaller* arguments (for a :cmd:`Fixpoint`) or be *guarded by a constructor* (for a :cmd:`CoFixpoint`). The verification that recursive proof arguments are correct is done only at the time of registering - the lemma in the environment. To know if the use of induction hypotheses is + the lemma in the global environment. To know if the use of induction hypotheses is correct at some time of the interactive development of a proof, use the command :cmd:`Guarded`. @@ -178,25 +179,24 @@ Chapter :ref:`Tactics`. The basic assertion command is: .. exn:: Nested proofs are discouraged and not allowed by default. This error probably means that you forgot to close the last "Proof." with "Qed." or "Defined.". \ If you really intended to use nested proofs, you can do so by turning the "Nested Proofs Allowed" flag on. - You are asserting a new statement while already being in proof editing mode. + You are asserting a new statement when you're already in proof mode. This feature, called nested proofs, is disabled by default. To activate it, turn the :flag:`Nested Proofs Allowed` flag on. -Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof editing mode -until the proof is completed. In proof editing mode, the user primarily enters -tactics, which are described in chapter :ref:`Tactics`. The user may also enter -commands to manage the proof editing mode. They are described in Chapter -:ref:`proofhandling`. +Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof mode +until the proof is completed. In proof mode, the user primarily enters +tactics (see :ref:`writing-proofs`). The user may also enter +commands to manage the proof mode (see :ref:`proofhandling`). When the proof is complete, use the :cmd:`Qed` command so the kernel verifies -the proof and adds it to the environment. +the proof and adds it to the global environment. .. note:: #. Several statements can be simultaneously asserted provided the :flag:`Nested Proofs Allowed` flag was turned on. - #. Not only other assertions but any vernacular command can be given + #. Not only other assertions but any command can be given while in the process of proving a given assertion. In this case, the command is understood as if it would have been given before the statements still to be proved. Nonetheless, this practice is discouraged @@ -211,4 +211,4 @@ the proof and adds it to the environment. side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the - current asserted statement into an axiom and exit the proof editing mode. + current asserted statement into an axiom and exit proof mode. diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 4bee7cc1b1..4e892f709d 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -36,7 +36,7 @@ Inductive types :attr:`private(matching)` attributes. Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. - The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. + The :n:`@ident`\s are simultaneously added to the global environment before the types of constructors are checked. Each :n:`@ident` can be used independently thereafter. See :ref:`mutually_inductive_types`. @@ -86,7 +86,7 @@ A simple inductive type belongs to a universe that is a simple :n:`@sort`. The type nat is defined as the least :g:`Set` containing :g:`O` and closed by the :g:`S` constructor. The names :g:`nat`, :g:`O` and :g:`S` are added to the - environment. + global environment. This definition generates four elimination principles: :g:`nat_rect`, :g:`nat_ind`, :g:`nat_rec` and :g:`nat_sind`. The type of :g:`nat_ind` is: @@ -413,7 +413,7 @@ constructions. It is especially useful when defining functions over mutually defined inductive types. Example: :ref:`Mutual Fixpoints<example_mutual_fixpoints>`. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -636,7 +636,7 @@ contains an inductive definition. .. example:: - Provided that our environment :math:`E` contains inductive definitions we showed before, + Provided that our global environment :math:`E` contains inductive definitions we showed before, these two inference rules above enable us to conclude that: .. math:: diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 6d96e15202..2e678c49d8 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -283,7 +283,6 @@ are now available through the dot notation. Check A.B.U. .. cmd:: Export {+ @filtered_import } - :name: Export Similar to :cmd:`Import`, except that when the module containing this command is imported, the :n:`{+ @qualid }` are imported as well. @@ -465,7 +464,7 @@ We also need additional typing judgments: + :math:`\WFT{E}{S}`, denoting that a structure :math:`S` is well-formed, + :math:`\WTM{E}{p}{S}`, denoting that the module pointed by :math:`p` has type :math:`S` in - environment :math:`E`. + the global environment :math:`E`. + :math:`\WEV{E}{S}{\ovl{S}}`, denoting that a structure :math:`S` is evaluated to a structure :math:`S` in weak head normal form. + :math:`\WS{E}{S_1}{S_2}` , denoting that a structure :math:`S_1` is a subtype of a @@ -881,7 +880,7 @@ started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-opt .. _qualified-names: Qualified identifiers ---------------------- +~~~~~~~~~~~~~~~~~~~~~ .. insertprodn qualid field_ident @@ -965,7 +964,7 @@ names. A logical prefix Lib can be associated with a physical path using the command line option ``-Q`` `path` ``Lib``. All subfolders of path are -recursively associated to the logical path ``Lib`` extended with the +recursively associated with the logical path ``Lib`` extended with the corresponding suffix coming from the physical path. For instance, the folder ``path/fOO/Bar`` maps to ``Lib.fOO.Bar``. Subdirectories corresponding to invalid Coq identifiers are skipped, and, by convention, @@ -973,7 +972,7 @@ subdirectories named ``CVS`` or ``_darcs`` are skipped too. Thanks to this mechanism, ``.vo`` files are made available through the logical name of the folder they are in, extended with their own -basename. For example, the name associated to the file +basename. For example, the name associated with the file ``path/fOO/Bar/File.vo`` is ``Lib.fOO.Bar.File``. The same caveat applies for invalid identifiers. When compiling a source file, the ``.vo`` file stores its logical name, so that an error is issued if it is loaded with the @@ -1011,3 +1010,73 @@ subdirectories of path). See the command :cmd:`Declare ML Module` in See :ref:`command-line-options` for a more general view over the Coq command line options. + +.. _controlling-locality-of-commands: + +Controlling the scope of commands with locality attributes +---------------------------------------------------------- + +Many commands have effects that apply only within a specific scope, +typically the section or the module in which the command was +called. Locality :term:`attributes <attribute>` can alter the scope of +the effect. Below, we give the semantics of each locality attribute +while noting a few exceptional commands for which :attr:`local` and +:attr:`global` attributes are interpreted differently. + +.. attr:: local + + The :attr:`local` attribute limits the effect of the command to the + current scope (section or module). + + The ``Local`` prefix is an alternative syntax for the :attr:`local` + attribute (see :n:`@legacy_attr`). + + .. note:: + + - For some commands, this is the only locality supported within + sections (e.g., for :cmd:`Notation`, :cmd:`Ltac` and + :ref:`Hint <creating_hints>` commands). + + - For some commands, this is the default locality within + sections even though other locality attributes are supported + as well (e.g., for the :cmd:`Arguments` command). + + .. warning:: + + **Exception:** when :attr:`local` is applied to + :cmd:`Definition`, :cmd:`Theorem` or their variants, its + semantics are different: it makes the defined objects available + only through their fully-qualified names rather than their + unqualified names after an :cmd:`Import`. + +.. attr:: export + + The :attr:`export` attribute makes the effect of the command + persist when the section is closed and applies the effect when the + module containing the command is imported. + + Commands supporting this attribute include :cmd:`Set`, :cmd:`Unset` + and the :ref:`Hint <creating_hints>` commands, although the latter + don't support it within sections. + +.. attr:: global + + The :attr:`global` attribute makes the effect of the command + persist even when the current section or module is closed. Loading + the file containing the command (possibly transitively) applies the + effect of the command. + + The ``Global`` prefix is an alternative syntax for the + :attr:`global` attribute (see :n:`@legacy_attr`). + + .. warning:: + + **Exception:** for a few commands (like :cmd:`Notation` and + :cmd:`Ltac`), this attribute behaves like :attr:`export`. + + .. warning:: + + We strongly discourage using the :attr:`global` locality + attribute because the transitive nature of file loading gives + the user little control. We recommend using the :attr:`export` + locality attribute where it is supported. diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index 7eedbcd59a..6671c67fb2 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -119,13 +119,11 @@ The following settings let you control the display format for types: You can override the display format for specified types by adding entries to these tables: .. table:: Printing Record @qualid - :name: Printing Record Specifies a set of qualids which are displayed as records. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. .. table:: Printing Constructor @qualid - :name: Printing Constructor Specifies a set of qualids which are displayed as constructors. Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. @@ -208,7 +206,7 @@ other arguments are the parameters of the inductive type. This message is followed by an explanation of this impossibility. There may be three reasons: - #. The name :token:`ident` already exists in the environment (see :cmd:`Axiom`). + #. The name :token:`ident` already exists in the global environment (see :cmd:`Axiom`). #. The body of :token:`ident` uses an incorrect elimination for :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). #. The type of the projections :token:`ident` depends on previous diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst index 75389bb259..c16152ff4f 100644 --- a/doc/sphinx/language/core/sections.rst +++ b/doc/sphinx/language/core/sections.rst @@ -3,57 +3,33 @@ Section mechanism ----------------- -Sections create local contexts which can be shared across multiple definitions. - -.. example:: - - Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. - - .. coqtop:: all - - Section s1. - - Inside a section, local parameters can be introduced using :cmd:`Variable`, - :cmd:`Hypothesis`, or :cmd:`Context` (there are also plural variants for - the first two). - - .. coqtop:: all - - Variables x y : nat. - - The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions - won't persist when the section is closed, and all persistent definitions which - depend on `y'` will be prefixed with `let y' := y in`. - - .. coqtop:: in - - Let y' := y. - Definition x' := S x. - Definition x'' := x' + y'. - - .. coqtop:: all - - Print x'. - Print x''. - - End s1. - - Print x'. - Print x''. - - Notice the difference between the value of :g:`x'` and :g:`x''` inside section - :g:`s1` and outside. +Sections are naming scopes that permit creating section-local declarations that can +be used by other declarations in the section. Declarations made +with :cmd:`Variable`, :cmd:`Hypothesis`, :cmd:`Context`, +:cmd:`Let`, :cmd:`Let Fixpoint` and +:cmd:`Let CoFixpoint` (or the plural variants of the first two) within sections +are local to the section. + +In proofs done within the section, section-local declarations +are included in the :term:`local context` of the initial goal of the proof. +They are also accessible in definitions made with the :cmd:`Definition` command. + +Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. +Sections can be nested. +When a section is closed, its local declarations are no longer available. +Global declarations that refer to them will be adjusted so they're still +usable outside the section as shown in this :ref:`example <section_local_declarations>`. .. cmd:: Section @ident - This command is used to open a section named :token:`ident`. + Opens the section named :token:`ident`. Section names do not need to be unique. .. cmd:: End @ident - This command closes the section or module named :token:`ident`. - See :ref:`Terminating an interactive module or module type definition<terminating_module>` + Closes the section or module named :token:`ident`. + See :ref:`Terminating an interactive module or module type definition <terminating_module>` for a description of its use with modules. After closing the @@ -78,14 +54,14 @@ Sections create local contexts which can be shared across multiple definitions. Let CoFixpoint @cofix_definition {* with @cofix_definition } :name: Let; Let Fixpoint; Let CoFixpoint - These commands behave like :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that + These are similar to :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that the declared constant is local to the current section. When the section is closed, all persistent definitions and theorems within it that depend on the constant will be wrapped with a :n:`@term_let` with the same declaration. As for :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, - if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -103,3 +79,38 @@ Sections create local contexts which can be shared across multiple definitions. Context (b' := b). .. seealso:: Section :ref:`binders`. Section :ref:`contexts` in chapter :ref:`typeclasses`. + +.. _section_local_declarations: + +.. example:: Section-local declarations + + .. coqtop:: all + + Section s1. + + .. coqtop:: all + + Variables x y : nat. + + The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions + won't persist when the section is closed, and all persistent definitions which + depend on `y'` will be prefixed with `let y' := y in`. + + .. coqtop:: in + + Let y' := y. + Definition x' := S x. + Definition x'' := x' + y'. + + .. coqtop:: all + + Print x'. + Print x''. + + End s1. + + Print x'. + Print x''. + + Notice the difference between the value of :g:`x'` and :g:`x''` inside section + :g:`s1` and outside. diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index d178311b4c..214541570c 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -4,7 +4,6 @@ Setting properties of a function's arguments ++++++++++++++++++++++++++++++++++++++++++++ .. cmd:: Arguments @reference {* @arg_specs } {* , {* @implicits_alt } } {? : {+, @args_modifier } } - :name: Arguments .. insertprodn argument_spec args_modifier diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index aa754ab63d..4cc35794cc 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -199,8 +199,8 @@ but also that the infix relation was bound to the ``nat_eq`` relation. This relation is selected whenever ``==`` is used on terms of type nat. This can be read in the line declaring the canonical structure ``nat_EQty``, where the first argument to ``Pack`` is the key and its second -argument a group of canonical values associated to the key. In this -case we associate to nat only one canonical value (since its class, +argument a group of canonical values associated with the key. In this +case we associate with nat only one canonical value (since its class, ``nat_EQcl`` has just one member). The use of the projection ``op`` requires its argument to be in the class ``EQ``, and uses such a member (function) to actually compare its arguments. @@ -530,7 +530,7 @@ instances of the ``LEQ`` class. The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers all the other pieces of the class ``LEQ`` and declares them as canonical -values associated to the ``T`` key. All in all, the only new piece of +values associated with the ``T`` key. All in all, the only new piece of information we add in the ``LEQ`` class is the mixin, all the rest is already canonical for ``T`` and hence can be inferred by Coq. diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst index fd9695e270..7206fb8581 100644 --- a/doc/sphinx/language/extensions/evars.rst +++ b/doc/sphinx/language/extensions/evars.rst @@ -5,6 +5,9 @@ Existential variables --------------------- +:gdef:`Existential variables <existential variable>` represent as yet unknown +values. + .. insertprodn term_evar term_evar .. prodn:: diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index 23ba5f703a..765d04ec88 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -66,7 +66,7 @@ would be a solution of the inference problem. **Contextual Implicit Arguments** An implicit argument can be *contextual* or not. An implicit argument -is said *contextual* if it can be inferred only from the knowledge of +is said to be *contextual* if it can be inferred only from the knowledge of the type of the context of the current expression. For instance, the only argument of:: @@ -384,7 +384,7 @@ Displaying implicit arguments when pretty-printing .. flag:: Printing Implicit - By default, the basic pretty-printing rules hide the inferrable implicit + By default, the basic pretty-printing rules hide the inferable implicit arguments of an application. Turn this flag on to force printing all implicit arguments. @@ -506,7 +506,7 @@ or :g:`m` to the type :g:`nat` of natural numbers). .. flag:: Printing Use Implicit Types By default, the type of bound variables is not printed when - the variable name is associated to an implicit type which matches the + the variable name is associated with an implicit type which matches the actual type of the variable. This feature can be deactivated by turning this flag off. diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index 8e62c2af13..1c022448b0 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -252,7 +252,6 @@ If an inductive type has just one constructor, pattern matching can be written using the first destructuring let syntax. .. table:: Printing Let @qualid - :name: Printing Let Specifies a set of qualids for which pattern matching is displayed using a let expression. Note that this only applies to pattern matching instances entered with :g:`match`. @@ -269,7 +268,6 @@ can be written using ``if`` … ``then`` … ``else`` …. This table controls which types are written this way: .. table:: Printing If @qualid - :name: Printing If Specifies a set of qualids for which pattern matching is displayed using ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add` and :cmd:`Remove` @@ -720,7 +718,7 @@ Recall that a list of patterns is also a pattern. So, when we destructure several terms at the same time and the branches have different types we need to provide the elimination predicate for this multiple pattern. It is done using the same scheme: each term may be -associated to an ``as`` clause and an ``in`` clause in order to introduce +associated with an ``as`` clause and an ``in`` clause in order to introduce a dependent product. For example, an equivalent definition for :g:`concat` (even though the diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index d20a82e6c0..a10312972e 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -43,7 +43,7 @@ Batch compilation (coqc) ------------------------ The ``coqc`` command takes a name *file* as argument. Then it looks for a -vernacular file named *file*.v, and tries to compile it into a +file named *file*.v, and tries to compile it into a *file*.vo file (See :ref:`compiled-files`). .. caution:: @@ -219,6 +219,71 @@ and ``coqtop``, unless stated otherwise: :-batch: Exit just after argument parsing. Available for ``coqtop`` only. :-verbose: Output the content of the input file as it is compiled. This option is available for ``coqc`` only. +:-native-compiler (yes|no|ondemand): Enable the :tacn:`native_compute` + reduction machine and precompilation to ``.cmxs`` files for future use + by :tacn:`native_compute`. + Setting ``yes`` enables :tacn:`native_compute`; it also causes Coq + to precompile the native code for future use; all dependencies need + to have been precompiled beforehand. Setting ``no`` disables + :tacn:`native_compute` which defaults back to :tacn:`vm_compute`; no files are precompiled. + Setting ``ondemand`` enables :tacn:`native_compute` + but disables precompilation; all missing dependencies will be recompiled + every time :tacn:`native_compute` is called. + + .. _native-compiler-options: + + .. versionchanged:: 8.13 + + The default value is set at configure time, + ``-config`` can be used to retrieve it. + All this can be summarized in the following table: + + .. list-table:: + :header-rows: 1 + + * - ``configure`` + - ``coqc`` + - ``native_compute`` + - outcome + - requirements + * - yes + - yes (default) + - native_compute + - ``.cmxs`` + - ``.cmxs`` of deps + * - yes + - no + - vm_compute + - none + - none + * - yes + - ondemand + - native_compute + - none + - none + * - no + - yes, no, ondemand + - vm_compute + - none + - none + * - ondemand + - yes + - native_compute + - ``.cmxs`` + - ``.cmxs`` of deps + * - ondemand + - no + - vm_compute + - none + - none + * - ondemand + - ondemand (default) + - native_compute + - none + - none + +:-native-output-dir: Set the directory in which to put the aforementioned + ``.cmxs`` for :tacn:`native_compute`. Defaults to ``.coq-native``. :-vos: Indicate Coq to skip the processing of opaque proofs (i.e., proofs ending with :cmd:`Qed` or :cmd:`Admitted`), output a ``.vos`` files instead of a ``.vo`` file, and to load ``.vos`` files instead of ``.vo`` files @@ -434,7 +499,7 @@ wrong. In the current version, it does not modify the compiled libraries to mark them as successfully checked. Note that non-logical information is not checked. By logical -information, we mean the type and optional body associated to names. +information, we mean the type and optional body associated with names. It excludes for instance anything related to the concrete syntax of objects (customized syntax rules, association between short and long names), implicit arguments, etc. diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index c239797cc2..dcc60195ed 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -7,7 +7,7 @@ Coq Integrated Development Environment The Coq Integrated Development Environment is a graphical tool, to be used as a user-friendly replacement to `coqtop`. Its main purpose is to -allow the user to navigate forward and backward into a Coq vernacular +allow the user to navigate forward and backward into a Coq file, executing corresponding commands or undoing them respectively. CoqIDE is run by typing the command `coqide` on the command line. @@ -100,10 +100,10 @@ processed color, though their preceding proofs have the processed color. Notice that for all these buttons, except for the "gears" button, their operations are also available in the menu, where their keyboard shortcuts are given. -Vernacular commands, templates ------------------------------------ +Commands and templates +---------------------- -The Templates menu allows using shortcuts to insert vernacular +The Templates menu allows using shortcuts to insert commands. This is a nice way to proceed if you are not sure of the syntax of the command you want. @@ -116,7 +116,7 @@ Queries .. image:: ../_static/coqide-queries.png :alt: CoqIDE queries -We call *query* any vernacular command that does not change the current state, +We call *query* any command that does not change the current state, such as ``Check``, ``Search``, etc. To run such commands interactively, without writing them in scripts, CoqIDE offers a *query pane*. The query pane can be displayed on demand by using the ``View`` menu, or using the shortcut ``F1``. diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index b63ae32311..2046788ef3 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -339,7 +339,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Hint Rewrite Ack0 Ack1 Ack2 : base0. + Global Hint Rewrite Ack0 Ack1 Ack2 : base0. .. coqtop:: all @@ -367,7 +367,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Hint Rewrite g0 g1 g2 using lia : base1. + Global Hint Rewrite g0 g1 g2 using lia : base1. .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 87a367fc93..013ff0a83f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -284,6 +284,8 @@ A sequence is an expression of the following form: .. tacn:: @ltac_expr3__1 ; {| @ltac_expr3__2 | @binder_tactic } :name: ltac-seq + .. todo: can't use "… ; …" as the name because of the semicolon + The expression :n:`@ltac_expr3__1` is evaluated to :n:`v__1`, which must be a tactic value. The tactic :n:`v__1` is applied to the current goals, possibly producing more goals. Then the right-hand side is evaluated to @@ -481,7 +483,6 @@ Do loop ~~~~~~~ .. tacn:: do @nat_or_var @ltac_expr3 - :name: do The do loop repeats a tactic :token:`nat_or_var` times: @@ -497,7 +498,6 @@ Repeat loop ~~~~~~~~~~~ .. tacn:: repeat @ltac_expr3 - :name: repeat The repeat loop repeats a tactic until it fails. @@ -515,7 +515,6 @@ Catching errors: try We can catch the tactic errors with: .. tacn:: try @ltac_expr3 - :name: try :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused goal independently. If the application of @@ -531,7 +530,6 @@ Detecting progress We can check if a tactic made progress with: .. tacn:: progress @ltac_expr3 - :name: progress :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused subgoal independently. If the application of ``v`` @@ -641,7 +639,6 @@ First tactic to succeed In some cases backtracking may be too expensive. .. tacn:: first [ {*| @ltac_expr } ] - :name: first For each focused goal, independently apply the first :token:`ltac_expr` that succeeds. The :n:`@ltac_expr`\s must evaluate to tactic values. @@ -701,7 +698,6 @@ Selects and applies the first tactic that solves each goal (i.e. leaves no subgo in a series of alternative tactics: .. tacn:: solve [ {*| @ltac_expr__i } ] - :name: solve For each current subgoal: evaluates and applies each :n:`@ltac_expr` in order until one is found that solves the subgoal. @@ -743,7 +739,6 @@ Conditional branching: tryif ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: tryif @ltac_expr__test then @ltac_expr__then else @ltac_expr2__else - :name: tryif For each focused goal, independently: Evaluate and apply :n:`@ltac_expr__test`. If :n:`@ltac_expr__test` succeeds at least once, evaluate and apply :n:`@ltac_expr__then` @@ -772,7 +767,6 @@ Another way of restricting backtracking is to restrict a tactic to a single success: .. tacn:: once @ltac_expr3 - :name: once :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied but only its first success is used. If ``v`` fails, @@ -788,7 +782,6 @@ Coq provides an experimental way to check that a tactic has *exactly one* success: .. tacn:: exactly_once @ltac_expr3 - :name: exactly_once :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied if it has at most one success. If ``v`` fails, @@ -816,7 +809,6 @@ Checking for failure: assert_fails Coq defines an |Ltac| tactic in `Init.Tactics` to check that a tactic *fails*: .. tacn:: assert_fails @ltac_expr3 - :name: assert_fails If :n:`@ltac_expr3` fails, the proof state is unchanged and no message is printed. If :n:`@ltac_expr3` unexpectedly has at least one success, the tactic performs @@ -863,7 +855,6 @@ Coq defines an |Ltac| tactic in `Init.Tactics` to check that a tactic has *at le success: .. tacn:: assert_succeeds @ltac_expr3 - :name: assert_succeeds If :n:`@ltac_expr3` has at least one success, the proof state is unchanged and no message is printed. If :n:`@ltac_expr3` fails, the tactic performs @@ -877,7 +868,6 @@ Print/identity tactic: idtac .. tacn:: idtac {* {| @ident | @string | @natural } } - :name: idtac Leaves the proof unchanged and prints the given tokens. :token:`String<string>`\s and :token:`natural`\s are printed @@ -889,7 +879,7 @@ Print/identity tactic: idtac Failing ~~~~~~~ -.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @natural } } +.. tacn:: {| fail | gfail } {? @nat_or_var } {* {| @ident | @string | @natural } } :name: fail; gfail :tacn:`fail` is the always-failing tactic: it does not solve any @@ -910,7 +900,7 @@ Failing tactic into the goals, meaning that if there are no goals when it is evaluated, a tactic call like :tacn:`let` :n:`x := H in` :tacn:`fail` `0 x` will succeed. - :n:`@int_or_var` + :n:`@nat_or_var` The failure level. If no level is specified, it defaults to 0. The level is used by :tacn:`try`, :tacn:`repeat`, :tacn:`match goal` and the branching tacticals. If 0, it makes :tacn:`match goal` consider the next clause @@ -974,7 +964,6 @@ We can force a tactic to stop if it has not finished after a certain amount of time: .. tacn:: timeout @nat_or_var @ltac_expr3 - :name: timeout :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied normally, except that it is interrupted after :n:`@nat_or_var` seconds @@ -998,7 +987,6 @@ Timing a tactic A tactic execution can be timed: .. tacn:: time {? @string } @ltac_expr3 - :name: time evaluates :n:`@ltac_expr3` and displays the running time of the tactic expression, whether it fails or succeeds. In case of several successes, the time for each successive @@ -1015,7 +1003,6 @@ Tactic expressions that produce terms can be timed with the experimental tactic .. tacn:: time_constr @ltac_expr - :name: time_constr which evaluates :n:`@ltac_expr ()` and displays the time the tactic expression evaluated, assuming successful evaluation. Time is in seconds and is @@ -1026,12 +1013,10 @@ tactic implemented using the following internal tactics: .. tacn:: restart_timer {? @string } - :name: restart_timer Reset a timer .. tacn:: finish_timing {? ( @string ) } {? @string } - :name: finish_timing Display an optionally named timer. The parenthesized string argument is also optional, and determines the label associated with the timer @@ -1362,7 +1347,7 @@ Pattern matching on goals and hypotheses: match goal :tacn:`lazymatch goal`, :tacn:`match goal` and :tacn:`multimatch goal` are :token:`l1_tactic`\s. - Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + Use this form to match hypotheses and/or goals in the local context. These patterns have zero or more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the differences noted below, this works the same as the corresponding :n:`@match_key @ltac_expr` construct (see :tacn:`match`). Each current goal is processed independently. @@ -1533,7 +1518,7 @@ expression returns an identifier: .. todo you can't have a :tacn: with the same name as a :gdef: for now, eg `fresh` can't be both - Returns a fresh identifier name (i.e. one that is not already used in the context + Returns a fresh identifier name (i.e. one that is not already used in the local context and not previously returned by :tacn:`fresh` in the current :token:`ltac_expr`). The fresh identifier is formed by concatenating the final :token:`ident` of each :token:`qualid` (dropping any qualified components) and each specified :token:`string`. @@ -1541,11 +1526,11 @@ expression returns an identifier: If no arguments are given, the name is a fresh derivative of the name ``H``. .. note:: We recommend generating the fresh identifier immediately before - adding it in the proof context. Using :tacn:`fresh` in a local function + adding it to the local context. Using :tacn:`fresh` in a local function may not work as you expect: - Successive :tacn:`fresh`\es give distinct names even if the names haven't - yet been added to the proof context: + Successive calls to :tacn:`fresh` give distinct names even if the names haven't + yet been added to the local context: .. coqtop:: reset none @@ -1635,7 +1620,6 @@ Testing boolean expressions: guard ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: guard @int_or_var @comparison @int_or_var - :name: guard .. insertprodn int_or_var comparison @@ -1734,7 +1718,6 @@ Defining |Ltac| symbols .. index:: ::= .. cmd:: Ltac @tacdef_body {* with @tacdef_body } - :name: Ltac .. insertprodn tacdef_body tacdef_body @@ -2248,7 +2231,6 @@ Tracing execution not printed. .. opt:: Info Level @natural - :name: Info Level This option is an alternative to the :cmd:`Info` command. @@ -2269,17 +2251,17 @@ The debugger stops, prompting for a command which can be one of the following: +-----------------+-----------------------------------------------+ -| simple newline: | go to the next step | +| newline | go to the next step | +-----------------+-----------------------------------------------+ -| h: | get help | +| h | get help | +-----------------+-----------------------------------------------+ -| x: | exit current evaluation | +| r n | advance n steps further | +-----------------+-----------------------------------------------+ -| s: | continue current evaluation without stopping | +| r string | advance up to the next call to “idtac string” | +-----------------+-----------------------------------------------+ -| r n: | advance n steps further | +| s | continue current evaluation without stopping | +-----------------+-----------------------------------------------+ -| r string: | advance up to the next call to “idtac string” | +| x | exit current evaluation | +-----------------+-----------------------------------------------+ .. exn:: Debug mode not available in the IDE @@ -2366,25 +2348,21 @@ performance issue. Unset Ltac Profiling. .. tacn:: start ltac profiling - :name: start ltac profiling This tactic behaves like :tacn:`idtac` but enables the profiler. .. tacn:: stop ltac profiling - :name: stop ltac profiling Similarly to :tacn:`start ltac profiling`, this tactic behaves like :tacn:`idtac`. Together, they allow you to exclude parts of a proof script from profiling. .. tacn:: reset ltac profile - :name: reset ltac profile Equivalent to the :cmd:`Reset Ltac Profile` command, which allows resetting the profile from tactic scripts for benchmarking purposes. .. tacn:: show ltac profile {? {| cutoff @integer | @string } } - :name: show ltac profile Equivalent to the :cmd:`Show Ltac Profile` command, which allows displaying the profile from tactic scripts for @@ -2410,11 +2388,10 @@ Run-time optimization tactic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. tacn:: optimize_heap - :name: optimize_heap This tactic behaves like :tacn:`idtac`, except that running it compacts the - heap in the OCaml run-time system. It is analogous to the Vernacular - command :cmd:`Optimize Heap`. + heap in the OCaml run-time system. It is analogous to the + :cmd:`Optimize Heap` command. .. tacn:: infoH @ltac_expr3 diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 375129c02d..1bb4216e4f 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -173,7 +173,6 @@ Type declarations One can define new types with the following commands. .. cmd:: Ltac2 Type {? rec } @tac2typ_def {* with @tac2typ_def } - :name: Ltac2 Type .. insertprodn tac2typ_def tac2rec_field @@ -301,7 +300,6 @@ Ltac2 Definitions ~~~~~~~~~~~~~~~~~ .. cmd:: Ltac2 {? mutable } {? rec } @tac2def_body {* with @tac2def_body } - :name: Ltac2 .. insertprodn tac2def_body tac2def_body @@ -322,7 +320,6 @@ Ltac2 Definitions If ``mutable`` is set, the definition can be redefined at a later stage (see below). .. cmd:: Ltac2 Set @qualid {? as @ident } := @ltac2_expr - :name: Ltac2 Set This command redefines a previous ``mutable`` definition. Mutable definitions act like dynamic binding, i.e. at runtime, the last defined @@ -557,7 +554,7 @@ Built-in quotations ltac2_quotations ::= ident : ( @lident ) | constr : ( @term ) | open_constr : ( @term ) - | pattern : ( @cpattern ) + | pat : ( @cpattern ) | reference : ( {| & @ident | @qualid } ) | ltac1 : ( @ltac1_expr_in_env ) | ltac1val : ( @ltac1_expr_in_env ) @@ -571,7 +568,7 @@ The current implementation recognizes the following built-in quotations: (type ``Init.constr``). - ``open_constr``, which parses Coq terms and produces a term potentially with holes at runtime (type ``Init.constr`` as well). -- ``pattern``, which parses Coq patterns and produces a pattern used for term +- ``pat``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). - ``reference`` Qualified names are globalized at internalization into the corresponding global reference, @@ -598,7 +595,7 @@ modes, the *strict* and the *non-strict* mode. hypotheses. If this doesn't hold, internalization will fail. To work around this error, one has to specifically use the ``&`` notation. - In non-strict mode, any simple identifier appearing in a term quotation which - is not bound in the global context is turned into a dynamic reference to a + is not bound in the global environment is turned into a dynamic reference to a hypothesis. That is to say, internalization will succeed, but the evaluation of the term at runtime will fail if there is no such variable in the dynamic context. @@ -982,7 +979,7 @@ Match over goals gmatch_hyp_pattern ::= @name : @ltac2_match_pattern Matches over goals, similar to Ltac1 :tacn:`match goal`. - Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + Use this form to match hypotheses and/or goals in the local context. These patterns have zero or more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the differences noted below, this works the same as the corresponding :n:`@ltac2_match_key @ltac2_expr` construct (see :tacn:`match!`). Each current goal is processed independently. @@ -1164,7 +1161,6 @@ Notations --------- .. cmd:: Ltac2 Notation {+ @ltac2_scope } {? : @natural } := @ltac2_expr - :name: Ltac2 Notation .. todo seems like name maybe should use lident rather than ident, considering: @@ -1487,7 +1483,7 @@ Other nonterminals that have syntactic classes are listed here. * - :n:`conversion` - :token:`ltac2_conversion` - - :token:`conversion` + - * - :n:`rewriting` - :token:`ltac2_oriented_rewriter` @@ -1679,7 +1675,6 @@ Evaluation Ltac2 features a toplevel loop that can be used to evaluate expressions. .. cmd:: Ltac2 Eval @ltac2_expr - :name: Ltac2 Eval This command evaluates the term in the current proof if there is one, or in the global environment otherwise, and displays the resulting value to the user @@ -1877,9 +1872,9 @@ In Ltac expressions .. exn:: Unbound {| value | constructor } X - * if `X` is meant to be a term from the current stactic environment, replace + * if `X` is meant to be a term from the current static environment, replace the problematic use by `'X`. - * if `X` is meant to be a hypothesis from the goal context, replace the + * if `X` is meant to be a hypothesis from the local context, replace the problematic use by `&X`. In quotations @@ -1889,7 +1884,7 @@ In quotations * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, replace the problematic use by `$X`. - * if `X` is meant to be a hypothesis from the goal context, replace the + * if `X` is meant to be a hypothesis from the local context, replace the problematic use by `&X`. Exception catching diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 07c2d268c6..bab9d35099 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -116,8 +116,8 @@ compatible with the rest of Coq, up to a few discrepancies: + New keywords (``is``) might clash with variable, constant, tactic or - tactical names, or with quasi-keywords in tactic or vernacular - notations. + tactical names, or with quasi-keywords in tactic or + notation commands. + New tactic(al)s names (:tacn:`last`, :tacn:`done`, :tacn:`have`, :tacn:`suffices`, :tacn:`suff`, :tacn:`without loss`, :tacn:`wlog`, :tacn:`congr`, :tacn:`unlock`) might clash with user tactic names. @@ -799,8 +799,9 @@ An *occurrence switch* can be: set x := {+1 3}(f 2). Notice that some occurrences of a given term may be - hidden to the user, for example because of a notation. The vernacular - ``Set Printing All`` command displays all these hidden occurrences and + hidden to the user, for example because of a notation. Setting the + :flag:`Printing All` flag causes these hidden occurrences to + be shown when the term is displayed. This setting should be used to find the correct coding of the occurrences to be selected [#1]_. @@ -1023,7 +1024,7 @@ conversely in between deductive steps. In |SSR| these moves are performed by two *tacticals* ``=>`` and ``:``, so that the bookkeeping required by a deductive step can be -directly associated to that step, and that tactics in an |SSR| +directly associated with that step, and that tactics in an |SSR| script correspond to actual logical steps in the proof rather than merely shuffle facts. Still, some isolated bookkeeping is unavoidable, such as naming variables and assumptions at the beginning of a @@ -1189,7 +1190,7 @@ The move tactic. ```````````````` .. tacn:: move - :name: move + :name: move (ssreflect) This tactic, in its defective form, behaves like the :tacn:`hnf` tactic. @@ -5502,7 +5503,7 @@ equivalences are indeed taken into account, otherwise only single string that contains symbols or is followed by a scope key, is interpreted as the constant whose notation involves that string (e.g., :g:`+` for :g:`addn`), if this is unambiguous; otherwise the diagnostic - includes the output of the :cmd:`Locate` vernacular command. + includes the output of the :cmd:`Locate` command. + whose statement, including assumptions and types, contains a subterm matching the next patterns. If a pattern is prefixed by ``-``, the test is reversed; diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index d8c4fb61c2..071fcbee11 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3,35 +3,46 @@ Tactics ======== -A deduction rule is a link between some (unique) formula, that we call -the *conclusion* and (several) formulas that we call the *premises*. A -deduction rule can be read in two ways. The first one says: “if I know -this and this then I can deduce this”. For instance, if I have a proof -of A and a proof of B then I have a proof of A ∧ B. This is forward -reasoning from premises to conclusion. The other way says: “to prove -this I have to prove this and this”. For instance, to prove A ∧ B, I -have to prove A and I have to prove B. This is backward reasoning from -conclusion to premises. We say that the conclusion is the *goal* to -prove and premises are the *subgoals*. The tactics implement *backward -reasoning*. When applied to a goal, a tactic replaces this goal with -the subgoals it generates. We say that a tactic reduces a goal to its -subgoal(s). - -Each (sub)goal is denoted with a number. The current goal is numbered -1. By default, a tactic is applied to the current goal, but one can -address a particular goal in the list by writing n:tactic which means -“apply tactic tactic to goal number n”. We can show the list of -subgoals by typing Show (see Section :ref:`requestinginformation`). - -Since not every rule applies to a given statement, not every tactic can -be used to reduce a given goal. In other words, before applying a tactic -to a given goal, the system checks that some *preconditions* are -satisfied. If it is not the case, the tactic raises an error message. - -Tactics are built from atomic tactics and tactic expressions (which -extends the folklore notion of tactical) to combine those atomic -tactics. This chapter is devoted to atomic tactics. The tactic -language will be described in Chapter :ref:`ltac`. +Tactics specify how to transform the :term:`proof state` of an +incomplete proof to eventually generate a complete proof. + +Proofs can be developed in two basic ways: In :gdef:`forward reasoning`, +the proof begins by proving simple statements that are then combined to prove the +theorem statement as the last step of the proof. With forward reasoning, +for example, +the proof of `A /\\ B` would begin with proofs of `A` and `B`, which are +then used to prove `A /\\ B`. Forward reasoning is probably the most common +approach in human-generated proofs. + +In :gdef:`backward reasoning`, the proof begins with the theorem statement +as the goal, which is then gradually transformed until every subgoal generated +along the way has been proven. In this case, the proof of `A /\\ B` begins +with that formula as the goal. This can be transformed into two subgoals, +`A` and `B`, followed by the proofs of `A` and `B`. Coq and its tactics +use backward reasoning. + +A tactic may fully prove a goal, in which case the goal is removed +from the proof state. +More commonly, a tactic replaces a goal with one or more :term:`subgoals <subgoal>`. +(We say that a tactic reduces a goal to its subgoals.) + +Most tactics require specific elements or preconditions to reduce a goal; +they display error messages if they can't be applied to the goal. +A few tactics, such as :tacn:`auto`, don't fail even if the proof state +is unchanged. + +Goals are identified by number. The current goal is number +1. Tactics are applied to the current goal by default. (The +default can be changed with the :opt:`Default Goal Selector` +option.) They can +be applied to another goal or to multiple goals with a +:ref:`goal selector <goal-selectors>` such as :n:`2: @tactic`. + +This chapter describes many of the most common built-in tactics. +Built-in tactics can be combined to form tactic expressions, which are +described in the :ref:`Ltac` chapter. Since tactic expressions can +be used anywhere that a built-in tactic can be used, "tactic" may +refer to both built-in tactics and tactic expressions. Common elements of tactics -------------------------- @@ -66,7 +77,7 @@ specified, the default selector is used. .. todo: fully describe selectors. At the moment, ltac has a fairly complete description .. todo: mention selectors can be applied to some commands, such as - Check, Search, SearchHead, SearchPattern, SearchRewrite. + Check, Search, SearchPattern, SearchRewrite. .. opt:: Default Goal Selector "@toplevel_selector" :name: Default Goal Selector @@ -487,10 +498,16 @@ one or more of its hypotheses. :n:`{? - } {+ @nat_or_var }` Selects the specified occurrences within a single goal or hypothesis. - Occurrences are numbered from left to right starting with 1 when the - goal is printed with the :flag:`Printing All` flag. (In particular, occurrences - in :ref:`implicit arguments <ImplicitArguments>` and - :ref:`coercions <Coercions>` are counted but not shown by default.) + Occurrences are numbered starting with 1 following a depth-first traversal + of the term's expression, including occurrences in + :ref:`implicit arguments <ImplicitArguments>` + and :ref:`coercions <Coercions>` that are not displayed by default. + (Set the :flag:`Printing All` flag to show those in the printed term.) + + For example, when matching the pattern `_ + _` in the term `(a + b) + c`, + occurrence 1 is `(...) + c` and + occurrence 2 is `(a + b)`. When matching that pattern with term `a + (b + c)`, + occurrence 1 is `a + (...)` and occurrence 2 is `b + c`. Specifying `-` includes all occurrences *except* the ones listed. @@ -529,8 +546,21 @@ one or more of its hypotheses. which is equivalent to `in * |- *`. Use `* |-` to select all occurrences in all hypotheses. -Tactics that use occurrence clauses include :tacn:`set`, -:tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. + Tactics that select a specific hypothesis H to apply to other hypotheses, + such as :tacn:`rewrite` `H in * |-`, won't apply H to itself. + + If multiple + occurrences are given, such as in :tacn:`rewrite` `H at 1 2 3`, the tactic + must match at least one occurrence in order to succeed. The tactic will fail + if no occurrences match. Occurrence numbers that are out of range (e.g. + `at 1 3` when there are only 2 occurrences in the hypothesis or conclusion) + are ignored. + + .. todo: remove last sentence above and add "Invalid occurrence number @natural" exn for 8.14 + per #13568. + + Tactics that use occurrence clauses include :tacn:`set`, + :tacn:`remember`, :tacn:`induction` and :tacn:`destruct`. .. seealso:: @@ -645,10 +675,10 @@ Applying theorems :tacn:`notypeclasses refine`: it performs type checking without resolution of typeclasses, does not perform beta reductions or shelve the subgoals. - .. flag:: Debug Unification - - Enables printing traces of unification steps used during - elaboration/typechecking and the :tacn:`refine` tactic. + :opt:`Debug` ``"unification"`` enables printing traces of + unification steps used during elaboration/typechecking and the + :tacn:`refine` tactic. ``"ho-unification"`` prints information + about higher order heuristics. .. tacn:: apply @term :name: apply @@ -1010,10 +1040,9 @@ Applying theorems when the instantiation of a variable cannot be found (cf. :tacn:`eapply` and :tacn:`apply`). -.. flag:: Debug Tactic Unification - - Enables printing traces of unification steps in tactic unification. - Tactic unification is used in tactics such as :tacn:`apply` and :tacn:`rewrite`. +:opt:`Debug` ``"tactic-unification"`` enables printing traces of +unification steps in tactic unification. Tactic unification is used in +tactics such as :tacn:`apply` and :tacn:`rewrite`. .. _managingthelocalcontext: @@ -1630,17 +1659,21 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. .. tacv:: instantiate (@natural := @term) - This variant allows to refer to an existential variable which was not named - by the user. The :n:`@natural` argument is the position of the existential variable - from right to left in the goal. Because this variant is not robust to slight - changes in the goal, its use is strongly discouraged. + This variant selects an existential variable by its position. The + :n:`@natural` argument is the position of the existential variable + *from right to left* in the conclusion of the goal. (Use one of + the variants below to select an existential variable in a + hypothesis.) Counting starts at 1 and multiple occurrences of the + same existential variable are counted multiple times. Because this + variant is not robust to slight changes in the goal, its use is + strongly discouraged. .. tacv:: instantiate ( @natural := @term ) in @ident instantiate ( @natural := @term ) in ( value of @ident ) instantiate ( @natural := @term ) in ( type of @ident ) These allow to refer respectively to existential variables occurring in a - hypothesis or in the body or the type of a local definition. + hypothesis or in the body or the type of a local definition (named :n:`@ident`). .. tacv:: instantiate @@ -1979,7 +2012,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This is a more basic induction tactic. Again, the type of the argument :n:`@term` must be an inductive type. Then, according to the type of the goal, the tactic ``elim`` chooses the appropriate destructor and applies it - as the tactic :tacn:`apply` would do. For instance, if the proof context + as the tactic :tacn:`apply` would do. For instance, if the local context contains :g:`n:nat` and the current goal is :g:`T` of type :g:`Prop`, then :n:`elim n` is equivalent to :n:`apply nat_ind with (n:=n)`. The tactic ``elim`` does not modify the context of the goal, neither introduces the @@ -2039,19 +2072,6 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) is the name given by :n:`intros until @natural` to the :n:`@natural`-th non-dependent premise of the goal. -.. tacn:: double induction @ident @ident - :name: double induction - - This tactic is deprecated and should be replaced by - :n:`induction @ident; induction @ident` (or - :n:`induction @ident ; destruct @ident` depending on the exact needs). - -.. tacv:: double induction @natural__1 @natural__2 - - This tactic is deprecated and should be replaced by - :n:`induction num1; induction num3` where :n:`num3` is the result - of :n:`num2 - num1` - .. tacn:: dependent induction @ident :name: dependent induction @@ -2651,7 +2671,7 @@ and an explanation of the underlying technique. Like in a fix expression, the induction hypotheses have to be used on structurally smaller arguments. The verification that inductive proof arguments are correct is done only at the time of registering the - lemma in the environment. To know if the use of induction hypotheses + lemma in the global environment. To know if the use of induction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). @@ -2671,7 +2691,7 @@ and an explanation of the underlying technique. name given to the coinduction hypothesis. Like in a cofix expression, the use of induction hypotheses have to guarded by a constructor. The verification that the use of co-inductive hypotheses is correct is - done only at the time of registering the lemma in the environment. To + done only at the time of registering the lemma in the global environment. To know if the use of coinduction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). @@ -2752,14 +2772,11 @@ succeeds, and results in an error otherwise. :name: is_var This tactic checks whether its argument is a variable or hypothesis in - the current goal context or in the opened sections. + the current local context. .. exn:: Not a variable or hypothesis. :undocumented: - -.. _equality: - Equality -------- @@ -2954,59 +2971,7 @@ references to automatically generated names. Performance-oriented tactic variants ------------------------------------ -.. tacn:: change_no_check @term - :name: change_no_check - - For advanced usage. Similar to :tacn:`change` :n:`@term`, but as an optimization, - it skips checking that :n:`@term` is convertible to the goal. - - Recall that the Coq kernel typechecks proofs again when they are concluded to - ensure safety. Hence, using :tacn:`change` checks convertibility twice - overall, while :tacn:`change_no_check` can produce ill-typed terms, - but checks convertibility only once. - Hence, :tacn:`change_no_check` can be useful to speed up certain proof - scripts, especially if one knows by construction that the argument is - indeed convertible to the goal. - - In the following example, :tacn:`change_no_check` replaces :g:`False` by - :g:`True`, but :cmd:`Qed` then rejects the proof, ensuring consistency. - - .. example:: - - .. coqtop:: all abort - - Goal False. - change_no_check True. - exact I. - Fail Qed. - - :tacn:`change_no_check` supports all of :tacn:`change`'s variants. - - .. tacv:: change_no_check @term with @term’ - :undocumented: - - .. tacv:: change_no_check @term at {+ @natural} with @term’ - :undocumented: - - .. tacv:: change_no_check @term {? {? at {+ @natural}} with @term} in @ident - - .. example:: - - .. coqtop:: all abort - - Goal True -> False. - intro H. - change_no_check False in H. - exact H. - Fail Qed. - - .. tacv:: convert_concl_no_check @term - :name: convert_concl_no_check - - .. deprecated:: 8.11 - - Deprecated old name for :tacn:`change_no_check`. Does not support any of its - variants. +.. todo: move the following adjacent to the `exact` tactic in the rewriting chapter? .. tacn:: exact_no_check @term :name: exact_no_check diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index e866e4c624..37d605360d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1,7 +1,7 @@ .. _vernacularcommands: -Vernacular commands -============================= +Commands +======== .. _displaying: @@ -60,7 +60,7 @@ Query commands -------------- Unlike other commands, :production:`query_command`\s may be prefixed with -a goal selector (:n:`@natural:`) to specify which goal context it applies to. +a goal selector (:n:`@natural:`) to specify which goals it applies to. If no selector is provided, the command applies to the current goal. If no proof is open, then the command only applies to accessible objects. (see Section :ref:`invocation-of-tactics`). @@ -312,31 +312,6 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). Search is:Instance [ Reflexive | Symmetric ]. -.. cmd:: SearchHead @one_pattern {? {| inside | outside } {+ @qualid } } - - .. deprecated:: 8.12 - - Use the `headconcl:` clause of :cmd:`Search` instead. - - Displays the name and type of all hypotheses of the - selected goal (if any) and theorems of the current context that have the - form :n:`{? forall {* @binder }, } {* P__i -> } C` where :n:`@one_pattern` - matches a subterm of `C` in head position. For example, a :n:`@one_pattern` of `f _ b` - matches `f a b`, which is a subterm of `C` in head position when `C` is `f a b c`. - - See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. - - .. example:: :cmd:`SearchHead` examples - - .. coqtop:: none reset - - Add Search Blacklist "internal_". - - .. coqtop:: all warn - - SearchHead le. - SearchHead (@eq bool). - .. cmd:: SearchPattern @one_pattern {? {| inside | outside } {+ @qualid } } Displays the name and type of all hypotheses of the @@ -382,10 +357,9 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). SearchRewrite (_ + _ + _). .. table:: Search Blacklist @string - :name: Search Blacklist Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, - :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose + :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose fully-qualified name contains any of the strings will be excluded from the search results. The default blacklisted substrings are ``_subterm``, ``_subproof`` and ``Private_``. @@ -396,7 +370,7 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). .. flag:: Search Output Name Only This flag restricts the output of search commands to identifier names; - turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, + turning it on causes invocations of :cmd:`Search`, :cmd:`SearchPattern`, :cmd:`SearchRewrite` etc. to omit types from their output, printing only identifiers. @@ -668,8 +642,8 @@ Loadpath ------------ Loadpaths are preferably managed using Coq command line options (see -Section :ref:`libraries-and-filesystem`) but there remain vernacular commands to manage them -for practical purposes. Such commands are only meant to be issued in +Section :ref:`libraries-and-filesystem`), but there are also commands +to manage them within Coq. These commands are only meant to be issued in the toplevel, and using them in source files is discouraged. @@ -740,7 +714,7 @@ Backtracking ------------ The backtracking commands described in this section can only be used -interactively, they cannot be part of a vernacular file loaded via +interactively, they cannot be part of a Coq file loaded via ``Load`` or compiled by ``coqc``. @@ -844,7 +818,6 @@ Quitting and debugging displayed. .. opt:: Default Timeout @natural - :name: Default Timeout If set, each :n:`@sentence` is treated as if it was prefixed with :cmd:`Timeout` :n:`@natural`, except for :cmd:`Timeout` commands themselves. If unset, @@ -883,7 +856,6 @@ Controlling display This flag controls the normal displaying. .. opt:: Warnings "{+, {? {| - | + } } @ident }" - :name: Warnings This option configures the display of warnings. It is experimental, and expects, between quotes, a comma-separated list of warning names or @@ -893,15 +865,21 @@ Controlling display interpreted from left to right, so in case of an overlap, the flags on the right have higher priority, meaning that `A,-A` is equivalent to `-A`. +.. opt:: Debug "{+, {? - } @ident }" + + Configures the display of debug messages. Each :n:`@ident` enables debug messages + for that component, while :n:`-@ident` disables messages for the component. + ``all`` activates or deactivates all other components. ``backtrace`` controls printing of + error backtraces. + + :cmd:`Test` `Debug` displays the list of components and their enabled/disabled state. .. opt:: Printing Width @natural - :name: Printing Width This command sets which left-aligned part of the width of the screen is used for display. At the time of writing this documentation, the default value is 78. .. opt:: Printing Depth @natural - :name: Printing Depth This option controls the nesting depth of the formatter used for pretty- printing. Beyond this depth, display of subterms is replaced by dots. At the @@ -1088,57 +1066,6 @@ described first. .. seealso:: :ref:`performingcomputations` -.. _controlling-locality-of-commands: - -Controlling the locality of commands ------------------------------------------ - -.. attr:: global - local - - Some commands support a :attr:`local` or :attr:`global` attribute - to control the scope of their effect. There is also a legacy (and - much more commonly used) syntax using the ``Local`` or ``Global`` - prefixes (see :n:`@legacy_attr`). There are four kinds of - commands: - - + Commands whose default is to extend their effect both outside the - section and the module or library file they occur in. For these - commands, the :attr:`local` attribute limits the effect of the command to the - current section or module it occurs in. As an example, the :cmd:`Coercion` - and :cmd:`Strategy` commands belong to this category. - + Commands whose default behavior is to stop their effect at the end - of the section they occur in but to extend their effect outside the module or - library file they occur in. For these commands, the :attr:`local` attribute limits the - effect of the command to the current module if the command does not occur in a - section and the :attr:`global` attribute extends the effect outside the current - sections and current module if the command occurs in a section. As an example, - the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong - to this category. Notice that a subclass of these commands do not support - extension of their scope outside sections at all and the :attr:`global` attribute is not - applicable to them. - + Commands whose default behavior is to stop their effect at the end - of the section or module they occur in. For these commands, the :attr:`global` - attribute extends their effect outside the sections and modules they - occur in. The :cmd:`Transparent` and :cmd:`Opaque` commands - belong to this category. - + Commands whose default behavior is to extend their effect outside - sections but not outside modules when they occur in a section and to - extend their effect outside the module or library file they occur in - when no section contains them. For these commands, the :attr:`local` attribute - limits the effect to the current section or module while the :attr:`global` - attribute extends the effect outside the module even when the command - occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this - category. - -.. attr:: export - - Some commands support an :attr:`export` attribute. The effect of - the attribute is to make the effect of the command available when - the module containing it is imported. It is supported in - particular by the :ref:`Hint <creating_hints>`, :cmd:`Set` and :cmd:`Unset` - commands. - .. _controlling-typing-flags: Controlling Typing Flags diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index 472df2bd91..30f7be5f13 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -273,18 +273,21 @@ Creating Hints :cmd:`Import` or :cmd:`Require` the current module. + :attr:`export` hints are visible from other modules when they :cmd:`Import` the current - module, but not when they only :cmd:`Require` it. This attribute is supported by - all `Hint` commands except for :cmd:`Hint Rewrite`. + module, but not when they only :cmd:`Require` it. + :attr:`global` hints are visible from other modules when they :cmd:`Import` or :cmd:`Require` the current module. + .. versionadded:: 8.14 + + The :cmd:`Hint Rewrite` now supports locality attributes like other `Hint` commands. + .. deprecated:: 8.13 The default value for hint locality will change in a future - release. For the time being, adding hints outside of sections without - specifying an explicit locality will trigger a deprecation - warning. We recommend you use :attr:`export` whenever possible. + release. Hints added outside of sections without an explicit + locality are now deprecated. We recommend using :attr:`export` + where possible. The `Hint` commands are: @@ -335,7 +338,7 @@ Creating Hints .. exn:: @qualid cannot be used as a hint The head symbol of the type of :n:`@qualid` is a bound variable - such that this tactic cannot be associated to a constant. + such that this tactic cannot be associated with a constant. .. cmd:: Hint Immediate {+ {| @qualid | @one_term } } {? : {+ @ident } } diff --git a/doc/sphinx/proofs/automatic-tactics/logic.rst b/doc/sphinx/proofs/automatic-tactics/logic.rst index 5aaded2726..3f1f5d46c5 100644 --- a/doc/sphinx/proofs/automatic-tactics/logic.rst +++ b/doc/sphinx/proofs/automatic-tactics/logic.rst @@ -194,9 +194,7 @@ Solvers for logic and equality additional arguments can be given to congruence by filling in the holes in the terms given in the error message, using the `with` clause. - .. flag:: Congruence Verbose - - Makes :tacn:`congruence` print debug information. + :opt:`Debug` ``"congruence"`` makes :tacn:`congruence` print debug information. .. tacn:: btauto diff --git a/doc/sphinx/proofs/writing-proofs/proof-mode.rst b/doc/sphinx/proofs/writing-proofs/proof-mode.rst index 40d032543f..931ac905f6 100644 --- a/doc/sphinx/proofs/writing-proofs/proof-mode.rst +++ b/doc/sphinx/proofs/writing-proofs/proof-mode.rst @@ -1,74 +1,175 @@ .. _proofhandling: -------------------- - Proof handling -------------------- +---------- +Proof mode +---------- -In Coq’s proof editing mode all top-level commands documented in -Chapter :ref:`vernacularcommands` remain available and the user has access to specialized -commands dealing with proof development pragmas documented in this -section. They can also use some other specialized commands called -*tactics*. They are the very tools allowing the user to deal with -logical reasoning. They are documented in Chapter :ref:`tactics`. +:gdef:`Proof mode <proof mode>` is used to prove theorems. +Coq enters proof mode when you begin a proof, +such as with the :cmd:`Theorem` command. It exits proof mode when +you complete a proof, such as with the :cmd:`Qed` command. Tactics, +which are available only in proof mode, incrementally transform incomplete +proofs to eventually generate a complete proof. -Coq user interfaces usually have a way of marking whether the user has -switched to proof editing mode. For instance, in coqtop the prompt ``Coq <`` is changed into -:n:`@ident <` where :token:`ident` is the declared name of the theorem currently edited. +When you run Coq interactively, such as through CoqIDE, Proof General or +coqtop, Coq shows the current proof state (the incomplete proof) as you +enter tactics. This information isn't shown when you run Coq in batch +mode with `coqc`. -At each stage of a proof development, one has a list of goals to -prove. Initially, the list consists only in the theorem itself. After -having applied some tactics, the list of goals contains the subgoals -generated by the tactics. +Proof State +----------- -To each subgoal is associated a number of hypotheses called the *local context* -of the goal. Initially, the local context contains the local variables and -hypotheses of the current section (see Section :ref:`gallina-assumptions`) and -the local variables and hypotheses of the theorem statement. It is enriched by -the use of certain tactics (see e.g. :tacn:`intro`). +The :gdef:`proof state` consists of one or more unproven goals. +Each goal has a :gdef:`conclusion` (the statement that is to be proven) +and a :gdef:`local context`, which contains named :term:`hypotheses <hypothesis>` +(which are propositions), variables and local definitions that can be used in +proving the conclusion. The proof may also use *constants* from the :term:`global environment` +such as definitions and proven theorems. -When a proof is completed, the message ``Proof completed`` is displayed. -One can then register this proof as a defined constant in the -environment. Because there exists a correspondence between proofs and -terms of λ-calculus, known as the *Curry-Howard isomorphism* -:cite:`How80,Bar81,Gir89,H89`, Coq stores proofs as terms of |Cic|. Those -terms are called *proof terms*. +The term ":gdef:`goal`" may refer to an entire goal or to the conclusion +of a goal, depending on the context. +The conclusion appears below a line and the local context appears above the line. +The conclusion is a type. Each item in the local context begins with a name +and ends, after a colon, with an associated type. +Local definitions are shown in the form `n := 0 : nat`, for example, in which `nat` is the +type of `0`. -.. exn:: No focused proof. +The local context of a goal contains items specific to the goal as well +as section-local variables and hypotheses (see :ref:`gallina-assumptions`) defined +in the current :ref:`section <section-mechanism>`. The latter are included in the +initial proof state. +Items in the local context are ordered; an item can only refer to items that appear +before it. (A more mathematical description of the *local context* is +:ref:`here <Local-context>`.) - Coq raises this error message when one attempts to use a proof editing command - out of the proof editing mode. +The :gdef:`global environment` has definitions and proven theorems that are global in scope. +(A more mathematical description of the *global environment* is :ref:`here <Global-environment>`.) + +When you begin proving a theorem, the proof state shows +the statement of the theorem below the line and often nothing in the +local context: + +.. coqtop:: none + + Parameter P: nat -> Prop. + +.. coqtop:: out + + Goal forall n m: nat, n > m -> P 1 /\ P 2. + +After applying the :tacn:`intros` :term:`tactic`, we see hypotheses above the line. +The names of variables (`n` and `m`) and hypotheses (`H`) appear before a colon, followed by +the type they represent. + +.. coqtop:: all + + intros. + +Some tactics, such as :tacn:`split`, create new goals, which may +be referred to as :gdef:`subgoals <subgoal>` for clarity. +Goals are numbered from 1 to N at each step of the proof to permit applying a +tactic to specific goals. The local context is only shown for the first goal. + +.. coqtop:: all + + split. + +"Variables" may refer specifically to local context items for which the type of their type +is `Set` or `Type`, and :gdef:`"hypotheses" <hypothesis>` refers to items that are +:term:`propositions <proposition>`, +for which the type of their type is `Prop` or `SProp`, +but these terms are also used interchangeably. + +.. coqtop:: out + + let t_n := type of n in idtac "type of n :" t_n; + let tt_n := type of t_n in idtac "type of" t_n ":" tt_n. + let t_H := type of H in idtac "type of H :" t_H; + let tt_H := type of t_H in idtac "type of" t_H ":" tt_H. + +A proof script, consisting of the tactics that are applied to prove a +theorem, is often informally referred to as a "proof". +The real proof, whether complete or incomplete, is a term, the :gdef:`proof term`, +which users may occasionally want to examine. (This is based on the +*Curry-Howard isomorphism* :cite:`How80,Bar81,Gir89,H89`, which is +a correspondence between between proofs and terms and between +propositions and types of λ-calculus. The isomorphism is also +sometimes called the "propositions-as-types correspondence".) + +The :cmd:`Show Proof` command displays the incomplete proof term +before you've completed the proof. For example, here's the proof +term after using the :tacn:`split` tactic above: + +.. coqtop:: all + + Show Proof. + +The incomplete parts, the goals, are represented by +:term:`existential variables <existential variable>` +with names that begin with `?Goal`. The :cmd:`Show Existentials` command +shows each existential with the hypotheses and conclusion for the associated goal. + +.. coqtop:: all + + Show Existentials. + +Coq's kernel verifies the correctness of proof terms when it exits +proof mode by checking that the proof term is :term:`well-typed` and +that its type is the same as the theorem statement. + +After a proof is completed, :cmd:`Print` `<theorem_name>` +shows the proof term and its type. The type appears after +the colon (`forall ...`), as for this theorem from Coq's standard library: + +.. coqtop:: all + + Print proj1. .. _proof-editing-mode: -Entering and leaving proof editing mode ---------------------------------------- +Entering and exiting proof mode +------------------------------- + +Coq enters :term:`proof mode` when you begin a proof through +commands such as :cmd:`Theorem` or :cmd:`Goal`. Coq user interfaces +usually have a way to indicate that you're in proof mode. + +:term:`Tactics <tactic>` are available only in proof mode (currently they give syntax +errors outside of proof mode). Most :term:`commands <command>` can be used both in and out of +proof mode, but some commands only work in or outside of proof mode. -The proof editing mode is entered by asserting a statement, which typically is -the assertion of a theorem using an assertion command like :cmd:`Theorem`. The -list of assertion commands is given in :ref:`Assertions`. The command -:cmd:`Goal` can also be used. +When the proof is completed, you can exit proof mode with commands such as +:cmd:`Qed`, :cmd:`Defined` and :cmd:`Save`. .. cmd:: Goal @type - This is intended for quick assertion of statements, without knowing in - advance which name to give to the assertion, typically for quick - testing of the provability of a statement. If the proof of the - statement is eventually completed and validated, the statement is then - bound to the name ``Unnamed_thm`` (or a variant of this name not already - used for another statement). + Asserts an unnamed proposition. This is intended for quick tests that + a proposition is provable. If the proof is eventually completed and + validated, you can assign a name with the :cmd:`Save` or :cmd:`Defined` + commands. If no name is given, the name will be `Unnamed_thm` (or, + if that name is already defined, a variant of that). .. cmd:: Qed - This command is available in interactive editing proof mode when the - proof is completed. Then :cmd:`Qed` extracts a proof term from the proof - script, switches back to Coq top-level and attaches the extracted - proof term to the declared name of the original goal. The name is - added to the environment as an opaque constant. + Passes a completed :term:`proof term` to Coq's kernel + to check that the proof term is :term:`well-typed` and + to verify that its type matches the theorem statement. If it's verified, the + proof term is added to the global environment as an opaque constant + using the declared name from the original goal. + + It's very rare for a proof term to fail verification. Generally this + indicates a bug in a tactic you used or that you misused some + unsafe tactics. .. exn:: Attempt to save an incomplete proof. :undocumented: + .. exn:: No focused proof (No proof-editing in progress). + + You tried to use a proof mode command such as :cmd:`Qed` outside of proof + mode. + .. note:: Sometimes an error occurs when building the proof term, because @@ -81,9 +182,9 @@ list of assertion commands is given in :ref:`Assertions`. The command even incur a memory overflow. .. cmd:: Save @ident - :name: Save - Saves a completed proof with the name :token:`ident`, which + Similar to :cmd:`Qed`, except that the proof term is added to the global + context with the name :token:`ident`, which overrides any name provided by the :cmd:`Theorem` command or its variants. @@ -98,7 +199,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Admitted - This command is available in interactive editing mode to give up + This command is available in proof mode to give up the current proof and declare the initial goal as an axiom. .. cmd:: Abort {? {| All | @ident } } @@ -120,7 +221,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Proof @term :name: Proof `term` - This command applies in proof editing mode. It is equivalent to + This command applies in proof mode. It is equivalent to :n:`exact @term. Qed.` That is, you have to give the full proof in one gulp, as a proof term (see Section :ref:`applyingtheorems`). @@ -159,7 +260,7 @@ list of assertion commands is given in :ref:`Assertions`. The command | Type {? * } | All - Opens proof editing mode, declaring the set of + Opens proof mode, declaring the set of section variables (see :ref:`gallina-assumptions`) used by the proof. At :cmd:`Qed` time, the system verifies that the set of section variables used in @@ -210,7 +311,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. example:: - .. coqtop:: all + .. coqtop:: all reset Section Test. Variable n : nat. @@ -232,7 +333,6 @@ The following options modify the behavior of ``Proof using``. .. opt:: Default Proof Using "@section_var_expr" - :name: Default Proof Using Use :n:`@section_var_expr` as the default ``Proof using`` value. E.g. ``Set Default Proof Using "a b"`` will complete all ``Proof`` commands not followed by a @@ -301,7 +401,7 @@ Name a set of section hypotheses for ``Proof using`` Use :cmd:`Unshelve` instead. Proof modes -``````````` +----------- When entering proof mode through commands such as :cmd:`Goal` and :cmd:`Proof`, Coq picks by default the |Ltac| mode. Nonetheless, there exist other proof modes @@ -312,8 +412,8 @@ be changed using the following option. .. opt:: Default Proof Mode @string Select the proof mode to use when starting a proof. Depending on the proof - mode, various syntactic constructs are allowed when writing an interactive - proof. All proof modes support vernacular commands; the proof mode determines + mode, various syntactic constructs are allowed when writing a + proof. All proof modes support commands; the proof mode determines which tactic language and set of tactic definitions are available. The possible option values are: @@ -349,16 +449,16 @@ Navigation in the proof tree .. cmd:: Restart - Restores the proof editing process to the original goal. + Restores the proof to the original goal. .. exn:: No focused proof to restart. :undocumented: .. cmd:: Focus {? @natural } - Focuses the attention on the first subgoal to prove or, if :token:`natural` is + Focuses the attention on the first goal to prove or, if :token:`natural` is specified, the :token:`natural`\-th. The - printing of the other subgoals is suspended until the focused subgoal + printing of the other goals is suspended until the focused goal is solved or unfocused. .. deprecated:: 8.8 @@ -379,14 +479,9 @@ Navigation in the proof tree .. _curly-braces: -.. index:: { - } - -.. todo: :name: "{"; "}" doesn't work, nor does :name: left curly bracket; right curly bracket, - hence the verbose names - .. tacn:: {? {| @natural | [ @ident ] } : } %{ - %} + %} + :name: {; } .. todo See https://github.com/coq/coq/issues/12004 and @@ -403,7 +498,7 @@ Navigation in the proof tree or focus the next one. :n:`@natural:` - Focuses on the :token:`natural`\-th subgoal to prove. + Focuses on the :token:`natural`\-th goal to prove. :n:`[ @ident ]: %{` Focuses on the named goal :token:`ident`. @@ -477,7 +572,7 @@ Navigation in the proof tree Brackets are used to focus on a single goal given either by its position or by its name if it has one. - .. seealso:: The error messages for bullets below. + .. seealso:: The error messages for bullets below. .. _bullets: @@ -567,7 +662,6 @@ Set Bullet Behavior ~~~~~~~~~~~~~~~~~~~ .. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } - :name: Bullet Behavior This option controls the bullet behavior and can take two possible values: @@ -577,8 +671,7 @@ Set Bullet Behavior Modifying the order of goals ```````````````````````````` -.. tacn:: cycle @integer - :name: cycle +.. tacn:: cycle @int_or_var Reorders the selected goals so that the first :n:`@integer` goals appear after the other selected goals. @@ -601,8 +694,7 @@ Modifying the order of goals all: cycle 2. all: cycle -3. -.. tacn:: swap @integer @integer - :name: swap +.. tacn:: swap @int_or_var @int_or_var Exchanges the position of the specified goals. Negative values for :n:`@integer` indicate counting goals @@ -621,7 +713,6 @@ Modifying the order of goals all: swap 1 -1. .. tacn:: revgoals - :name: revgoals Reverses the order of the selected goals. The tactic is only useful with a goal selector, most commonly `all :`. Note that other selectors reorder goals; @@ -638,16 +729,17 @@ Modifying the order of goals Postponing the proof of some goals `````````````````````````````````` +Goals can be :gdef:`shelved` so they are no longer displayed in the proof state. +They can then be :gdef:`unshelved` to make them visible again. + .. tacn:: shelve - :name: shelve This tactic moves all goals under focus to a shelf. While on the shelf, goals will not be focused on. They can be solved by unification, or they can be called back into focus with the command :cmd:`Unshelve`. - .. tacv:: shelve_unifiable - :name: shelve_unifiable + .. tacn:: shelve_unifiable Shelves only the goals under focus that are mentioned in other goals. Goals that appear in the type of other goals can be solved by unification. @@ -667,14 +759,12 @@ Postponing the proof of some goals from the shelf into focus, by appending them to the end of the current list of focused goals. -.. tacn:: unshelve @tactic - :name: unshelve +.. tacn:: unshelve @ltac_expr1 Performs :n:`@tactic`, then unshelves existential variables added to the shelf by the execution of :n:`@tactic`, prepending them to the current goal. .. tacn:: give_up - :name: give_up This tactic removes the focused goals from the proof. They are not solved, and cannot be solved later in the proof. As the goals are not @@ -694,7 +784,7 @@ Requesting information Displays the current goals. :n:`@natural` - Display only the :token:`natural`\-th subgoal. + Display only the :token:`natural`\-th goal. :n:`@ident` Displays the named goal :token:`ident`. This is useful in @@ -791,7 +881,7 @@ Requesting information Some tactics (e.g. :tacn:`refine`) allow to build proofs using fixpoint or co-fixpoint constructions. Due to the incremental nature - of interactive proof construction, the check of the termination (or + of proof construction, the check of the termination (or guardedness) of the recursive calls in the fixpoint or cofixpoint constructions is postponed to the time of the completion of the proof. @@ -854,7 +944,6 @@ How to enable diffs ``````````````````` .. opt:: Diffs {| "on" | "off" | "removed" } - :name: Diffs The “on” setting highlights added tokens in green, while the “removed” setting additionally reprints items with removed tokens in red. Unchanged tokens in @@ -983,12 +1072,11 @@ To show differences in the proof term: .. image:: ../../_static/diffs-show-proof.png :alt: coqide with Set Diffs on with compacted hypotheses -Controlling the effect of proof editing commands ------------------------------------------------- +Controlling proof mode +---------------------- .. opt:: Hyps Limit @natural - :name: Hyps Limit This option controls the maximum number of hypotheses displayed in goals after the application of a tactic. All the hypotheses remain usable @@ -1009,7 +1097,7 @@ Controlling the effect of proof editing commands .. flag:: Printing Goal Names - When turned on, the name of the goal is printed in interactive + When turned on, the name of the goal is printed in proof mode, which can be useful in cases of cross references between goals. diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index 3649202b45..8c000a4aa7 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -1,301 +1,388 @@ -================================= -Term rewriting and simplification -================================= +========================= +Reasoning with equalities +========================= + +There are multiple notions of :gdef:`equality` in Coq: + +- :gdef:`Leibniz equality` is the standard + way to define equality in Coq and the Calculus of Inductive Constructions, + which is in terms of a binary relation, i.e. a binary function that returns + a `Prop`. The standard library + defines `eq` similar to this: + + .. coqdoc:: + + Inductive eq {A : Type} (x : A) : A -> Prop := eq_refl : eq x x. + + The notation `x = y` represents the term `eq x y`. The notation `x = y :> A` + gives the type of x and y explicitly. + +- :gdef:`Setoid equality <setoid equality>` defines equality in terms of an equivalence + relation. A :gdef:`setoid` is a set that is equipped with an equivalence relation + (see https://en.wikipedia.org/wiki/Setoid). These are needed to form a :gdef:`quotient set` + or :gdef:`quotient` + (see https://en.wikipedia.org/wiki/Equivalence_Class). In Coq, users generally work + with setoids rather than constructing quotients, for which there is no specific support. + +- :gdef:`Definitional equality <definitional equality>` is equality based on the + :ref:`conversion rules <Conversion-rules>`, which Coq can determine automatically. + When two terms are definitionally equal, Coq knows it can + replace one with the other, such as with :tacn:`change` `X with Y`, among many + other advantages. ":term:`Convertible <convertible>`" is another way of saying that + two terms are definitionally equal. .. _rewritingexpressions: -Rewriting expressions ---------------------- +Rewriting with Leibniz and setoid equality +------------------------------------------ -These tactics use the equality :g:`eq:forall A:Type, A->A->Prop` defined in -file ``Logic.v`` (see :ref:`coq-library-logic`). The notation for :g:`eq T t u` is -simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. +.. tacn:: rewrite {+, @oriented_rewriter } {? @occurrences } {? by @ltac_expr3 } -.. tacn:: rewrite @term - :name: rewrite + .. insertprodn oriented_rewriter one_term_with_bindings - This tactic applies to any goal. The type of :token:`term` must have the form + .. prodn:: + oriented_rewriter ::= {? {| -> | <- } } {? @natural } {? {| ? | ! } } @one_term_with_bindings + one_term_with_bindings ::= {? > } @one_term {? with @bindings } - ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` + Replaces subterms with other subterms that have been proven to be equal. + The type of :n:`@one_term` must have the form: - where :g:`eq` is the Leibniz equality or a registered setoid equality. + :n:`{? forall {+ (x__i: A__i) } , } EQ @term__1 @term__2` - Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, - resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then - replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. - Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, - and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new - subgoals. + .. todo :term:`Leibniz equality` does not work with Sphinx 2.3.1. It does with Sphinx 3.0.3. - .. exn:: The @term provided does not end with an equation. - :undocumented: + where :g:`EQ` is the Leibniz equality `eq` or a registered :term:`setoid equality`. + Note that :n:`eq @term__1 @term__2` is typically written with the infix notation + :n:`@term__1 = @term__2`. You must `Require Setoid` to use the tactic + with a setoid equality or with :ref:`setoid rewriting <generalizedrewriting>`. + In the general form, any :n:`@binder` may be used, not just :n:`(x__i: A__i)`. - .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. - :undocumented: + .. todo doublecheck the @binder comment is correct. - .. tacv:: rewrite -> @term + :n:`rewrite @one_term` finds subterms matching :n:`@term__1` in the goal, + and replaces them with :n:`@term__2` (or the reverse if `<-` is given). + Some of the variables :g:`x`\ :sub:`i` are solved by unification, + and some of the types :n:`A__1, ..., A__n` may become new + subgoals. :tacn:`rewrite` won't find occurrences inside `forall` that refer + to variables bound by the `forall`; use the more advanced :tacn:`setoid_rewrite` + if you want to find such occurrences. - Is equivalent to :n:`rewrite @term` + :n:`{+, @oriented_rewriter }` + The :n:`@oriented_rewriter`\s are applied sequentially + to the first goal generated by the previous :n:`@oriented_rewriter`. If any of them fail, + the tactic fails. - .. tacv:: rewrite <- @term + :n:`{? {| -> | <- } }` + For `->` (the default), :n:`@term__1` is rewritten + into :n:`@term__2`. For `<-`, :n:`@term__2` is rewritten into :n:`@term__1`. - Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left + :n:`{? @natural } {? {| ? | ! } }` + :n:`@natural` is the number of rewrites to perform. If `?` is given, :n:`@natural` + is the maximum number of rewrites to perform; otherwise :n:`@natural` is the exact number + of rewrites to perform. - .. tacv:: rewrite @term in @goal_occurrences + `?` (without :n:`@natural`) performs the rewrite as many times as possible + (possibly zero times). + This form never fails. `!` (without :n:`@natural`) performs the rewrite as many + times as possible + and at least once. The tactic fails if the requested number of rewrites can't + be performed. :n:`@natural !` is equivalent to :n:`@natural`. - Analogous to :n:`rewrite @term` but rewriting is done following - the clause :token:`goal_occurrences`. For instance: + :n:`@occurrences` + If :n:`@occurrences` specifies multiple occurrences, the tactic succeeds if + any of them can be rewritten. If not specified, only the first occurrence + in the conclusion is replaced. - + :n:`rewrite H in H'` will rewrite `H` in the hypothesis - ``H'`` instead of the current goal. - + :n:`rewrite H in H' at 1, H'' at - 2 |- *` means - :n:`rewrite H; rewrite H in H' at 1; rewrite H in H'' at - 2.` - In particular a failure will happen if any of these three simpler tactics - fails. - + :n:`rewrite H in * |-` will do :n:`rewrite H in H'` for all hypotheses - :g:`H'` different from :g:`H`. - A success will happen as soon as at least one of these simpler tactics succeeds. - + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` - that succeeds if at least one of these two tactics succeeds. + .. note:: - Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. + If :n:`at @occs_nums` is specified, rewriting is always done + with :ref:`setoid rewriting <generalizedrewriting>`, even for + Leibniz equality, which means that you must `Require + Setoid` to use that form. However, note that :tacn:`rewrite` + (even when using setoid rewriting) and :tacn:`setoid_rewrite` + don't behave identically (as is noted above and below). - .. tacv:: rewrite @term at @occurrences + :n:`by @ltac_expr3` + If specified, is used to resolve all side conditions generated by the tactic. - Rewrite only the given :token:`occurrences` of :token:`term`. Occurrences are - specified from left to right as for pattern (:tacn:`pattern`). The rewrite is - always performed using setoid rewriting, even for Leibniz’s equality, so one - has to ``Import Setoid`` to use this variant. + .. note:: - .. tacv:: rewrite @term by @tactic + For each selected hypothesis and/or the conclusion, + :tacn:`rewrite` finds the first matching subterm in + depth-first search order. Only subterms identical to + that first matched subterm are rewritten. If the `at` clause is specified, + only these subterms are considered when counting occurrences. + To select a different set of matching subterms, you can + specify how some or all of the free variables are bound by + using a `with` clause (see :n:`@one_term_with_bindings`). - Use tactic to completely solve the side-conditions arising from the - :tacn:`rewrite`. + For instance, if we want to rewrite the right-hand side in the + following goal, this will not work: - .. tacv:: rewrite {+, @orientation @term} {? in @ident } + .. coqtop:: none - Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one - working on the first subgoal generated by the previous one. An :production:`orientation` - ``->`` or ``<-`` can be inserted before each :token:`term` to rewrite. One - unique clause can be added at the end after the keyword in; it will then - affect all rewrite operations. + Require Import Arith. - In all forms of rewrite described above, a :token:`term` to rewrite can be - immediately prefixed by one of the following modifiers: + .. coqtop:: out - + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many - times as possible (perhaps zero time). This form never fails. - + :n:`@natural?` : works similarly, except that it will do at most :token:`natural` rewrites. - + `!` : works as `?`, except that at least one rewrite should succeed, otherwise - the tactic fails. - + :n:`@natural!` (or simply :n:`@natural`) : precisely :token:`natural` rewrites of :token:`term` will be done, - leading to failure if these :token:`natural` rewrites are not possible. + Lemma example x y : x + y = y + x. - .. tacv:: erewrite @term - :name: erewrite + .. coqtop:: all fail - This tactic works as :n:`rewrite @term` but turning - unresolved bindings into existential variables, if any, instead of - failing. It has the same variants as :tacn:`rewrite` has. + rewrite Nat.add_comm at 2. - .. flag:: Keyed Unification + One can explicitly specify how some variables are bound to match + a different subterm: - Makes higher-order unification used by :tacn:`rewrite` rely on a set of keys to drive - unification. The subterms, considered as rewriting candidates, must start with - the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments - are then unified up to full reduction. + .. coqtop:: all abort -.. tacn:: replace @term with @term’ - :name: replace + rewrite Nat.add_comm with (m := x). - This tactic applies to any goal. It replaces all free occurrences of :n:`@term` - in the current goal with :n:`@term’` and generates an equality :n:`@term = @term’` - as a subgoal. This equality is automatically solved if it occurs among - the assumptions, or if its symmetric form occurs. It is equivalent to - :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. + Note that the more advanced :tacn:`setoid_rewrite` tactic + behaves differently, and thus the number of occurrences + available to rewrite may differ between the two tactics. - .. exn:: Terms do not have convertible types. + .. exn:: Tactic failure: Setoid library not loaded. :undocumented: - .. tacv:: replace @term with @term’ by @tactic + .. todo You can use Typeclasses Debug to tell whether rewrite used + setoid rewriting. Example here: https://github.com/coq/coq/pull/13470#discussion_r539230973 - This acts as :n:`replace @term with @term’` but applies :token:`tactic` to solve the generated - subgoal :n:`@term = @term’`. + .. exn:: Cannot find a relation to rewrite. + :undocumented: - .. tacv:: replace @term + .. exn:: Tactic generated a subgoal identical to the original goal. + :undocumented: - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` or :n:`@term’ = @term`. + .. exn:: Found no subterm matching @term in @ident. + Found no subterm matching @term in the current goal. - .. tacv:: replace -> @term + This happens if :n:`@term` does not occur in, respectively, the named hypothesis or the goal. - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` + .. tacn:: erewrite {+, @oriented_rewriter } {? @occurrences } {? by @ltac_expr3 } - .. tacv:: replace <- @term + Works like :tacn:`rewrite`, but turns + unresolved bindings, if any, into existential variables instead of + failing. It has the same parameters as :tacn:`rewrite`. + + .. flag:: Keyed Unification - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term’ = @term` + Makes higher-order unification used by :tacn:`rewrite` rely on a set of keys to drive + unification. The subterms, considered as rewriting candidates, must start with + the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments + are then unified up to full reduction. - .. tacv:: replace @term {? with @term} in @goal_occurrences {? by @tactic} - replace -> @term in @goal_occurrences - replace <- @term in @goal_occurrences +.. tacn:: rewrite * {? {| -> | <- } } @one_term {? in @ident } {? at @rewrite_occs } {? by @ltac_expr3 } + rewrite * {? {| -> | <- } } @one_term at @rewrite_occs in @ident {? by @ltac_expr3 } + :name: rewrite *; _ + :undocumented: - Acts as before but the replacements take place in the specified clauses - (:token:`goal_occurrences`) (see :ref:`performingcomputations`) and not - only in the conclusion of the goal. The clause argument must not contain - any ``type of`` nor ``value of``. +.. tacn:: rewrite_db @ident {? in @ident } + :undocumented: - .. tacv:: cutrewrite {? {| <- | -> } } (@term__1 = @term__2) {? in @ident } - :name: cutrewrite +.. tacn:: replace @one_term__from with @one_term__to {? @occurrences } {? by @ltac_expr3 } + replace {? {| -> | <- } } @one_term__from {? @occurrences } + :name: replace; _ - .. deprecated:: 8.5 + The first form replaces all free occurrences of :n:`@one_term__from` + in the current goal with :n:`@one_term__to` and generates an equality + :n:`@one_term__to = @one_term__from` + as a subgoal. (Note the generated equality is reversed with respect + to the order of the two terms in the tactic syntax; see + issue `#13480 <https://github.com/coq/coq/issues/13480>`_.) + This equality is automatically solved if it occurs among + the hypotheses, or if its symmetric form occurs. - Use :tacn:`replace` instead. + The second form, with `->` or no arrow, replaces :n:`@one_term__from` + with :n:`@term__to` using + the first hypothesis whose type has the form :n:`@one_term__from = @term__to`. + If `<-` is given, the tactic uses the first hypothesis with the reverse form, + i.e. :n:`@term__to = @one_term__from`. -.. tacn:: subst @ident - :name: subst + :n:`@occurrences` + The `type of` and `value of` forms are not supported. + Note you must `Require Setoid` to use the `at` clause in :n:`@occurrences`. - This tactic applies to a goal that has :n:`@ident` in its context and (at - least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` - with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by - :g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and - clears :n:`@ident` and :g:`H` from the context. + :n:`by @ltac_expr3` + Applies the :n:`@ltac_expr3` to solve the generated equality. - If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also - unfolded and cleared. + .. exn:: Terms do not have convertible types. + :undocumented: - If :n:`@ident` is a section variable it is expected to have no - indirect occurrences in the goal, i.e. that no global declarations - implicitly depending on the section variable must be present in the - goal. + .. tacn:: cutrewrite {? {| -> | <- } } @one_term {? in @ident } - .. note:: - + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the - first one is used. + Where :n:`@one_term` is an equality. - + If :g:`H` is itself dependent in the goal, it is replaced by the proof of - reflexivity of equality. + .. deprecated:: 8.5 - .. tacv:: subst {+ @ident} + Use :tacn:`replace` instead. - This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. +.. tacn:: substitute {? {| -> | <- } } @one_term {? with @bindings } + :undocumented: - .. tacv:: subst +.. tacn:: subst {* @ident } - This applies :tacn:`subst` repeatedly from top to bottom to all hypotheses of the - context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` - or :n:`@ident := t` exists, with :n:`@ident` not occurring in - ``t`` and :n:`@ident` not a section variable with indirect - dependencies in the goal. + For each :n:`@ident`, in order, for which there is a hypothesis in the form + :n:`@ident = @term` or :n:`@term = @ident`, replaces :n:`@ident` with :n:`@term` + everywhere in the hypotheses and the conclusion and clears :n:`@ident` and the hypothesis + from the context. If there are multiple hypotheses that match the :n:`@ident`, + the first one is used. If no :n:`@ident` is given, replacement is done for all + hypotheses in the appropriate form in top to bottom order. + + If :n:`@ident` is a local definition of the form :n:`@ident := @term`, it is also + unfolded and cleared. + + If :n:`@ident` is a section variable it must have no + indirect occurrences in the goal, i.e. no global declarations + implicitly depending on the section variable may be present in the + goal. + + .. note:: + If the hypothesis is itself dependent in the goal, it is replaced by the proof of + reflexivity of equality. .. flag:: Regular Subst Tactic This flag controls the behavior of :tacn:`subst`. When it is activated (it is by default), :tacn:`subst` also deals with the following corner cases: - + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` - and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not - a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` - or :n:`u = @ident`:sub:`2`; without the flag, a second call to - subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or + + A context with ordered hypotheses :n:`@ident__1 = @ident__2` + and :n:`@ident__1 = t`, or :n:`t′ = @ident__1` with `t′` not + a variable, and no other hypotheses of the form :n:`@ident__2 = u` + or :n:`u = @ident__2`; without the flag, a second call to + subst would be necessary to replace :n:`@ident__2` by `t` or `t′` respectively. + The presence of a recursive equation which without the flag would be a cause of failure of :tacn:`subst`. - + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` - and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the + + A context with cyclic dependencies as with hypotheses :n:`@ident__1 = f @ident__2` + and :n:`@ident__2 = g @ident__1` which without the flag would be a cause of failure of :tacn:`subst`. - Additionally, it prevents a local definition such as :n:`@ident := t` to be + Additionally, it prevents a local definition such as :n:`@ident := t` from being unfolded which otherwise it would exceptionally unfold in configurations containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` with `u′` not a variable. Finally, it preserves the initial order of hypotheses, which without the flag it may break. - default. - .. exn:: Cannot find any non-recursive equality over :n:`@ident`. + .. exn:: Cannot find any non-recursive equality over @ident. :undocumented: - .. exn:: Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in hypothesis :n:`@ident`. - Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in the conclusion. + .. exn:: Section variable @ident occurs implicitly in global declaration @qualid present in hypothesis @ident. + Section variable @ident occurs implicitly in global declaration @qualid present in the conclusion. Raised when the variable is a section variable with indirect dependencies in the goal. + If :n:`@ident` is a section variable, it must not have any + indirect occurrences in the goal, i.e. no global declarations + implicitly depending on the section variable may be present in the + goal. +.. tacn:: simple subst + :undocumented: -.. tacn:: stepl @term - :name: stepl +.. tacn:: stepl @one_term {? by @ltac_expr } - This tactic is for chaining rewriting steps. It assumes a goal of the - form :n:`R @term @term` where ``R`` is a binary relation and relies on a + For chaining rewriting steps. It assumes a goal in the + form :n:`R @term__1 @term__2` where ``R`` is a binary relation and relies on a database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` - where `eq` is typically a setoid equality. The application of :n:`stepl @term` - then replaces the goal by :n:`R @term @term` and adds a new goal stating - :n:`eq @term @term`. + where `eq` is typically a setoid equality. The application of :n:`stepl @one_term` + then replaces the goal by :n:`R @one_term @term__2` and adds a new goal stating + :n:`eq @one_term @term__1`. + + If :n:`@ltac_expr` is specified, it is applied to the side condition. - .. cmd:: Declare Left Step @term + .. cmd:: Declare Left Step @one_term - Adds :n:`@term` to the database used by :tacn:`stepl`. + Adds :n:`@one_term` to the database used by :tacn:`stepl`. This tactic is especially useful for parametric setoids which are not accepted as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see :ref:`Generalizedrewriting`). - .. tacv:: stepl @term by @tactic - - This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. - - .. tacv:: stepr @term by @tactic - :name: stepr + .. tacn:: stepr @one_term {? by @ltac_expr } - This behaves as :tacn:`stepl` but on the right-hand-side of the binary - relation. Lemmas are expected to be of the form + This behaves like :tacn:`stepl` but on the right hand side of the binary + relation. Lemmas are expected to be in the form :g:`forall x y z, R x y -> eq y z -> R x z`. - .. cmd:: Declare Right Step @term + .. cmd:: Declare Right Step @one_term Adds :n:`@term` to the database used by :tacn:`stepr`. +Rewriting with definitional equality +------------------------------------ -.. tacn:: change @term - :name: change +.. tacn:: change {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } - This tactic applies to any goal. It implements the rule ``Conv`` given in - :ref:`subtyping-rules`. :g:`change U` replaces the current goal `T` - with `U` providing that `U` is well-formed and that `T` and `U` are - convertible. + Replaces terms with other :term:`convertible` terms. + If :n:`@one_term__from` is not specified, then :n:`@one_term__from` replaces the conclusion and/or + the specified hypotheses. If :n:`@one_term__from` is specified, the tactic replaces occurrences + of :n:`@one_term__to` within the conclusion and/or the specified hypotheses. + + :n:`{? @one_term__from {? at @occs_nums } with }` + Replaces the occurrences of :n:`@one_term__from` specified by :n:`@occs_nums` + with :n:`@one_term__to`, provided that the two :n:`@one_term`\s are + convertible. :n:`@one_term__from` may contain pattern variables such as `?x`, + whose value which will substituted for `x` in :n:`@one_term__to`, such as in + `change (f ?x ?y) with (g (x, y))` or `change (fun x => ?f x) with f`. + + The `at ... with ...` form is deprecated in 8.14; use `with ... at ...` instead. + For `at ... with ... in H |-`, use `with ... in H at ... |-`. + + :n:`@occurrences` + If `with` is not specified, :n:`@occurrences` must only specify + entire hypotheses and/or the goal; it must not include any + :n:`at @occs_nums` clauses. .. exn:: Not convertible. :undocumented: - .. tacv:: change @term with @term’ + .. exn:: Found an "at" clause without "with" clause + :undocumented: + + .. tacn:: now_show @one_term - This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. - The term :n:`@term` and :n:`@term’` must be convertible. + A synonym for :n:`change @one_term`. It can be used to + make some proof steps explicit when refactoring a proof script + to make it readable. - .. tacv:: change @term at {+ @natural} with @term’ + .. seealso:: :ref:`Performing computations <performingcomputations>` - This replaces the occurrences numbered :n:`{+ @natural}` of :n:`@term` by :n:`@term’` - in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. +.. tacn:: change_no_check {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } - .. exn:: Too few occurrences. - :undocumented: + For advanced usage. Similar to :tacn:`change`, but as an optimization, + it skips checking that :n:`@one_term__to` is convertible with the goal or + :n:`@one_term__from`. - .. tacv:: change @term {? {? at {+ @natural}} with @term} in @goal_occurrences + Recall that the Coq kernel typechecks proofs again when they are concluded to + ensure correctness. Hence, using :tacn:`change` checks convertibility twice + overall, while :tacn:`change_no_check` can produce ill-typed terms, + but checks convertibility only once. + Hence, :tacn:`change_no_check` can be useful to speed up certain proof + scripts, especially if one knows by construction that the argument is + indeed convertible to the goal. - In the presence of :n:`with`, this applies :tacn:`change` to the - occurrences specified by :n:`@goal_occurrences`. In the - absence of :n:`with`, :n:`@goal_occurrences` is expected to - only list hypotheses (and optionally the conclusion) without - specifying occurrences (i.e. no :n:`at` clause). + In the following example, :tacn:`change_no_check` replaces :g:`False` with + :g:`True`, but :cmd:`Qed` then rejects the proof, ensuring consistency. - .. tacv:: now_show @term + .. example:: - This is a synonym of :n:`change @term`. It can be used to - make some proof steps explicit when refactoring a proof script - to make it readable. + .. coqtop:: all abort fail - .. seealso:: :ref:`Performing computations <performingcomputations>` + Goal False. + change_no_check True. + exact I. + Qed. + + .. example:: + + .. coqtop:: all abort fail + + Goal True -> False. + intro H. + change_no_check False in H. + exact H. + Qed. .. _performingcomputations: @@ -442,7 +529,10 @@ the conversion in hypotheses :n:`{+ @ident}`. in :cite:`FullReduction`. If Coq is running in native code, it can be typically two to five times faster than :tacn:`vm_compute`. Note however that the compilation cost is higher, so it is worth using only for intensive - computations. + computations. Depending on the configuration, this tactic can either default to + :tacn:`vm_compute`, recompile dependencies or fail due to some missing + precompiled dependencies, + see :ref:`the native-compiler option <native-compiler-options>` for details. .. flag:: NativeCompute Timing @@ -469,9 +559,7 @@ the conversion in hypotheses :n:`{+ @ident}`. on the profile file to see the results. Consult the ``perf`` documentation for more details. -.. flag:: Debug Cbv - - This flag makes :tacn:`cbv` (and its derivative :tacn:`compute`) print + :opt:`Debug` ``"Cbv"`` makes :tacn:`cbv` (and its derivative :tacn:`compute`) print information about the constants it encounters and the unfolding decisions it makes. @@ -572,10 +660,8 @@ the conversion in hypotheses :n:`{+ @ident}`. This applies :tacn:`simpl` only to the :n:`{+ @natural}` applicative subterms whose head occurrence is :n:`@qualid` (or :n:`@string`). -.. flag:: Debug RAKAM - - This flag makes :tacn:`cbn` print various debugging information. - ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. +:opt:`Debug` ``"RAKAM"`` makes :tacn:`cbn` print various debugging information. +``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. .. tacn:: unfold @qualid :name: unfold @@ -839,10 +925,8 @@ the conversion in hypotheses :n:`{+ @ident}`. Conversion tactics applied to hypotheses ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. tacn:: @tactic in {+, @ident} - - Applies :token:`tactic` (any of the conversion tactics listed in this - section) to the hypotheses :n:`{+ @ident}`. + The form :n:`@tactic in {+, @ident }` applies :token:`tactic` (any of the + conversion tactics listed in this section) to the hypotheses :n:`{+ @ident}`. If :token:`ident` is a local definition, then :token:`ident` can be replaced by :n:`type of @ident` to address not the body but the type of the local diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index f454f4313d..609884ce1d 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1073,7 +1073,7 @@ main grammar, or from another custom entry as is the case in Notation "[ e ]" := e (e custom expr at level 2). to indicate that ``e`` has to be parsed at level ``2`` of the grammar -associated to the custom entry ``expr``. The level can be omitted, as in +associated with the custom entry ``expr``. The level can be omitted, as in .. coqdoc:: @@ -1159,7 +1159,6 @@ Similarly, to indicate that a custom entry should parse global references Notation "x" := x (in custom expr at level 0, x global). .. cmd:: Print Custom Grammar @ident - :name: Print Custom Grammar This displays the state of the grammar for terms associated with the custom entry :token:`ident`. @@ -1551,7 +1550,6 @@ Displaying information about scopes Use the :cmd:`Print Visibility` command to display the current notation scope stack. .. cmd:: Print Scope @scope_name - :name: Print Scope Displays all notations defined in the notation scope :n:`@scope_name`. It also displays the delimiting key and the class to which the @@ -1685,7 +1683,6 @@ Number notations ~~~~~~~~~~~~~~~~ .. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print {? ( {+, @number_modifier } ) } : @scope_name - :name: Number Notation .. insertprodn number_modifier number_string_via @@ -1842,12 +1839,12 @@ Number notations .. exn:: @qualid__parse should go from Number.int to @type or (option @type). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The parsing function given to the :cmd:`Number Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: @qualid__print should go from @type to Number.int or (option Number.int). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The printing function given to the :cmd:`Number Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: Unexpected term @term while parsing a number notation. @@ -1877,7 +1874,6 @@ String notations ~~~~~~~~~~~~~~~~ .. cmd:: String Notation @qualid__type @qualid__parse @qualid__print {? ( @number_string_via ) } : @scope_name - :name: String Notation Allows the user to customize how strings are parsed and printed. @@ -1921,12 +1917,12 @@ String notations .. exn:: @qualid__parse should go from Byte.byte or (list Byte.byte) to @type or (option @type). The parsing function given to the :cmd:`String Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: @qualid__print should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). The printing function given to the :cmd:`String Notation` - vernacular is not of the right type. + command is not of the right type. .. exn:: Unexpected term @term while parsing a string notation. diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index 93571ecebb..0f0edc6bdd 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -170,7 +170,6 @@ Tactics ------- .. tacn:: functional induction @term {? using @one_term {? with @bindings } } {? as @simple_intropattern } - :name: functional induction Performs case analysis and induction following the definition of a function :token:`qualid`, which must be fully applied to its arguments as part of @@ -221,7 +220,6 @@ Tactics :undocumented: .. tacn:: functional inversion {| @ident | @natural } {? @qualid } - :name: functional inversion Performs inversion on hypothesis :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst index b68b2ed2a7..78ac17bda1 100644 --- a/doc/sphinx/using/tools/coqdoc.rst +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -34,9 +34,9 @@ Coq material inside documentation. Coq material is quoted between the delimiters ``[`` and ``]``. Square brackets may be nested, the inner ones being understood as being part of the -quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun -x => u]``). Inside quotations, the code is pretty-printed in the same -way as it is in code parts. +quoted code (thus you can quote a term like ``let id := fun [T : Type] (x : t) => x in id 0`` +by writing ``[let id := fun [T : Type] (x : t) => x in id 0]``). +Inside quotations, the code is pretty-printed the same way as in code parts. Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be followed by a newline and the latter must follow a newline. diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 8f642df8fd..fa739e97bc 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -220,10 +220,7 @@ class CoqObject(ObjectDescription): # todo: then maybe the above "if" is not needed names_in_subdomain = self.subdomain_data() if name in names_in_subdomain: - try: - print("Duplicate", self.subdomain, "name: ", name) - except UnicodeEncodeError: # in CI - print("*** UnicodeEncodeError") + print("Duplicate", self.subdomain, "name: ", name) # self._warn_if_duplicate_name(names_in_subdomain, name, signode) return targetid @@ -348,7 +345,7 @@ class VernacVariantObject(VernacObject): .. cmd:: Axiom @ident : @term. This command links :token:`term` to the name :token:`term` as its specification in - the global context. The fact asserted by :token:`term` is thus assumed as a + the global environment. The fact asserted by :token:`term` is thus assumed as a postulate. .. cmdv:: Parameter @ident : @term. diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 75b3260166..27144fd1ad 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -447,7 +447,7 @@ binder: [ open_binders: [ | REPLACE name LIST0 name ":" lconstr -| WITH LIST1 name ":" lconstr +| WITH LIST1 name ":" type (* @Zimmi48: Special token .. is for use in the Notation command. (see bug_3304.v) *) | DELETE name ".." name | REPLACE name LIST0 name binders @@ -864,8 +864,8 @@ ltac_expr1: [ | EDIT match_key ADD_OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key ltac_expr5 "with" match_list "end" -| REPLACE failkw [ int_or_var | ] LIST0 message_token -| WITH failkw OPT int_or_var LIST0 message_token +| REPLACE failkw [ nat_or_var | ] LIST0 message_token +| WITH failkw OPT nat_or_var LIST0 message_token | REPLACE reference LIST0 tactic_arg | WITH reference LIST1 tactic_arg | l1_tactic @@ -1003,7 +1003,7 @@ simple_tactic: [ | DELETE "replace" uconstr clause | "replace" orient uconstr clause | REPLACE "rewrite" "*" orient uconstr "in" hyp "at" occurrences by_arg_tac -| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences by_arg_tac ) +| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences ) by_arg_tac | DELETE "rewrite" "*" orient uconstr "in" hyp by_arg_tac | DELETE "rewrite" "*" orient uconstr "at" occurrences by_arg_tac | DELETE "rewrite" "*" orient uconstr by_arg_tac @@ -1510,8 +1510,6 @@ query_command: [ | WITH "Check" lconstr | REPLACE "About" smart_global OPT univ_name_list "." | WITH "About" smart_global OPT univ_name_list -| REPLACE "SearchHead" constr_pattern in_or_out_modules "." -| WITH "SearchHead" constr_pattern in_or_out_modules | REPLACE "SearchPattern" constr_pattern in_or_out_modules "." | WITH "SearchPattern" constr_pattern in_or_out_modules | REPLACE "SearchRewrite" constr_pattern in_or_out_modules "." @@ -1814,6 +1812,7 @@ ltac_defined_tactics: [ | "lia" | "lra" | "nia" +| "now_show" constr | "nra" | "over" TAG SSR | "split_Rabs" @@ -2065,7 +2064,7 @@ ltac2_tactic_atom: [ | MOVETO ltac2_quotations "constr" ":" "(" lconstr ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "open_constr" ":" "(" lconstr ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| MOVETO ltac2_quotations "pattern" ":" "(" cpattern ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "pat" ":" "(" cpattern ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "reference" ":" "(" globref ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | MOVETO ltac2_quotations "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) @@ -2373,7 +2372,7 @@ ssrapplyarg: [ ] constr_with_bindings_arg: [ -| EDIT ADD_OPT ">" constr_with_bindings TAG SSR +| EDIT ADD_OPT ">" constr_with_bindings ] destruction_arg: [ @@ -2469,6 +2468,15 @@ variance_identref: [ | EDIT ADD_OPT variance identref ] +conversion: [ +| DELETE constr +| DELETE constr "with" constr +| PRINT +| REPLACE constr "at" occs_nums "with" constr +| WITH OPT ( constr OPT ( "at" occs_nums ) "with" ) constr +| PRINT +] + SPLICE: [ | clause | noedit_mode @@ -2694,6 +2702,8 @@ SPLICE: [ | cumul_ident_decl | variance | variance_identref +| rewriter +| conversion ] (* end SPLICE *) RENAME: [ @@ -2751,6 +2761,7 @@ RENAME: [ | pattern_occ pattern_occs | hypident_occ hyp_occs | concl_occ concl_occs +| constr_with_bindings_arg one_term_with_bindings ] simple_tactic: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index dd7990368e..a1c1d87763 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -1726,8 +1726,6 @@ let process_rst g file args seen tac_prods cmd_prods = let cmd_exclude_files = [ "doc/sphinx/proof-engine/ssreflect-proof-language.rst"; - "doc/sphinx/proofs/writing-proofs/rewriting.rst"; - "doc/sphinx/proofs/writing-proofs/proof-mode.rst"; "doc/sphinx/proof-engine/tactics.rst"; ] in diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index ccf38d2c15..bc6b803bbb 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -687,17 +687,6 @@ command: [ | "Add" "Zify" "BinOpSpec" constr (* micromega plugin *) | "Add" "Zify" "UnOpSpec" constr (* micromega plugin *) | "Add" "Zify" "Saturate" constr (* micromega plugin *) -| "Add" "InjTyp" constr (* micromega plugin *) -| "Add" "BinOp" constr (* micromega plugin *) -| "Add" "UnOp" constr (* micromega plugin *) -| "Add" "CstOp" constr (* micromega plugin *) -| "Add" "BinRel" constr (* micromega plugin *) -| "Add" "PropOp" constr (* micromega plugin *) -| "Add" "PropBinOp" constr (* micromega plugin *) -| "Add" "PropUOp" constr (* micromega plugin *) -| "Add" "BinOpSpec" constr (* micromega plugin *) -| "Add" "UnOpSpec" constr (* micromega plugin *) -| "Add" "Saturate" constr (* micromega plugin *) | "Show" "Zify" "InjTyp" (* micromega plugin *) | "Show" "Zify" "BinOp" (* micromega plugin *) | "Show" "Zify" "UnOp" (* micromega plugin *) @@ -705,7 +694,6 @@ command: [ | "Show" "Zify" "BinRel" (* micromega plugin *) | "Show" "Zify" "UnOpSpec" (* micromega plugin *) | "Show" "Zify" "BinOpSpec" (* micromega plugin *) -| "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" constr OPT ring_mods (* ring plugin *) | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) @@ -1258,7 +1246,6 @@ query_command: [ | "Compute" lconstr "." | "Check" lconstr "." | "About" smart_global OPT univ_name_list "." -| "SearchHead" constr_pattern in_or_out_modules "." | "SearchPattern" constr_pattern in_or_out_modules "." | "SearchRewrite" constr_pattern in_or_out_modules "." | "Search" search_query search_queries "." @@ -1551,7 +1538,6 @@ simple_tactic: [ | "revert" LIST1 hyp | "simple" "induction" quantified_hypothesis | "simple" "destruct" quantified_hypothesis -| "double" "induction" quantified_hypothesis quantified_hypothesis | "admit" | "fix" ident natural | "cofix" ident @@ -1669,7 +1655,6 @@ simple_tactic: [ | "autounfold_one" hintbases | "unify" constr constr | "unify" constr constr "with" preident -| "convert_concl_no_check" constr | "typeclasses" "eauto" "bfs" OPT nat_or_var "with" LIST1 preident | "typeclasses" "eauto" OPT nat_or_var "with" LIST1 preident | "typeclasses" "eauto" "bfs" OPT nat_or_var @@ -2095,7 +2080,7 @@ ltac_expr1: [ | "first" "[" LIST0 ltac_expr5 SEP "|" "]" | "solve" "[" LIST0 ltac_expr5 SEP "|" "]" | "idtac" LIST0 message_token -| failkw [ int_or_var | ] LIST0 message_token +| failkw [ nat_or_var | ] LIST0 message_token | simple_tactic | tactic_value | reference LIST0 tactic_arg @@ -3370,7 +3355,7 @@ G_LTAC2_tactic_atom: [ | "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| "pattern" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) +| "pat" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) | "reference" ":" "(" globref ")" (* Ltac2 plugin *) | "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index d950b32160..a34e96ac16 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -493,7 +493,7 @@ term_forall_or_fun: [ ] open_binders: [ -| LIST1 name ":" term +| LIST1 name ":" type | LIST1 binder ] @@ -1001,18 +1001,6 @@ command: [ | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" OPT [ "CutOff" integer | string ] | "Show" "Lia" "Profile" (* micromega plugin *) -| "Add" "InjTyp" one_term (* micromega plugin *) -| "Add" "BinOp" one_term (* micromega plugin *) -| "Add" "UnOp" one_term (* micromega plugin *) -| "Add" "CstOp" one_term (* micromega plugin *) -| "Add" "BinRel" one_term (* micromega plugin *) -| "Add" "PropOp" one_term (* micromega plugin *) -| "Add" "PropBinOp" one_term (* micromega plugin *) -| "Add" "PropUOp" one_term (* micromega plugin *) -| "Add" "BinOpSpec" one_term (* micromega plugin *) -| "Add" "UnOpSpec" one_term (* micromega plugin *) -| "Add" "Saturate" one_term (* micromega plugin *) -| "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* ring plugin *) | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) @@ -1117,7 +1105,6 @@ command: [ | "Compute" term | "Check" term | "About" reference OPT univ_name_list -| "SearchHead" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchPattern" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) @@ -1247,11 +1234,7 @@ lident: [ destruction_arg: [ | natural -| constr_with_bindings_arg -] - -constr_with_bindings_arg: [ -| OPT ">" one_term OPT ( "with" bindings ) (* SSR plugin *) +| one_term_with_bindings ] occurrences: [ @@ -1630,7 +1613,6 @@ simple_tactic: [ | "revert" LIST1 ident | "simple" "induction" [ ident | natural ] | "simple" "destruct" [ ident | natural ] -| "double" "induction" [ ident | natural ] [ ident | natural ] | "admit" | "clear" LIST0 ident | "clear" "-" LIST1 ident @@ -1657,7 +1639,7 @@ simple_tactic: [ | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" | "idtac" LIST0 [ ident | string | natural ] -| [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | natural ] +| [ "fail" | "gfail" ] OPT nat_or_var LIST0 [ ident | string | natural ] | ltac_expr ssrintros (* SSR plugin *) | "fun" LIST1 name "=>" ltac_expr | "eval" red_expr "in" term @@ -1691,7 +1673,7 @@ simple_tactic: [ | "absurd" one_term | "contradiction" OPT ( one_term OPT ( "with" bindings ) ) | "autorewrite" OPT "*" "with" LIST1 ident OPT occurrences OPT ( "using" ltac_expr ) -| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" rewrite_occs OPT ( "by" ltac_expr3 ) ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" rewrite_occs ) OPT ( "by" ltac_expr3 ) | "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" rewrite_occs "in" ident OPT ( "by" ltac_expr3 ) | "refine" one_term | "simple" "refine" one_term @@ -1762,7 +1744,6 @@ simple_tactic: [ | "autounfold" OPT hintbases OPT occurrences | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) -| "convert_concl_no_check" one_term | "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 ident ) | "head_of_constr" ident one_term | "not_evar" one_term @@ -1783,12 +1764,12 @@ simple_tactic: [ | "eintros" LIST0 intropattern | "decide" "equality" | "compare" one_term one_term -| "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "elim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) -| "eelim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) +| "apply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "eapply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "simple" "apply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "simple" "eapply" LIST1 one_term_with_bindings SEP "," OPT in_hyp_as +| "elim" one_term_with_bindings OPT ( "using" one_term OPT ( "with" bindings ) ) +| "eelim" one_term_with_bindings OPT ( "using" one_term OPT ( "with" bindings ) ) | "case" induction_clause_list | "ecase" induction_clause_list | "fix" ident natural OPT ( "with" LIST1 fixdecl ) @@ -1842,8 +1823,8 @@ simple_tactic: [ | "unfold" LIST1 reference_occs SEP "," OPT occurrences | "fold" LIST1 one_term OPT occurrences | "pattern" LIST1 pattern_occs SEP "," OPT occurrences -| "change" conversion OPT occurrences -| "change_no_check" conversion OPT occurrences +| "change" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences +| "change_no_check" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences | "btauto" | "rtauto" | "congruence" OPT natural OPT ( "with" LIST1 one_term ) @@ -1922,6 +1903,7 @@ simple_tactic: [ | "lia" | "lra" | "nia" +| "now_show" one_term | "nra" | "over" (* SSR plugin *) | "split_Rabs" @@ -1977,11 +1959,11 @@ as_name: [ ] oriented_rewriter: [ -| OPT [ "->" | "<-" ] rewriter +| OPT [ "->" | "<-" ] OPT natural OPT [ "?" | "!" ] one_term_with_bindings ] -rewriter: [ -| OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg +one_term_with_bindings: [ +| OPT ">" one_term OPT ( "with" bindings ) ] induction_clause_list: [ @@ -2381,7 +2363,7 @@ ltac2_quotations: [ | "ident" ":" "(" lident ")" | "constr" ":" "(" term ")" | "open_constr" ":" "(" term ")" -| "pattern" ":" "(" cpattern ")" +| "pat" ":" "(" cpattern ")" | "reference" ":" "(" [ "&" ident | qualid ] ")" | "ltac1" ":" "(" ltac1_expr_in_env ")" | "ltac1val" ":" "(" ltac1_expr_in_env ")" @@ -2423,7 +2405,6 @@ tac2mode: [ | "Compute" term | "Check" term | "About" reference OPT univ_name_list -| "SearchHead" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchPattern" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) @@ -2454,12 +2435,6 @@ cofixdecl: [ | "(" ident LIST0 simple_binder ":" term ")" ] -conversion: [ -| one_term -| one_term "with" one_term -| one_term "at" occs_nums "with" one_term -] - func_scheme_def: [ | ident ":=" "Induction" "for" qualid "Sort" sort_family (* funind plugin *) ] diff --git a/dune-project b/dune-project index 1187c58449..03e7147019 100644 --- a/dune-project +++ b/dune-project @@ -27,7 +27,8 @@ (ocaml (>= 4.05.0)) (dune (>= 2.5.0)) (ocamlfind (>= 1.8.1)) - (zarith (>= 1.10))) + (zarith (>= 1.10)) + (ounit2 :with-test)) (synopsis "The Coq Proof Assistant") (description "Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable @@ -75,6 +76,7 @@ development of interactive proofs.")) (license "OPL-1.0") (depends (dune (and :build (>= 2.5.0))) + (conf-python-3 :build) (coq (and :build (= :version)))) (synopsis "The Coq Proof Assistant --- Reference Manual") (description "Coq is a formal proof management system. It provides diff --git a/engine/eConstr.ml b/engine/eConstr.ml index c29de27efb..157995a173 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -35,6 +35,10 @@ include (Evd.MiniEConstr : module type of Evd.MiniEConstr type types = t type constr = t type existential = t pexistential +type case_return = t pcase_return +type case_branch = t pcase_branch +type case_invert = t pcase_invert +type case = (t, t, EInstance.t) pcase type fixpoint = (t, t) pfixpoint type cofixpoint = (t, t) pcofixpoint type unsafe_judgment = (constr, types) Environ.punsafe_judgment @@ -69,7 +73,7 @@ let mkInd i = of_kind (Ind (in_punivs i)) let mkConstructU pc = of_kind (Construct pc) let mkConstruct c = of_kind (Construct (in_punivs c)) let mkConstructUi ((ind,u),i) = of_kind (Construct ((ind,i),u)) -let mkCase (ci, c, iv, r, p) = of_kind (Case (ci, c, iv, r, p)) +let mkCase (ci, u, pms, c, iv, r, p) = of_kind (Case (ci, u, pms, c, iv, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) @@ -195,7 +199,7 @@ let destCoFix sigma c = match kind sigma c with | _ -> raise DestKO let destCase sigma c = match kind sigma c with -| Case (ci, t, iv, c, p) -> (ci, t, iv, c, p) +| Case (ci, u, pms, t, iv, c, p) -> (ci, u, pms, t, iv, c, p) | _ -> raise DestKO let destProj sigma c = match kind sigma c with @@ -320,19 +324,28 @@ let existential_type = Evd.existential_type let lift n c = of_constr (Vars.lift n (unsafe_to_constr c)) -let map_under_context f n c = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_under_context f n (unsafe_to_constr c)) -let map_branches f ci br = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr_array (Constr.map_branches f ci (unsafe_to_constr_array br)) -let map_return_predicate f ci p = - let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_return_predicate f ci (unsafe_to_constr p)) +let of_branches : Constr.case_branch array -> case_branch array = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let unsafe_to_branches : case_branch array -> Constr.case_branch array = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let of_return : Constr.case_return -> case_return = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x -let map_user_view sigma f c = +let unsafe_to_return : case_return -> Constr.case_return = + match Evd.MiniEConstr.unsafe_eq with + | Refl -> fun x -> x + +let map_branches f br = + let f c = unsafe_to_constr (f (of_constr c)) in + of_branches (Constr.map_branches f (unsafe_to_branches br)) +let map_return_predicate f p = let f c = unsafe_to_constr (f (of_constr c)) in - of_constr (Constr.map_user_view f (unsafe_to_constr (whd_evar sigma c))) + of_return (Constr.map_return_predicate f (unsafe_to_return p)) let map sigma f c = let f c = unsafe_to_constr (f (of_constr c)) in @@ -346,7 +359,61 @@ let iter sigma f c = let f c = f (of_constr c) in Constr.iter f (unsafe_to_constr (whd_evar sigma c)) -let iter_with_full_binders sigma g f n c = +let expand_case env _sigma (ci, u, pms, p, iv, c, bl) = + let u = EInstance.unsafe_to_instance u in + let pms = unsafe_to_constr_array pms in + let p = unsafe_to_return p in + let iv = unsafe_to_case_invert iv in + let c = unsafe_to_constr c in + let bl = unsafe_to_branches bl in + let (ci, p, iv, c, bl) = Inductive.expand_case env (ci, u, pms, p, iv, c, bl) in + let p = of_constr p in + let c = of_constr c in + let iv = of_case_invert iv in + let bl = of_constr_array bl in + (ci, p, iv, c, bl) + +let annotate_case env sigma (ci, u, pms, p, iv, c, bl as case) = + let (_, p, _, _, bl) = expand_case env sigma case in + let p = + (* Too bad we need to fetch this data in the environment, should be in the + case_info instead. *) + let (_, mip) = Inductive.lookup_mind_specif env ci.ci_ind in + decompose_lam_n_decls sigma (mip.Declarations.mind_nrealdecls + 1) p + in + let mk_br c n = decompose_lam_n_decls sigma n c in + let bl = Array.map2 mk_br bl ci.ci_cstr_ndecls in + (ci, u, pms, p, iv, c, bl) + +let expand_branch env _sigma u pms (ind, i) (nas, _br) = + let open Declarations in + let u = EInstance.unsafe_to_instance u in + let pms = unsafe_to_constr_array pms in + let (mib, mip) = Inductive.lookup_mind_specif env ind in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + let ans = Inductive.instantiate_context u subst nas ctx in + let ans : rel_context = match Evd.MiniEConstr.unsafe_eq with Refl -> ans in + ans + +let contract_case env _sigma (ci, p, iv, c, bl) = + let p = unsafe_to_constr p in + let iv = unsafe_to_case_invert iv in + let c = unsafe_to_constr c in + let bl = unsafe_to_constr_array bl in + let (ci, u, pms, p, iv, c, bl) = Inductive.contract_case env (ci, p, iv, c, bl) in + let u = EInstance.make u in + let pms = of_constr_array pms in + let p = of_return p in + let iv = of_case_invert iv in + let c = of_constr c in + let bl = of_branches bl in + (ci, u, pms, p, iv, c, bl) + +let iter_with_full_binders env sigma g f n c = let open Context.Rel.Declaration in match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -357,7 +424,10 @@ let iter_with_full_binders sigma g f n c = | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl + | Case (ci,u,pms,p,iv,c,bl) -> + let (ci, _, pms, p, iv, c, bl) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx (ctx, c) = f (List.fold_right g ctx n) c in + Array.Fun1.iter f n pms; f_ctx p; iter_invert (f n) iv; f n c; Array.iter f_ctx bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; @@ -566,8 +636,8 @@ let universes_of_constr sigma c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c - | Case (_,_,CaseInvert {univs;args=_},_,_) -> - let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma univs)) s in + | Case (_,u,_,_,_,_,_) -> + let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c | _ -> fold sigma aux s c in aux LSet.empty c diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 882dfe2848..0d038e9a67 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -20,6 +20,8 @@ type t = Evd.econstr type types = t type constr = t type existential = t pexistential +type case_return = t pcase_return +type case_branch = t pcase_branch type fixpoint = (t, t) pfixpoint type cofixpoint = (t, t) pcofixpoint type unsafe_judgment = (constr, types) Environ.punsafe_judgment @@ -58,6 +60,9 @@ sig val is_empty : t -> bool end +type case_invert = t pcase_invert +type case = (t, t, EInstance.t) pcase + type 'a puniverses = 'a * EInstance.t (** {5 Destructors} *) @@ -128,7 +133,7 @@ val mkIndU : inductive * EInstance.t -> t val mkConstruct : constructor -> t val mkConstructU : constructor * EInstance.t -> t val mkConstructUi : (inductive * EInstance.t) * int -> t -val mkCase : case_info * t * (t,EInstance.t) case_invert * t * t array -> t +val mkCase : case -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t val mkArrow : t -> Sorts.relevance -> t -> t @@ -199,7 +204,7 @@ val destConst : Evd.evar_map -> t -> Constant.t * EInstance.t val destEvar : Evd.evar_map -> t -> t pexistential val destInd : Evd.evar_map -> t -> inductive * EInstance.t val destConstruct : Evd.evar_map -> t -> constructor * EInstance.t -val destCase : Evd.evar_map -> t -> case_info * t * (t,EInstance.t) case_invert * t * t array +val destCase : Evd.evar_map -> t -> case val destProj : Evd.evar_map -> t -> Projection.t * t val destFix : Evd.evar_map -> t -> (t, t) pfixpoint val destCoFix : Evd.evar_map -> t -> (t, t) pcofixpoint @@ -250,14 +255,12 @@ val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) val map : Evd.evar_map -> (t -> t) -> t -> t -val map_user_view : Evd.evar_map -> (t -> t) -> t -> t val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t -val map_under_context : (t -> t) -> int -> t -> t -val map_branches : (t -> t) -> case_info -> t array -> t array -val map_return_predicate : (t -> t) -> case_info -> t -> t +val map_branches : (t -> t) -> case_branch array -> case_branch array +val map_return_predicate : (t -> t) -> case_return -> case_return val iter : Evd.evar_map -> (t -> unit) -> t -> unit val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit -val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit +val iter_with_full_binders : Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a (** Gather the universes transitively used in the term, including in the @@ -337,6 +340,21 @@ val fresh_global : val is_global : Evd.evar_map -> GlobRef.t -> t -> bool [@@ocaml.deprecated "Use [EConstr.isRefX] instead."] +val expand_case : Environ.env -> Evd.evar_map -> + case -> (case_info * t * case_invert * t * t array) + +val annotate_case : Environ.env -> Evd.evar_map -> case -> + case_info * EInstance.t * t array * (rel_context * t) * case_invert * t * (rel_context * t) array +(** Same as above, but doesn't turn contexts into binders *) + +val expand_branch : Environ.env -> Evd.evar_map -> + EInstance.t -> t array -> constructor -> case_branch -> rel_context +(** Given a universe instance and parameters for the inductive type, + constructs the typed context in which the branch lives. *) + +val contract_case : Environ.env -> Evd.evar_map -> + (case_info * t * case_invert * t * t array) -> case + (** {5 Extra} *) val of_existential : Constr.existential -> existential @@ -345,7 +363,7 @@ val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, typ val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt -val of_case_invert : (Constr.t,Univ.Instance.t) case_invert -> (t,EInstance.t) case_invert +val of_case_invert : Constr.case_invert -> case_invert (** {5 Unsafe operations} *) @@ -371,7 +389,7 @@ sig val to_instance : EInstance.t -> Univ.Instance.t (** Physical identity. Does not care for normalization. *) - val to_case_invert : (t,EInstance.t) case_invert -> (Constr.t,Univ.Instance.t) case_invert + val to_case_invert : case_invert -> Constr.case_invert val eq : (t, Constr.t) eq (** Use for transparent cast between types. *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index ba6a9ea6d9..f9f8268507 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -144,7 +144,7 @@ let head_evar sigma c = let c = EConstr.Unsafe.to_constr c in let rec hrec c = match kind c with | Evar (evk,_) -> evk - | Case (_,_,_,c,_) -> hrec c + | Case (_, _, _, _, _, c, _) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c diff --git a/engine/evd.ml b/engine/evd.ml index 706e51d4b3..ed40b63d14 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -525,7 +525,7 @@ end = struct let principal = if principal then match fgl.principal with - | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") + | Some _ -> CErrors.user_err Pp.(str "Only one main goal per instantiation.") | None -> Some evk else fgl.principal in diff --git a/engine/evd.mli b/engine/evd.mli index a6d55c2615..58f635b7bd 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -772,8 +772,8 @@ module MiniEConstr : sig (Constr.t, Constr.types) Context.Named.Declaration.pt val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt - val of_case_invert : (constr,Univ.Instance.t) case_invert -> (econstr,EInstance.t) case_invert - val unsafe_to_case_invert : (econstr,EInstance.t) case_invert -> (constr,Univ.Instance.t) case_invert + val of_case_invert : constr pcase_invert -> econstr pcase_invert + val unsafe_to_case_invert : econstr pcase_invert -> constr pcase_invert val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, t) Context.Rel.Declaration.pt val to_rel_decl : evar_map -> (t, t) Context.Rel.Declaration.pt -> diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 7784b38c80..5208469082 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -74,7 +74,7 @@ module NonLogical : sig (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t - val timeout : int -> 'a t -> 'a option t + val timeout : float -> 'a t -> 'a option t (** Construct a monadified side-effect. Exceptions raised by the argument are wrapped with {!Exception}. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index b3061eaa81..abc1a907d3 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -927,7 +927,7 @@ let _ = CErrors.register_handler begin function | _ -> None end -let tclTIMEOUT n t = +let tclTIMEOUTF n t = let open Proof in (* spiwack: as one of the monad is a continuation passing monad, it doesn't force the computation to be threaded inside the underlying @@ -952,6 +952,8 @@ let tclTIMEOUT n t = return res | Util.Inr (e, info) -> tclZERO ~info e +let tclTIMEOUT n t = tclTIMEOUTF (float_of_int n) t + let tclTIME s t = let pr_time t1 t2 n msg = let msg = diff --git a/engine/proofview.mli b/engine/proofview.mli index fe0d7ae51e..bf6021b1b6 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -418,7 +418,8 @@ val tclCHECKINTERRUPT : unit tactic (** [tclTIMEOUT n t] can have only one success. In case of timeout it fails with [tclZERO Tac_Timeout]. *) -val tclTIMEOUT : int -> 'a tactic -> 'a tactic +val tclTIMEOUTF : float -> 'a tactic -> 'a tactic +val tclTIMEOUT : int -> 'a tactic -> 'a tactic (** [tclTIME s t] displays time for each atomic call to t, using s as an identifying annotation if present *) diff --git a/engine/termops.ml b/engine/termops.ml index 66131e1a8f..4dc584cfa8 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -606,7 +606,7 @@ let map_left2 f a g b = r, s end -let map_constr_with_binders_left_to_right sigma g f l c = +let map_constr_with_binders_left_to_right env sigma g f l c = let open RelDecl in let open EConstr in match EConstr.kind sigma c with @@ -650,14 +650,20 @@ let map_constr_with_binders_left_to_right sigma g f l c = let al' = List.map_left (f l) al in if List.for_all2 (==) al' al then c else mkEvar (e, al') - | Case (ci,p,iv,b,bl) -> + | Case (ci,u,pms,p,iv,b,bl) -> + let (ci, _, pms, p0, _, b, bl0) = annotate_case env sigma (ci, u, pms, p, iv, b, bl) in + let f_ctx (nas, _ as r) (ctx, c) = + let c' = f (List.fold_right g ctx l) c in + if c' == c then r else (nas, c') + in (* In v8 concrete syntax, predicate is after the term to match! *) let b' = f l b in + let pms' = Array.map_left (f l) pms in + let p' = f_ctx p p0 in let iv' = map_invert (f l) iv in - let p' = f l p in - let bl' = Array.map_left (f l) bl in - if b' == b && p' == p && iv' == iv && bl' == bl then c - else mkCase (ci, p', iv', b', bl') + let bl' = Array.map_left (fun (c, c0) -> f_ctx c c0) (Array.map2 (fun x y -> (x, y)) bl bl0) in + if b' == b && pms' == pms && p' == p && iv' == iv && bl' == bl then c + else mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in @@ -677,34 +683,8 @@ let map_constr_with_binders_left_to_right sigma g f l c = if def' == def && t' == t && ty' == ty then c else mkArray(u,t',def',ty') -let rec map_under_context_with_full_binders sigma g f l n d = - if n = 0 then f l d else - match EConstr.kind sigma d with - | LetIn (na,b,t,c) -> - let b' = f l b in - let t' = f l t in - let c' = map_under_context_with_full_binders sigma g f (g (Context.Rel.Declaration.LocalDef (na,b,t)) l) (n-1) c in - if b' == b && t' == t && c' == c then d - else EConstr.mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f l t in - let b' = map_under_context_with_full_binders sigma g f (g (Context.Rel.Declaration.LocalAssum (na,t)) l) (n-1) b in - if t' == t && b' == b then d - else EConstr.mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches_with_full_binders sigma g f l ci bl = - let tags = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context_with_full_binders sigma g f l) tags bl in - if Array.for_all2 (==) bl' bl then bl else bl' - -let map_return_predicate_with_full_binders sigma g f l ci p = - let n = List.length ci.ci_pp_info.ind_tags in - let p' = map_under_context_with_full_binders sigma g f l n p in - if p' == p then p else p' - (* strong *) -let map_constr_with_full_binders_gen userview sigma g f l cstr = +let map_constr_with_full_binders env sigma g f l cstr = let open EConstr in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -736,20 +716,19 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = | Evar (e,al) -> let al' = List.map (f l) al in if List.for_all2 (==) al al' then cstr else mkEvar (e, al') - | Case (ci,p,iv,c,bl) when userview -> - let p' = map_return_predicate_with_full_binders sigma g f l ci p in - let iv' = map_invert (f l) iv in - let c' = f l c in - let bl' = map_branches_with_full_binders sigma g f l ci bl in - if p==p' && iv'==iv && c==c' && bl'==bl then cstr else - mkCase (ci, p', iv', c', bl') - | Case (ci,p,iv,c,bl) -> - let p' = f l p in + | Case (ci, u, pms, p, iv, c, bl) -> + let (ci, _, pms, p0, _, c, bl0) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx (nas, _ as r) (ctx, c) = + let c' = f (List.fold_right g ctx l) c in + if c' == c then r else (nas, c') + in + let pms' = Array.Smart.map (f l) pms in + let p' = f_ctx p p0 in let iv' = map_invert (f l) iv in let c' = f l c in - let bl' = Array.map (f l) bl in - if p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else - mkCase (ci, p', iv', c', bl') + let bl' = Array.map2 f_ctx bl bl0 in + if pms==pms' && p==p' && iv'==iv && c==c' && Array.for_all2 (==) bl bl' then cstr else + mkCase (ci, u, pms', p', iv', c', bl') | Fix (ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in let l' = fold_rec_types g fx l in @@ -770,12 +749,6 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let ty' = f l ty in if def==def' && t == t' && ty==ty' then cstr else mkArray (u,t', def',ty') -let map_constr_with_full_binders sigma g f = - map_constr_with_full_binders_gen false sigma g f - -let map_constr_with_full_binders_user_view sigma g f = - map_constr_with_full_binders_gen true sigma g f - (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as @@ -783,7 +756,7 @@ let map_constr_with_full_binders_user_view sigma g f = index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) -let fold_constr_with_full_binders sigma g f n acc c = +let fold_constr_with_full_binders env sigma g f n acc c = let open EConstr.Vars in let open Context.Rel.Declaration in match EConstr.kind sigma c with @@ -795,7 +768,10 @@ let fold_constr_with_full_binders sigma g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Case (ci, u, pms, p, iv, c, bl) -> + let (ci, _, pms, p, _, c, bl) = EConstr.annotate_case env sigma (ci, u, pms, p, iv, c, bl) in + let f_ctx acc (ctx, c) = f (List.fold_right g ctx n) acc c in + Array.fold_left f_ctx (f n (fold_invert (f n) (f_ctx (Array.fold_left (f n) acc pms) p) iv) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in diff --git a/engine/termops.mli b/engine/termops.mli index 709fa361a9..12df61e4c8 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -50,16 +50,12 @@ val it_mkLambda_or_LetIn_from_no_LetIn : Constr.constr -> Constr.rel_context -> (** {6 Generic iterators on constr} *) val map_constr_with_binders_left_to_right : - Evd.evar_map -> + Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : - Evd.evar_map -> - (rel_declaration -> 'a -> 'a) -> - ('a -> constr -> constr) -> 'a -> constr -> constr -val map_constr_with_full_binders_user_view : - Evd.evar_map -> + Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr @@ -73,7 +69,7 @@ val map_constr_with_full_binders_user_view : val fold_constr_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b -val fold_constr_with_full_binders : Evd.evar_map -> +val fold_constr_with_full_binders : Environ.env -> Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 335c2e5e68..330ed5d0ad 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -68,6 +68,10 @@ let subst_univs_fn_constr f c = let u' = fi u in if u' == u then t else (changed := true; mkConstructU (c, u')) + | Case (ci, u, pms, p, iv, c, br) -> + let u' = fi u in + if u' == u then map aux t + else (changed := true; map aux (mkCase (ci, u', pms, p, iv, c, br))) | _ -> map aux t in let c' = aux c in @@ -147,10 +151,10 @@ let nf_evars_and_universes_opt_subst f subst = | Sort (Type u) -> let u' = Univ.subst_univs_universe subst u in if u' == u then c else mkSort (sort_of_univ u') - | Case (ci,p,CaseInvert {univs;args},t,br) -> - let univs' = Instance.subst_fn lsubst univs in - if univs' == univs then Constr.map aux c - else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},t,br)) + | Case (ci,u,pms,p,iv,t,br) -> + let u' = Instance.subst_fn lsubst u in + if u' == u then Constr.map aux c + else Constr.map aux (mkCase (ci,u',pms,p,iv,t,br)) | Array (u,elems,def,ty) -> let u' = Univ.Instance.subst_fn lsubst u in let elems' = CArray.Smart.map aux elems in diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index b8228df2aa..20e9f0134f 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -13,13 +13,9 @@ open Preferences let ideslave_coqtop_flags = ref None -(** * Version and date *) +(** * Version *) -let get_version_date () = - let date = - if Glib.Utf8.validate Coq_config.date - then Coq_config.date - else "<date not printable>" in +let get_version () = try (* the following makes sense only when running with local layout *) let coqroot = Filename.concat @@ -29,21 +25,20 @@ let get_version_date () = let ch = open_in (Filename.concat coqroot "revision") in let ver = input_line ch in let rev = input_line ch in - (ver,rev) - with _ -> (Coq_config.version,date) + close_in ch; + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let short_version () = - let (ver,date) = get_version_date () in - Printf.sprintf "The Coq Proof Assistant, version %s (%s)\n" ver date + Printf.sprintf "The Coq Proof Assistant, version %s\n" (get_version ()) let version () = - let (ver,date) = get_version_date () in Printf.sprintf - "The Coq Proof Assistant, version %s (%s)\ + "The Coq Proof Assistant, version %s\ \nArchitecture %s running %s operating system\ \nGtk version is %s\ \nThis is %s \n" - ver date + (get_version ()) Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) (Filename.basename Sys.executable_name) diff --git a/ide/coqide/coq_commands.ml b/ide/coqide/coq_commands.ml index 711986c2b2..2d75ad9ff6 100644 --- a/ide/coqide/coq_commands.ml +++ b/ide/coqide/coq_commands.ml @@ -207,7 +207,6 @@ let state_preserving = [ "Recursive Extraction Library"; "Search"; - "SearchHead"; "SearchPattern"; "SearchRewrite"; diff --git a/ide/coqide/coqide.ml b/ide/coqide/coqide.ml index f9e6e74372..3fbfbd66d3 100644 --- a/ide/coqide/coqide.ml +++ b/ide/coqide/coqide.ml @@ -1374,8 +1374,7 @@ let main files = let read_coqide_args argv = let set_debug () = Minilib.debug := true; - Flags.debug := true; - Exninfo.record_backtrace true + CDebug.set_debug_all true in let rec filter_coqtop coqtop project_files bindings_files out = function |"-unicode-bindings" :: sfilenames :: args -> @@ -1405,6 +1404,9 @@ let read_coqide_args argv = |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; filter_coqtop coqtop project_files bindings_files out args + | ("-v" | "--version") :: _ -> + Printf.printf "CoqIDE, version %s\n" Coq_config.version; + exit 0 |arg::args when out = [] && CString.is_prefix "-psn_" arg -> (* argument added by MacOS during .app launch *) filter_coqtop coqtop project_files bindings_files out args diff --git a/ide/coqide/coqide_main.ml b/ide/coqide/coqide_main.ml index 0812e00960..a178e72806 100644 --- a/ide/coqide/coqide_main.ml +++ b/ide/coqide/coqide_main.ml @@ -35,7 +35,7 @@ let catch_gtk_messages () = let () = GToolbox.message_box ~title:"Error" (header ^ msg) in Coqide.crash_save 1 |`ERROR -> - if !Flags.debug then GToolbox.message_box ~title:"Error" (header ^ msg) + if CDebug.(get_flag misc) then GToolbox.message_box ~title:"Error" (header ^ msg) else Printf.eprintf "%s\n" (header ^ msg) |`DEBUG -> Minilib.log msg |level when Sys.os_type = "Win32" -> Minilib.log ~level msg diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 602acefa7c..a6a7f7d742 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -35,11 +35,11 @@ let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s let pr_debug s = - if !Flags.debug then pr_with_pid s + if CDebug.(get_flag misc) then pr_with_pid s let pr_debug_call q = - if !Flags.debug then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q) + if CDebug.(get_flag misc) then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q) let pr_debug_answer q r = - if !Flags.debug then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r) + if CDebug.(get_flag misc) then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r) (** Categories of commands *) @@ -195,7 +195,7 @@ let concl_next_tac = let process_goal sigma g = let env = Goal.V82.env sigma g in let min_env = Environ.reset_context env in - let id = if Printer.print_goal_names () then Names.Id.to_string (Termops.evar_suggested_name g sigma) else "" in + let id = if Printer.print_goal_names () then Names.Id.to_string (Termops.evar_suggested_name g sigma) else Goal.uid g in let ccl = pr_letype_env ~goal_concl_style:true env sigma (Goal.V82.concl sigma g) in @@ -397,8 +397,8 @@ let set_options options = let about () = { Interface.coqtop_version = Coq_config.version; Interface.protocol_version = Xmlprotocol.protocol_version; - Interface.release_date = Coq_config.date; - Interface.compile_date = Coq_config.compile_date; + Interface.release_date = "n/a"; + Interface.compile_date = "n/a"; } let handle_exn (e, info) = @@ -513,9 +513,11 @@ let msg_format = ref (fun () -> (* The loop ignores the command line arguments as the current model delegates its handing to the toplevel container. *) -let loop run_mode ~opts:_ state = +let loop ( { Coqtop.run_mode; color_mode },_) ~opts:_ state = match run_mode with | Coqtop.Batch -> exit 0 + | Coqtop.(Query PrintTags) -> Coqtop.print_style_tags color_mode; exit 0 + | Coqtop.(Query _) -> Printf.eprintf "Unknown query"; exit 1 | Coqtop.Interactive -> let open Vernac.State in set_doc state.doc; @@ -580,32 +582,28 @@ coqidetop specific options:\n\ \n --help-XML-protocol print documentation of the Coq XML protocol\n" } -let islave_parse ~opts extra_args = +let islave_parse extra_args = let open Coqtop in - let run_mode, extra_args = coqtop_toplevel.parse_extra ~opts extra_args in + let ({ run_mode; color_mode }, stm_opts), extra_args = coqtop_toplevel.parse_extra extra_args in let extra_args = parse extra_args in (* One of the role of coqidetop is to find the name of buffers to open *) (* in the command line; Coqide is waiting these names on stdout *) (* (see filter_coq_opts in coq.ml), so we send them now *) print_string (String.concat "\n" extra_args); - run_mode, [] + ( { Coqtop.run_mode; color_mode }, stm_opts), [] -let islave_init run_mode ~opts = +let islave_init ( { Coqtop.run_mode; color_mode }, stm_opts) injections ~opts = if run_mode = Coqtop.Batch then Flags.quiet := true; - Coqtop.init_toploop opts + Coqtop.init_toploop opts stm_opts injections -let islave_default_opts = - Coqargs.{ default with - config = { default.config with - stm_flags = { default.config.stm_flags with - Stm.AsyncOpts.async_proofs_worker_priority = CoqworkmgrApi.High }}} +let islave_default_opts = Coqargs.default let () = let open Coqtop in let custom = { parse_extra = islave_parse ; - help = coqidetop_specific_usage; - init = islave_init; + usage = coqidetop_specific_usage; + init_extra = islave_init; run = loop; - opts = islave_default_opts } in + initial_args = islave_default_opts } in start_coq custom diff --git a/ide/coqide/microPG.ml b/ide/coqide/microPG.ml index 5a4871b70a..9908703cea 100644 --- a/ide/coqide/microPG.ml +++ b/ide/coqide/microPG.ml @@ -15,7 +15,7 @@ open GdkKeysyms open Printf let eprintf x = - if !Flags.debug then Printf.eprintf x else Printf.ifprintf stderr x + if CDebug.(get_flag misc) then Printf.eprintf x else Printf.ifprintf stderr x type gui = { notebook : session Wg_Notebook.typed_notebook; diff --git a/ide/coqide/wg_Find.ml b/ide/coqide/wg_Find.ml index 7e89191bd1..7f30cc8c6c 100644 --- a/ide/coqide/wg_Find.ml +++ b/ide/coqide/wg_Find.ml @@ -219,16 +219,18 @@ class finder name (view : GText.view) = let _ = replace_all_button#connect#clicked ~callback:self#replace_all in (* Keypress interaction *) - let generic_cb esc_cb ret_cb ev = + let dispatch_key_cb esc_cb ret_cb shift_ret_cb ev = let ev_key = GdkEvent.Key.keyval ev in - let (return, _) = GtkData.AccelGroup.parse "Return" in - let (esc, _) = GtkData.AccelGroup.parse "Escape" in - if ev_key = return then (ret_cb (); true) - else if ev_key = esc then (esc_cb (); true) + let ev_modifiers = GdkEvent.Key.state ev in + if ev_key = GdkKeysyms._Return then + (if List.mem `SHIFT ev_modifiers then + shift_ret_cb () + else ret_cb (); true) + else if ev_key = GdkKeysyms._Escape then (esc_cb (); true) else false in - let find_cb = generic_cb self#hide self#find_forward in - let replace_cb = generic_cb self#hide self#replace in + let find_cb = dispatch_key_cb self#hide self#find_forward self#find_backward in + let replace_cb = dispatch_key_cb self#hide self#replace self#replace in let _ = find_entry#event#connect#key_press ~callback:find_cb in let _ = replace_entry#event#connect#key_press ~callback:replace_cb in diff --git a/ide/coqide/wg_ProofView.ml b/ide/coqide/wg_ProofView.ml index 8e451c9917..fa37edd82b 100644 --- a/ide/coqide/wg_ProofView.ml +++ b/ide/coqide/wg_ProofView.ml @@ -66,11 +66,11 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = mat in let goals_cnt = List.length rem_goals + 1 in let head_str = Printf.sprintf - "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") + "%d goal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") in let goal_str ?(shownum=false) index total id = let annot = - if CString.is_empty id then if shownum then Printf.sprintf "(%d/%d)" index total else "" + if Option.has_some (int_of_string_opt id) (* some uid *) then if shownum then Printf.sprintf "(%d/%d)" index total else "" else Printf.sprintf "(?%s)" id in Printf.sprintf "______________________________________%s\n" annot in @@ -148,10 +148,10 @@ let display mode (view : #GText.view_skel) goals hints evars = let evars = match evars with None -> [] | Some evs -> evs in begin match (bg, shelved_goals,given_up_goals, evars) with | [], [], [], [] -> - view#buffer#insert "No more subgoals." + view#buffer#insert "No more goals." | [], [], [], _ :: _ -> (* A proof has been finished, but not concluded *) - view#buffer#insert "No more subgoals, but there are non-instantiated existential variables:\n\n"; + view#buffer#insert "No more goals, but there are non-instantiated existential variables:\n\n"; let iter evar = let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in view#buffer#insert msg @@ -160,7 +160,7 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "\nYou can use Grab Existential Variables." | [], [], _, _ -> (* The proof is finished, with the exception of given up goals. *) - view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; + view#buffer#insert "No more goals, but there are some goals you gave up:\n\n"; let iter goal = insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" @@ -180,7 +180,7 @@ let display mode (view : #GText.view_skel) goals hints evars = let total = List.length bg in let goal_str index id = let annot = - if CString.is_empty id then Printf.sprintf "(%d/%d)" index total + if Option.has_some (int_of_string_opt id) (* some uid *) then Printf.sprintf "(%d/%d)" index total else Printf.sprintf "(?%s)" id in Printf.sprintf "______________________________________%s\n" annot diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f3ba884856..8138b4c6d9 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1463,23 +1463,33 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PIf (c,b1,b2) -> GIf (glob_of_pat avoid env sigma c, (Anonymous,None), glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2) - | PCase ({cip_style=Constr.LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> - let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in + | PCase ({cip_style=Constr.LetStyle},None,tm,[(0,n,b)]) -> + let n, b = glob_of_pat_under_context avoid env sigma (n, b) in + let nal = Array.to_list n in GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with | [], _ -> [] | _, Some ind -> - let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat avoid env sigma c)) bl in - simple_cases_matrix_of_branches ind bl' + let map (i, n, c) = + let n, c = glob_of_pat_under_context avoid env sigma (n, c) in + let nal = Array.to_list n in + let mkPatVar na = DAst.make @@ PatVar na in + let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + let ids = List.map_filter Nameops.Name.to_option nal in + CAst.make @@ (ids,[p],c) + in + List.map map bl | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in - let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with - | PMeta None, _, _ -> (Anonymous,None),None - | _, Some ind, Some nargs -> - return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) + let indnames,rtn = match p, info.cip_ind with + | None, _ -> (Anonymous,None),None + | Some p, Some ind -> + let nas, p = glob_of_pat_under_context avoid env sigma p in + let nas = Array.rev_to_list nas in + ((List.hd nas, Some (CAst.make (ind, List.tl nas))), Some p) | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) @@ -1523,6 +1533,18 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with let glob_of = glob_of_pat avoid env sigma in GArray (None, Array.map glob_of t, glob_of def, glob_of ty) +and glob_of_pat_under_context avoid env sigma (nas, pat) = + let fold (avoid, env, nas, epat) na = + let na, avoid = compute_displayed_name_in_pattern sigma avoid na epat in + let env = Termops.add_name na env in + let epat = match epat with PLambda (_, _, p) -> p | _ -> assert false in + (avoid, env, na :: nas, epat) + in + let epat = Array.fold_right (fun na p -> PLambda (na, PMeta None, p)) nas pat in + let (avoid', env', nas, _) = Array.fold_left fold (avoid, env, [], epat) nas in + let pat = glob_of_pat avoid' env' sigma pat in + (Array.rev_of_list nas, pat) + let extern_constr_pattern env sigma pat = extern true (InConstrEntrySomeLevel,(None,[])) (* XXX no vars? *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 70a4ea35e9..7c63ebda3a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -244,6 +244,8 @@ let contract_curly_brackets_pat ntn (l,ll) = type local_univs = { bound : Univ.Level.t Id.Map.t; unb_univs : bool } +let empty_local_univs = { bound = Id.Map.empty; unb_univs = false } + type intern_env = { ids: Id.Set.t; unb: bool; @@ -1202,6 +1204,11 @@ let intern_sort ~local_univs s = let intern_instance ~local_univs us = Option.map (List.map (map_glob_sort_gen (intern_sort_name ~local_univs))) us +let try_interp_name_alias = function + | [], { CAst.v = CRef (ref,u) } -> + NRef (intern_reference ref,intern_instance ~local_univs:empty_local_univs u) + | _ -> raise Not_found + (* Is it a global reference or a syntactic definition? *) let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let loc = qid.loc in @@ -1251,16 +1258,16 @@ let intern_qualid_for_pattern test_global intern_not qid pats = | SynDef kn -> let filter (vars,a) = match a with - | NRef g -> + | NRef (g,_) -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_global g; let () = assert (List.is_empty vars) in Some (g, Some [], pats) - | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) + | NApp (NRef (g,_),[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) test_global g; let () = assert (List.is_empty vars) in Some (g, None, pats) - | NApp (NRef g,args) -> + | NApp (NRef (g,_),args) -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_global g; let nvars = List.length vars in @@ -1330,7 +1337,7 @@ let interp_reference vars r = let r,_ = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false; - local_univs = { bound=Id.Map.empty; unb_univs = false };(* <- doesn't matter here *) + local_univs = empty_local_univs;(* <- doesn't matter here *) tmp_scope = None; scopes = []; impls = empty_internalization_env; binder_block_names = None} Environ.empty_named_context_val @@ -1784,10 +1791,10 @@ let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((make ?loc id),scopes)) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end - | NRef g -> + | NRef (g,_) -> ensure_kind test_kind ?loc g; DAst.make ?loc @@ RCPatCstr (g, in_patargs ?loc scopes g true false [] args) - | NApp (NRef g,ntnpl) -> + | NApp (NRef (g,_),ntnpl) -> ensure_kind test_kind ?loc g; let ntnpl = List.map (in_not test_kind_inner loc scopes fullsubst []) ntnpl in let no_impl = @@ -2554,7 +2561,7 @@ let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in let c = internalize env {ids; unb = false; - local_univs = { bound = Id.Map.empty; unb_univs = false }; + local_univs = empty_local_univs; tmp_scope = None; scopes = []; impls; binder_block_names = None} false (empty_ltac_sign, vl) a in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index f92a54e23f..65b63962d0 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -150,6 +150,10 @@ val interp_constr_pattern : (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) val intern_reference : qualid -> GlobRef.t +(** For syntactic definitions: check if abbreviation to a name + and avoid early insertion of maximal implicit arguments *) +val try_interp_name_alias : 'a list * constr_expr -> notation_constr + (** Expands abbreviations (syndef); raise an error if not existing *) val interp_reference : ltac_sign -> qualid -> glob_constr diff --git a/interp/impargs.ml b/interp/impargs.ml index 7742f985de..1e85fadce5 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -209,16 +209,16 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Proj (p, _) when rig -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Case _ when rig -> if strict then () else - iter_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders env sigma push_lift (frec false) ed c | Evar _ -> () | _ -> - iter_with_full_binders sigma push_lift (frec rig) ed c + iter_with_full_binders env sigma push_lift (frec rig) ed c in let () = if not (Vars.noccur_between sigma 1 bound m) then frec true (env,1) m in acc @@ -228,7 +228,7 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc let rec is_rigid_head sigma t = match kind sigma t with | Rel _ | Evar _ -> false | Ind _ | Const _ | Var _ | Sort _ -> true - | Case (_,_,_,f,_) -> is_rigid_head sigma f + | Case (_,_,_,_,_,f,_) -> is_rigid_head sigma f | Proj (p,c) -> true | App (f,args) -> (match kind sigma f with diff --git a/interp/notation.ml b/interp/notation.ml index f2d113954b..d6002d71b5 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -400,12 +400,12 @@ let cases_pattern_key c = match DAst.get c with | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) - | NApp (NRef ref,args) -> RefKey(canonical_gr ref), AppBoundedNotation (List.length args) - | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_,_) -> + | NApp (NRef (ref,_),args) -> RefKey(canonical_gr ref), AppBoundedNotation (List.length args) + | NList (_,_,NApp (NRef (ref,_),args),_,_) + | NBinderList (_,_,NApp (NRef (ref,_),args),_,_) -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args) - | NRef ref -> RefKey(canonical_gr ref), NotAppNotation - | NApp (NList (_,_,NApp (NRef ref,args),_,_), args') -> + | NRef (ref,_) -> RefKey(canonical_gr ref), NotAppNotation + | NApp (NList (_,_,NApp (NRef (ref,_),args),_,_), args') -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args + List.length args') | NApp (NList (_,_,NApp (_,args),_,_), args') -> Oth, AppBoundedNotation (List.length args + List.length args') @@ -1357,6 +1357,7 @@ let find_with_delimiters = function match (String.Map.find scope !scope_map).delimiters with | Some key -> Some (Some scope, Some key) | None -> None + | exception Not_found -> None let rec find_without_delimiters find (ntn_scope,ntn) = function | OpenScopeItem scope :: scopes -> @@ -2353,8 +2354,8 @@ let browse_notation strict ntn map = let global_reference_of_notation ~head test (ntn,sc,(on_parsing,on_printing,{not_interp = (_,c)})) = match c with - | NRef ref when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) - | NApp (NRef ref, l) when head || List.for_all isNVar_or_NHole l && test ref -> + | NRef (ref,_) when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) + | NApp (NRef (ref,_), l) when head || List.for_all isNVar_or_NHole l && test ref -> Some (on_parsing,on_printing,ntn,sc,ref) | _ -> None diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 0e7f085bde..ea5e2a1ad4 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -43,6 +43,28 @@ let cast_type_iter2 f t1 t2 = match t1, t2 with in NList and NBinderList, since the iterator has its own variable *) let replace_var i j var = j :: List.remove Id.equal i var +(* compare_glob_universe_instances true strictly_lt us1 us2 computes us1 <= us2, + compare_glob_universe_instances false strictly_lt us1 us2 computes us1 = us2. + strictly_lt will be set to true if any part is strictly less. *) +let compare_glob_universe_instances lt strictly_lt us1 us2 = + match us1, us2 with + | None, None -> true + | Some _, None -> strictly_lt := true; lt + | None, Some _ -> false + | Some l1, Some l2 -> + CList.for_all2eq (fun u1 u2 -> + match u1, u2 with + | UAnonymous {rigid=true}, UAnonymous {rigid=true} -> true + | UAnonymous {rigid=false}, UAnonymous {rigid=false} -> true + | UAnonymous _, UAnonymous _ -> false + | UNamed _, UAnonymous _ -> strictly_lt := true; lt + | UAnonymous _, UNamed _ -> false + | UNamed _, UNamed _ -> glob_level_eq u1 u2) l1 l2 + +(* Compute us1 <= us2, as a boolean *) +let compare_glob_universe_instances_le us1 us2 = + compare_glob_universe_instances true (ref false) us1 us2 + (* When [lt] is [true], tell if [t1] is a strict refinement of [t2] (this is a partial order, so returning [false] does not mean that [t2] is finer than [t1]); when [lt] is false, tell if [t1] is the @@ -93,7 +115,7 @@ let compare_notation_constr lt (vars1,vars2) t1 t2 = | NHole _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> () | NVar id1, NHole (_, _, _) when lt && List.mem_f Id.equal id1 vars1 -> () | _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> strictly_lt := true - | NRef gr1, NRef gr2 when GlobRef.equal gr1 gr2 -> () + | NRef (gr1,u1), NRef (gr2,u2) when GlobRef.equal gr1 gr2 && compare_glob_universe_instances lt strictly_lt u1 u2 -> () | NHole (_, _, _), NHole (_, _, _) -> () (* FIXME? *) | _, NHole (_, _, _) when lt -> strictly_lt := true | NList (i1, j1, iter1, tail1, b1), NList (i2, j2, iter2, tail2, b2) @@ -377,7 +399,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_stat | NCast (c,k) -> GCast (f e c,map_cast_type (f (h.slide e)) k) | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) - | NRef x -> GRef (x,None) + | NRef (x,u) -> GRef (x,u) | NInt i -> GInt i | NFloat f -> GFloat f | NArray (t,def,ty) -> GArray(None, Array.map (f e) t, f e def, f e ty) @@ -612,7 +634,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GHole (w,naming,arg) -> if arg != None then has_ltac := true; NHole (w, naming, arg) - | GRef (r,_) -> NRef r + | GRef (r,u) -> NRef (r,u) | GArray (_u,t,def,ty) -> NArray (Array.map aux t, aux def, aux ty) | GEvar _ | GPatVar _ -> user_err Pp.(str "Existential variables not allowed in notations.") @@ -706,10 +728,10 @@ let rec subst_pat subst pat = let rec subst_notation_constr subst bound raw = match raw with - | NRef ref -> + | NRef (ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else (match t with - | None -> NRef ref' + | None -> NRef (ref',u) | Some t -> fst (notation_constr_of_constr bound t.Univ.univ_abstracted_value)) @@ -1344,7 +1366,7 @@ let rec match_ inner u alp metas sigma a1 a2 = (* Matching compositionally *) | GVar id1, NVar id2 when alpha_var id1 id2 (fst (snd alp)) -> sigma - | GRef (r1,_), NRef r2 when (GlobRef.equal r1 r2) -> sigma + | GRef (r1,u1), NRef (r2,u2) when (GlobRef.equal r1 r2) && compare_glob_universe_instances_le u1 u2 -> sigma | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = @@ -1570,10 +1592,10 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(false,0,[]) | PatVar Anonymous, NHole _ -> sigma,(false,0,[]) - | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when Construct.CanOrd.equal r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2,None) when Construct.CanOrd.equal r1 r2 -> let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(false,0,l) - | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2),l2) + | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2,None),l2) when Construct.CanOrd.equal r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in @@ -1597,9 +1619,9 @@ and match_cases_pattern_no_more_args metas sigma a1 a2 = let match_ind_pattern metas sigma ind pats a2 = match a2 with - | NRef (GlobRef.IndRef r2) when Ind.CanOrd.equal ind r2 -> + | NRef (GlobRef.IndRef r2,None) when Ind.CanOrd.equal ind r2 -> sigma,(false,0,pats) - | NApp (NRef (GlobRef.IndRef r2),l2) + | NApp (NRef (GlobRef.IndRef r2,None),l2) when Ind.CanOrd.equal ind r2 -> let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats diff --git a/interp/notation_term.ml b/interp/notation_term.ml index c541a19bfd..2979447cf8 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -21,7 +21,7 @@ open Glob_term type notation_constr = (* Part common to [glob_constr] and [cases_pattern] *) - | NRef of GlobRef.t + | NRef of GlobRef.t * glob_level list option | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option diff --git a/interp/reserve.ml b/interp/reserve.ml index 274d3655d3..07160dcf6f 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -71,10 +71,10 @@ let reserve_table = Summary.ref Id.Map.empty ~name:"reserved-type" let reserve_revtable = Summary.ref KeyMap.empty ~name:"reserved-type-rev" let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) - | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args) - | NList (_,_,NApp (NRef ref,args),_,_) - | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) - | NRef ref -> RefKey(canonical_gr ref), None + | NApp (NRef (ref,_),args) -> RefKey(canonical_gr ref), Some (List.length args) + | NList (_,_,NApp (NRef (ref,_),args),_,_) + | NBinderList (_,_,NApp (NRef (ref,_),args),_,_) -> RefKey (canonical_gr ref), Some (List.length args) + | NRef (ref,_) -> RefKey(canonical_gr ref), None | _ -> Oth, None let cache_reserved_type (_,(id,t)) = diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 46baa00c74..91d05f7317 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -26,7 +26,7 @@ let global_of_extended_global_head = function | SynDef kn -> let _, syn_def = search_syntactic_definition kn in let rec head_of = function - | NRef ref -> ref + | NRef (ref,None) -> ref | NApp (rc, _) -> head_of rc | NCast (rc, _) -> head_of rc | NLetIn (_, _, _, rc) -> head_of rc @@ -37,8 +37,8 @@ let global_of_extended_global = function | TrueGlobal ref -> ref | SynDef kn -> match search_syntactic_definition kn with - | [],NRef ref -> ref - | [],NApp (NRef ref,[]) -> ref + | [],NRef (ref,None) -> ref + | [],NApp (NRef (ref,None),[]) -> ref | _ -> raise Not_found let locate_global_with_alias ?(head=false) qid = diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index f3ad3546ff..39e628883a 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -40,7 +40,7 @@ let load_syntax_constant i ((sp,kn),(_local,syndef)) = Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function - | _,NRef ref -> + | _,NRef (ref,_) -> let (dir,id) = repr_qualid (Nametab.shortest_qualid_of_global Id.Set.empty ref) in DirPath.is_empty dir && Id.equal id (basename sp) | _ -> diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 1ba6a8c8fe..20890a28dc 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -21,68 +21,12 @@ #include <caml/alloc.h> #include <caml/memory.h> #include "coq_instruct.h" +#include "coq_arity.h" #include "coq_fix_code.h" #ifdef THREADED_CODE char ** coq_instr_table; char * coq_instr_base; -int arity[STOP+1]; - -void init_arity () { - /* instruction with zero operand */ - arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= - arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= - arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= - arity[PUSHACC6]=arity[PUSHACC7]= - arity[ENVACC0]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]= - arity[PUSHENVACC0]=arity[PUSHENVACC1]=arity[PUSHENVACC2]=arity[PUSHENVACC3]= - arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[APPLY4]=arity[RESTART]= - arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE1]= - arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE1]= - arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= - arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= - arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= - 0; - /* instruction with one operand */ - arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= - arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= - arity[APPTERM3]=arity[RETURN]=arity[GRAB]=arity[OFFSETCLOSURE]= - arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= - arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= - arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= - arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ENSURESTACKCAPACITY]= - arity[CHECKADDINT63]=arity[CHECKADDCINT63]=arity[CHECKADDCARRYCINT63]= - arity[CHECKSUBINT63]=arity[CHECKSUBCINT63]=arity[CHECKSUBCARRYCINT63]= - arity[CHECKMULINT63]=arity[CHECKMULCINT63]= - arity[CHECKDIVINT63]=arity[CHECKMODINT63]=arity[CHECKDIVEUCLINT63]= - arity[CHECKDIV21INT63]= - arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= - arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= - arity[CHECKLSLINT63CONST1]=arity[CHECKLSRINT63CONST1]= - arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= - arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]= - arity[CHECKEQFLOAT]=arity[CHECKLTFLOAT]=arity[CHECKLEFLOAT]= - arity[CHECKOPPFLOAT]=arity[CHECKABSFLOAT]=arity[CHECKCOMPAREFLOAT]= - arity[CHECKCLASSIFYFLOAT]= - arity[CHECKADDFLOAT]=arity[CHECKSUBFLOAT]=arity[CHECKMULFLOAT]= - arity[CHECKDIVFLOAT]=arity[CHECKSQRTFLOAT]= - arity[CHECKFLOATOFINT63]=arity[CHECKFLOATNORMFRMANTISSA]= - arity[CHECKFRSHIFTEXP]=arity[CHECKLDSHIFTEXP]= - arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; - /* instruction with two operands */ - arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[CHECKCAMLCALL1]=arity[CHECKCAMLCALL2_1]= - arity[CHECKCAMLCALL2]=arity[CHECKCAMLCALL3_1]= - arity[PROJ]= - 2; - /* instruction with four operands */ - arity[MAKESWITCHBLOCK]=4; - /* instruction with arbitrary operands */ - arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0; -} - #endif /* THREADED_CODE */ @@ -164,9 +108,7 @@ value coq_tcode_of_code (value code) { opcode_t instr; COPY32(&instr,p); p++; - if (instr < 0 || instr > STOP){ - instr = STOP; - }; + if (instr < 0 || instr > STOP) abort(); *q++ = VALINSTR(instr); if (instr == SWITCH) { uint32_t i, sizes, const_size, block_size; @@ -183,8 +125,9 @@ value coq_tcode_of_code (value code) { q++; for(i=1; i<n; i++) { COPY32(q,p); p++; q++; }; } else { - uint32_t i, ar; + int i, ar; ar = arity[instr]; + if (ar < 0) abort(); for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } } diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 5a233e6178..916d9753a4 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -18,7 +18,6 @@ void * coq_stat_alloc (asize_t sz); #ifdef THREADED_CODE extern char ** coq_instr_table; extern char * coq_instr_base; -void init_arity(); #define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base)) #else #define VALINSTR(instr) instr diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a825283b2b..95a334561f 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -338,10 +338,6 @@ value coq_interprete print_instr("PUSH"); *--sp = accu; Next; } - Instruct(PUSHACC0) { - print_instr("PUSHACC0"); - *--sp = accu; Next; - } Instruct(PUSHACC1){ print_instr("PUSHACC1"); *--sp = accu; accu = sp[1]; Next; @@ -1015,20 +1011,6 @@ value coq_interprete Next; } - Instruct(SETFIELD0){ - print_instr("SETFIELD0"); - caml_modify(&Field(accu, 0),*sp); - sp++; - Next; - } - - Instruct(SETFIELD1){ - print_instr("SETFIELD1"); - caml_modify(&Field(accu, 1),*sp); - sp++; - Next; - } - Instruct(SETFIELD){ print_instr("SETFIELD"); caml_modify(&Field(accu, *pc),*sp); @@ -1288,16 +1270,6 @@ value coq_interprete Next; } - Instruct(MAKEPROD) { - print_instr("MAKEPROD"); - *--sp=accu; - Alloc_small(accu,2,0); - Field(accu, 0) = sp[0]; - Field(accu, 1) = sp[1]; - sp += 2; - Next; - } - Instruct(BRANCH) { /* unconditional branching */ print_instr("BRANCH"); @@ -1501,34 +1473,6 @@ value coq_interprete Next; } - Instruct(CHECKLSLINT63CONST1) { - print_instr("CHECKLSLINT63CONST1"); - if (Is_uint63(accu)) { - pc++; - Uint63_lsl1(accu); - Next; - } else { - *--sp = uint63_one(); - *--sp = accu; - accu = Field(coq_global_data, *pc++); - goto apply2; - } - } - - Instruct(CHECKLSRINT63CONST1) { - print_instr("CHECKLSRINT63CONST1"); - if (Is_uint63(accu)) { - pc++; - Uint63_lsr1(accu); - Next; - } else { - *--sp = uint63_one(); - *--sp = accu; - accu = Field(coq_global_data, *pc++); - goto apply2; - } - } - Instruct (CHECKADDMULDIVINT63) { print_instr("CHECKADDMULDIVINT63"); CheckInt3(); diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index fe076f8f04..a55ff57c8d 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -100,9 +100,6 @@ value init_coq_vm(value unit) /* ML */ fprintf(stderr,"already open \n");fflush(stderr);} else { drawinstr=0; -#ifdef THREADED_CODE - init_arity(); -#endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); /* Initialing the interpreter */ diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index 13568957c2..dd9b9e55be 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -119,12 +119,8 @@ DECLARE_BINOP(lor) #define Uint63_lor(x, y) CALL_BINOP(lor, x, y) DECLARE_BINOP(lsl) #define Uint63_lsl(x, y) CALL_BINOP(lsl, x, y) -DECLARE_UNOP(lsl1) -#define Uint63_lsl1(x) CALL_UNOP(lsl1, x) DECLARE_BINOP(lsr) #define Uint63_lsr(x, y) CALL_BINOP(lsr, x, y) -DECLARE_UNOP(lsr1) -#define Uint63_lsr1(x) CALL_UNOP(lsr1, x) DECLARE_BINOP(lt) #define Uint63_lt(r, x, y) CALL_RELATION(r, lt, x, y) DECLARE_BINOP(lxor) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 27696e8856..731ae8f46e 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -55,8 +55,6 @@ else \ accu = uint63_zero; \ }while(0) -#define Uint63_lsl1(x) (accu = (value)((((uint64_t)(x)-1) << 1) +1)) -#define Uint63_lsr1(x) (accu = (value)(((uint64_t)(x) >> 1) |1)) /* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ /* (modulo 2^63) for p <= 63 */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index d3e2a2fa7f..a2484f79a7 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -14,3 +14,7 @@ (rule (targets coq_jumptbl.h) (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe jump)))) + +(rule + (targets coq_arity.h) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe arity)))) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index d2256720c4..8edf916a7a 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -34,6 +34,8 @@ open Environ open Vars open Esubst +module RelDecl = Context.Rel.Declaration + let stats = ref false (* Profiling *) @@ -342,8 +344,8 @@ and fterm = | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs + | FCaseT of case_info * Univ.Instance.t * constr array * case_return * fconstr * case_branch array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * Univ.Instance.t * constr array * case_return * finvert * fconstr * case_branch array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs @@ -355,7 +357,7 @@ and fterm = | FCLOS of constr * fconstr subs | FLOCKED -and finvert = Univ.Instance.t * fconstr array +and finvert = fconstr array let fterm_of v = v.term let set_ntrl v = v.mark <- Mark.set_ntrl v.mark @@ -410,7 +412,7 @@ type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array - | ZcaseT of case_info * constr * constr array * fconstr subs + | ZcaseT of case_info * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args @@ -578,10 +580,11 @@ let rec to_constr lfts v = | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op - | FCaseT (ci,p,c,ve,env) -> to_constr_case lfts ci p NoInvert c ve env - | FCaseInvert (ci,p,(univs,args),c,ve,env) -> - let iv = CaseInvert {univs;args=Array.map (to_constr lfts) args} in - to_constr_case lfts ci p iv c ve env + | FCaseT (ci, u, pms, p, c, ve, env) -> + to_constr_case lfts ci u pms p NoInvert c ve env + | FCaseInvert (ci, u, pms, p, indices, c, ve, env) -> + let iv = CaseInvert {indices=Array.map (to_constr lfts) indices} in + to_constr_case lfts ci u pms p iv c ve env | FFix ((op,(lna,tys,bds)) as fx, e) -> if is_subs_id e && is_lift_id lfts then mkFix fx @@ -649,14 +652,20 @@ let rec to_constr lfts v = subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) -and to_constr_case lfts ci p iv c ve env = +and to_constr_case lfts ci u pms p iv c ve env = if is_subs_id env && is_lift_id lfts then - mkCase (ci, p, iv, to_constr lfts c, ve) + mkCase (ci, u, pms, p, iv, to_constr lfts c, ve) else let subs = comp_subs lfts env in - mkCase (ci, subst_constr subs p, iv, - to_constr lfts c, - Array.map (fun b -> subst_constr subs b) ve) + let f_ctx (nas, c) = + let c = subst_constr (Esubst.subs_liftn (Array.length nas) subs) c in + (nas, c) + in + mkCase (ci, u, Array.map (fun c -> subst_constr subs c) pms, + f_ctx p, + iv, + to_constr lfts c, + Array.map f_ctx ve) and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with | Rel i -> @@ -687,8 +696,8 @@ let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {mark=Mark.neutr m.mark; term=FApp(m, args)} s - | ZcaseT(ci,p,br,e)::s -> - let t = FCaseT(ci, p, m, br, e) in + | ZcaseT(ci, u, pms, p, br, e)::s -> + let t = FCaseT(ci, u, pms, p, m, br, e) in let mark = mark (neutr (Mark.red_state m.mark)) Unknown in zip {mark; term=t} s | Zproj p :: s -> @@ -763,6 +772,9 @@ let rec subs_consn v i n s = if Int.equal i n then s else subs_consn v (i + 1) n (subs_cons v.(i) s) +let subs_consv v s = + subs_consn v 0 (Array.length v) s + (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) let rec get_args n tys f e = function @@ -870,6 +882,74 @@ let drop_parameters depth n argstk = (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor.") +let inductive_subst (ind, _) mib u pms e = + let rec self i accu = + if Int.equal i mib.mind_ntypes then accu + else + let c = inject (mkIndU ((ind, i), u)) in + self (i + 1) (subs_cons c accu) + in + let self = self 0 (subs_id 0) in + let rec mk_pms i ctx = match ctx with + | [] -> self + | RelDecl.LocalAssum _ :: ctx -> + let c = mk_clos e pms.(i) in + let subs = mk_pms (i - 1) ctx in + subs_cons c subs + | RelDecl.LocalDef (_, c, _) :: ctx -> + let c = Vars.subst_instance_constr u c in + let subs = mk_pms i ctx in + subs_cons (mk_clos subs c) subs + in + mk_pms (Array.length pms - 1) mib.mind_params_ctxt + +(* Iota-reduction: feed the arguments of the constructor to the branch *) +let get_branch infos depth ci u pms (ind, c) br e args = + let i = c - 1 in + let args = drop_parameters depth ci.ci_npar args in + let (_nas, br) = br.(i) in + if Int.equal ci.ci_cstr_ndecls.(i) ci.ci_cstr_nargs.(i) then + (* No let-bindings in the constructor, we don't have to fetch the + environment to know the value of the branch. *) + let rec push e stk = match stk with + | [] -> e + | Zapp v :: stk -> push (subs_consv v e) stk + | (Zshift _ | ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ -> + assert false + in + let e = push e args in + (br, e) + else + (* The constructor contains let-bindings, but they are not physically + present in the match, so we fetch them in the environment. *) + let env = info_env infos in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let (ctx, _) = mip.mind_nf_lc.(i) in + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let map = function + | Zapp args -> args + | Zshift _ | ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _ -> + assert false + in + let ind_subst = inductive_subst ind mib u pms e in + let args = Array.concat (List.map map args) in + let rec push i e = function + | [] -> [] + | RelDecl.LocalAssum _ :: ctx -> + let ans = push (pred i) e ctx in + args.(i) :: ans + | RelDecl.LocalDef (_, b, _) :: ctx -> + let ans = push i e ctx in + let b = subst_instance_constr u b in + let s = Array.rev_of_list ans in + let e = subs_consv s ind_subst in + let v = mk_clos e b in + v :: ans + in + let ext = push (Array.length args - 1) [] ctx in + (br, subs_consv (Array.rev_of_list ext) e) + (** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments @@ -909,7 +989,6 @@ let rec project_nth_arg n = function | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _ | Zprimitive _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) - (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be @@ -1092,16 +1171,6 @@ module FNativeEntries = fNInf := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNInf) }; fNaN := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNaN) }; | None -> defined_f_class := false - let defined_refl = ref false - - let frefl = ref dummy - - let init_refl retro = - match retro.Retroknowledge.retro_refl with - | Some crefl -> - defined_refl := true; - frefl := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs crefl) } - | None -> defined_refl := false let defined_array = ref false @@ -1118,7 +1187,6 @@ module FNativeEntries = init_cmp !current_retro; init_f_cmp !current_retro; init_f_class !current_retro; - init_refl !current_retro; init_array !current_retro let check_env env = @@ -1269,7 +1337,7 @@ let rec knh info m stk = | FCLOS(t,e) -> knht info e t (zupdate info m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) - | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) + | FCaseT(ci,u,pms,p,t,br,e) -> knh info t (ZcaseT(ci,u,pms,p,br,e)::zupdate info m stk) | FFix(((ri,n),_),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') @@ -1289,10 +1357,10 @@ and knht info e t stk = match kind t with | App(a,b) -> knht info e a (append_stack (mk_clos_vect e b) stk) - | Case(ci,p,NoInvert,t,br) -> - knht info e t (ZcaseT(ci, p, br, e)::stk) - | Case(ci,p,CaseInvert{univs;args},t,br) -> - let term = FCaseInvert (ci, p, (univs,Array.map (mk_clos e) args), mk_clos e t, br, e) in + | Case(ci,u,pms,p,NoInvert,t,br) -> + knht info e t (ZcaseT(ci, u, pms, p, br, e)::stk) + | Case(ci,u,pms,p,CaseInvert{indices},t,br) -> + let term = FCaseInvert (ci, u, pms, p, (Array.map (mk_clos e) indices), mk_clos e t, br, e) in { mark = mark Red Unknown; term }, stk | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk | Cast(a,_,_) -> knht info e a stk @@ -1347,15 +1415,15 @@ let rec knr info tab m stk = | Def v -> kni info tab v stk | Primitive _ -> assert false | OpaqueDef _ | Undef _ -> (set_ntrl m; (m,stk))) - | FConstruct((_ind,c),_u) -> + | FConstruct(c,_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then (match [@ocaml.warning "-4"] strip_update_shift_app m stk with - | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> + | (depth, args, ZcaseT(ci,u,pms,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); - let rargs = drop_parameters depth ci.ci_npar args in - knit info tab e br.(c-1) (rargs@s) + let (br, e) = get_branch info depth ci u pms c br e args in + knit info tab e br s | (_, cargs, Zfix(fx,par)::s) when use_fix -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in @@ -1399,8 +1467,9 @@ let rec knr info tab m stk = kni info tab a (Zprimitive(op,c,rargs,nargs)::s) end | (_, _, s) -> (m, s)) - | FCaseInvert (ci,_p,iv,_c,v,env) when red_set info.i_flags fMATCH -> - begin match case_inversion info tab ci iv v with + | FCaseInvert (ci, u, pms, _p,iv,_c,v,env) when red_set info.i_flags fMATCH -> + let pms = mk_clos_vect env pms in + begin match case_inversion info tab ci u pms iv v with | Some c -> knit info tab env c stk | None -> (m, stk) end @@ -1417,13 +1486,17 @@ and knit info tab e t stk = let (ht,s) = knht info e t stk in knr info tab ht s -and case_inversion info tab ci (univs,args) v = +and case_inversion info tab ci u params indices v = let open Declarations in - if Array.is_empty args then Some v.(0) + (* No binders / lets at all in the unique branch *) + let v = match v with + | [| [||], v |] -> v + | _ -> assert false + in + if Array.is_empty indices then Some v else let env = info_env info in let ind = ci.ci_ind in - let params, indices = Array.chop ci.ci_npar args in let psubst = subs_consn params 0 ci.ci_npar (subs_id 0) in let mib = Environ.lookup_mind (fst ind) env in let mip = mib.mind_packets.(snd ind) in @@ -1432,12 +1505,12 @@ and case_inversion info tab ci (univs,args) v = let _ind, expect_args = destApp expect in let check_index i index = let expected = expect_args.(ci.ci_npar + i) in - let expected = Vars.subst_instance_constr univs expected in + let expected = Vars.subst_instance_constr u expected in let expected = mk_clos psubst expected in !conv {info with i_flags=all} tab expected index in if Array.for_all_i check_index 0 indices - then Some v.(0) else None + then Some v else None let kh info tab v stk = fapp_stack(kni info tab v stk) @@ -1448,9 +1521,13 @@ let rec zip_term zfun m stk = | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s - | ZcaseT(ci,p,br,e)::s -> - let t = mkCase(ci, zfun (mk_clos e p), NoInvert, m, - Array.map (fun b -> zfun (mk_clos e b)) br) in + | ZcaseT(ci, u, pms, p, br, e) :: s -> + let zip_ctx (nas, c) = + let e = Esubst.subs_liftn (Array.length nas) e in + (nas, zfun (mk_clos e c)) + in + let t = mkCase(ci, u, Array.map (fun c -> zfun (mk_clos e c)) pms, zip_ctx p, + NoInvert, m, Array.map zip_ctx br) in zip_term zfun t s | Zproj p::s -> let t = mkProj (Projection.make p true, m) in diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 3e8916673d..bccbddb0fc 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -110,8 +110,8 @@ type fterm = | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FCaseInvert of case_info * constr * finvert * fconstr * constr array * fconstr subs + | FCaseT of case_info * Univ.Instance.t * constr array * case_return * fconstr * case_branch array * fconstr subs (* predicate and branches are closures *) + | FCaseInvert of case_info * Univ.Instance.t * constr array * case_return * finvert * fconstr * case_branch array * fconstr subs | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs @@ -130,7 +130,7 @@ type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array - | ZcaseT of case_info * constr * constr array * fconstr subs + | ZcaseT of case_info * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args diff --git a/kernel/constr.ml b/kernel/constr.ml index bbaf95c9df..30542597c5 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -83,9 +83,15 @@ type pconstant = Constant.t puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses -type ('constr, 'univs) case_invert = +type 'constr pcase_invert = | NoInvert - | CaseInvert of { univs : 'univs; args : 'constr array } + | CaseInvert of { indices : 'constr array } + +type 'constr pcase_branch = Name.t Context.binder_annot array * 'constr +type 'types pcase_return = Name.t Context.binder_annot array * 'types + +type ('constr, 'types, 'univs) pcase = + case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) @@ -103,7 +109,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) | Construct of (constructor * 'univs) - | Case of case_info * 'constr * ('constr, 'univs) case_invert * 'constr * 'constr array + | Case of case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr @@ -119,6 +125,10 @@ type existential = existential_key * constr list type types = constr +type case_invert = constr pcase_invert +type case_return = types pcase_return +type case_branch = constr pcase_branch +type case = (constr, types, Instance.t) pcase type rec_declaration = (constr, types) prec_declaration type fixpoint = (constr, types) pfixpoint type cofixpoint = (constr, types) pcofixpoint @@ -194,7 +204,7 @@ let mkConstructU c = Construct c let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkCase (ci, p, iv, c, ac) = Case (ci, p, iv, c, ac) +let mkCase (ci, u, params, p, iv, c, ac) = Case (ci, u, params, p, iv, c, ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] @@ -425,7 +435,7 @@ let destConstruct c = match kind c with (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind c with - | Case (ci,p,iv,c,v) -> (ci,p,iv,c,v) + | Case (ci,u,params,p,iv,c,v) -> (ci,u,params,p,iv,c,v) | _ -> raise DestKO let destProj c = match kind c with @@ -471,8 +481,8 @@ let decompose_appvect c = let fold_invert f acc = function | NoInvert -> acc - | CaseInvert {univs=_;args} -> - Array.fold_left f acc args + | CaseInvert {indices} -> + Array.fold_left f acc indices let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -484,7 +494,8 @@ let fold f acc c = match kind c with | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c | Evar (_,l) -> List.fold_left f acc l - | Case (_,p,iv,c,bl) -> Array.fold_left f (f (fold_invert f (f acc p) iv) c) bl + | Case (_,_,pms,(_,p),iv,c,bl) -> + Array.fold_left (fun acc (_, b) -> f acc b) (f (fold_invert f (f (Array.fold_left f acc pms) p) iv) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl | CoFix (_,(_lna,tl,bl)) -> @@ -498,8 +509,8 @@ let fold f acc c = match kind c with let iter_invert f = function | NoInvert -> () - | CaseInvert {univs=_; args;} -> - Array.iter f args + | CaseInvert {indices;} -> + Array.iter f indices let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -511,7 +522,8 @@ let iter f c = match kind c with | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c | Evar (_,l) -> List.iter f l - | Case (_,p,iv,c,bl) -> f p; iter_invert f iv; f c; Array.iter f bl + | Case (_,_,pms,p,iv,c,bl) -> + Array.iter f pms; f (snd p); iter_invert f iv; f c; Array.iter (fun (_, b) -> f b) bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | Array(_u,t,def,ty) -> Array.iter f t; f def; f ty @@ -531,7 +543,12 @@ let iter_with_binders g f n c = match kind c with | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l | Evar (_,l) -> List.iter (fun c -> f n c) l - | Case (_,p,iv,c,bl) -> f n p; iter_invert (f n) iv; f n c; Array.Fun1.iter f n bl + | Case (_,_,pms,p,iv,c,bl) -> + Array.Fun1.iter f n pms; + f (iterate g (Array.length (fst p)) n) (snd p); + iter_invert (f n) iv; + f n c; + Array.Fun1.iter (fun n (ctx, b) -> f (iterate g (Array.length ctx) n) b) n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> Array.Fun1.iter f n tl; @@ -560,7 +577,11 @@ let fold_constr_with_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Case (_,_,pms,p,iv,c,bl) -> + let fold_ctx n accu (nas, c) = + f (iterate g (Array.length nas) n) accu c + in + Array.fold_left (fold_ctx n) (f n (fold_invert (f n) (fold_ctx n (Array.fold_left (f n) acc pms) p) iv) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -576,62 +597,39 @@ let fold_constr_with_binders g f n acc c = not recursive and the order with which subterms are processed is not specified *) -let rec map_under_context f n d = - if n = 0 then f d else - match kind d with - | LetIn (na,b,t,c) -> - let b' = f b in - let t' = f t in - let c' = map_under_context f (n-1) c in - if b' == b && t' == t && c' == c then d - else mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f t in - let b' = map_under_context f (n-1) b in - if t' == t && b' == b then d - else mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches f ci bl = - let nl = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context f) nl bl in +let map_under_context f d = + let (nas, p) = d in + let p' = f p in + if p' == p then d else (nas, p') + +let map_branches f bl = + let bl' = Array.map (map_under_context f) bl in if Array.for_all2 (==) bl' bl then bl else bl' -let map_return_predicate f ci p = - map_under_context f (List.length ci.ci_pp_info.ind_tags) p - -let rec map_under_context_with_binders g f l n d = - if n = 0 then f l d else - match kind d with - | LetIn (na,b,t,c) -> - let b' = f l b in - let t' = f l t in - let c' = map_under_context_with_binders g f (g l) (n-1) c in - if b' == b && t' == t && c' == c then d - else mkLetIn (na,b',t',c') - | Lambda (na,t,b) -> - let t' = f l t in - let b' = map_under_context_with_binders g f (g l) (n-1) b in - if t' == t && b' == b then d - else mkLambda (na,t',b') - | _ -> CErrors.anomaly (Pp.str "Ill-formed context") - -let map_branches_with_binders g f l ci bl = - let tags = Array.map List.length ci.ci_pp_info.cstr_tags in - let bl' = Array.map2 (map_under_context_with_binders g f l) tags bl in +let map_return_predicate f p = + map_under_context f p + +let map_under_context_with_binders g f l d = + let (nas, p) = d in + let l = iterate g (Array.length nas) l in + let p' = f l p in + if p' == p then d else (nas, p') + +let map_branches_with_binders g f l bl = + let bl' = Array.map (map_under_context_with_binders g f l) bl in if Array.for_all2 (==) bl' bl then bl else bl' -let map_return_predicate_with_binders g f l ci p = - map_under_context_with_binders g f l (List.length ci.ci_pp_info.ind_tags) p +let map_return_predicate_with_binders g f l p = + map_under_context_with_binders g f l p let map_invert f = function | NoInvert -> NoInvert - | CaseInvert {univs;args;} as orig -> - let args' = Array.Smart.map f args in - if args == args' then orig - else CaseInvert {univs;args=args';} + | CaseInvert {indices;} as orig -> + let indices' = Array.Smart.map f indices in + if indices == indices' then orig + else CaseInvert {indices=indices';} -let map_gen userview f c = match kind c with +let map f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> c | Cast (b,k,t) -> @@ -668,20 +666,14 @@ let map_gen userview f c = match kind c with let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') - | Case (ci,p,iv,b,bl) when userview -> + | Case (ci,u,pms,p,iv,b,bl) -> + let pms' = Array.Smart.map f pms in let b' = f b in let iv' = map_invert f iv in - let p' = map_return_predicate f ci p in - let bl' = map_branches f ci bl in - if b'==b && iv'==iv && p'==p && bl'==bl then c - else mkCase (ci, p', iv', b', bl') - | Case (ci,p,iv,b,bl) -> - let b' = f b in - let iv' = map_invert f iv in - let p' = f p in - let bl' = Array.Smart.map f bl in - if b'==b && iv'==iv && p'==p && bl'==bl then c - else mkCase (ci, p', iv', b', bl') + let p' = map_return_predicate f p in + let bl' = map_branches f bl in + if b'==b && iv'==iv && p'==p && bl'==bl && pms'==pms then c + else mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.Smart.map f tl in let bl' = Array.Smart.map f bl in @@ -699,17 +691,26 @@ let map_gen userview f c = match kind c with if def'==def && t==t' && ty==ty' then c else mkArray(u,t',def',ty') -let map_user_view = map_gen true -let map = map_gen false - (* Like {!map} but with an accumulator. *) let fold_map_invert f acc = function | NoInvert -> acc, NoInvert - | CaseInvert {univs;args;} as orig -> - let acc, args' = Array.fold_left_map f acc args in - if args==args' then acc, orig - else acc, CaseInvert {univs;args=args';} + | CaseInvert {indices;} as orig -> + let acc, indices' = Array.fold_left_map f acc indices in + if indices==indices' then acc, orig + else acc, CaseInvert {indices=indices';} + +let fold_map_under_context f accu d = + let (nas, p) = d in + let accu, p' = f accu p in + if p' == p then accu, d else accu, (nas, p') + +let fold_map_branches f accu bl = + let accu, bl' = Array.Smart.fold_left_map (fold_map_under_context f) accu bl in + if Array.for_all2 (==) bl' bl then accu, bl else accu, bl' + +let fold_map_return_predicate f accu p = + fold_map_under_context f accu p let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -749,13 +750,14 @@ let fold_map f accu c = match kind c with let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') - | Case (ci,p,iv,b,bl) -> - let accu, b' = f accu b in + | Case (ci,u,pms,p,iv,b,bl) -> + let accu, pms' = Array.Smart.fold_left_map f accu pms in + let accu, p' = fold_map_return_predicate f accu p in let accu, iv' = fold_map_invert f accu iv in - let accu, p' = f accu p in - let accu, bl' = Array.Smart.fold_left_map f accu bl in - if b'==b && iv'==iv && p'==p && bl'==bl then accu, c - else accu, mkCase (ci, p', iv', b', bl') + let accu, b' = f accu b in + let accu, bl' = fold_map_branches f accu bl in + if pms'==pms && p'==p && iv'==iv && b'==b && bl'==bl then accu, c + else accu, mkCase (ci, u, pms', p', iv', b', bl') | Fix (ln,(lna,tl,bl)) -> let accu, tl' = Array.Smart.fold_left_map f accu tl in let accu, bl' = Array.Smart.fold_left_map f accu bl in @@ -816,13 +818,14 @@ let map_with_binders g f l c0 = match kind c0 with let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') - | Case (ci, p, iv, c, bl) -> - let p' = f l p in + | Case (ci, u, pms, p, iv, c, bl) -> + let pms' = Array.Fun1.Smart.map f l pms in + let p' = map_return_predicate_with_binders g f l p in let iv' = map_invert (f l) iv in let c' = f l c in - let bl' = Array.Fun1.Smart.map f l bl in - if p' == p && iv' == iv && c' == c && bl' == bl then c0 - else mkCase (ci, p', iv', c', bl') + let bl' = map_branches_with_binders g f l bl in + if pms' == pms && p' == p && iv' == iv && c' == c && bl' == bl then c0 + else mkCase (ci, u, pms', p', iv', c', bl') | Fix (ln, (lna, tl, bl)) -> let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in @@ -878,13 +881,15 @@ type 'constr constr_compare_fn = int -> 'constr -> 'constr -> bool optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) -let eq_invert eq leq_universes iv1 iv2 = +let eq_invert eq iv1 iv2 = match iv1, iv2 with | NoInvert, NoInvert -> true | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false - | CaseInvert {univs;args}, CaseInvert iv2 -> - leq_universes univs iv2.univs - && Array.equal eq args iv2.args + | CaseInvert {indices}, CaseInvert iv2 -> + Array.equal eq indices iv2.indices + +let eq_under_context eq (_nas1, p1) (_nas2, p2) = + eq p1 p2 let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t1 t2 = match kind_nocast_gen kind1 t1, kind_nocast_gen kind2 t2 with @@ -911,8 +916,12 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Ind (c1,u1), Ind (c2,u2) -> Ind.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 | Construct (c1,u1), Construct (c2,u2) -> Construct.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 - | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> - eq 0 p1 p2 && eq_invert (eq 0) (leq_universes None) iv1 iv2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 + | Case (ci1,u1,pms1,p1,iv1,c1,bl1), Case (ci2,u2,pms2,p2,iv2,c2,bl2) -> + (** FIXME: what are we doing with u1 = u2 ? *) + Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind && leq_universes (Some (GlobRef.IndRef ci1.ci_ind, 0)) u1 u2 && + Array.equal (eq 0) pms1 pms2 && eq_under_context (eq 0) p1 p2 && + eq_invert (eq 0) iv1 iv2 && + eq 0 c1 c2 && Array.equal (eq_under_context (eq 0)) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 @@ -1050,8 +1059,7 @@ let compare_invert f iv1 iv2 = | NoInvert, CaseInvert _ -> -1 | CaseInvert _, NoInvert -> 1 | CaseInvert iv1, CaseInvert iv2 -> - (* univs ignored deliberately *) - Array.compare f iv1.args iv2.args + Array.compare f iv1.indices iv2.indices let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= @@ -1063,6 +1071,9 @@ let constr_ord_int f t1 t2 = let fix_cmp (a1, i1) (a2, i2) = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in + let ctx_cmp f (_n1, p1) (_n2, p2) = + f p1 p2 + in match kind t1, kind t2 with | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 @@ -1096,12 +1107,13 @@ let constr_ord_int f t1 t2 = | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,_u1), Construct (ct2,_u2) -> Construct.CanOrd.compare ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 - | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> - let c = f p1 p2 in + | Case (_,_u1,pms1,p1,iv1,c1,bl1), Case (_,_u2,pms2,p2,iv2,c2,bl2) -> + let c = Array.compare f pms1 pms2 in + if Int.equal c 0 then let c = ctx_cmp f p1 p2 in if Int.equal c 0 then let c = compare_invert f iv1 iv2 in if Int.equal c 0 then let c = f c1 c2 in - if Int.equal c 0 then Array.compare f bl1 bl2 - else c else c else c + if Int.equal c 0 then Array.compare (ctx_cmp f) bl1 bl2 + else c else c else c else c | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) @@ -1176,9 +1188,11 @@ let invert_eqeq iv1 iv2 = match iv1, iv2 with | NoInvert, NoInvert -> true | NoInvert, CaseInvert _ | CaseInvert _, NoInvert -> false - | CaseInvert iv1, CaseInvert iv2 -> - iv1.univs == iv2.univs - && iv1.args == iv2.args + | CaseInvert {indices=i1}, CaseInvert {indices=i2} -> + i1 == i2 + +let hasheq_ctx (nas1, c1) (nas2, c2) = + array_eqeq nas1 nas2 && c1 == c2 let hasheq t1 t2 = match t1, t2 with @@ -1197,8 +1211,11 @@ let hasheq t1 t2 = | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 - | Case (ci1,p1,iv1,c1,bl1), Case (ci2,p2,iv2,c2,bl2) -> - ci1 == ci2 && p1 == p2 && invert_eqeq iv1 iv2 && c1 == c2 && array_eqeq bl1 bl2 + | Case (ci1,u1,pms1,p1,iv1,c1,bl1), Case (ci2,u2,pms2,p2,iv2,c2,bl2) -> + (** FIXME: use deeper equality for contexts *) + u1 == u2 && array_eqeq pms1 pms2 && + ci1 == ci2 && hasheq_ctx p1 p2 && + invert_eqeq iv1 iv2 && c1 == c2 && Array.equal hasheq_ctx bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 @@ -1247,7 +1264,7 @@ let sh_instance = Univ.Instance.share representation for [constr] using [hash_consing_functions] on leaves. *) let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = - let rec hash_term t = + let rec hash_term (t : t) = match t with | Var i -> (Var (sh_id i), combinesmall 1 (Id.hash i)) @@ -1289,13 +1306,27 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let u', hu = sh_instance u in (Construct (sh_construct c, u'), combinesmall 11 (combine (Construct.SyntacticOrd.hash c) hu)) - | Case (ci,p,iv,c,bl) -> - let p, hp = sh_rec p - and iv, hiv = sh_invert iv - and c, hc = sh_rec c in - let bl,hbl = hash_term_array bl in - let hbl = combine4 hc hp hiv hbl in - (Case (sh_ci ci, p, iv, c, bl), combinesmall 12 hbl) + | Case (ci,u,pms,p,iv,c,bl) -> + (** FIXME: use a dedicated hashconsing structure *) + let hcons_ctx (lna, c) = + let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in + let fold accu na = combine (hash_annot Name.hash na) accu in + let hna = Array.fold_left fold 0 lna in + let c, hc = sh_rec c in + (lna, c), combine hna hc + in + let u, hu = sh_instance u in + let pms,hpms = hash_term_array pms in + let p, hp = hcons_ctx p in + let iv, hiv = sh_invert iv in + let c, hc = sh_rec c in + let fold accu c = + let c, h = hcons_ctx c in + combine accu h, c + in + let hbl, bl = Array.fold_left_map fold 0 bl in + let hbl = combine (combine hc (combine hiv (combine hpms (combine hu hp)))) hbl in + (Case (sh_ci ci, u, pms, p, iv, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in @@ -1334,10 +1365,9 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = and sh_invert = function | NoInvert -> NoInvert, 0 - | CaseInvert {univs;args;} -> - let univs, hu = sh_instance univs in - let args, ha = hash_term_array args in - CaseInvert {univs;args;}, combinesmall 1 (combine hu ha) + | CaseInvert {indices;} -> + let indices, ha = hash_term_array indices in + CaseInvert {indices;}, combinesmall 1 ha and sh_rec t = let (y, h) = hash_term t in @@ -1400,8 +1430,8 @@ let rec hash t = combinesmall 10 (combine (Ind.CanOrd.hash ind) (Instance.hash u)) | Construct (c,u) -> combinesmall 11 (combine (Construct.CanOrd.hash c) (Instance.hash u)) - | Case (_ , p, iv, c, bl) -> - combinesmall 12 (combine4 (hash c) (hash p) (hash_invert iv) (hash_term_array bl)) + | Case (_ , u, pms, p, iv, c, bl) -> + combinesmall 12 (combine (combine (hash c) (combine (hash_invert iv) (combine (hash_term_array pms) (combine (Instance.hash u) (hash_under_context p))))) (hash_branches bl)) | Fix (_ln ,(_, tl, bl)) -> combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) | CoFix(_ln, (_, tl, bl)) -> @@ -1417,8 +1447,8 @@ let rec hash t = and hash_invert = function | NoInvert -> 0 - | CaseInvert {univs;args;} -> - combinesmall 1 (combine (Instance.hash univs) (hash_term_array args)) + | CaseInvert {indices;} -> + combinesmall 1 (hash_term_array indices) and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t @@ -1426,6 +1456,11 @@ and hash_term_array t = and hash_term_list t = List.fold_left (fun acc t -> combine (hash t) acc) 0 t +and hash_under_context (_, t) = hash t + +and hash_branches bl = + Array.fold_left (fun acc t -> combine acc (hash_under_context t)) 0 bl + module CaseinfoHash = struct type t = case_info @@ -1551,10 +1586,15 @@ let rec debug_print c = | Construct (((sp,i),j),u) -> str"Constr(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" | Proj (p,c) -> str"Proj(" ++ Constant.debug_print (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ debug_print c ++ str")" - | Case (_ci,p,iv,c,bl) -> v 0 - (hv 0 (str"<"++debug_print p++str">"++ cut() ++ str"Case " ++ - debug_print c ++ debug_invert iv ++ str"of") ++ cut() ++ - prlist_with_sep (fun _ -> brk(1,2)) debug_print (Array.to_list bl) ++ + | Case (_ci,_u,pms,p,iv,c,bl) -> + let pr_ctx (nas, c) = + prvect_with_sep spc (fun na -> Name.print na.binder_name) nas ++ spc () ++ str "|-" ++ spc () ++ + debug_print c + in + v 0 (hv 0 (str"Case " ++ + debug_print c ++ cut () ++ str "as" ++ cut () ++ prlist_with_sep cut debug_print (Array.to_list pms) ++ + cut () ++ str"return"++ cut () ++ pr_ctx p ++ debug_invert iv ++ cut () ++ str"with") ++ cut() ++ + prlist_with_sep (fun _ -> brk(1,2)) pr_ctx (Array.to_list bl) ++ cut() ++ str"end") | Fix f -> debug_print_fix debug_print f | CoFix(i,(lna,tl,bl)) -> @@ -1573,6 +1613,6 @@ let rec debug_print c = and debug_invert = let open Pp in function | NoInvert -> mt() - | CaseInvert {univs;args;} -> - spc() ++ str"Invert {univs=" ++ Instance.pr Level.pr univs ++ - str "; args=" ++ prlist_with_sep spc debug_print (Array.to_list args) ++ str "} " + | CaseInvert {indices;} -> + spc() ++ str"Invert {indices=" ++ + prlist_with_sep spc debug_print (Array.to_list indices) ++ str "} " diff --git a/kernel/constr.mli b/kernel/constr.mli index ed63ac507c..57dd850ee7 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -49,11 +49,11 @@ type case_info = ci_pp_info : case_printing (* not interpreted by the kernel *) } -type ('constr, 'univs) case_invert = +type 'constr pcase_invert = | NoInvert (** Normal reduction: match when the scrutinee is a constructor. *) - | CaseInvert of { univs : 'univs; args : 'constr array; } + | CaseInvert of { indices : 'constr array; } (** Reduce when the indices match those of the unique constructor. (SProp to non SProp only) *) @@ -152,14 +152,30 @@ val mkRef : GlobRef.t Univ.puniverses -> constr (** Constructs a destructor of inductive type. - [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] + [mkCase ci params p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. - [p] structure is [fun args x -> "return clause"] + + [p] structure is [args x |- "return clause"] [ac]{^ ith} element is ith constructor case presented as - {e lambda construct_args (without params). case_term } *) -val mkCase : case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array -> constr + {e construct_args |- case_term } *) + +type 'constr pcase_branch = Name.t Context.binder_annot array * 'constr +(** Names of the indices + name of self *) + +type 'types pcase_return = Name.t Context.binder_annot array * 'types +(** Names of the branches *) + +type ('constr, 'types, 'univs) pcase = + case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array + +type case_invert = constr pcase_invert +type case_return = types pcase_return +type case_branch = constr pcase_branch +type case = (constr, types, Univ.Instance.t) pcase + +val mkCase : case -> constr (** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] @@ -243,7 +259,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Ind of (inductive * 'univs) (** A name of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) | Construct of (constructor * 'univs) (** A constructor of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) - | Case of case_info * 'constr * ('constr,'univs) case_invert * 'constr * 'constr array + | Case of case_info * 'univs * 'constr array * 'types pcase_return * 'constr pcase_invert * 'constr * 'constr pcase_branch array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr @@ -351,7 +367,7 @@ Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) -val destCase : constr -> case_info * constr * (constr,Univ.Instance.t) case_invert * constr * constr array +val destCase : constr -> case (** Destructs a projection *) val destProj : constr -> Projection.t * constr @@ -421,12 +437,6 @@ val lift : int -> constr -> constr (** {6 Functionals working on expressions canonically abstracted over a local context (possibly with let-ins)} *) -(** [map_under_context f l c] maps [f] on the immediate subterms of a - term abstracted over a context of length [n] (local definitions - are counted) *) - -val map_under_context : (constr -> constr) -> int -> constr -> constr - (** [map_branches f br] maps [f] on the immediate subterms of an array of "match" branches [br] in canonical eta-let-expanded form; it is not recursive and the order with which subterms are processed is @@ -434,7 +444,7 @@ val map_under_context : (constr -> constr) -> int -> constr -> constr types and possibly terms occurring in the context of each branch as well as the body of each branch *) -val map_branches : (constr -> constr) -> case_info -> constr array -> constr array +val map_branches : (constr -> constr) -> case_branch array -> case_branch array (** [map_return_predicate f p] maps [f] on the immediate subterms of a return predicate of a "match" in canonical eta-let-expanded form; @@ -443,16 +453,7 @@ val map_branches : (constr -> constr) -> case_info -> constr array -> constr arr the types and possibly terms occurring in the context of each branch as well as the body of the predicate *) -val map_return_predicate : (constr -> constr) -> case_info -> constr -> constr - -(** [map_under_context_with_binders g f n l c] maps [f] on the - immediate subterms of a term abstracted over a context of length - [n] (local definitions are counted); it preserves sharing; it - carries an extra data [n] (typically a lift index) which is - processed by [g] (which typically add 1 to [n]) at each binder - traversal *) - -val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> int -> constr -> constr +val map_return_predicate : (constr -> constr) -> case_return -> case_return (** [map_branches_with_binders f br] maps [f] on the immediate subterms of an array of "match" branches [br] in canonical @@ -464,7 +465,7 @@ val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> ' occurring in the context of the branch as well as the body of the branch *) -val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr array -> constr array +val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_branch array -> case_branch array (** [map_return_predicate_with_binders f p] maps [f] on the immediate subterms of a return predicate of a "match" in canonical @@ -476,7 +477,7 @@ val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> occurring in the context of each branch as well as the body of the predicate *) -val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr -> constr +val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_return -> case_return (** {6 Functionals working on the immediate subterm of a construction } *) @@ -486,7 +487,7 @@ val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) - val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a -val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a +val fold_invert : ('a -> 'b -> 'a) -> 'a -> 'b pcase_invert -> 'a (** [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is @@ -494,21 +495,14 @@ val fold_invert : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) case_invert -> 'a val map : (constr -> constr) -> constr -> constr -val map_invert : ('a -> 'a) -> ('a, 'b) case_invert -> ('a, 'b) case_invert - -(** [map_user_view f c] maps [f] on the immediate subterms of [c]; it - differs from [map f c] in that the typing context and body of the - return predicate and of the branches of a [match] are considered as - immediate subterm of a [match] *) - -val map_user_view : (constr -> constr) -> constr -> constr +val map_invert : ('a -> 'a) -> 'a pcase_invert -> 'a pcase_invert (** Like {!map}, but also has an additional accumulator. *) val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr val fold_map_invert : ('a -> 'b -> 'a * 'b) -> - 'a -> ('b, 'c) case_invert -> 'a * ('b, 'c) case_invert + 'a -> 'b pcase_invert -> 'a * 'b pcase_invert (** [map_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -525,7 +519,7 @@ val map_with_binders : val iter : (constr -> unit) -> constr -> unit -val iter_invert : ('a -> unit) -> ('a, 'b) case_invert -> unit +val iter_invert : ('a -> unit) -> 'a pcase_invert -> unit (** [iter_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -603,8 +597,8 @@ val compare_head_gen_leq : Univ.Instance.t instance_compare_fn -> constr constr_compare_fn -> constr constr_compare_fn -val eq_invert : ('a -> 'a -> bool) -> ('b -> 'b -> bool) - -> ('a, 'b) case_invert -> ('a, 'b) case_invert -> bool +val eq_invert : ('a -> 'a -> bool) + -> 'a pcase_invert -> 'a pcase_invert -> bool (** {6 Hashconsing} *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 3707a75157..f82b754c59 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -75,30 +75,23 @@ let share_univs cache r u l = let (u', args) = share cache r l in mkApp (instantiate_my_gr r (Instance.append u' u), args) -let update_case cache ci iv modlist = - match share cache (IndRef ci.ci_ind) modlist with - | exception Not_found -> ci, iv - | u, l -> - let iv = match iv with - | NoInvert -> NoInvert - | CaseInvert {univs; args;} -> - let univs = Instance.append u univs in - let args = Array.append l args in - CaseInvert {univs; args;} - in - { ci with ci_npar = ci.ci_npar + Array.length l }, iv - let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = let share_univs = share_univs cache in - let update_case = update_case cache in let rec substrec c = match kind c with - | Case (ci,p,iv,t,br) -> - let ci,iv = update_case ci iv modlist in - Constr.map substrec (mkCase (ci,p,iv,t,br)) + | Case (ci, u, pms, p, iv, t, br) -> + begin match share cache (IndRef ci.ci_ind) modlist with + | (u', prefix) -> + let u = Instance.append u' u in + let pms = Array.append prefix pms in + let ci = { ci with ci_npar = ci.ci_npar + Array.length prefix } in + Constr.map substrec (mkCase (ci,u,pms,p,iv,t,br)) + | exception Not_found -> + Constr.map substrec c + end | Ind (ind,u) -> (try diff --git a/kernel/environ.ml b/kernel/environ.ml index 6f2aeab203..63fbaa6a3b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -571,6 +571,12 @@ let is_primitive env c = | Declarations.Primitive _ -> true | _ -> false +let get_primitive env c = + let cb = lookup_constant c env in + match cb.Declarations.const_body with + | Declarations.Primitive p -> Some p + | _ -> None + let is_int63_type env c = match env.retroknowledge.Retroknowledge.retro_int63 with | None -> false diff --git a/kernel/environ.mli b/kernel/environ.mli index dfd9173d10..414ef2b4d7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -248,6 +248,7 @@ val constant_type_in : env -> Constant.t puniverses -> types val constant_opt_value_in : env -> Constant.t puniverses -> constr option val is_primitive : env -> Constant.t -> bool +val get_primitive : env -> Constant.t -> CPrimitives.t option val is_array_type : env -> Constant.t -> bool val is_int63_type : env -> Constant.t -> bool diff --git a/kernel/esubst.ml b/kernel/esubst.ml index afd8e3ef67..1c8575ef05 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -245,3 +245,38 @@ let rec lift_subst mk e s = match s with let t, e = tree_map mk e t in let rem = lift_subst mk e rem in Cons (h, t, rem) + +module Internal = +struct + +type 'a or_rel = REL of int | VAL of int * 'a + +let to_rel shift = function +| Var i -> REL (i + shift) +| Arg v -> VAL (shift, v) + +let rec get_tree_subst shift accu = function +| Leaf (w, x) -> + to_rel (shift + w) x :: accu +| Node (w, x, l, r, _) -> + let accu = get_tree_subst (shift + w + eval l) accu r in + let accu = get_tree_subst (shift + w) accu l in + to_rel (shift + w) x :: accu + +let rec get_subst shift accu = function +| Nil (w, n) -> + List.init n (fun i -> REL (w + i + shift + 1)) +| Cons (_, t, s) -> + let accu = get_subst (shift + eval t) accu s in + get_tree_subst shift accu t + +let rec get_shift accu = function +| Nil (w, n) -> accu + w + n +| Cons (_, t, s) -> get_shift (eval t + accu) s + +let repr (s : 'a subs) = + let shift = get_shift 0 s in + let subs = get_subst 0 [] s in + subs, shift + +end diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 8ff29ab07a..b0fbe680c3 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -94,3 +94,15 @@ val is_lift_id : lift -> bool That is, if Γ ⊢ e : Δ and Δ ⊢ σ : Ξ, then Γ ⊢ lift_subst mk e σ : Ξ. *) val lift_subst : (lift -> 'a -> 'b) -> lift -> 'a subs -> 'b subs + +(** Debugging utilities *) +module Internal : +sig +type 'a or_rel = REL of int | VAL of int * 'a + +(** High-level representation of a substitution. The first component is a list + that associates a value to an index, and the second component is the + relocation shift that must be applied to any variable pointing outside of + the substitution. *) +val repr : 'a subs -> 'a or_rel list * int +end diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index dc2cd349ce..bda65956be 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -10,198 +10,195 @@ (** List of opcodes. - It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and - [vmopcodes.ml] files. + It is used to generate the files [coq_instruct.h], [coq_jumptbl.h], + [coq_arity.h], and [vmopcodes.ml]. - If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c - with the arity of the instruction and maybe coq_tcode_of_code. + [STOP] needs to be the last opcode. + + Arity -1 designates opcodes that need special handling in [coq_fix_code.c]. *) let opcodes = [| - "ACC0"; - "ACC1"; - "ACC2"; - "ACC3"; - "ACC4"; - "ACC5"; - "ACC6"; - "ACC7"; - "ACC"; - "PUSH"; - "PUSHACC0"; - "PUSHACC1"; - "PUSHACC2"; - "PUSHACC3"; - "PUSHACC4"; - "PUSHACC5"; - "PUSHACC6"; - "PUSHACC7"; - "PUSHACC"; - "POP"; - "ENVACC0"; - "ENVACC1"; - "ENVACC2"; - "ENVACC3"; - "ENVACC"; - "PUSHENVACC0"; - "PUSHENVACC1"; - "PUSHENVACC2"; - "PUSHENVACC3"; - "PUSHENVACC"; - "PUSH_RETADDR"; - "APPLY"; - "APPLY1"; - "APPLY2"; - "APPLY3"; - "APPLY4"; - "APPTERM"; - "APPTERM1"; - "APPTERM2"; - "APPTERM3"; - "RETURN"; - "RESTART"; - "GRAB"; - "GRABREC"; - "CLOSURE"; - "CLOSUREREC"; - "CLOSURECOFIX"; - "OFFSETCLOSURE0"; - "OFFSETCLOSURE1"; - "OFFSETCLOSURE"; - "PUSHOFFSETCLOSURE0"; - "PUSHOFFSETCLOSURE1"; - "PUSHOFFSETCLOSURE"; - "GETGLOBAL"; - "PUSHGETGLOBAL"; - "MAKEBLOCK"; - "MAKEBLOCK1"; - "MAKEBLOCK2"; - "MAKEBLOCK3"; - "MAKEBLOCK4"; - "SWITCH"; - "PUSHFIELDS"; - "GETFIELD0"; - "GETFIELD1"; - "GETFIELD"; - "SETFIELD0"; - "SETFIELD1"; - "SETFIELD"; - "PROJ"; - "ENSURESTACKCAPACITY"; - "CONST0"; - "CONST1"; - "CONST2"; - "CONST3"; - "CONSTINT"; - "PUSHCONST0"; - "PUSHCONST1"; - "PUSHCONST2"; - "PUSHCONST3"; - "PUSHCONSTINT"; - "ACCUMULATE"; - "MAKESWITCHBLOCK"; - "MAKEACCU"; - "MAKEPROD"; - "BRANCH"; - "CHECKADDINT63"; - "CHECKADDCINT63"; - "CHECKADDCARRYCINT63"; - "CHECKSUBINT63"; - "CHECKSUBCINT63"; - "CHECKSUBCARRYCINT63"; - "CHECKMULINT63"; - "CHECKMULCINT63"; - "CHECKDIVINT63"; - "CHECKMODINT63"; - "CHECKDIVEUCLINT63"; - "CHECKDIV21INT63"; - "CHECKLXORINT63"; - "CHECKLORINT63"; - "CHECKLANDINT63"; - "CHECKLSLINT63"; - "CHECKLSRINT63"; - "CHECKADDMULDIVINT63"; - "CHECKLSLINT63CONST1"; - "CHECKLSRINT63CONST1"; - "CHECKEQINT63"; - "CHECKLTINT63"; - "CHECKLEINT63"; - "CHECKCOMPAREINT63"; - "CHECKHEAD0INT63"; - "CHECKTAIL0INT63"; - "CHECKOPPFLOAT"; - "CHECKABSFLOAT"; - "CHECKEQFLOAT"; - "CHECKLTFLOAT"; - "CHECKLEFLOAT"; - "CHECKCOMPAREFLOAT"; - "CHECKCLASSIFYFLOAT"; - "CHECKADDFLOAT"; - "CHECKSUBFLOAT"; - "CHECKMULFLOAT"; - "CHECKDIVFLOAT"; - "CHECKSQRTFLOAT"; - "CHECKFLOATOFINT63"; - "CHECKFLOATNORMFRMANTISSA"; - "CHECKFRSHIFTEXP"; - "CHECKLDSHIFTEXP"; - "CHECKNEXTUPFLOAT"; - "CHECKNEXTDOWNFLOAT"; - "CHECKNEXTUPFLOATINPLACE"; - "CHECKNEXTDOWNFLOATINPLACE"; - "CHECKCAMLCALL2_1"; - "CHECKCAMLCALL1"; - "CHECKCAMLCALL2"; - "CHECKCAMLCALL3_1"; - "STOP" + "ACC0", 0; + "ACC1", 0; + "ACC2", 0; + "ACC3", 0; + "ACC4", 0; + "ACC5", 0; + "ACC6", 0; + "ACC7", 0; + "ACC", 1; + "PUSH", 0; + "PUSHACC1", 0; + "PUSHACC2", 0; + "PUSHACC3", 0; + "PUSHACC4", 0; + "PUSHACC5", 0; + "PUSHACC6", 0; + "PUSHACC7", 0; + "PUSHACC", 1; + "POP", 1; + "ENVACC0", 0; + "ENVACC1", 0; + "ENVACC2", 0; + "ENVACC3", 0; + "ENVACC", 1; + "PUSHENVACC0", 0; + "PUSHENVACC1", 0; + "PUSHENVACC2", 0; + "PUSHENVACC3", 0; + "PUSHENVACC", 1; + "PUSH_RETADDR", 1; + "APPLY", 1; + "APPLY1", 0; + "APPLY2", 0; + "APPLY3", 0; + "APPLY4", 0; + "APPTERM", 2; + "APPTERM1", 1; + "APPTERM2", 1; + "APPTERM3", 1; + "RETURN", 1; + "RESTART", 0; + "GRAB", 1; + "GRABREC", 1; + "CLOSURE", 2; + "CLOSUREREC", -1; + "CLOSURECOFIX", -1; + "OFFSETCLOSURE0", 0; + "OFFSETCLOSURE1", 0; + "OFFSETCLOSURE", 1; + "PUSHOFFSETCLOSURE0", 0; + "PUSHOFFSETCLOSURE1", 0; + "PUSHOFFSETCLOSURE", 1; + "GETGLOBAL", 1; + "PUSHGETGLOBAL", 1; + "MAKEBLOCK", 2; + "MAKEBLOCK1", 1; + "MAKEBLOCK2", 1; + "MAKEBLOCK3", 1; + "MAKEBLOCK4", 1; + "SWITCH", -1; + "PUSHFIELDS", 1; + "GETFIELD0", 0; + "GETFIELD1", 0; + "GETFIELD", 1; + "SETFIELD", 1; + "PROJ", 2; + "ENSURESTACKCAPACITY", 1; + "CONST0", 0; + "CONST1", 0; + "CONST2", 0; + "CONST3", 0; + "CONSTINT", 1; + "PUSHCONST0", 0; + "PUSHCONST1", 0; + "PUSHCONST2", 0; + "PUSHCONST3", 0; + "PUSHCONSTINT", 1; + "ACCUMULATE", 0; + "MAKESWITCHBLOCK", 4; + "MAKEACCU", 1; + "BRANCH", 1; + "CHECKADDINT63", 1; + "CHECKADDCINT63", 1; + "CHECKADDCARRYCINT63", 1; + "CHECKSUBINT63", 1; + "CHECKSUBCINT63", 1; + "CHECKSUBCARRYCINT63", 1; + "CHECKMULINT63", 1; + "CHECKMULCINT63", 1; + "CHECKDIVINT63", 1; + "CHECKMODINT63", 1; + "CHECKDIVEUCLINT63", 1; + "CHECKDIV21INT63", 1; + "CHECKLXORINT63", 1; + "CHECKLORINT63", 1; + "CHECKLANDINT63", 1; + "CHECKLSLINT63", 1; + "CHECKLSRINT63", 1; + "CHECKADDMULDIVINT63", 1; + "CHECKEQINT63", 1; + "CHECKLTINT63", 1; + "CHECKLEINT63", 1; + "CHECKCOMPAREINT63", 1; + "CHECKHEAD0INT63", 1; + "CHECKTAIL0INT63", 1; + "CHECKOPPFLOAT", 1; + "CHECKABSFLOAT", 1; + "CHECKEQFLOAT", 1; + "CHECKLTFLOAT", 1; + "CHECKLEFLOAT", 1; + "CHECKCOMPAREFLOAT", 1; + "CHECKCLASSIFYFLOAT", 1; + "CHECKADDFLOAT", 1; + "CHECKSUBFLOAT", 1; + "CHECKMULFLOAT", 1; + "CHECKDIVFLOAT", 1; + "CHECKSQRTFLOAT", 1; + "CHECKFLOATOFINT63", 1; + "CHECKFLOATNORMFRMANTISSA", 1; + "CHECKFRSHIFTEXP", 1; + "CHECKLDSHIFTEXP", 1; + "CHECKNEXTUPFLOAT", 1; + "CHECKNEXTDOWNFLOAT", 1; + "CHECKNEXTUPFLOATINPLACE", 1; + "CHECKNEXTDOWNFLOATINPLACE", 1; + "CHECKCAMLCALL2_1", 2; + "CHECKCAMLCALL1", 2; + "CHECKCAMLCALL2", 2; + "CHECKCAMLCALL3_1", 2; + "STOP", 0 |] let pp_c_comment fmt = - Format.fprintf fmt "/* %a */" + Format.fprintf fmt "/* %s */" let pp_ocaml_comment fmt = - Format.fprintf fmt "(* %a *)" + Format.fprintf fmt "(* %s *)" let pp_header isOcaml fmt = Format.fprintf fmt "%a" - (fun fmt -> - (if isOcaml then pp_ocaml_comment else pp_c_comment) fmt - Format.pp_print_string) + (if isOcaml then pp_ocaml_comment else pp_c_comment) "DO NOT EDIT: automatically generated by kernel/genOpcodeFiles.ml" -let pp_with_commas fmt k = - Array.iteri (fun n s -> - Format.fprintf fmt " %a%s@." - k s - (if n + 1 < Array.length opcodes - then "," else "") - ) opcodes - let pp_coq_instruct_h fmt = - let line = Format.fprintf fmt "%s@." in pp_header false fmt; - line "#pragma once"; - line "enum instructions {"; - pp_with_commas fmt Format.pp_print_string; - line "};" + Format.fprintf fmt "#pragma once@.enum instructions {@."; + Array.iter (fun (name, _) -> + Format.fprintf fmt " %s,@." name + ) opcodes; + Format.fprintf fmt "};@." let pp_coq_jumptbl_h fmt = - pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") + pp_header false fmt; + Array.iter (fun (name, _) -> + Format.fprintf fmt " &&coq_lbl_%s,@." name + ) opcodes + +let pp_coq_arity_h fmt = + pp_header false fmt; + Format.fprintf fmt "static signed char arity[] = {@."; + Array.iter (fun (_, arity) -> + Format.fprintf fmt " %d,@." arity + ) opcodes; + Format.fprintf fmt "};@." let pp_vmopcodes_ml fmt = pp_header true fmt; Array.iteri (fun n s -> Format.fprintf fmt "let op%s = %d@.@." s n - ) opcodes + ) (Array.map fst opcodes) let usage () = - Format.eprintf "usage: %s [enum|jump|copml]@." Sys.argv.(0); + Format.eprintf "usage: %s [enum|jump|arity|copml]@." Sys.argv.(0); exit 1 let main () = match Sys.argv.(1) with | "enum" -> pp_coq_instruct_h Format.std_formatter | "jump" -> pp_coq_jumptbl_h Format.std_formatter + | "arity" -> pp_coq_arity_h Format.std_formatter | "copml" -> pp_vmopcodes_ml Format.std_formatter | _ -> usage () | exception Invalid_argument _ -> usage () diff --git a/kernel/inductive.ml b/kernel/inductive.ml index ce12d65614..eb18d4b90e 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -72,7 +72,7 @@ let constructor_instantiate mind u mib c = let s = ind_subst mind mib u in substl s (subst_instance_constr u c) -let instantiate_params full t u args sign = +let instantiate_params t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch.") in let (rem_args, subs, ty) = @@ -81,8 +81,7 @@ let instantiate_params full t u args sign = match (decl, largs, kind ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> - (largs, (substl subs (subst_instance_constr u b))::subs, t) - | (_,[],_) -> if full then fail() else ([], subs, ty) + (largs, (substl subs (subst_instance_constr u b))::subs, t) | _ -> fail ()) sign ~init:(args,[],t) @@ -93,11 +92,11 @@ let instantiate_params full t u args sign = let full_inductive_instantiate mib u params sign = let dummy = Sorts.prop in let t = Term.mkArity (Vars.subst_instance_context u sign,dummy) in - fst (Term.destArity (instantiate_params true t u params mib.mind_params_ctxt)) + fst (Term.destArity (instantiate_params t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in - instantiate_params true inst_ind u params mib.mind_params_ctxt + instantiate_params inst_ind u params mib.mind_params_ctxt (************************************************************************) (************************************************************************) @@ -372,6 +371,91 @@ let check_correct_arity env c pj ind specif params = with LocalArity kinds -> error_elim_arity env ind c pj kinds +(** {6 Changes of representation of Case nodes} *) + +(** Provided: + - a universe instance [u] + - a term substitution [subst] + - name replacements [nas] + [instantiate_context u subst nas ctx] applies both [u] and [subst] to [ctx] + while replacing names using [nas] (order reversed) +*) +let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> assert (Int.equal i (-1)); [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + instantiate (Array.length nas - 1) ctx + +let expand_case_specif mib (ci, u, params, p, iv, c, br) = + (* Γ ⊢ c : I@{u} params args *) + (* Γ, indices, self : I@{u} params indices ⊢ p : Type *) + let mip = mib.mind_packets.(snd ci.ci_ind) in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list params) in + (* Expand the return clause *) + let ep = + let (nas, p) = p in + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ci.ci_ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + let realdecls = instantiate_context u paramsubst nas realdecls in + Term.it_mkLambda_or_LetIn p realdecls + in + (* Expand the branches *) + let subst = paramsubst @ ind_subst (fst ci.ci_ind) mib u in + let ebr = + let build_one_branch i (nas, br) (ctx, _) = + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let ctx = instantiate_context u subst nas ctx in + Term.it_mkLambda_or_LetIn br ctx + in + Array.map2_i build_one_branch br mip.mind_nf_lc + in + (ci, ep, iv, c, ebr) + +let expand_case env (ci, _, _, _, _, _, _ as case) = + let specif = Environ.lookup_mind (fst ci.ci_ind) env in + expand_case_specif specif case + +let contract_case env (ci, p, iv, c, br) = + let (mib, mip) = lookup_mind_specif env ci.ci_ind in + let (arity, p) = Term.decompose_lam_n_decls (mip.mind_nrealdecls + 1) p in + let (u, pms) = match arity with + | LocalAssum (_, ty) :: _ -> + (** Last binder is the self binder for the term being eliminated *) + let (ind, args) = decompose_appvect ty in + let (ind, u) = destInd ind in + let () = assert (Ind.CanOrd.equal ind ci.ci_ind) in + let pms = Array.sub args 0 mib.mind_nparams in + (** Unlift the parameters from under the index binders *) + let dummy = List.make mip.mind_nrealdecls mkProp in + let pms = Array.map (fun c -> Vars.substl dummy c) pms in + (u, pms) + | _ -> assert false + in + let p = + let nas = Array.of_list (List.rev_map get_annot arity) in + (nas, p) + in + let map i br = + let (ctx, br) = Term.decompose_lam_n_decls mip.mind_consnrealdecls.(i) br in + let nas = Array.of_list (List.rev_map get_annot ctx) in + (nas, br) + in + (ci, u, pms, p, iv, c, Array.mapi map br) (************************************************************************) (* Type of case branches *) @@ -793,7 +877,8 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_all renv.env t) in match kind f with | Rel k -> subterm_var k renv - | Case (ci,p,_iv,c,lbr) -> (* iv ignored: it's just a cache *) + | Case (ci, u, pms, p, iv, c, lbr) -> (* iv ignored: it's just a cache *) + let (ci, p, _iv, c, lbr) = expand_case renv.env (ci, u, pms, p, iv, c, lbr) in let stack' = push_stack_closures renv l stack in let cases_spec = branches_specif renv (lazy_subterm_specif renv [] c) ci @@ -1018,7 +1103,8 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(lift p c,l)) end - | Case (ci,p,iv,c_0,lrest) -> (* iv ignored: it's just a cache *) + | Case (ci, u, pms, ret, iv, c_0, br) -> (* iv ignored: it's just a cache *) + let (ci, p, _iv, c_0, lrest) = expand_case renv.env (ci, u, pms, ret, iv, c_0, br) in begin try List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg info for the arguments of each branch *) @@ -1040,7 +1126,7 @@ let check_one_fix renv recpos trees def = (* the call to whd_betaiotazeta will reduce the apparent iota redex away *) check_rec_call renv [] - (Term.applist (mkCase (ci,p,iv,c_0,lrest), l)) + (Term.applist (mkCase (ci, u, pms, ret, iv, c_0, br), l)) | _ -> Exninfo.iraise exn end @@ -1324,13 +1410,14 @@ let check_one_cofix env nbfix def deftype = else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) - | Case (_,p,_,tm,vrest) -> (* iv ignored: just a cache *) - begin - let tree = match restrict_spec env (Subterm (Strict, tree)) p with - | Dead_code -> assert false - | Subterm (_, tree') -> tree' - | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) - in + | Case (ci, u, pms, p, iv, tm, br) -> (* iv ignored: just a cache *) + begin + let (_, p, _iv, tm, vrest) = expand_case env (ci, u, pms, p, iv, tm, br) in + let tree = match restrict_spec env (Subterm (Strict, tree)) p with + | Dead_code -> assert false + | Subterm (_, tree') -> tree' + | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) + in if (noccur_with_meta n nbfix p) then if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 78658dc4de..5808a3fa65 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -79,6 +79,23 @@ val arities_of_specif : MutInd.t puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int +(** Given a pattern-matching represented compactly, expands it so as to produce + lambda and let abstractions in front of the return clause and the pattern + branches. *) +val expand_case : env -> case -> (case_info * constr * case_invert * constr * constr array) + +val expand_case_specif : mutual_inductive_body -> case -> (case_info * constr * case_invert * constr * constr array) + +(** Dual operation of the above. Fails if the return clause or branch has not + the expected form. *) +val contract_case : env -> (case_info * constr * case_invert * constr * constr array) -> case + +(** [instantiate_context u subst nas ctx] applies both [u] and [subst] + to [ctx] while replacing names using [nas] (order reversed). In particular, + assumes that [ctx] and [nas] have the same length. *) +val instantiate_context : Instance.t -> Vars.substl -> Name.t Context.binder_annot array -> + rel_context -> rel_context + (** [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression: <p>Cases (c :: (I args)) of b1..bn end diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index d02f92ef26..50c3ba1cc6 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -198,7 +198,9 @@ let rec infer_fterm cv_pb infos variances hd stk = let variances = infer_vect infos variances elems in infer_stack infos variances stk - | FCaseInvert (_,p,_,_,br,e) -> + | FCaseInvert (ci, u, pms, p, _, _, br, e) -> + let mib = Environ.lookup_mind (fst ci.ci_ind) (info_env (fst infos)) in + let (_, p, _, _, br) = Inductive.expand_case_specif mib (ci, u, pms, p, NoInvert, mkProp, br) in let infer c variances = infer_fterm CONV infos variances (mk_clos e c) [] in let variances = infer p variances in Array.fold_right infer br variances @@ -217,7 +219,10 @@ and infer_stack infos variances (stk:CClosure.stack) = | Zfix (fx,a) -> let variances = infer_fterm CONV infos variances fx [] in infer_stack infos variances a - | ZcaseT (_, p, br, e) -> + | ZcaseT (ci,u,pms,p,br,e) -> + let dummy = mkProp in + let case = (ci, u, pms, p, NoInvert, dummy, br) in + let (_, p, _, _, br) = Inductive.expand_case (info_env (fst infos)) case in let variances = infer_fterm CONV infos variances (mk_clos e p) [] in infer_vect infos variances (Array.map (mk_clos e) br) | Zshift _ -> variances diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 5b2a7bd9c2..75fd70d923 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -31,6 +31,8 @@ Primred CClosure Relevanceops Reduction +Type_errors +Inductive Vmlambda Nativelambda Vmbytegen @@ -40,9 +42,7 @@ Vmsymtable Vm Vconv Nativeconv -Type_errors Modops -Inductive Typeops InferCumulativity IndTyping diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 2aeb1ea202..c5ac57a2cd 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -340,15 +340,6 @@ let subst_retro_action subst action = let c' = subst_constant subst c in if c == c' then action else Register_type(prim, c') -(* Here the semantics is completely unclear. - What does "Hint Unfold t" means when "t" is a parameter? - Does the user mean "Unfold X.t" or does she mean "Unfold y" - where X.t is later on instantiated with y? I choose the first - interpretation (i.e. an evaluable reference is never expanded). *) -let subst_evaluable_reference subst = function - | EvalVarRef id -> EvalVarRef id - | EvalConstRef kn -> EvalConstRef (subst_constant subst kn) - let rec map_kn f f' c = let func = map_kn f f' in match kind c with @@ -364,21 +355,26 @@ let rec map_kn f f' c = | Construct (((kn,i),j),u) -> let kn' = f kn in if kn'==kn then c else mkConstructU (((kn',i),j),u) - | Case (ci,p,iv,ct,l) -> + | Case (ci,u,pms,p,iv,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in let kn' = f kn in if kn'==kn then ci.ci_ind else kn',i in - let p' = func p in + let f_ctx (nas, c as d) = + let c' = func c in + if c' == c then d else (nas, c') + in + let pms' = Array.Smart.map func pms in + let p' = f_ctx p in let iv' = map_invert func iv in let ct' = func ct in - let l' = Array.Smart.map func l in - if (ci.ci_ind==ci_ind && p'==p && iv'==iv + let l' = Array.Smart.map f_ctx l in + if (ci.ci_ind==ci_ind && pms'==pms && p'==p && iv'==iv && l'==l && ct'==ct)then c else - mkCase ({ci with ci_ind = ci_ind}, - p',iv',ct', l') + mkCase ({ci with ci_ind = ci_ind}, u, + pms',p',iv',ct', l') | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index bc5816dafb..9cf270cff7 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -146,14 +146,6 @@ val subst_proj : substitution -> Projection.t -> Projection.t val subst_retro_action : substitution -> Retroknowledge.action -> Retroknowledge.action -(** Here the semantics is completely unclear. - What does "Hint Unfold t" means when "t" is a parameter? - Does the user mean "Unfold X.t" or does she mean "Unfold y" - where X.t is later on instantiated with y? I choose the first - interpretation (i.e. an evaluable reference is never expanded). *) -val subst_evaluable_reference : - substitution -> evaluable_global_reference -> evaluable_global_reference - (** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) val replace_mp_in_kn : ModPath.t -> ModPath.t -> KerName.t -> KerName.t diff --git a/kernel/names.ml b/kernel/names.ml index be65faf234..60c6c7bd67 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1100,16 +1100,6 @@ module GlobRef = struct end -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -(* Better to have it here that in closure, since used in grammar.cma *) -let eq_egr e1 e2 = match e1, e2 with - EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 - | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 - | _, _ -> false - (** Located identifiers and objects with syntax. *) type lident = Id.t CAst.t diff --git a/kernel/names.mli b/kernel/names.mli index 747299bb12..09885396c0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -714,14 +714,6 @@ module GlobRef : sig end -(** Better to have it here that in Closure, since required in grammar.cma *) -(* XXX: Move to a module *) -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool - (** Located identifiers and objects with syntax. *) type lident = Id.t CAst.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 09db29d222..d517d215ed 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -24,6 +24,11 @@ open Environ compiler. mllambda represents a fragment of ML, and can easily be printed to OCaml code. *) +let debug_native_flag, debug_native_compiler = CDebug.create_full ~name:"native-compiler" () + +let keep_debug_files () = + CDebug.get_flag debug_native_flag + (** Local names **) (* The first component is there for debugging purposes only *) @@ -1939,7 +1944,7 @@ let compile_constant env sigma con cb = | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in - if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); + debug_native_compiler (fun () -> Pp.str "Generated lambda code"); let is_lazy = is_lazy t in let code = if is_lazy then mk_lazy code else code in let l = Constant.label con in @@ -1950,11 +1955,11 @@ let compile_constant env sigma con cb = let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in - if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); + debug_native_compiler (fun () -> Pp.str "Generated mllambda code"); let code = optimize_stk (Glet(Gconstant ("", con),code)::auxdefs) in - if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); + debug_native_compiler (fun () -> Pp.str "Optimized mllambda code"); code | _ -> let i = push_symbol (SymbConst con) in @@ -2101,7 +2106,7 @@ let compile_deps env sigma prefix init t = | Proj (p,c) -> let init = compile_mind_deps env prefix init (Projection.mind p) in aux env lvl init c - | Case (ci, _p, _iv, _c, _ac) -> + | Case (ci, _u, _pms, _p, _iv, _c, _ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix init mind in fold_constr_with_binders succ (aux env) lvl init t diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index aab6e1d4a0..1b14801fec 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -21,6 +21,10 @@ to OCaml code. *) type mllambda type global +val debug_native_compiler : CDebug.t + +val keep_debug_files : unit -> bool + val pp_global : Format.formatter -> global -> unit val mk_open : string -> global diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index d77ee759c6..7e73725c6c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -159,12 +159,12 @@ let native_conv_gen pb sigma env univs t1 t2 = let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in let fn = compile ml_filename code ~profile:false in - if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); + debug_native_compiler (fun () -> Pp.str "Running test..."); let t0 = Sys.time () in call_linker ~fatal:true ~prefix fn (Some upds); let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + debug_native_compiler (fun () -> Pp.str time_info); (* TODO change 0 when we can have de Bruijn *) fst (conv_val env pb 0 !rt1 !rt2 univs) diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index b27c53ef0f..f3b483467d 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -535,7 +535,8 @@ let rec lambda_of_constr cache env sigma c = let prefix = get_mind_prefix env (fst ind) in mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] - | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) + | Case (ci, u, pms, t, iv, a, br) -> (* XXX handle iv *) + let (ci, t, _iv, a, branches) = Inductive.expand_case env (ci, u, pms, t, iv, a, br) in let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind env in let oib = mib.mind_packets.(i) in diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 1e1085d5ff..3eb3c949bc 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -38,7 +38,7 @@ let ( / ) = Filename.concat let my_temp_dir = lazy (CUnix.mktemp_dir "Coq_native" "") let () = at_exit (fun () -> - if not !Flags.debug && Lazy.is_val my_temp_dir then + if not (keep_debug_files ()) && Lazy.is_val my_temp_dir then try let d = Lazy.force my_temp_dir in Array.iter (fun f -> Sys.remove (Filename.concat d f)) (Sys.readdir d); @@ -129,7 +129,7 @@ let call_compiler ?profile:(profile=false) ml_filename = ::"-w"::"a" ::include_dirs) @ ["-impl"; ml_filename] in - if !Flags.debug then Feedback.msg_debug (Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); + debug_native_compiler (fun () -> Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (Envars.ocamlfind ()) args in match res with @@ -142,7 +142,7 @@ let call_compiler ?profile:(profile=false) ml_filename = let compile fn code ~profile:profile = write_ml_code fn code; let r = call_compiler ~profile fn in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; + if (not (keep_debug_files ())) && Sys.file_exists fn then Sys.remove fn; r type native_library = Nativecode.global list * Nativevalues.symbols @@ -160,7 +160,7 @@ let compile_library (code, symb) fn = let fn = dirname / basename in write_ml_code fn ~header code; let _ = call_compiler fn in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn + if (not (keep_debug_files ())) && Sys.file_exists fn then Sys.remove fn (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) @@ -171,7 +171,7 @@ let call_linker ?(fatal=true) ~prefix f upds = begin let msg = "Cannot find native compiler file " ^ f in if fatal then CErrors.user_err Pp.(str msg) - else if !Flags.debug then Feedback.msg_debug (Pp.str msg) + else debug_native_compiler (fun () -> Pp.str msg) end else (try @@ -180,7 +180,7 @@ let call_linker ?(fatal=true) ~prefix f upds = with Dynlink.Error _ as exn -> let exn = Exninfo.capture exn in if fatal then Exninfo.iraise exn - else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); + else debug_native_compiler (fun () -> CErrors.(iprint exn))); match upds with Some upds -> update_locations upds | _ -> () let link_library ~prefix ~dirname ~basename = diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index c95880dc36..2e27fe071e 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -28,35 +28,35 @@ and translate_field prefix mp env acc (l,x) = match x with | SFBconst cb -> let con = Constant.make2 mp l in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); compile_constant_field env prefix con acc cb | SFBmind mb -> - (if !Flags.debug then + (debug_native_compiler (fun () -> let id = mb.mind_packets.(0).mind_typename in let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); compile_mind_field mp l acc mb | SFBmodule md -> let mp = md.mod_mp in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); translate_mod prefix mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); translate_mod prefix mp env mdtyp.mod_type acc let dump_library mp dp env mod_expr = - if !Flags.debug then Feedback.msg_debug (Pp.str "Compiling library..."); + debug_native_compiler (fun () -> Pp.str "Compiling library..."); match mod_expr with | NoFunctor struc -> let env = add_structure mp struc empty_delta_resolver env in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index cf40263f61..1e39756d47 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -56,7 +56,7 @@ let compare_stack_shape stk1 stk2 = | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj _p1::s1, Zproj _p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | (ZcaseT(_c1,_,_,_)::s1, ZcaseT(_c2,_,_,_)::s2) -> + | (ZcaseT(_c1,_,_,_,_,_)::s1, ZcaseT(_c2,_,_,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -74,7 +74,7 @@ type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack - | Zlcase of case_info * lift * constr * constr array * fconstr subs + | Zlcase of case_info * lift * Univ.Instance.t * constr array * case_return * case_branch array * fconstr subs | Zlprimitive of CPrimitives.t * pconstant * lft_fconstr list * lft_fconstr next_native_args and lft_constr_stack = lft_constr_stack_elt list @@ -109,8 +109,8 @@ let pure_stack lfts stk = | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) - | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,p,br,e)::pstk) + | (ZcaseT(ci,u,pms,p,br,e),(l,pstk)) -> + (l,Zlcase(ci,l,u,pms,p,br,e)::pstk) | (Zprimitive(op,c,rargs,kargs),(l,pstk)) -> (l,Zlprimitive(op,c,List.map (fun t -> (l,t)) rargs, List.map (fun (k,t) -> (k,(l,t))) kargs)::pstk)) @@ -233,6 +233,9 @@ let convert_instances ~flex u u' (s, check) = exception MustExpand +let convert_instances_cumul pb var u u' (s, check) = + (check.compare_cumul_instances pb var u u' s, check) + let get_cumulativity_constraints cv_pb variance u u' = match cv_pb with | CONV -> @@ -294,8 +297,6 @@ let conv_table_key infos ~nargs k1 k2 cuniv = | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible -exception IrregularPatternShape - let unfold_ref_with_args infos tab fl v = match unfold_reference infos tab fl with | Def def -> Some (def, v) @@ -327,17 +328,6 @@ let push_relevance infos r = let push_relevances infos nas = { infos with cnv_inf = CClosure.push_relevances infos.cnv_inf nas } -let rec skip_pattern infos relevances n c1 c2 = - if Int.equal n 0 then {infos with cnv_inf = CClosure.set_info_relevances infos.cnv_inf relevances}, c1, c2 - else match kind c1, kind c2 with - | Lambda (x, _, c1), Lambda (_, _, c2) -> - skip_pattern infos (Range.cons x.Context.binder_relevance relevances) (pred n) c1 c2 - | _ -> raise IrregularPatternShape - -let skip_pattern infos n c1 c2 = - if Int.equal n 0 then infos, c1, c2 - else skip_pattern infos (info_relevances infos.cnv_inf) n c1 c2 - let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in try Relevanceops.relevance_of_fterm env (info_relevances infos.cnv_inf) lft c == Sorts.Irrelevant with _ -> false @@ -364,6 +354,39 @@ let eta_expand_constructor env ((ind,ctor),u as pctor) = let c = Term.it_mkLambda_or_LetIn c ctx in inject c +let inductive_subst (mind, _) mib u pms = + let open Context.Rel.Declaration in + let ntypes = mib.mind_ntypes in + let rec self i accu = + if Int.equal i ntypes then accu + else self (i + 1) (subs_cons (inject (mkIndU ((mind, i), u))) accu) + in + let accu = self 0 (subs_id 0) in + let rec mk_pms pms ctx = match ctx, pms with + | [], [] -> accu + | LocalAssum _ :: ctx, c :: pms -> + let subs = mk_pms pms ctx in + subs_cons c subs + | LocalDef (_, c, _) :: ctx, pms -> + let c = Vars.subst_instance_constr u c in + let subs = mk_pms pms ctx in + subs_cons (mk_clos subs c) subs + | LocalAssum _ :: _, [] | [], _ :: _ -> assert false + in + mk_pms (List.rev pms) mib.mind_params_ctxt + +let esubst_of_rel_context_instance ctx u args e = + let open Context.Rel.Declaration in + let rec aux lft e args ctx = match ctx with + | [] -> lft, e + | LocalAssum _ :: ctx -> aux (lft + 1) (subs_lift e) (subs_lift args) ctx + | LocalDef (_, c, _) :: ctx -> + let c = Vars.subst_instance_constr u c in + let c = mk_clos args c in + aux lft (subs_cons c e) (subs_cons c args) ctx + in + aux 0 e args (List.rev ctx) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -672,13 +695,23 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if Float64.equal f1 f2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | FCaseInvert (ci1,p1,_,_,br1,e1), FCaseInvert (ci2,p2,_,_,br2,e2) -> + | FCaseInvert (ci1,u1,pms1,p1,_,_,br1,e1), FCaseInvert (ci2,u2,pms2,p2,_,_,br2,e2) -> (if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible); let el1 = el_stack lft1 v1 and el2 = el_stack lft2 v2 in - let ccnv = ccnv CONV l2r infos el1 el2 in - let cuniv = ccnv (mk_clos e1 p1) (mk_clos e2 p2) cuniv in - Array.fold_right2 (fun b1 b2 cuniv -> ccnv (mk_clos e1 b1) (mk_clos e2 b2) cuniv) - br1 br2 cuniv + let fold c1 c2 cuniv = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + (** FIXME: cache the presence of let-bindings in the case_info *) + let mind = Environ.lookup_mind (fst ci1.ci_ind) (info_env infos.cnv_inf) in + let mip = mind.Declarations.mind_packets.(snd ci1.ci_ind) in + let cuniv = + let ind = (mind,snd ci1.ci_ind) in + let nargs = inductive_cumulativity_arguments ind in + convert_inductives CONV ind nargs u1 u2 cuniv + in + let pms1 = Array.map_to_list (fun c -> mk_clos e1 c) pms1 in + let pms2 = Array.map_to_list (fun c -> mk_clos e2 c) pms2 in + let cuniv = List.fold_right2 fold pms1 pms2 cuniv in + let cuniv = convert_return_clause ci1.ci_ind mind mip l2r infos e1 e2 el1 el2 u1 u2 pms1 pms2 p1 p2 cuniv in + convert_branches ci1.ci_ind mind mip l2r infos e1 e2 el1 el2 u1 u2 pms1 pms2 br1 br2 cuniv | FArray (u1,t1,ty1), FArray (u2,t2,ty2) -> let len = Parray.length_int t1 in @@ -714,11 +747,27 @@ and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 - | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> + | (Zlcase(ci1,l1,u1,pms1,p1,br1,e1),Zlcase(ci2,l2,u2,pms2,p2,br2,e2)) -> if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible; - let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in - convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 + let cu = cu1 in + (** FIXME: cache the presence of let-bindings in the case_info *) + let mind = Environ.lookup_mind (fst ci1.ci_ind) (info_env infos.cnv_inf) in + let mip = mind.Declarations.mind_packets.(snd ci1.ci_ind) in + let cu = + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + convert_instances ~flex:false u1 u2 cu + else + match mind.Declarations.mind_variance with + | None -> convert_instances ~flex:false u1 u2 cu + | Some variances -> convert_instances_cumul CONV variances u1 u2 cu + in + let pms1 = Array.map_to_list (fun c -> mk_clos e1 c) pms1 in + let pms2 = Array.map_to_list (fun c -> mk_clos e2 c) pms2 in + let fold_params c1 c2 accu = f (l1, c1) (l2, c2) accu in + let cu = List.fold_right2 fold_params pms1 pms2 cu in + let cu = convert_return_clause ci1.ci_ind mind mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 p1 p2 cu in + convert_branches ci1.ci_ind mind mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 br1 br2 cu | (Zlprimitive(op1,_,rargs1,kargs1),Zlprimitive(op2,_,rargs2,kargs2)) -> if not (CPrimitives.equal op1 op2) then raise NotConvertible else let cu2 = List.fold_right2 f rargs1 rargs2 cu1 in @@ -743,21 +792,55 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible -and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = - (** Skip comparison of the pattern types. We know that the two terms are - living in a common type, thus this check is useless. *) - let fold n c1 c2 cuniv = match skip_pattern infos n c1 c2 with - | (infos, c1, c2) -> - let lft1 = el_liftn n lft1 in - let lft2 = el_liftn n lft2 in +and convert_under_context l2r infos e1 e2 lft1 lft2 ctx (nas1, c1) (nas2, c2) cu = + let n = Array.length nas1 in + let () = assert (Int.equal n (Array.length nas2)) in + let n, e1, e2 = match ctx with + | None -> (* nolet *) let e1 = subs_liftn n e1 in let e2 = subs_liftn n e2 in - ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv - | exception IrregularPatternShape -> - (** Might happen due to a shape invariant that is not enforced *) - ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + (n, e1, e2) + | Some (ctx, u1, u2, args1, args2) -> + let n1, e1 = esubst_of_rel_context_instance ctx u1 args1 e1 in + let n2, e2 = esubst_of_rel_context_instance ctx u2 args2 e2 in + let () = assert (Int.equal n1 n2) in + n1, e1, e2 + in + let lft1 = el_liftn n lft1 in + let lft2 = el_liftn n lft2 in + let infos = push_relevances infos nas1 in + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cu + +and convert_return_clause ind mib mip l2r infos e1 e2 l1 l2 u1 u2 pms1 pms2 p1 p2 cu = + let ctx = + if Int.equal mip.mind_nrealargs mip.mind_nrealdecls then None + else + let ctx, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let pms1 = inductive_subst ind mib u1 pms1 in + let pms2 = inductive_subst ind mib u1 pms2 in + let open Context.Rel.Declaration in + (* Add the inductive binder *) + let dummy = mkProp in + let ctx = LocalAssum (Context.anonR, dummy) :: ctx in + Some (ctx, u1, u2, pms1, pms2) + in + convert_under_context l2r infos e1 e2 l1 l2 ctx p1 p2 cu + +and convert_branches ind mib mip l2r infos e1 e2 lft1 lft2 u1 u2 pms1 pms2 br1 br2 cuniv = + let fold i (ctx, _) cuniv = + let ctx = + if Int.equal mip.mind_consnrealdecls.(i) mip.mind_consnrealargs.(i) then None + else + let ctx, _ = List.chop mip.mind_consnrealdecls.(i) ctx in + let pms1 = inductive_subst ind mib u1 pms1 in + let pms2 = inductive_subst ind mib u2 pms2 in + Some (ctx, u1, u2, pms1, pms2) + in + let c1 = br1.(i) in + let c2 = br2.(i) in + convert_under_context l2r infos e1 e2 lft1 lft2 ctx c1 c2 cuniv in - Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv + Array.fold_right_i fold mip.mind_nf_lc cuniv and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with | [], [] -> cuniv diff --git a/kernel/relevanceops.ml b/kernel/relevanceops.ml index f12b8cba37..986fc685d1 100644 --- a/kernel/relevanceops.ml +++ b/kernel/relevanceops.ml @@ -61,7 +61,7 @@ let rec relevance_of_fterm env extra lft f = | FProj (p, _) -> relevance_of_projection env p | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance - | FCaseT (ci, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _) -> ci.ci_relevance + | FCaseT (ci, _, _, _, _, _, _) | FCaseInvert (ci, _, _, _, _, _, _, _) -> ci.ci_relevance | FLambda (len, tys, bdy, e) -> let extra = List.fold_left (fun accu (x, _) -> Range.cons (binder_relevance x) accu) extra tys in let lft = Esubst.el_liftn len lft in @@ -97,7 +97,7 @@ and relevance_of_term_extra env extra lft subs c = | App (c, _) -> relevance_of_term_extra env extra lft subs c | Const (c,_) -> relevance_of_constant env c | Construct (c,_) -> relevance_of_constructor env c - | Case (ci, _, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> relevance_of_projection env p diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index f7c4b62d1f..505f6c648d 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -35,7 +35,6 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) - retro_refl : constructor option } let empty = { @@ -48,7 +47,6 @@ let empty = { retro_cmp = None; retro_f_cmp = None; retro_f_class = None; - retro_refl = None; } type action = diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index fd412cdd0a..80c0baaf95 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -29,7 +29,6 @@ type retroknowledge = { (* PNormal, NNormal, PSubn, NSubn, PZero, NZero, PInf, NInf, NaN *) - retro_refl : constructor option } val empty : retroknowledge diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 802a32b0e7..741491c917 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -548,22 +548,26 @@ let rec execute env cstr = | Construct c -> cstr, type_of_constructor env c - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> + (** FIXME: change type_of_case to handle the compact form *) + let (ci, p, iv, c, lf) = expand_case env (ci, u, pms, p, iv, c, lf) in let c', ct = execute env c in let iv' = match iv with | NoInvert -> NoInvert - | CaseInvert {univs;args} -> - let ct' = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + let args = Array.append pms indices in + let ct' = mkApp (mkIndU (ci.ci_ind,u), args) in let (ct', _) : constr * Sorts.t = execute_is_type env ct' in let () = conv_leq false env ct ct' in let _, args' = decompose_appvect ct' in - if args == args' then iv else CaseInvert {univs;args=args'} + if args == args' then iv + else CaseInvert {indices=Array.sub args' (Array.length pms) (Array.length indices)} in let p', pt = execute env p in let lf', lft = execute_array env lf in let ci', t = type_of_case env ci p' pt iv' c' ct lf' lft in let cstr = if ci == ci' && c == c' && p == p' && iv == iv' && lf == lf' then cstr - else mkCase(ci',p',iv',c',lf') + else mkCase (Inductive.contract_case env (ci',p',iv',c',lf')) in cstr, t @@ -720,11 +724,6 @@ let judge_of_inductive env indu = let judge_of_constructor env cu = make_judge (mkConstructU cu) (type_of_constructor env cu) -let judge_of_case env ci pj iv cj lfj = - let lf, lft = dest_judgev lfj in - let ci, t = type_of_case env ci pj.uj_val pj.uj_type iv cj.uj_val cj.uj_type lf lft in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, iv, cj.uj_val, lft)) t - (* Building type of primitive operators and type *) let type_of_prim_const env _u c = diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d381e55dd6..5ea7163f72 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -92,12 +92,6 @@ val judge_of_cast : val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment -(** {6 Type of Cases. } *) -val judge_of_case : env -> case_info - -> unsafe_judgment -> (constr,Instance.t) case_invert -> unsafe_judgment - -> unsafe_judgment array - -> unsafe_judgment - (** {6 Type of global references. } *) val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 096e458ec4..b988ec40a7 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -222,15 +222,35 @@ let choose p g u = if Level.is_sprop u then if p u then Some u else None else G.choose p g.graph u -let dump_universes f g = G.dump f g.graph - let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g.graph -let pr_universes prl g = G.pr prl g.graph - -let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] -let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) -let sort_universes g = g_map (G.sort make_dummy [Level.prop;Level.set]) g +(** Pretty-printing *) + +let pr_pmap sep pr map = + let cmp (u,_) (v,_) = Level.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (LMap.bindings map)) + +let pr_arc prl = let open Pp in + function + | u, G.Node ltle -> + if LMap.is_empty ltle then mt () + else + prl u ++ str " " ++ + v 0 + (pr_pmap spc (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + ltle) ++ + fnl () + | u, G.Alias v -> + prl u ++ str " = " ++ prl v ++ fnl () + +type node = G.node = +| Alias of Level.t +| Node of bool LMap.t + +let repr g = G.repr g.graph + +let pr_universes prl g = pr_pmap Pp.mt (pr_arc prl) g (** Profiling *) diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 87b3634e28..9ac29f5139 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -77,15 +77,9 @@ exception UndeclaredLevel of Univ.Level.t val check_declared_universes : t -> Univ.LSet.t -> unit -(** {6 Pretty-printing of universes. } *) - -val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t - (** The empty graph of universes *) val empty_universes : t -val sort_universes : t -> t - (** [constraints_of_universes g] returns [csts] and [partition] where [csts] are the non-Eq constraints and [partition] is the partition of the universes into equivalence classes. *) @@ -108,10 +102,17 @@ val check_subtype : lbound:Bound.t -> AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) -(** {6 Dumping to a file } *) +(** {6 Dumping} *) + +type node = +| Alias of Level.t +| Node of bool LMap.t (** Nodes v s.t. u < v (true) or u <= v (false) *) + +val repr : t -> node LMap.t + +(** {6 Pretty-printing of universes. } *) -val dump_universes : - (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit +val pr_universes : (Level.t -> Pp.t) -> node LMap.t -> Pp.t (** {6 Debugging} *) val check_universes_invariants : t -> unit diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index 988611df3e..4f2cbc4262 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -206,9 +206,7 @@ let () = Callback.register "uint63 leq" le; Callback.register "uint63 lor" l_or; Callback.register "uint63 lsl" l_sl; - Callback.register "uint63 lsl1" (fun x -> l_sl x Int64.one); Callback.register "uint63 lsr" l_sr; - Callback.register "uint63 lsr1" (fun x -> l_sr x Int64.one); Callback.register "uint63 lt" lt; Callback.register "uint63 lxor" l_xor; Callback.register "uint63 mod" rem; diff --git a/kernel/vars.ml b/kernel/vars.ml index a446fa413c..b09577d4db 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -253,12 +253,20 @@ let subst_univs_level_constr subst c = if u' == u then t else (changed := true; mkSort (Sorts.sort_of_univ u')) - | Case (ci,p,CaseInvert {univs;args},c,br) -> - if Univ.Instance.is_empty univs then Constr.map aux t + | Case (ci, u, pms, p, CaseInvert {indices}, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t else - let univs' = f univs in - if univs' == univs then Constr.map aux t - else (changed:=true; Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br))) + let u' = f u in + if u' == u then Constr.map aux t + else (changed:=true; Constr.map aux (mkCase (ci,u',pms,p,CaseInvert {indices},c,br))) + + | Case (ci, u, pms, p, NoInvert, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t + else + let u' = f u in + if u' == u then Constr.map aux t + else + (changed := true; Constr.map aux (mkCase (ci, u', pms, p, NoInvert, c, br))) | Array (u,elems,def,ty) -> let u' = f u in @@ -305,10 +313,18 @@ let subst_instance_constr subst c = if u' == u then t else (mkSort (Sorts.sort_of_univ u')) - | Case (ci,p,CaseInvert {univs;args},c,br) -> - let univs' = f univs in - if univs' == univs then Constr.map aux t - else Constr.map aux (mkCase (ci,p,CaseInvert {univs=univs';args},c,br)) + | Case (ci, u, pms, p, CaseInvert {indices}, c, br) -> + let u' = f u in + if u' == u then Constr.map aux t + else Constr.map aux (mkCase (ci,u',pms,p,CaseInvert {indices},c,br)) + + | Case (ci, u, pms, p, NoInvert, c, br) -> + if Univ.Instance.is_empty u then Constr.map aux t + else + let u' = f u in + if u' == u then Constr.map aux t + else + Constr.map aux (mkCase (ci, u', pms, p, NoInvert, c, br)) | Array (u,elems,def,ty) -> let u' = f u in @@ -348,8 +364,8 @@ let universes_of_constr c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c - | Case (_,_,CaseInvert {univs;args=_},_,_) -> - let s = LSet.fold LSet.add (Instance.levels univs) s in + | Case (_, u, _, _, _,_ ,_) -> + let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c | _ -> Constr.fold aux s c in aux LSet.empty c diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index 4977aec00a..c2b087f061 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -49,7 +49,6 @@ type instruction = | Kgetglobal of Constant.t | Kconst of structured_constant | Kmakeblock of int * tag - | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array | Kpushfields of int @@ -123,7 +122,6 @@ let rec pp_instr i = str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> str "makeblock " ++ int n ++ str ", " ++ int m - | Kmakeprod -> str "makeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ pp_lbl lbls ++ str ", " ++ int sz diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index 003a77ab78..eeca0d2ad1 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -47,7 +47,6 @@ type instruction = | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from ** the top of the stack *) - | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) | Kpushfields of int diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 70c92fd8f0..20de4bc81b 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -569,7 +569,7 @@ let rec compile_lam env cenv lam sz cont = | Lprod (dom,codom) -> let cont1 = - Kpush :: compile_lam env cenv dom (sz+1) (Kmakeprod :: cont) in + Kpush :: compile_lam env cenv dom (sz+1) (Kmakeblock (2,0) :: cont) in compile_lam env cenv codom sz cont1 | Llam (ids,body) -> diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index c1d8fcb855..d3af8bf09b 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -135,6 +135,16 @@ let out env opcode = let is_immed i = Uint63.le (Uint63.of_int i) Uint63.maxuint31 +(* Detect whether the current value of the accu register is no longer + needed (i.e., the register is written before being read). If so, the + register can be used freely; no need to save and restore it. *) +let is_accu_dead = function + | [] -> false + | c :: _ -> + match c with + | Kacc _ | Kenvacc _ | Kconst _ | Koffsetclosure _ | Kgetglobal _ -> true + | _ -> false + let out_int env n = out_word env n (n asr 8) (n asr 16) (n asr 24) @@ -327,8 +337,6 @@ let emit_instr env = function if Int.equal n 0 then invalid_arg "emit_instr : block size = 0" else if n < 4 then (out env(opMAKEBLOCK1 + n - 1); out_int env t) else (out env opMAKEBLOCK; out_int env n; out_int env t) - | Kmakeprod -> - out env opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> out env opMAKESWITCHBLOCK; out_label env typlbl; out_label env swlbl; @@ -349,8 +357,7 @@ let emit_instr env = function if n <= 1 then out env (opGETFIELD0+n) else (out env opGETFIELD;out_int env n) | Ksetfield n -> - if n <= 1 then out env (opSETFIELD0+n) - else (out env opSETFIELD;out_int env n) + out env opSETFIELD; out_int env n | Ksequence _ -> invalid_arg "Vmemitcodes.emit_instr" | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size @@ -375,7 +382,9 @@ let rec emit env insns remaining = match insns with | (first::rest) -> emit env first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> - if n < 8 then out env(opPUSHACC0 + n) else (out env opPUSHACC; out_int env n); + if n = 0 then out env opPUSH + else if n < 8 then out env (opPUSHACC1 + n - 1) + else (out env opPUSHACC; out_int env n); emit env c remaining | Kpush :: Kenvacc n :: c -> if n >= 0 && n <= 3 @@ -397,6 +406,9 @@ let rec emit env insns remaining = match insns with | Kpush :: Kconst const :: c -> out env opPUSHGETGLOBAL; slot_for_const env const; emit env c remaining + | Kpushfields 1 :: c when is_accu_dead c -> + out env opGETFIELD0; + emit env (Kpush :: c) remaining | Kpop n :: Kjump :: c -> out env opRETURN; out_int env n; emit env c remaining | Ksequence c1 :: c -> diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 390fa58883..91de58b0e6 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -674,7 +674,8 @@ let rec lambda_of_constr env c = | Construct _ -> lambda_of_app env c empty_args - | Case(ci,t,_iv,a,branches) -> (* XXX handle iv *) + | Case (ci, u, pms, t, iv, a, br) -> (* XXX handle iv *) + let (ci, t, _iv, a, branches) = Inductive.expand_case env.global_env (ci, u, pms, t, iv, a, br) in let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env.global_env in let oib = mib.mind_packets.(snd ind) in diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml index 8da09dc98a..17299c72eb 100644 --- a/lib/acyclicGraph.ml +++ b/lib/acyclicGraph.ml @@ -58,15 +58,59 @@ module Make (Point:Point) = struct *) - module PMap = Point.Map - module PSet = Point.Set + module Index : + sig + type t + val equal : t -> t -> bool + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + type table + val empty : table + val fresh : Point.t -> table -> t * table + val mem : Point.t -> table -> bool + val find : Point.t -> table -> t + val repr : t -> table -> Point.t + end = + struct + type t = int + let equal = Int.equal + module Set = Int.Set + module Map = Int.Map + + type table = { + tab_len : int; + tab_fwd : Point.t Int.Map.t; + tab_bwd : int Point.Map.t + } + + let empty = { + tab_len = 0; + tab_fwd = Int.Map.empty; + tab_bwd = Point.Map.empty; + } + let mem x t = Point.Map.mem x t.tab_bwd + let find x t = Point.Map.find x t.tab_bwd + let repr n t = Int.Map.find n t.tab_fwd + + let fresh x t = + let () = assert (not @@ mem x t) in + let n = t.tab_len in + n, { + tab_len = n + 1; + tab_fwd = Int.Map.add n x t.tab_fwd; + tab_bwd = Point.Map.add x n t.tab_bwd; + } + end + + module PMap = Index.Map + module PSet = Index.Set module Constraint = Point.Constraint type status = NoMark | Visited | WeakVisited | ToMerge (* Comparison on this type is pointer equality *) type canonical_node = - { canon: Point.t; + { canon: Index.t; ltle: bool PMap.t; (* true: strict (lt) constraint. false: weak (le) constraint. *) gtge: PSet.t; @@ -76,19 +120,18 @@ module Make (Point:Point) = struct mutable status: status } - let big_rank = 1000000 - (* A Point.t is either an alias for another one, or a canonical one, for which we know the points that are above *) type entry = | Canonical of canonical_node - | Equiv of Point.t + | Equiv of Index.t type t = { entries : entry PMap.t; index : int; - n_nodes : int; n_edges : int } + n_nodes : int; n_edges : int; + table : Index.table } (** Used to cleanup mutable marks if a traversal function is interrupted before it has the opportunity to do it itself. *) @@ -123,7 +166,8 @@ module Make (Point:Point) = struct | _ -> assert false) g.entries; index = g.index; n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } + n_edges = g.n_edges; + table = g.table } (* Low-level function : changes data associated with a canonical node. Resets the mutable fields in the old record, in order to avoid breaking @@ -147,7 +191,10 @@ module Make (Point:Point) = struct | Canonical arc -> arc | exception Not_found -> CErrors.anomaly ~label:"Univ.repr" - Pp.(str"Universe " ++ Point.pr u ++ str" undefined.") + Pp.(str"Universe " ++ Point.pr (Index.repr u g.table) ++ str" undefined.") + + let repr_node g u = + repr g (Index.find u g.table) exception AlreadyDeclared @@ -158,30 +205,6 @@ module Make (Point:Point) = struct assert (g.index > min_int); { g with index = g.index - 1 } - (* [safe_repr] is like [repr] but if the graph doesn't contain the - searched point, we add it. *) - let safe_repr g u = - let rec safe_repr_rec entries u = - match PMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { canon = u; - ltle = PMap.empty; gtge = PSet.empty; - rank = 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = PMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - (* Returns 1 if u is higher than v in topological order. -1 lower 0 if u = v *) @@ -194,6 +217,7 @@ module Make (Point:Point) = struct (* Checks most of the invariants of the graph. For debugging purposes. *) let check_invariants ~required_canonical g = + let required_canonical u = required_canonical (Index.repr u g.table) in let n_edges = ref 0 in let n_nodes = ref 0 in PMap.iter (fun l u -> @@ -214,7 +238,7 @@ module Make (Point:Point) = struct PMap.exists (fun l _ -> u == repr g l) v.ltle)) ) u.gtge; assert (u.status = NoMark); - assert (Point.equal l u.canon); + assert (Index.equal l u.canon); assert (u.ilvl > g.index); assert (not (PMap.mem u.canon u.ltle)); incr n_nodes @@ -226,7 +250,7 @@ module Make (Point:Point) = struct let clean_ltle g ltle = PMap.fold (fun u strict acc -> let uu = (repr g u).canon in - if Point.equal uu u then acc + if Index.equal uu u then acc else ( let acc = PMap.remove u (fst acc) in if not strict && PMap.mem uu acc then (acc, true) @@ -236,7 +260,7 @@ module Make (Point:Point) = struct let clean_gtge g gtge = PSet.fold (fun u acc -> let uu = (repr g u).canon in - if Point.equal uu u then acc + if Index.equal uu u then acc else PSet.add uu (PSet.remove u (fst acc)), true) gtge (gtge, false) @@ -340,7 +364,7 @@ module Make (Point:Point) = struct | Visited -> false, to_revert | ToMerge -> true, to_revert | NoMark -> let to_revert = x::to_revert in - if Point.equal x.canon v then + if Index.equal x.canon v then begin x.status <- ToMerge; true, to_revert end else begin @@ -451,7 +475,7 @@ module Make (Point:Point) = struct (* Inserting shortcuts for old nodes. *) let g = List.fold_left (fun g n -> - if Point.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) + if Index.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) g to_merge in @@ -507,11 +531,10 @@ module Make (Point:Point) = struct raise e let add ?(rank=0) v g = - try - let _arcv = PMap.find v g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); + if Index.mem v g.table then raise AlreadyDeclared + else + let () = assert (g.index > min_int) in + let v, table = Index.fresh v g.table in let node = { canon = v; ltle = PMap.empty; @@ -523,17 +546,18 @@ module Make (Point:Point) = struct } in let entries = PMap.add v (Canonical node) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges; table } exception Undeclared of Point.t let check_declared g us = - let check l = if not (PMap.mem l g.entries) then raise (Undeclared l) in - PSet.iter check us + let check l = if not (Index.mem l g.table) then raise (Undeclared l) in + Point.Set.iter check us exception Found_explanation of (constraint_type * Point.t) list let get_explanation strict u v g = - let v = repr g v in + let u = Index.find u g.table in + let v = repr_node g v in let visited_strict = ref PMap.empty in let rec traverse strict u = if u == v then @@ -553,6 +577,7 @@ module Make (Point:Point) = struct | None -> () | Some exp -> let typ = if strictu' then Lt else Le in + let u' = Index.repr u' g.table in raise (Found_explanation ((typ, u') :: exp))) u.ltle; None @@ -560,7 +585,7 @@ module Make (Point:Point) = struct end in let u = repr g u in - if u == v then [(Eq, v.canon)] + if u == v then [(Eq, Index.repr v.canon g.table)] else match traverse strict u with Some exp -> exp | None -> assert false let get_explanation strict u v g = @@ -634,21 +659,27 @@ module Make (Point:Point) = struct let check_eq g u v = u == v || - let arcu = repr g u and arcv = repr g v in + let arcu = repr_node g u and arcv = repr_node g v in arcu == arcv let check_smaller g strict u v = - search_path strict (repr g u) (repr g v) g + search_path strict (repr_node g u) (repr_node g v) g let check_leq g u v = check_smaller g false u v let check_lt g u v = check_smaller g true u v (* enforce_eq g u v will force u=v if possible, will fail otherwise *) - let rec enforce_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_eq v u g + let enforce_eq u v g = + let ucan = repr_node g u in + let vcan = repr_node g v in + if ucan == vcan then g + else if topo_compare ucan vcan = 1 then + let ucan = vcan and vcan = ucan in + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + Point.error_inconsistency Eq v u (get_explanation true v u g) else let g = insert_edge false ucan vcan g in (* Cannot fail *) try insert_edge false vcan ucan g @@ -657,58 +688,40 @@ module Make (Point:Point) = struct (* enforce_leq g u v will force u<=v if possible, will fail otherwise *) let enforce_leq u v g = - let ucan = repr g u in - let vcan = repr g v in + let ucan = repr_node g u in + let vcan = repr_node g v in try insert_edge false ucan vcan g with CycleDetected -> Point.error_inconsistency Le u v (get_explanation true v u g) (* enforce_lt u v will force u<v if possible, will fail otherwise *) let enforce_lt u v g = - let ucan = repr g u in - let vcan = repr g v in + let ucan = repr_node g u in + let vcan = repr_node g v in try insert_edge true ucan vcan g with CycleDetected -> Point.error_inconsistency Lt u v (get_explanation false v u g) let empty = - { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0; table = Index.empty } (* Normalization *) - (** [normalize g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) - let normalize g = - let g = - { g with - entries = PMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).canon) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - PMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - let constraints_of g = - let module UF = Unionfind.Make (PSet) (PMap) in + let module UF = Unionfind.Make (Point.Set) (Point.Map) in let uf = UF.create () in let constraints_of u v acc = match v with | Canonical {canon=u; ltle; _} -> PMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in + let u = Index.repr u g.table in + let v = Index.repr v g.table in Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc + | Equiv v -> + let u = Index.repr u g.table in + let v = Index.repr v g.table in + UF.union u v uf; acc in let csts = PMap.fold constraints_of g.entries Constraint.empty in csts, UF.partition uf @@ -716,16 +729,20 @@ module Make (Point:Point) = struct (* domain g.entries = kept + removed *) let constraints_for ~kept g = (* rmap: partial map from canonical points to kept points *) + let add_cst u knd v cst = + Constraint.add (Index.repr u g.table, knd, Index.repr v g.table) cst + in + let kept = Point.Set.fold (fun u accu -> PSet.add (Index.find u g.table) accu) kept PSet.empty in let rmap, csts = PSet.fold (fun u (rmap,csts) -> let arcu = repr g u in if PSet.mem arcu.canon kept then - let csts = if Point.equal u arcu.canon then csts - else Constraint.add (u,Eq,arcu.canon) csts + let csts = if Index.equal u arcu.canon then csts + else add_cst u Eq arcu.canon csts in PMap.add arcu.canon arcu.canon rmap, csts else match PMap.find arcu.canon rmap with - | v -> rmap, Constraint.add (u,Eq,v) csts + | v -> rmap, add_cst u Eq v csts | exception Not_found -> PMap.add arcu.canon u rmap, csts) kept (PMap.empty,Constraint.empty) in @@ -736,7 +753,7 @@ module Make (Point:Point) = struct (match PMap.find v.canon rmap with | v -> let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in + let csts = add_cst u d v csts in add_from u csts todo | exception Not_found -> (* v is not equal to any kept point *) @@ -752,102 +769,42 @@ module Make (Point:Point) = struct arc.ltle csts) kept csts - let domain g = PMap.domain g.entries + let domain g = + let fold u _ accu = Point.Set.add (Index.repr u g.table) accu in + PMap.fold fold g.entries Point.Set.empty let choose p g u = let exception Found of Point.t in - let ru = (repr g u).canon in - if p ru then Some ru + let ru = (repr_node g u).canon in + let ruv = Index.repr ru g.table in + if p ruv then Some ruv else try PMap.iter (fun v -> function | Canonical _ -> () (* we already tried [p ru] *) | Equiv v' -> let rv = (repr g v').canon in - if rv == ru && p v then raise (Found v) + if rv == ru then + let v = Index.repr v g.table in + if p v then raise (Found v) (* NB: we could also try [p v'] but it will come up in the rest of the iteration regardless. *) ) g.entries; None with Found v -> Some v - let sort make_dummy first g = - let cans = - PMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest = - PMap.mapi (fun u _ -> if CList.mem_f Point.equal u first then 0 else 2) - (PMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest = - List.fold_left (fun lowest can -> - let lvl = PMap.find can.canon lowest in - PMap.fold (fun u' strict lowest -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').canon in - PMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest) - can.ltle lowest) - lowest cans - in - let max_lvl = PMap.fold (fun _ a b -> max a b) lowest 0 in - let types = Array.init (max_lvl + 1) (fun i -> - match List.nth_opt first i with - | Some u -> u - | None -> make_dummy (i-2)) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl > List.length first && not (CList.is_empty first) then - enforce_lt (CList.last first) types.(List.length first) g - else g - in - let g = - PMap.fold (fun u lvl g -> enforce_eq u (types.(lvl)) g) - lowest g - in - normalize g - - (** Pretty-printing *) - - let pr_pmap sep pr map = - let cmp (u,_) (v,_) = Point.compare u v in - Pp.prlist_with_sep sep pr (List.sort cmp (PMap.bindings map)) - - let pr_arc prl = let open Pp in - function - | _, Canonical {canon=u; ltle; _} -> - if PMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_pmap spc (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - ltle) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - - let pr prl g = - pr_pmap Pp.mt (pr_arc prl) g.entries - - (* Dumping constraints to a file *) - - let dump output g = - let dump_arc u = function - | Canonical {canon=u; ltle; _} -> - PMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u v) ltle; - | Equiv v -> - output Eq u v + type node = Alias of Point.t | Node of bool Point.Map.t + type repr = node Point.Map.t + + let repr g = + let fold u n accu = + let n = match n with + | Canonical n -> + let fold u lt accu = Point.Map.add (Index.repr u g.table) lt accu in + let ltle = PMap.fold fold n.ltle Point.Map.empty in + Node ltle + | Equiv u -> Alias (Index.repr u g.table) + in + Point.Map.add (Index.repr u g.table) n accu in - PMap.iter dump_arc g.entries + PMap.fold fold g.entries Point.Map.empty end diff --git a/lib/acyclicGraph.mli b/lib/acyclicGraph.mli index e9f05ed74d..8c9d2e6461 100644 --- a/lib/acyclicGraph.mli +++ b/lib/acyclicGraph.mli @@ -65,18 +65,12 @@ module Make (Point:Point) : sig val choose : (Point.t -> bool) -> t -> Point.t -> Point.t option - val sort : (int -> Point.t) -> Point.t list -> t -> t - (** [sort mk first g] builds a totally ordered graph. The output - graph should imply the input graph (and the implication will be - strict most of the time), but is not necessarily minimal. The - lowest points in the result are identified with [first]. - Moreover, it adds levels [Type.n] to identify the points (not in - [first]) at level n. An artificial constraint (last first < mk - (length first)) is added to ensure that they are not merged. - Note: the result is unspecified if the input graph already - contains [mk n] nodes. *) - - val pr : (Point.t -> Pp.t) -> t -> Pp.t - - val dump : (constraint_type -> Point.t -> Point.t -> unit) -> t -> unit + (** {5 High-level representation} *) + + type node = + | Alias of Point.t + | Node of bool Point.Map.t (** Nodes v s.t. u < v (true) or u <= v (false) *) + type repr = node Point.Map.t + val repr : t -> repr + end diff --git a/lib/cDebug.ml b/lib/cDebug.ml new file mode 100644 index 0000000000..efa7365b91 --- /dev/null +++ b/lib/cDebug.ml @@ -0,0 +1,92 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type flag = bool ref + +type t = (unit -> Pp.t) -> unit + +let debug = ref CString.Map.empty + +(* Used to remember level of Set Debug "all" for debugs created by + plugins dynlinked after the Set *) +let all_flag = ref false + +let set_debug_backtrace b = + Exninfo.record_backtrace b + +let set_debug_all b = + set_debug_backtrace b; + CString.Map.iter (fun _ flag -> flag := b) !debug; + all_flag := b + +let create_full ~name () = + let anomaly pp = CErrors.anomaly ~label:"CDebug.create" pp in + let () = match name with + | "all"|"backtrace" -> anomaly Pp.(str"The debug name \""++str name++str"\" is reserved.") + | _ -> + if CString.Map.mem name !debug then + anomaly Pp.(str "The debug name \"" ++ str name ++ str "\" is already used.") + in + let pp x = + Feedback.msg_debug Pp.(str "[" ++ str name ++ str "] " ++ x) + in + let flag = ref !all_flag in + debug := CString.Map.add name flag !debug; + let pp x = + if !flag + then pp (x ()) + in + flag, pp + +let create ~name () = + snd (create_full ~name ()) + +let get_flag flag = !flag + +let warn_unknown_debug = CWarnings.create ~name:"unknown-debug-flag" ~category:"option" + Pp.(fun name -> str "There is no debug flag \"" ++ str name ++ str "\".") + +let get_flags () = + let pp_flag name flag = if flag then name else "-"^name in + let flags = + CString.Map.fold + (fun name v acc -> pp_flag name !v :: acc) + !debug [] + in + let all = pp_flag "all" !all_flag in + let bt = pp_flag "backtrace" (Printexc.backtrace_status()) in + String.concat "," (all::bt::flags) + +exception Error + +let parse_flags s = + let parse_flag s = + if CString.is_empty s then raise Error + else if s.[0] = '-' + then String.sub s 1 (String.length s - 1), false + else s, true + in + try + Some (CList.map parse_flag @@ String.split_on_char ',' s) + with Error -> None + +let set_flags s = match parse_flags s with + | None -> CErrors.user_err Pp.(str "Syntax error in debug flags.") + | Some flags -> + let set_one_flag (name,b) = match name with + | "all" -> set_debug_all b + | "backtrace" -> set_debug_backtrace b + | _ -> match CString.Map.find_opt name !debug with + | None -> warn_unknown_debug name + | Some flag -> flag := b + in + List.iter set_one_flag flags + +let misc, pp_misc = create_full ~name:"misc" () diff --git a/lib/cDebug.mli b/lib/cDebug.mli new file mode 100644 index 0000000000..846c4b493b --- /dev/null +++ b/lib/cDebug.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type flag + +type t = (unit -> Pp.t) -> unit + +(** Creates a debug component, which may be used to print debug + messages. + + A debug component is named by the string [name]. It is either + active or inactive. + + The special component ["all"] may be used to control all components. + + There is also a special component ["backtrace"] to control + backtrace recording. +*) +val create : name:string -> unit -> t + +(** Useful when interacting with a component from code, typically when + doing something more complicated than printing. + + Note that the printer function prints some metadata compared to + [ fun pp -> if get_flag flag then Feedback.msg_debug (pp ()) ] + *) +val create_full : name:string -> unit -> flag * t + +val get_flag : flag -> bool + +(** [get_flags] and [set_flags] use the user syntax: a comma separated + list of activated "component" and "-component"s. [get_flags] starts + with "all" or "-all" and lists all components after it (even if redundant). *) +val get_flags : unit -> string + +(** Components not mentioned are not affected (use the "all" component + at the start if you want to reset everything). *) +val set_flags : string -> unit + +val set_debug_all : bool -> unit + +val misc : flag +val pp_misc : t diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 760c07783b..1baedb64c9 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -30,6 +30,7 @@ let anomaly ?loc ?info ?label pp = let info = Option.cata (Loc.add_loc info) info loc in Exninfo.iraise (Anomaly (label, pp), info) +(* TODO remove the option *) exception UserError of string option * Pp.t (* User errors *) let user_err ?loc ?info ?hdr strm = @@ -46,7 +47,7 @@ exception Timeout = Control.Timeout let where = function | None -> mt () | Some s -> - if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () + str "in " ++ str s ++ str ":" ++ spc () let raw_anomaly e = match e with | Anomaly (s, pps) -> @@ -133,7 +134,7 @@ let print_no_report e = iprint_no_report (e, Exninfo.info e) let _ = register_handler begin function | UserError(s, pps) -> - Some (where s ++ pps) + Some pps | _ -> None end diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index cc1fa647f9..ee7dab92bc 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -173,3 +173,9 @@ let create ~name ~category ?(default=Enabled) pp = | Disabled -> () | AsError -> CErrors.user_err ?loc (pp x) | Enabled -> Feedback.msg_warning ?loc (pp x) + +(* Remark: [warn] does not need to start with a comma, but if present + it won't hurt (",," is normalized into ","). *) +let with_warn warn (f:'b -> 'a) x = + let s = get_flags () in + Util.try_finally (fun x -> set_flags (s^","^warn);f x) x set_flags s diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index ded1f9be3b..b63eed09d0 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -19,3 +19,10 @@ val set_flags : string -> unit (** Cleans up a user provided warnings status string, e.g. removing unknown warnings (in which case a warning is emitted) or subsumed warnings . *) val normalize_flags_string : string -> string + +(** [with_warn "-xxx,+yyy..." f x] calls [f x] after setting the + warnings as specified in the string (keeping other previously set + warnings), and restores current warnings after [f()] returns or + raises an exception. If both f and restoring the warnings raise + exceptions, the latter is raised. *) +val with_warn: string -> ('b -> 'a) -> 'b -> 'a diff --git a/lib/control.ml b/lib/control.ml index 7da95ff3dd..ea94bda064 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -30,11 +30,12 @@ let check_for_interrupt () = (** This function does not work on windows, sigh... *) let unix_timeout n f x = + let open Unix in let timeout_handler _ = raise Timeout in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in - let _ = Unix.alarm n in + let _ = setitimer ITIMER_REAL {it_interval = 0.; it_value = n} in let restore_timeout () = - let _ = Unix.alarm 0 in + let _ = setitimer ITIMER_REAL { it_interval = 0.; it_value = 0. } in Sys.set_signal Sys.sigalrm psh in try @@ -52,7 +53,7 @@ let windows_timeout n f x = let thread init = while not !killed do let cur = Unix.gettimeofday () in - if float_of_int n <= cur -. init then begin + if n <= cur -. init then begin interrupt := true; exited := true; Thread.exit () @@ -68,7 +69,7 @@ let windows_timeout n f x = let cur = Unix.gettimeofday () in (* The thread did not interrupt, but the computation took longer than expected. *) - let () = if float_of_int n <= cur -. init then begin + let () = if n <= cur -. init then begin exited := true; raise Sys.Break end in @@ -83,7 +84,7 @@ let windows_timeout n f x = let () = killed := true in Exninfo.iraise e -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } +type timeout = { timeout : 'a 'b. float -> ('a -> 'b) -> 'a -> 'b option } let timeout_fun = match Sys.os_type with | "Unix" | "Cygwin" -> { timeout = unix_timeout } diff --git a/lib/control.mli b/lib/control.mli index 9465d8f0d5..f992d8e8d0 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -24,13 +24,13 @@ val check_for_interrupt : unit -> unit (** Use this function as a potential yield function. If {!interrupt} has been set, il will raise [Sys.Break]. *) -val timeout : int -> ('a -> 'b) -> 'a -> 'b option +val timeout : float -> ('a -> 'b) -> 'a -> 'b option (** [timeout n f x] tries to compute [Some (f x)], and if it fails to do so before [n] seconds, returns [None] instead. *) (** Set a particular timeout function; warning, this is an internal API and it is scheduled to go away. *) -type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> 'b option } +type timeout = { timeout : 'a 'b. float -> ('a -> 'b) -> 'a -> 'b option } val set_timeout : timeout -> unit (** [protect_sigalrm f x] computes [f x], but if SIGALRM is received during that diff --git a/lib/flags.ml b/lib/flags.ml index 83733cf00d..57e879add7 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -46,7 +46,6 @@ let async_proofs_is_worker () = !async_proofs_worker_id <> "master" let load_vos_libraries = ref false -let debug = ref false let xml_debug = ref false let in_debugger = ref false diff --git a/lib/flags.mli b/lib/flags.mli index ebd23a4d20..e10e2c8cb8 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -40,7 +40,6 @@ val async_proofs_is_worker : unit -> bool val load_vos_libraries : bool ref (** Debug flags *) -val debug : bool ref val xml_debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref diff --git a/lib/lib.mllib b/lib/lib.mllib index 4e08e87084..bbc9966498 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -10,6 +10,7 @@ Loc Feedback CErrors CWarnings +CDebug AcyclicGraph Rtree diff --git a/lib/pp.mli b/lib/pp.mli index 12f1ba9bb2..b3c2301d34 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -10,30 +10,31 @@ (** Coq document type. *) -(** Pretty printing guidelines ******************************************) -(* *) -(* `Pp.t` is the main pretty printing document type *) -(* in the Coq system. Documents are composed laying out boxes, and *) -(* users can add arbitrary tag metadata that backends are free *) -(* to interpret. *) -(* *) -(* The datatype has a public view to allow serialization or advanced *) -(* uses, however regular users are _strongly_ warned against its use, *) -(* they should instead rely on the available functions below. *) -(* *) -(* Box order and number is indeed an important factor. Try to create *) -(* a proper amount of boxes. The `++` operator provides "efficient" *) -(* concatenation, but using the list constructors is usually preferred. *) -(* *) -(* That is to say, this: *) -(* *) -(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) -(* *) -(* is preferred to: *) -(* *) -(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) -(* *) -(************************************************************************) +(** +{4 Pretty printing guidelines} + +[Pp.t] is the main pretty printing document type +in the Coq system. Documents are composed laying out boxes, and +users can add arbitrary tag metadata that backends are free +to interpret. + +The datatype has a public view to allow serialization or advanced +uses, however regular users are _strongly_ warned against its use, +they should instead rely on the available functions below. + +Box order and number is indeed an important factor. Try to create +a proper amount of boxes. The [++] operator provides "efficient" +concatenation, but using the list constructors is usually preferred. + +That is to say, this: + +[hov [str "Term"; hov (pr_term t); str "is defined"]] + +is preferred to: + +[hov (str "Term" ++ hov (pr_term t) ++ str "is defined")] +*) + (* XXX: Improve and add attributes *) type pp_tag = string diff --git a/lib/spawn.ml b/lib/spawn.ml index 2fe7b31d04..27b4387b61 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -13,7 +13,7 @@ let prefer_sock = Sys.os_type = "Win32" let accept_timeout = 10.0 let pr_err s = Printf.eprintf "(Spawn ,%d) %s\n%!" (Unix.getpid ()) s -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if CDebug.(get_flag misc) then begin pr_err s end else () type req = ReqDie | Hello of int * int diff --git a/lib/stateid.ml b/lib/stateid.ml index a1328f156c..2a41cb7866 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -45,3 +45,6 @@ type ('a,'b) request = { name : string } +let is_valid_ref = ref (fun ~doc:_ (_ : t) -> true) +let is_valid ~doc id = !is_valid_ref ~doc id +let set_is_valid f = is_valid_ref := f diff --git a/lib/stateid.mli b/lib/stateid.mli index 9b2de9c894..00acc962a2 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -42,3 +42,10 @@ type ('a,'b) request = { name : string } +(* Asks the document manager if the given state is valid (or belongs to an + old version of the document) *) +val is_valid : doc:int -> t -> bool + +(* By default [is_valid] always answers true, but a document manager supporting + undo operations like the STM can override this. *) +val set_is_valid : (doc:int -> t -> bool) -> unit diff --git a/lib/util.ml b/lib/util.ml index 87cc30e557..e8aa0f3e48 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -135,6 +135,13 @@ type 'a delayed = unit -> 'a let delayed_force f = f () +(* finalize - Credit X.Leroy, D.Remy. *) +let try_finally f x finally y = + let res = try f x with exn -> finally y; raise exn in + finally y; + res + + (* Misc *) type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b diff --git a/lib/util.mli b/lib/util.mli index fe34525671..aefb015c38 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -112,6 +112,15 @@ type 'a delayed = unit -> 'a val delayed_force : 'a delayed -> 'a +(** [try_finally f x g y] applies the main code [f] to [x] and + returns the result after having applied the finalization + code [g] to [y]. If the main code raises the exception + [exn], the finalization code is executed and [exn] is raised. + If the finalization code itself fails, the exception + returned is always the one from the finalization code. + Credit X.Leroy, D.Remy. *) +val try_finally: ('a -> 'b) -> 'a -> ('c -> unit) -> 'c -> 'b + (** {6 Enriched exceptions} *) type iexn = Exninfo.iexn diff --git a/library/nametab.ml b/library/nametab.ml index e94b696b60..bd96446f1c 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -574,7 +574,7 @@ let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as exn -> let exn, info = Exninfo.capture exn in - if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); + if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str "pr_global_env not found"); Exninfo.iraise (exn, info) let global_inductive qid = diff --git a/library/summary.ml b/library/summary.ml index 221ac868fa..572467ada3 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -131,28 +131,27 @@ let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x module Local = struct -type 'a local_ref = ('a CEphemeron.key * 'a Dyn.tag) ref +type 'a local_ref = 'a CEphemeron.key ref * 'a CEphemeron.key Dyn.tag -let set r v = r := (CEphemeron.create v, snd !r) +let set (r, tag) v = r := CEphemeron.create v -let get r = - let key, name = !r in - try CEphemeron.get key +let get (key, name) = + try CEphemeron.get !key with CEphemeron.InvalidKey -> let { init_function } = DynMap.find name !sum_map in init_function (); - CEphemeron.get (fst !r) + CEphemeron.get !key -let ref ?(freeze=fun x -> x) ~name init = +let ref (type a) ~name (init : a) : a local_ref = let () = check_name (mangle name) in - let tag : 'a Dyn.tag = Dyn.create (mangle name) in - let r = pervasives_ref (CEphemeron.create init, tag) in + let tag : a CEphemeron.key Dyn.tag = Dyn.create (mangle name) in + let r = pervasives_ref (CEphemeron.create init) in let () = sum_map := DynMap.add tag - { freeze_function = (fun ~marshallable -> freeze (get r)); - unfreeze_function = (set r); - init_function = (fun () -> set r init) } !sum_map + { freeze_function = (fun ~marshallable -> !r); + unfreeze_function = (fun v -> r := v); + init_function = (fun () -> r := CEphemeron.create init) } !sum_map in - r + (r, tag) let (!) = get let (:=) = set diff --git a/library/summary.mli b/library/summary.mli index 7c5e1bee6f..a6f94a49ae 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -53,7 +53,7 @@ val ref_tag : ?freeze:(marshallable:bool -> 'a -> 'a) -> name:string -> 'a -> 'a module Local : sig type 'a local_ref - val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref + val ref : name:string -> 'a -> 'a local_ref val (:=) : 'a local_ref -> 'a -> unit val (!) : 'a local_ref -> 'a diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index ac2058ba1b..343fb0b1fe 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -112,13 +112,13 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Case (info, r, _iv, arg, pats) -> + | Case (info, _, _, _, _, arg, pats) -> let is_bool = let i = info.ci_ind in Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then - Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) + Ifb ((aux arg), (aux (snd pats.(0))), (aux (snd pats.(1)))) else Var (Env.add env c) | _ -> diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 129b220680..6617f4726e 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -19,20 +19,12 @@ open Sorts open Constr open Context open Vars -open Goptions open Tacmach open Util let init_size=5 -let cc_verbose= - declare_bool_option_and_ref - ~depr:false - ~key:["Congruence";"Verbose"] - ~value:false - -let debug x = - if cc_verbose () then Feedback.msg_debug (x ()) +let debug_congruence = CDebug.create ~name:"congruence" () (* Signature table *) @@ -576,7 +568,7 @@ let add_inst state (inst,int_subst) = Control.check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then - debug (fun () -> str "discarding redundant (dis)equality") + debug_congruence (fun () -> str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; @@ -591,7 +583,7 @@ let add_inst state (inst,int_subst) = state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); @@ -599,7 +591,7 @@ let add_inst state (inst,int_subst) = end else begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); @@ -630,7 +622,7 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ + debug_congruence (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in @@ -670,7 +662,7 @@ let union state i1 i2 eq= | _,_ -> () let merge eq state = (* merge and no-merge *) - debug + debug_congruence (fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++ str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str "."); let uf=state.uf in @@ -683,7 +675,7 @@ let merge eq state = (* merge and no-merge *) union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug + debug_congruence (fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in @@ -745,7 +737,7 @@ let process_constructor_mark t i rep pac state = end let process_mark t m state = - debug + debug_congruence (fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in @@ -766,7 +758,7 @@ let check_disequalities state = if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis) else (str "No", check_aux q) in - let _ = debug + let _ = debug_congruence (fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++ pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in ans @@ -953,7 +945,7 @@ let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = - debug (fun () -> str "Running E-matching algorithm ... "); + debug_congruence (fun () -> str "Running E-matching algorithm ... "); try while true do Control.check_for_interrupt (); @@ -964,7 +956,7 @@ let find_instances state = !res let rec execute first_run state = - debug (fun () -> str "Executing ... "); + debug_congruence (fun () -> str "Executing ... "); try while Control.check_for_interrupt (); @@ -974,7 +966,7 @@ let rec execute first_run state = None -> if not(Int.Set.is_empty state.pa_classes) then begin - debug (fun () -> str "First run was incomplete, completing ... "); + debug_congruence (fun () -> str "First run was incomplete, completing ... "); complete state; execute false state end @@ -989,12 +981,12 @@ let rec execute first_run state = end else begin - debug (fun () -> str "Out of instances ... "); + debug_congruence (fun () -> str "Out of instances ... "); None end else begin - debug (fun () -> str "Out of depth ... "); + debug_congruence (fun () -> str "Out of depth ... "); None end | Some dis -> Some diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3270f74479..047756deef 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -121,7 +121,7 @@ val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : (unit -> Pp.t) -> unit +val debug_congruence : CDebug.t val forest : state -> forest diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 53d8c5bdd9..e7e0822916 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -95,13 +95,13 @@ let pinject p c n a = p_rule=Inject(p,c,n,a)} let rec equal_proof env sigma uf i j= - debug (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) and edge_proof env sigma uf ((i,j),eq)= - debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let pi=equal_proof env sigma uf i eq.lhs in let pj=psym (equal_proof env sigma uf j eq.rhs) in let pij= @@ -117,7 +117,7 @@ and edge_proof env sigma uf ((i,j),eq)= ptrans (ptrans pi pij) pj and constr_proof env sigma uf i ipac= - debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); + debug_congruence (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in let eq_it=equal_proof env sigma uf i t in if ipac.args=[] then @@ -130,20 +130,20 @@ and constr_proof env sigma uf i ipac= ptrans eq_it (pcongr p (prefl targ)) and path_proof env sigma uf i l= - debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ + debug_congruence (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) and congr_proof env sigma uf i j= - debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) and ind_proof env sigma uf i ipac j jpac= - debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let p=equal_proof env sigma uf i j and p1=constr_proof env sigma uf i ipac and p2=constr_proof env sigma uf j jpac in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 499c9684b2..341fde7b77 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,16 +420,16 @@ let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.(check_required_library logic_module_name); - let _ = debug (fun () -> Pp.str "Reading subgoal ...") in + let _ = debug_congruence (fun () -> Pp.str "Reading goal ...") in let state = make_prb gl depth additionnal_terms in - let _ = debug (fun () -> Pp.str "Problem built, solving ...") in + let _ = debug_congruence (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in - let _ = debug (fun () -> Pp.str "Computation completed.") in + let _ = debug_congruence (fun () -> Pp.str "Computation completed.") in let uf=forest state in match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); + debug_congruence (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6869f9c47e..0cad192332 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -672,9 +672,11 @@ let rec extract_term env sg mle mlt c args = (* we unify it with an fresh copy of the stored type of [Rel n]. *) let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env sg mle mlt extract_rel args - | Case ({ci_ind=ip},_,iv,c0,br) -> - (* If invert_case then this is a match that will get erased later, but right now we don't care. *) - extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args + | Case (ci, u, pms, r, iv, c0, br) -> + (* If invert_case then this is a match that will get erased later, but right now we don't care. *) + let (ip, r, iv, c0, br) = EConstr.expand_case env sg (ci, u, pms, r, iv, c0, br) in + let ip = ci.ci_ind in + extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args | Fix ((_,i),recd) -> extract_app env sg mle mlt (extract_fix env sg mle i recd) args | CoFix (i,recd) -> @@ -1078,9 +1080,13 @@ let fake_match_projection env p = let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem else - let p = mkLambda (x, lift 1 indty, liftn 1 2 ty) in - let branch = lift 1 (it_mkLambda_or_LetIn (mkRel (List.length ctx - (j-1))) ctx) in - let body = mkCase (ci, p, NoInvert, mkRel 1, [|branch|]) in + let p = ([|x|], liftn 1 2 ty) in + let branch = + let nas = Array.of_list (List.rev_map Context.Rel.Declaration.get_annot ctx) in + (nas, mkRel (List.length ctx - (j - 1))) + in + let params = Context.Rel.to_extended_vect mkRel 1 paramslet in + let body = mkCase (ci, u, params, p, NoInvert, mkRel 1, [|branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) mib.mind_params_ctxt | LocalDef (_,c,t) :: rem -> let c = liftn 1 j c in diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index c62bc73e41..e208ba9a5c 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -67,10 +67,13 @@ let unif env evd t1 t2= | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,_,ca,va),Case (_,pb,_,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in + | Case (cia,ua,pmsa,pa,iva,ca,va),Case (cib,ub,pmsb,pb,ivb,cb,vb)-> + let env = Global.env () in + let (cia,pa,iva,ca,va) = EConstr.expand_case env evd (cia,ua,pmsa,pa,iva,ca,va) in + let (cib,pb,iva,cb,vb) = EConstr.expand_case env evd (cib,ub,pmsb,pb,ivb,cb,vb) in + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 73eb943418..3234d40f73 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -598,12 +598,12 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos let sigma = Proofview.Goal.sigma g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, iv, t, cb) -> + | Case (ci, u, pms, ct, iv, t, cb) -> let do_finalize_t dyn_info' = Proofview.Goal.enter (fun g -> let t = dyn_info'.info in let dyn_infos = - {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + {dyn_info' with info = mkCase (ci, u, pms, ct, iv, t, cb)} in let g_nb_prod = nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) @@ -1260,7 +1260,7 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalConstRef (fst fname) ) ] + , Tacred.EvalConstRef (fst fname) ) ] ; (let do_prove = build_proof interactive_proof (Array.to_list fnames) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index ca6ae150a7..15cf88f827 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -195,16 +195,29 @@ let is_interactive recsl = } +(* For usability we temporarily switch off some flags during the call + to Function. However this is not satisfactory: + + 1- Function should not warn "non-recursive" and call the Definition + mechanism instead of Fixpoint when needed + + 2- Only for automatically generated names should + unused-pattern-matching-variable be ignored. *) + VERNAC COMMAND EXTEND Function STATE CUSTOM | ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { - if is_interactive recsl then - Vernacextend.VtOpenProof (fun () -> - Gen_principle.do_generate_principle_interactive (List.map snd recsl)) - else - Vernacextend.VtDefault (fun () -> - Gen_principle.do_generate_principle (List.map snd recsl)) } + let warn = "-unused-pattern-matching-variable,-matching-variable,-non-recursive" in + if is_interactive recsl then + Vernacextend.VtOpenProof (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle_interactive (List.map snd recsl)) + else + Vernacextend.VtDefault (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle (List.map snd recsl)) + } END { diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 314c8abcaf..cbdebb7bbc 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -917,13 +917,13 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(1)) ) ] ; tclMAP (fun id -> tclTRY (unfold_in_hyp [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(1)) ) ] (destVar sigma args.(1), Locus.InHyp))) (pf_ids_of_hyps g) ; intros_with_rewrite () ] @@ -936,13 +936,13 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = tclTHENLIST [ unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(2)) ) ] ; tclMAP (fun id -> tclTRY (unfold_in_hyp [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] + , Tacred.EvalVarRef (destVar sigma args.(2)) ) ] (destVar sigma args.(2), Locus.InHyp))) (pf_ids_of_hyps g) ; intros_with_rewrite () ] @@ -972,7 +972,7 @@ and intros_with_rewrite_aux () : unit Proofview.tactic = ( UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type" )) -> tauto - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [simplest_case v; intros_with_rewrite ()] | LetIn _ -> tclTHENLIST @@ -1005,7 +1005,7 @@ let rec reflexivity_with_destruct_cases () = (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( 2) with - | Case (_, _, _, v, _) -> + | Case (_, _, _, _, _, v, _) -> tclTHENLIST [ simplest_case v ; intros @@ -1158,7 +1158,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : else unfold_in_concl [ ( Locus.AllOccurrences - , Names.EvalConstRef + , Tacred.EvalConstRef (fst (destConst (Proofview.Goal.sigma g) f)) ) ] in (* The proof of each branche itself *) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 6464556e4e..266345a324 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -418,6 +418,7 @@ let make_eq () = with _ -> assert false let evaluable_of_global_reference r = + let open Tacred in (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with | GlobRef.ConstRef sp -> EvalConstRef sp diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 7b7044fdaf..e25f413fe4 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -100,7 +100,7 @@ val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : - GlobRef.t -> Names.evaluable_global_reference + GlobRef.t -> Tacred.evaluable_global_reference val list_rewrite : bool -> (EConstr.constr * bool) list -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 9d896e9182..9e9444951f 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -301,10 +301,11 @@ let check_not_nested env sigma forbidden e = | Const _ -> () | Ind _ -> () | Construct _ -> () - | Case (_, t, _, e, a) -> + | Case (_, _, pms, (_, t), _, e, a) -> + Array.iter check_not_nested pms; check_not_nested t; check_not_nested e; - Array.iter check_not_nested a + Array.iter (fun (_, c) -> check_not_nested c) a | Fix _ -> user_err Pp.(str "check_not_nested : Fix") | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in @@ -367,7 +368,7 @@ type journey_info = -> unit Proofview.tactic) -> ( case_info * constr - * (constr, EInstance.t) case_invert + * case_invert * constr * constr array , constr ) @@ -472,7 +473,8 @@ let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id ) ) - | Case (ci, t, iv, a, l) -> + | Case (ci, u, pms, t, iv, a, l) -> + let (ci, t, iv, a, l) = EConstr.expand_case env sigma (ci, u, pms, t, iv, a, l) in let continuation_tac_a = jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in @@ -776,7 +778,7 @@ let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos let a' = infos.info in let new_info = { infos with - info = mkCase (ci, a, iv, a', l) + info = mkCase (EConstr.contract_case env sigma (ci, a, iv, a', l)) ; is_main_branch = expr_info.is_main_branch ; is_final = expr_info.is_final } in diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index e39c066c95..b20c4d173d 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -259,13 +259,6 @@ TACTIC EXTEND simple_destruct | [ "simple" "destruct" quantified_hypothesis(h) ] -> { simple_destruct h } END -(** Double induction *) - -TACTIC EXTEND double_induction DEPRECATED { Deprecation.make () } -| [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> - { Elim.h_double_induction h1 h2 } -END - (* Admit *) TACTIC EXTEND admit diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 4a2c298caa..d9da47134d 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -299,7 +299,7 @@ TACTIC EXTEND rewrite_star { -let add_rewrite_hint ~poly bases ort t lcsr = +let add_rewrite_hint ~locality ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in let f ce = @@ -315,7 +315,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in let eqs = List.map f lcsr in - let add_hints base = add_rew_rules base eqs in + let add_hints base = add_rew_rules ~locality base eqs in List.iter add_hints bases let classify_hint _ = VtSideff ([], VtLater) @@ -323,15 +323,15 @@ let classify_hint _ = VtSideff ([], VtLater) } VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:polymorphic bl o None l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic bl o None l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - { add_rewrite_hint ~poly:polymorphic bl o (Some t) l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - { add_rewrite_hint ~poly:polymorphic ["core"] o None l } -| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - { add_rewrite_hint ~poly:polymorphic ["core"] o (Some t) l } + { add_rewrite_hint ~locality ~poly:polymorphic bl o (Some t) l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic ["core"] o None l } +| #[ polymorphic; locality = option_locality; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + { add_rewrite_hint ~locality ~poly:polymorphic ["core"] o (Some t) l } END (**********************************************************************) @@ -774,7 +774,7 @@ let rec find_a_destructable_match sigma t = let cl = [cl, (None, None), None], None in let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with - | Case (_,_,_,x,_) when closed0 sigma x -> + | Case (_,_,_,_,_,x,_) when closed0 sigma x -> if isVar sigma x then (* TODO check there is no rel n. *) raise (Found (Tacinterp.eval_tactic dest)) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 069a342b2a..82b41e41bd 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -11,7 +11,6 @@ { open Pp -open Constr open Stdarg open Pcoq.Prim open Pcoq.Constr @@ -199,20 +198,6 @@ TACTIC EXTEND unify END { -let deprecated_convert_concl_no_check = - CWarnings.create - ~name:"convert_concl_no_check" ~category:"deprecated" - (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") -} - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { - deprecated_convert_concl_no_check (); - Tactics.convert_concl ~check:false x DEFAULTcast - } -END - -{ let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index b1b96ea9a7..3da5b2bfc4 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -147,7 +147,7 @@ GRAMMAR EXTEND Gram | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } - | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + | g=failkw; n = [ n = nat_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } | a = tactic_value -> { TacArg(CAst.make ~loc a) } diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 6bf330c830..e7902d06eb 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -151,13 +151,13 @@ VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY STATE read_program -| [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } -| [ "Obligations" ] -> { show_obligations None } +| [ "Obligations" "of" ident(name) ] -> { fun ~stack:_ -> show_obligations (Some name) } +| [ "Obligations" ] -> { fun ~stack:_ -> show_obligations None } END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY STATE read_program -| [ "Preterm" "of" ident(name) ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } -| [ "Preterm" ] -> { fun ~pm -> Feedback.msg_notice (show_term ~pm None) } +| [ "Preterm" "of" ident(name) ] -> { fun ~stack:_ ~pm -> Feedback.msg_notice (show_term ~pm (Some name)) } +| [ "Preterm" ] -> { fun ~stack:_ ~pm -> Feedback.msg_notice (show_term ~pm None) } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 43957bbde5..cb430efb40 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -182,6 +182,11 @@ let merge_occurrences loc cl = function in (Some p, ans) +let deprecated_conversion_at_with = + CWarnings.create + ~name:"conversion_at_with" ~category:"deprecated" + (fun () -> Pp.str "The syntax [at ... with ...] is deprecated. Use [with ... at ...] instead.") + (* Auxiliary grammar rules *) open Pvernac.Vernac_ @@ -230,7 +235,8 @@ GRAMMAR EXTEND Gram [ [ c = constr -> { (None, c) } | c1 = constr; "with"; c2 = constr -> { (Some (AllOccurrences,c1),c2) } | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - { (Some (occs,c1), c2) } ] ] + { deprecated_conversion_at_with (); (* 8.14 *) + (Some (occs,c1), c2) } ] ] ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index faad792ea9..6ebb01703f 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -191,8 +191,8 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_and_short_name pr (c,_) = pr c let pr_evaluable_reference = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) + | Tacred.EvalVarRef id -> pr_id id + | Tacred.EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n @@ -381,8 +381,8 @@ let string_of_genarg_arg (ArgumentType arg) = str "<" ++ KerName.print kn ++ str ">" let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id id - | EvalConstRef sp -> + | Tacred.EvalVarRef id -> pr_id id + | Tacred.EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (GlobRef.ConstRef sp) let pr_as_disjunctive_ipat prc ipatl = diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 79e0adf9f7..4f58eceb59 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -106,7 +106,7 @@ val pr_may_eval : val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t -val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t +val pr_evaluable_reference_env : env -> Tacred.evaluable_global_reference -> Pp.t val pr_quantified_hypothesis : quantified_hypothesis -> Pp.t diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index aa2449d962..937d579012 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -436,11 +436,7 @@ let finish_timing ~prefix name = (* ******************** *) let print_results_filter ~cutoff ~filter = - (* The STM doesn't provide yet a proper document query and traversal - API, thus we need to re-check if some states are current anymore - (due to backtracking) using the `state_of_id` API. *) - let valid (did,id) _ = Stm.(state_of_id ~doc:(get_doc did) id) <> `Expired in - data := SM.filter valid !data; + data := SM.filter (fun (doc,id) _ -> Stateid.is_valid ~doc id) !data; let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 59533eb3e3..6d0e0c36b3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -918,7 +918,8 @@ let reset_env env = Environ.push_rel_context (Environ.rel_context env) env' let fold_match ?(force=false) env sigma c = - let (ci, p, iv, c, brs) = destCase sigma c in + let case = destCase sigma c in + let (ci, p, iv, c, brs) = EConstr.expand_case env sigma case in let cty = Retyping.get_type_of env sigma c in let dep, pred, exists, sk = let env', ctx, body = @@ -986,7 +987,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let argty = Retyping.get_type_of env (goalevars evars) arg in let state, res = s.strategy { state ; env ; unfresh ; - term1 = arg ; ty1 = argty ; + term1 = arg ; ty1 = argty ; cstr = (prop,None) ; evars } in let res' = @@ -1153,7 +1154,8 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Fail | Identity -> b' in state, res - | Case (ci, p, iv, c, brs) -> + | Case (ci, u, pms, p, iv, c, brs) -> + let (ci, p, iv, c, brs) = EConstr.expand_case env (goalevars evars) (ci, u, pms, p, iv, c, brs) in let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in @@ -1163,7 +1165,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let state, res = match c' with | Success r -> - let case = mkCase (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs) in + let case = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs)) in let res = make_leibniz_proof env case ty r in state, Success (coerce env (prop,cstr) res) | Fail | Identity -> @@ -1185,7 +1187,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in match found with | Some r -> - let ctxc = mkCase (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c'))) in + let ctxc = mkCase (EConstr.contract_case env (goalevars evars) (ci, lift 1 p, map_invert (lift 1) iv, lift 1 c, Array.of_list (List.rev (brs' c')))) in state, Success (make_leibniz_proof env ctxc ty r) | None -> state, c' else @@ -1386,7 +1388,7 @@ module Strategies = let fold_glob c : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> -(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in let unfolded = try Tacred.try_red_product env sigma c diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 9abdc2ddbe..5e88bf7c79 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -276,6 +276,7 @@ let coerce_to_closed_constr env v = c let coerce_to_evaluable_ref env sigma v = + let open Tacred in let fail () = raise (CannotCoerceTo "an evaluable reference") in let ev = match is_intro_pattern v with diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index b8592c5c76..8ca2510459 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -69,7 +69,7 @@ val coerce_to_uconstr : Value.t -> Ltac_pretype.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr val coerce_to_evaluable_ref : - Environ.env -> Evd.evar_map -> Value.t -> evaluable_global_reference + Environ.env -> Evd.evar_map -> Value.t -> Tacred.evaluable_global_reference val coerce_to_constr_list : Environ.env -> Value.t -> constr list diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 7b2c8e1d04..a880a3305e 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -270,7 +270,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var +type g_cst = Tacred.evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -324,7 +324,7 @@ type raw_tactic_arg = type t_trm = EConstr.constr type t_pat = constr_pattern -type t_cst = evaluable_global_reference +type t_cst = Tacred.evaluable_global_reference type t_ref = ltac_constant located type t_nam = Id.t diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 2382dcfbb9..3bb20b9d19 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -269,7 +269,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var +type g_cst = Tacred.evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -323,7 +323,7 @@ type raw_tactic_arg = type t_trm = EConstr.constr type t_pat = constr_pattern -type t_cst = evaluable_global_reference +type t_cst = Tacred.evaluable_global_reference type t_ref = ltac_constant located type t_nam = Id.t diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 8bee7afa2c..ae7a10ce52 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -308,8 +308,8 @@ let short_name qid = else None let evalref_of_globref ?loc ?short = function - | GlobRef.ConstRef cst -> ArgArg (EvalConstRef cst, short) - | GlobRef.VarRef id -> ArgArg (EvalVarRef id, short) + | GlobRef.ConstRef cst -> ArgArg (Tacred.EvalConstRef cst, short) + | GlobRef.VarRef id -> ArgArg (Tacred.EvalVarRef id, short) | r -> let tpe = match r with | GlobRef.IndRef _ -> "inductive" diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 90546ea939..6148f0d23f 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -89,7 +89,7 @@ let subst_global_reference subst = Locusops.or_var_map (subst_located (subst_global_reference subst)) let subst_evaluable subst = - let subst_eval_ref = subst_evaluable_reference subst in + let subst_eval_ref = Tacred.subst_evaluable_reference subst in Locusops.or_var_map (subst_and_short_name subst_eval_ref) let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index a7b571d3db..7d959aa788 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -189,6 +189,7 @@ let flatten_contravariant_disj _ ist = | _ -> fail let evalglobref_of_globref = + let open Tacred in function | GlobRef.VarRef v -> EvalVarRef v | GlobRef.ConstRef c -> EvalConstRef c diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 74d5374193..53aa619d10 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -28,7 +28,7 @@ open Q.Notations open Mutils let use_simplex = - Goptions.declare_bool_option_and_ref ~depr:false ~key:["Simplex"] ~value:true + Goptions.declare_bool_option_and_ref ~depr:true ~key:["Simplex"] ~value:true (* If set to some [file], arithmetic goals are dumped in [file].v *) @@ -223,6 +223,28 @@ let find_point l = let optimise v l = if use_simplex () then Simplex.optimise v l else Mfourier.Fourier.optimise v l +let output_cstr_sys o sys = + List.iter + (fun (c, wp) -> + Printf.fprintf o "%a by %a\n" output_cstr c ProofFormat.output_prf_rule wp) + sys + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let tr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_sys sys output_sys sys'; + sys' + +let tr_cstr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_cstr_sys sys + output_cstr_sys sys'; + sys' + let dual_raw_certificate l = if debug then begin Printf.printf "dual_raw_certificate\n"; @@ -375,25 +397,7 @@ let elim_simple_linear_equality sys0 = in iterate_until_stable elim sys0 -let output_sys o sys = - List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys - -let subst sys = - let sys' = WithProof.subst sys in - if debug then - Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys - sys'; - sys' - -let tr_sys str f sys = - let sys' = f sys in - if debug then ( - Printf.fprintf stdout "[%s\n" str; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - Printf.fprintf stdout "\n => \n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; - Printf.fprintf stdout "]\n" ); - sys' +let subst sys = tr_sys "subst" WithProof.subst sys (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. @@ -489,12 +493,10 @@ let nlinear_preprocess (sys : WithProof.t list) = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in let sys = sys @ all_pairs WithProof.product sys in - if debug then begin - Printf.fprintf stdout "Preprocessed\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys - end; List.map (WithProof.annot "P") sys +let nlinear_preprocess = tr_sys "nlinear_preprocess" nlinear_preprocess + let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in @@ -698,6 +700,15 @@ let pivot v (c1, p1) (c2, p2) = Some (xpivot cv1 cv2) else None +let pivot v c1 c2 = + let res = pivot v c1 c2 in + ( match res with + | None -> () + | Some (c, _) -> + if Vect.get v c.coeffs =/ Q.zero then () + else Printf.printf "pivot error %a\n" output_cstr c ); + res + (* op2 could be Eq ... this might happen *) let simpl_sys sys = @@ -762,6 +773,8 @@ let reduce_coprime psys = in Some (pivot_sys v (cstr, prf) ((c1, p1) :: sys)) +(*let pivot_sys v pc sys = tr_cstr_sys "pivot_sys" (pivot_sys v pc) sys*) + (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr, prf) = @@ -820,6 +833,8 @@ let reduction_equations psys = [reduce_unary; reduce_coprime; reduce_var_change (*; reduce_pivot*)]) psys +let reduction_equations = tr_cstr_sys "reduction_equations" reduction_equations + (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v, i) = @@ -891,11 +906,6 @@ let check_sys sys = open ProofFormat -let output_cstr_sys sys = - (pp_list ";" (fun o (c, wp) -> - Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) - sys - let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -1170,7 +1180,9 @@ let nlia enum prfdepth sys = No: if a wrong equation is chosen, the proof may fail. It would only be safe if the variable is linear... *) - let sys1 = elim_simple_linear_equality sys in + let sys1 = + elim_simple_linear_equality (WithProof.subst_constant true sys) + in let sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1 @ sys2) in let sys4 = make_cstr_system (*sys2@*) sys3 in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e119ceb241..91f7e27911 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -38,14 +38,14 @@ let max_depth = max_int (* Search limit for provers over Q R *) let lra_proof_depth = - declare_int_option_and_ref ~depr:false ~key:["Lra"; "Depth"] ~value:max_depth + declare_int_option_and_ref ~depr:true ~key:["Lra"; "Depth"] ~value:max_depth (* Search limit for provers over Z *) let lia_enum = - declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Enum"] ~value:true + declare_bool_option_and_ref ~depr:true ~key:["Lia"; "Enum"] ~value:true let lia_proof_depth = - declare_int_option_and_ref ~depr:false ~key:["Lia"; "Depth"] ~value:max_depth + declare_int_option_and_ref ~depr:true ~key:["Lia"; "Depth"] ~value:max_depth let get_lia_option () = (Certificate.use_simplex (), lia_enum (), lia_proof_depth ()) @@ -930,7 +930,8 @@ let is_prop env sigma term = Sorts.is_prop sort type formula_op = - { op_and : EConstr.t + { op_impl : EConstr.t option (* only for booleans *) + ; op_and : EConstr.t ; op_or : EConstr.t ; op_iff : EConstr.t ; op_not : EConstr.t @@ -939,7 +940,8 @@ type formula_op = let prop_op = lazy - { op_and = Lazy.force coq_and + { op_impl = None (* implication is Prod *) + ; op_and = Lazy.force coq_and ; op_or = Lazy.force coq_or ; op_iff = Lazy.force coq_iff ; op_not = Lazy.force coq_not @@ -948,13 +950,17 @@ let prop_op = let bool_op = lazy - { op_and = Lazy.force coq_andb + { op_impl = Some (Lazy.force coq_implb) + ; op_and = Lazy.force coq_andb ; op_or = Lazy.force coq_orb ; op_iff = Lazy.force coq_eqb ; op_not = Lazy.force coq_negb ; op_tt = Lazy.force coq_true ; op_ff = Lazy.force coq_false } +let is_implb sigma l o = + match o with None -> false | Some c -> EConstr.eq_constr sigma l c + let parse_formula (genv, sigma) parse_atom env tg term = let parse_atom b env tg t = try @@ -970,6 +976,10 @@ let parse_formula (genv, sigma) parse_atom env tg term = match EConstr.kind sigma term with | App (l, rst) -> ( match rst with + | [|a; b|] when is_implb sigma l op.op_impl -> + let f, env, tg = xparse_formula op k env tg a in + let g, env, tg = xparse_formula op k env tg b in + (mkformula_binary k (mkIMPL k) term f g, env, tg) | [|a; b|] when EConstr.eq_constr sigma l op.op_and -> let f, env, tg = xparse_formula op k env tg a in let g, env, tg = xparse_formula op k env tg b in @@ -2075,12 +2085,11 @@ module MakeCache (T : sig val hash_coeff : int -> coeff -> int val eq_prover_option : prover_option -> prover_option -> bool val eq_coeff : coeff -> coeff -> bool -end) : -sig +end) : sig type key = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + val memo_opt : (unit -> bool) -> string -> (key -> 'a) -> key -> 'a -end = -struct +end = struct module E = struct type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 0e5cac2d4a..74b0708743 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -19,12 +19,6 @@ let warn_deprecated_Spec = (fun () -> Pp.strbrk ("Show Zify Spec is deprecated. Use either \"Show Zify BinOpSpec\" or \"Show Zify UnOpSpec\".")) -let warn_deprecated_Add = - CWarnings.create ~name:"deprecated-Zify-Add" ~category:"deprecated" - (fun () -> - Pp.strbrk ("Add <X> is deprecated. Use instead Add Zify <X>.")) - - } DECLARE PLUGIN "zify_plugin" @@ -41,17 +35,6 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF | ["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" "InjTyp" constr(t) ] -> { warn_deprecated_Add (); Zify.InjTable.register t } -| ["Add" "BinOp" constr(t) ] -> { warn_deprecated_Add (); Zify.BinOp.register t } -| ["Add" "UnOp" constr(t) ] -> { warn_deprecated_Add (); Zify.UnOp.register t } -| ["Add" "CstOp" constr(t) ] -> { warn_deprecated_Add (); Zify.CstOp.register t } -| ["Add" "BinRel" constr(t) ] -> { warn_deprecated_Add (); Zify.BinRel.register t } -| ["Add" "PropOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropBinOp.register t } -| ["Add" "PropBinOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropBinOp.register t } -| ["Add" "PropUOp" constr(t) ] -> { warn_deprecated_Add (); Zify.PropUnOp.register t } -| ["Add" "BinOpSpec" constr(t) ] -> { warn_deprecated_Add (); Zify.BinOpSpec.register t } -| ["Add" "UnOpSpec" constr(t) ] -> { warn_deprecated_Add (); Zify.UnOpSpec.register t } -| ["Add" "Saturate" constr(t) ] -> { warn_deprecated_Add (); Zify.Saturate.register t } END TACTIC EXTEND ITER @@ -73,7 +56,4 @@ VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF |[ "Show" "Zify" "BinRel"] -> { Zify.BinRel.print () } |[ "Show" "Zify" "UnOpSpec"] -> { Zify.UnOpSpec.print() } |[ "Show" "Zify" "BinOpSpec"] -> { Zify.BinOpSpec.print() } -|[ "Show" "Zify" "Spec"] -> { - warn_deprecated_Spec () ; - Zify.UnOpSpec.print() ; Zify.BinOpSpec.print ()} END diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 7b29aa15f9..024fc6dade 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -485,7 +485,7 @@ module ProofFormat = struct let rec output_proof o = function | Done -> Printf.fprintf o "." | Step (i, p, pf) -> - Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + Printf.fprintf o "%i:= %a\n ; %a" i output_prf_rule p output_proof pf | Split (i, v, p1, p2) -> Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 output_proof p2 @@ -496,6 +496,48 @@ module ProofFormat = struct Printf.fprintf o "%i := %i = %i - %i ; %i := %i >= 0 ; %i := %i >= 0 ; %a" i x z t j z k t output_proof pr + module OrdPrfRule = struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1, x2) (y1, y2) = + match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i + + let rec compare p1 p2 = + match (p1, p2) with + | Annot (s1, p1), Annot (s2, p2) -> + if s1 = s2 then compare p1 p2 else String.compare s1 s2 + | Hyp i, Hyp j -> Int.compare i j + | Def i, Def j -> Int.compare i j + | Cst n, Cst m -> Q.compare n m + | Zero, Zero -> 0 + | Square v1, Square v2 -> Vect.compare v1 v2 + | MulC (v1, p1), MulC (v2, p2) -> + cmp_pair Vect.compare compare (v1, p1) (v2, p2) + | Gcd (b1, p1), Gcd (b2, p2) -> + cmp_pair Z.compare compare (b1, p1) (b2, p2) + | MulPrf (p1, q1), MulPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | CutPrf p, CutPrf p' -> compare p p' + | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) + end + + module PrfRuleMap = Map.Make (OrdPrfRule) + let rec pr_size = function | Annot (_, p) -> pr_size p | Zero | Square _ -> Q.zero @@ -537,33 +579,38 @@ module ProofFormat = struct (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. This is because the Coq proof format only accept they as a proof-step *) - let rec pr_rule_def_cut id = function - | Annot (_, p) -> pr_rule_def_cut id p - | MulC (p, prf) -> - let bds, id', prf' = pr_rule_def_cut id prf in - (bds, id', MulC (p, prf')) - | MulPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, MulPrf (p1, p2)) - | AddPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, AddPrf (p1, p2)) - | CutPrf p -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | Gcd (c, p) -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], id, x) + let pr_rule_def_cut m id p = + let rec pr_rule_def_cut m id = function + | Annot (_, p) -> pr_rule_def_cut m id p + | MulC (p, prf) -> + let bds, m, id', prf' = pr_rule_def_cut m id prf in + (bds, m, id', MulC (p, prf')) + | MulPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, MulPrf (p1, p2)) + | AddPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, AddPrf (p1, p2)) + | CutPrf p | Gcd (_, p) -> ( + let bds, m, id, p = pr_rule_def_cut m id p in + try + let id' = PrfRuleMap.find p m in + (bds, m, id, Def id') + with Not_found -> + let m = PrfRuleMap.add p id m in + ((id, p) :: bds, m, id + 1, Def id) ) + | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], m, id, x) + in + pr_rule_def_cut m id p (* Do not define top-level cuts *) - let pr_rule_def_cut id = function + let pr_rule_def_cut m id = function | CutPrf p -> - let bds, ids, p' = pr_rule_def_cut id p in - (bds, ids, CutPrf p') - | p -> pr_rule_def_cut id p + let bds, m, ids, p' = pr_rule_def_cut m id p in + (bds, m, ids, CutPrf p') + | p -> pr_rule_def_cut m id p let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p @@ -577,6 +624,69 @@ module ProofFormat = struct | MulPrf (p1, p2) | AddPrf (p1, p2) -> ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2) + let add_proof x y = + match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) + + let rec mul_cst_proof c p = + match p with + | Annot (s, p) -> Annot (s, mul_cst_proof c p) + | MulC (v, p') -> MulC (Vect.mul c v, p') + | _ -> ( + match Q.sign c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> + MulC (LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) + | _ -> assert false ) + + let sMulC v p = + let c, v' = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) + + let mul_proof p1 p2 = + match (p1, p2) with + | Zero, _ | _, Zero -> Zero + | Cst c, p | p, Cst c -> mul_cst_proof c p + | _, _ -> MulPrf (p1, p2) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + let rec dev_prf_rule p = + match p with + | Annot (s, p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> + PrfRuleMap.singleton p (LinPoly.constant Q.one) + | MulC (v, p) -> + PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf (p1, p2) -> + PrfRuleMap.merge + (fun k o1 o2 -> + match (o1, o2) with + | None, None -> None + | None, Some v | Some v, None -> Some v + | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) + (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf (p1, p2) -> ( + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) + ) + | Gcd (c, p) -> + PrfRuleMap.singleton + (Gcd (c, prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + | CutPrf p -> + PrfRuleMap.singleton + (CutPrf (prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + + let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) + (** [simplify_proof p] removes proof steps that are never re-used. *) let rec simplify_proof p = match p with @@ -618,7 +728,9 @@ module ProofFormat = struct | Done -> (id, Done) | Step (i, Gcd (c, p), Done) -> normalise_proof id (Step (i, p, Done)) | Step (i, p, prf) -> - let bds, id, p' = pr_rule_def_cut id p in + let bds, m, id, p' = + pr_rule_def_cut PrfRuleMap.empty id (simplify_prf_rule p) + in let id, prf = normalise_proof id prf in let prf = List.fold_left @@ -642,8 +754,10 @@ module ProofFormat = struct (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) - let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in + let bds1, m, id, p1' = + pr_rule_def_cut PrfRuleMap.empty id (implicit_cut p1) + in + let bds2, m, id, p2' = pr_rule_def_cut m id (implicit_cut p2) in let ids, prfs = List.split (List.map (normalise_proof id) pl) in ( List.fold_left max 0 ids , List.fold_left @@ -659,104 +773,6 @@ module ProofFormat = struct (snd res); res - module OrdPrfRule = struct - type t = prf_rule - - let id_of_constr = function - | Annot _ -> 0 - | Hyp _ -> 1 - | Def _ -> 2 - | Cst _ -> 3 - | Zero -> 4 - | Square _ -> 5 - | MulC _ -> 6 - | Gcd _ -> 7 - | MulPrf _ -> 8 - | AddPrf _ -> 9 - | CutPrf _ -> 10 - - let cmp_pair c1 c2 (x1, x2) (y1, y2) = - match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i - - let rec compare p1 p2 = - match (p1, p2) with - | Annot (s1, p1), Annot (s2, p2) -> - if s1 = s2 then compare p1 p2 else String.compare s1 s2 - | Hyp i, Hyp j -> Int.compare i j - | Def i, Def j -> Int.compare i j - | Cst n, Cst m -> Q.compare n m - | Zero, Zero -> 0 - | Square v1, Square v2 -> Vect.compare v1 v2 - | MulC (v1, p1), MulC (v2, p2) -> - cmp_pair Vect.compare compare (v1, p1) (v2, p2) - | Gcd (b1, p1), Gcd (b2, p2) -> - cmp_pair Z.compare compare (b1, p1) (b2, p2) - | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | AddPrf (p1, q1), AddPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | CutPrf p, CutPrf p' -> compare p p' - | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) - end - - let add_proof x y = - match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) - - let rec mul_cst_proof c p = - match p with - | Annot (s, p) -> Annot (s, mul_cst_proof c p) - | MulC (v, p') -> MulC (Vect.mul c v, p') - | _ -> ( - match Q.sign c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> - MulC (LinPoly.constant c, p) (* [p] should represent an equality *) - | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) - | _ -> assert false ) - - let sMulC v p = - let c, v' = Vect.decomp_cst v in - if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) - - let mul_proof p1 p2 = - match (p1, p2) with - | Zero, _ | _, Zero -> Zero - | Cst c, p | p, Cst c -> mul_cst_proof c p - | _, _ -> MulPrf (p1, p2) - - module PrfRuleMap = Map.Make (OrdPrfRule) - - let prf_rule_of_map m = - PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero - - let rec dev_prf_rule p = - match p with - | Annot (s, p) -> dev_prf_rule p - | Hyp _ | Def _ | Cst _ | Zero | Square _ -> - PrfRuleMap.singleton p (LinPoly.constant Q.one) - | MulC (v, p) -> - PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) - | AddPrf (p1, p2) -> - PrfRuleMap.merge - (fun k o1 o2 -> - match (o1, o2) with - | None, None -> None - | None, Some v | Some v, None -> Some v - | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) - (dev_prf_rule p1) (dev_prf_rule p2) - | MulPrf (p1, p2) -> ( - let p1' = dev_prf_rule p1 in - let p2' = dev_prf_rule p2 in - let p1'' = prf_rule_of_map p1' in - let p2'' = prf_rule_of_map p2' in - match p1'' with - | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' - | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) - ) - | _ -> PrfRuleMap.singleton p (LinPoly.constant Q.one) - - let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) - (* let mul_proof p1 p2 = let res = mul_proof p1 p2 in @@ -835,7 +851,8 @@ module ProofFormat = struct Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; raise x - let rec cmpl_proof env = function + let rec cmpl_proof env prf = + match prf with | Done -> Mc.DoneProof | Step (i, p, prf) -> ( match p with @@ -1097,15 +1114,33 @@ module WithProof = struct in List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) - let subst sys0 = + let iterate_pivot p sys0 = let elim sys = - let oeq, sys' = extract (is_substitution true) sys in + let oeq, sys' = extract p sys in match oeq with | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in iterate_until_stable elim (List.map snd (sort sys0)) + let subst_constant is_int sys = + let is_integer q = Q.(q =/ floor q) in + let is_constant ((c, o), p) = + match o with + | Ge | Gt -> None + | Eq -> ( + Vect.Bound.( + match of_vect c with + | None -> None + | Some b -> + if (not is_int) || is_integer (b.cst // b.coeff) then + Monomial.get_var (LinPoly.MonT.retrieve b.var) + else None) ) + in + iterate_pivot is_constant sys + + let subst sys0 = iterate_pivot (is_substitution true) sys0 + let saturate_subst b sys0 = let select = is_substitution b in let gen (v, pc) ((c, op), prf) = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 84b5421207..81c131fe78 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -393,6 +393,10 @@ module WithProof : sig val subst : t list -> t list + (** [subst_constant b sys] performs the equivalent of the 'subst' tactic of Coq + only if there is an equation a.x = c for a,c a constant and a divides c if b= true*) + val subst_constant : bool -> t list -> t list + (** [subst1 sys] performs a single substitution *) val subst1 : t list -> t list diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index d1403558ad..61966b60c0 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -14,7 +14,7 @@ open Pp open Lazy module NamedDecl = Context.Named.Declaration -let debug = false +let debug_zify = CDebug.create ~name:"zify" () (* The following [constr] are necessary for constructing the proof terms *) @@ -805,12 +805,11 @@ let pp_prf prf = let interp_prf evd inj source prf = let t, prf' = interp_prf evd inj source prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "interp_prf " ++ gl_pr_constr inj.EInjT.inj ++ str " " ++ gl_pr_constr source ++ str " = " ++ gl_pr_constr t ++ str " by " - ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ()); + ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ())); (t, prf') let mkvar evd inj e = @@ -888,13 +887,12 @@ let app_unop evd src unop arg prf = let app_unop evd src unop arg prf = let res = app_unop evd src unop arg prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "\napp_unop " ++ pp_prf evd unop.EUnOpT.inj1_t arg prf ++ str " => " - ++ pp_prf evd unop.EUnOpT.inj2_t src res); + ++ pp_prf evd unop.EUnOpT.inj2_t src res)); res let app_binop evd src binop arg1 prf1 arg2 prf2 = @@ -1066,8 +1064,7 @@ let match_operator env evd hd args (t, d) = let pp_trans_expr env evd e res = let {deriv = inj} = get_injection env evd e.typ in - if debug then - Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); + debug_zify (fun () -> Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res)); res let declared_term env evd hd args = @@ -1187,7 +1184,7 @@ let trans_binrel evd src rop a1 prf1 a2 prf2 = let trans_binrel evd src rop a1 prf1 a2 prf2 = let res = trans_binrel evd src rop a1 prf1 a2 prf2 in - if debug then Feedback.msg_debug Pp.(str "\ntrans_binrel " ++ pp_prfp res); + debug_zify (fun () -> Pp.(str "\ntrans_binrel " ++ pp_prfp res)); res let mkprf t p = @@ -1199,11 +1196,10 @@ let mkprf t p = let mkprf t p = let t', p = mkprf t p in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "mkprf " ++ gl_pr_constr t ++ str " <-> " ++ gl_pr_constr t' - ++ str " by " ++ gl_pr_constr p); + ++ str " by " ++ gl_pr_constr p)); (t', p) let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = @@ -1221,7 +1217,7 @@ let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let prf = trans_bin_prop op_constr op_iff t1 p1 t2 p2 in - if debug then Feedback.msg_debug (pp_prfp prf); + debug_zify (fun () -> pp_prfp prf); prf let trans_un_prop op_constr op_iff p1 prf1 = @@ -1285,8 +1281,7 @@ let trans_hyps env evd l = [] l let trans_hyp h t0 prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC (* Should detect before *) | CProof t' -> @@ -1313,8 +1308,7 @@ let trans_hyp h t0 prfp = (tclTHEN (Tactics.clear [h]) (Tactics.rename_hyp [(h', h)]))))) let trans_concl prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC | CProof t -> diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index 1caa042db6..19bdcbac58 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -1,9 +1,9 @@ (* Printing *) let pr x = - if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () + if CDebug.(get_flag misc) then (Format.printf "@[%s@]" x; flush(stdout);)else () let prt0 s = () (* print_string s;flush(stdout)*) -let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) -let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) +let sinfo s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str s) +let info s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str (s ())) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 4f7b3fbe74..9d92ffde74 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -354,8 +354,9 @@ let coq_True = gen_constant "core.True.type" 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 Tacred.is_evaluable env (EvalConstRef kn) -> + | Const (kn,u) when is_evaluable env (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index f6a741f468..5fbabd7ca1 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -46,7 +46,11 @@ type ssrclear = ssrhyps type ssrdocc = ssrclear option * ssrocc (* OLD ssr terms *) -type ssrtermkind = char (* FIXME, make algebraic *) +(* terms are pre constr, the kind is a parsing/printing flag to distinguish + * between x, @x and (x). It affects automatic clear and let-in preservation. *) +(* FIXME *) +(* Cpattern is a temporary flag that becomes InParens ASAP. *) +type ssrtermkind = Ssrmatching_plugin.Ssrmatching.ssrtermkind type ssrterm = ssrtermkind * Genintern.glob_constr_and_expr (* NEW ssr term *) diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 61643c2aa3..37eba7d399 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -19,30 +19,21 @@ open Ssrmatching_plugin open Ssrmatching open Ssrast -open Ssrprinters open Ssrcommon -let char_to_kind = function - | '(' -> xInParens - | '@' -> xWithAt - | ' ' -> xNoFlag - | 'x' -> xCpattern - | _ -> assert false - (** Backward chaining tactics: apply, exact, congr. *) (** The "apply" tactic *) let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = (* ppdebug(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) - let k = char_to_kind k in let rc = pf_intern_term ist gl c in let rcs' = rc :: rcs in match goclr with | None -> clr, rcs' | Some ghyps -> let clr' = snd (interp_hyps ist gl ghyps) @ clr in - if k <> xNoFlag then clr', rcs' else + if k <> NoFlag then clr', rcs' else let loc = rc.CAst.loc in match DAst.get rc with | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' @@ -132,7 +123,7 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in let ggenl, tclGENTAC = if gviews <> [] && ggenl <> [] then - let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g ist) (List.hd ggenl) in + let ggenl= List.map (fun (x,(k,p)) -> x, {kind=k; pattern=p; interpretation= Some ist}) (List.hd ggenl) in [], Tacticals.tclTHEN (Proofview.V82.of_tactic (genstac (ggenl,[]))) else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in tclGENTAC (fun gl -> diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cd219838d5..41fd96ccb5 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -252,7 +252,7 @@ let interp_refine ist gl rc = in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) - ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); + debug_ssr (fun () -> str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c); (sigma, (sigma, c)) @@ -290,7 +290,7 @@ let interp_hyps ist gl ghyps = (* Old terms *) let mk_term k c = k, (mkRHole, Some c) -let mk_lterm c = mk_term xNoFlag c +let mk_lterm c = mk_term NoFlag c (* New terms *) @@ -318,9 +318,9 @@ let interp_ast_closure_term (ist : Geninterp.interp_sign) (gl : 'goal Evd.sigma) let ssrterm_of_ast_closure_term { body; annotation } = let c = match annotation with - | `Parens -> xInParens - | `At -> xWithAt - | _ -> xNoFlag in + | `Parens -> InParens + | `At -> WithAt + | _ -> NoFlag in mk_term c body let ssrdgens_of_parsed_dgens = function @@ -926,7 +926,7 @@ let pf_interp_ty ?(resolve_typeclasses=false) env sigma0 ist ty = CProdN (abs, force_type t) | CLetIn (n, v, oty, t) -> incr n_binders; CLetIn (n, v, oty, force_type t) | _ -> (mkCCast ty (mkCType None)).v)) ty in - mk_term ' ' (force_type ty) in + mk_term NoFlag (force_type ty) in let strip_cast (sigma, t) = let open EConstr in let rec aux t = match kind_of_type sigma t with @@ -1099,7 +1099,7 @@ let hyp_of_var sigma v = SsrHyp (Loc.tag @@ EConstr.destVar sigma v) let interp_clr sigma = function | Some clr, (k, c) - when (k = xNoFlag || k = xWithAt) && is_pf_var sigma c -> + when (k = NoFlag || k = WithAt) && is_pf_var sigma c -> hyp_of_var sigma c :: clr | Some clr, _ -> clr | None, _ -> [] @@ -1167,7 +1167,7 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let cl = EConstr.of_constr cl in let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in if not(occur_existential sigma c) then - if tag_of_cpattern t = xWithAt then + if tag_of_cpattern t = WithAt then if not (EConstr.isVar sigma c) then errorstrm (str "@ can be used with variables only") else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with @@ -1207,7 +1207,7 @@ let gentac gen = Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux gl false gen in - ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); + debug_ssr (fun () -> str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c); let gl = pf_merge_uc ucst gl in if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 582c45cde1..78a59abda9 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -126,17 +126,17 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = fun (oc, orig_clr, occ, c_gen) -> pfLIFT begin fun gl -> let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in - ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); + debug_ssr (fun () -> (Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) | _ -> false in let match_pat env p occ h cl = let sigma0 = project orig_gl in - ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); + debug_ssr (fun () -> Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in - ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); + debug_ssr (fun () -> Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in @@ -212,10 +212,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let renamed_tys = Array.mapi (fun j (ctx, cty) -> let t = Term.it_mkProd_or_LetIn cty ctx in - ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); let t = Arguments_renaming.rename_type t (GlobRef.ConstructRef((kn,i),j+1)) in - ppdebug(lazy Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); t) tys in @@ -241,8 +241,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = in let () = let sigma = project gl in - ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); - ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in + debug_ssr (fun () -> Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + debug_ssr (fun () -> Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let open EConstr in let inf_deps_r = match kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) @@ -301,7 +301,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | Some (c, _, _,gl) -> Some(true, gl) | None -> None in first [try_c_last_arg;try_c_last_pattern] in - ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); + debug_ssr (fun () -> Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at @@ -321,7 +321,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); + debug_ssr (fun () -> Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -337,8 +337,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in head_p @ patterns, Util.List.uniquize clr, gl in - ppdebug(lazy Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); - ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); (* Predicate generation, and (if necessary) tactic to generalize the * equation asked by the user *) let elim_pred, gen_eq_tac, clr, gl = @@ -348,7 +348,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then - let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern env p)) in + let () = debug_ssr (fun () -> Pp.(str"postponing " ++ pp_pattern env p)) in cl, gl, post @ [h, p, inf_t, occ] else try let c, cl, ucst = match_pat env p occ h cl in @@ -420,8 +420,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else gl, concl in concl, gen_eq_tac, clr, gl in let gl, pty = pf_e_type_of gl elim_pred in - ppdebug(lazy Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); - ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); + debug_ssr (fun () -> Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); + debug_ssr (fun () -> Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); let gl = pf_unify_HO gl pred elim_pred in let elim = fire_subst gl elim in let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index fdfba48024..92a481dd18 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -76,7 +76,7 @@ let simpltac s = Proofview.Goal.enter (fun _ -> simpltac s) (** The "congr" tactic *) let interp_congrarg_at ist gl n rf ty m = - ppdebug(lazy Pp.(str"===interp_congrarg_at===")); + debug_ssr (fun () -> Pp.(str"===interp_congrarg_at===")); let congrn, _ = mkSsrRRef "nary_congruence" in let args1 = mkRnat n :: mkRHoles n @ [ty] in let args2 = mkRHoles (3 * n) in @@ -84,7 +84,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); + debug_ssr (fun () -> Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -92,8 +92,8 @@ let interp_congrarg_at ist gl n rf ty m = let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = - ppdebug(lazy (Pp.str"===congr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); + debug_ssr (fun () -> (Pp.str"===congr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); let sigma, _ as it = interp_term (pf_env gl) (project gl) ist t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in @@ -124,8 +124,8 @@ let newssrcongrtac arg ist = Proofview.Goal.enter_one ~__LOC__ begin fun _g -> (Ssrcommon.tacMK_SSR_CONST "ssr_congr_arrow") end >>= fun arr -> Proofview.V82.tactic begin fun gl -> - ppdebug(lazy Pp.(str"===newcongr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); + debug_ssr (fun () -> Pp.(str"===newcongr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = @@ -223,16 +223,16 @@ let simplintac occ rdx sim = end let rec get_evalref env sigma c = match EConstr.kind sigma c with - | Var id -> EvalVarRef id - | Const (k,_) -> EvalConstRef k + | Var id -> Tacred.EvalVarRef id + | Const (k,_) -> Tacred.EvalConstRef k | App (c', _) -> get_evalref env sigma c' | Cast (c', _, _) -> get_evalref env sigma c' - | Proj(c,_) -> EvalConstRef(Projection.constant c) + | Proj(c,_) -> Tacred.EvalConstRef(Projection.constant c) | _ -> errorstrm Pp.(str "The term " ++ pr_econstr_pat (Global.env ()) sigma c ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with - | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> + | App (f, a) when kt = NoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> (sigma, f), true | Const _ | Var _ -> p, true | Proj _ -> p, true @@ -385,8 +385,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) | e when CErrors.noncritical e -> raise (PRtype_error None) in - ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); - ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); try Proofview.V82.of_tactic (refine_with ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof)) gl with e when CErrors.noncritical e -> @@ -435,12 +435,12 @@ let rwcltac ?under ?map_redex cl rdx dir sr = let sigma0 = Evd.set_universe_context sigma0 ucst in let rdxt = Retyping.get_type_of env (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); + debug_ssr (fun () -> Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); let cvtac, rwtac, sigma0 = if EConstr.Vars.closed0 sigma0 r' then let sigma, c, c_eq = fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in - ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); + debug_ssr (fun () -> Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); let open EConstr in match kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> @@ -521,7 +521,7 @@ let rwprocess_rule env dir rule = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta env sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); + debug_ssr (fun () -> Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -736,7 +736,7 @@ let unlocktac ist args = Ssrcommon.tacMK_SSR_CONST "locked" >>= fun locked -> Ssrcommon.tacMK_SSR_CONST "master_key" >>= fun key -> let ktacs = [ - (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) xInParens); + (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) InParens); Ssrelim.casetac key (fun ?seed:_ k -> k) ] in Tacticals.New.tclTHENLIST (List.map utac args @ ktacs) diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 4961138190..bc46c23761 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -143,8 +143,8 @@ let havetac ist let gl, _ = pf_e_type_of gl idty in pf_unify_HO gl args_id.(2) abstract_key in Tacticals.tclTHENFIRST (Proofview.V82.of_tactic itac_mkabs) (fun gl -> - let mkt t = mk_term xNoFlag t in - let mkl t = (xNoFlag, (t, None)) in + let mkt t = mk_term NoFlag t in + let mkl t = (NoFlag, (t, None)) in let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in let interp_ty gl rtc t = let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc (pf_env gl) (project gl) ist t in a,b,u in @@ -296,8 +296,8 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave = | Some id -> if pats = [] then Tacticals.New.tclIDTAC else let args = Array.of_list args in - ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); - ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); + debug_ssr (fun () -> str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args))); + debug_ssr (fun () -> str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct); Tacticals.New.tclTHENS (basecuttac "ssr_have" ct) [Tactics.apply EConstr.(mkApp (mkVar id,args)); Tacticals.New.tclIDTAC] in "ssr_have", @@ -395,7 +395,7 @@ let intro_lock ipats = Array.length args = 3 && is_app_evar sigma args.(2) -> protect_subgoal env sigma hd args | _ -> - ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); + debug_ssr (fun () -> Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); Proofview.tclUNIT () end) @@ -468,13 +468,13 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = | Some l -> [IPatCase(Regular [l;[]])] in let map_redex env evar_map ~before:_ ~after:t = - ppdebug(lazy Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); + debug_ssr (fun () -> Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); let evar_map, ty = Typing.type_of env evar_map t in let new_t = (* pretty-rename the bound variables *) try begin match EConstr.destApp evar_map t with (f, ar) -> let lam = Array.last ar in - ppdebug(lazy Pp.(str"under: mapping:" ++ + debug_ssr(fun () -> Pp.(str"under: mapping:" ++ pr_econstr_env env evar_map lam)); let new_lam = pretty_rename evar_map lam varnames in let new_ar, len1 = Array.copy ar, pred (Array.length ar) in @@ -482,10 +482,10 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = EConstr.mkApp (f, new_ar) end with | DestKO -> - ppdebug(lazy Pp.(str"under: cannot pretty-rename bound variables with destApp")); + debug_ssr (fun () -> Pp.(str"under: cannot pretty-rename bound variables with destApp")); t in - ppdebug(lazy Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); + debug_ssr (fun () -> Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); evar_map, new_t in let undertacs = diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 46f90a7ee1..f8abed5482 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -324,7 +324,7 @@ end `tac`, where k is the size of `seeds` *) let tclSEED_SUBGOALS seeds tac = tclTHENin tac (fun i n -> - Ssrprinters.ppdebug (lazy Pp.(str"seeding")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"seeding")); (* eg [case: (H _ : nat)] generates 3 goals: - 1 for _ - 2 for the nat constructors *) @@ -416,11 +416,11 @@ let tclMK_ABSTRACT_VARS ids = (* Debugging *) let tclLOG p t = tclUNIT () >>= begin fun () -> - Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ pr_ipatop p)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "exec: " ++ pr_ipatop p)); tclUNIT () end <*> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str" on state:" ++ spc () ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str" on state:" ++ spc () ++ isPRINT g ++ str" goal:" ++ spc () ++ Printer.pr_goal (Goal.print g))); tclUNIT () @@ -429,7 +429,7 @@ let tclLOG p t = t p >>= fun ret -> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "done: " ++ isPRINT g)); tclUNIT () end >>= fun () -> tclUNIT ret @@ -579,10 +579,10 @@ let tclCompileIPats l = elab l ;; let tclCompileIPats l = - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats input: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats input: " ++ prlist_with_sep spc Ssrprinters.pr_ipat l)); let ops = tclCompileIPats l in - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats output: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats output: " ++ prlist_with_sep spc pr_ipatop ops)); ops @@ -597,11 +597,11 @@ let main ?eqtac ~first_case_is_dispatch iops = end (* }}} *) let tclIPAT_EQ eqtac ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~eqtac ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclIPATssr ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclCompileIPats = IpatMachine.tclCompileIPats @@ -741,7 +741,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin [A.. -> Ind] and opens new goals for [A..] as well as for the branches of [Ind], see the [~to_ind] argument *) if not(Termops.occur_existential sigma c) then - if Ssrmatching.tag_of_cpattern t = Ssrprinters.xWithAt then + if Ssrmatching.tag_of_cpattern t = Ssrmatching.WithAt then if not (EConstr.isVar sigma c) then Ssrcommon.errorstrm Pp.(str "@ can be used with variables only") else match Context.Named.lookup (EConstr.destVar sigma c) hyps with diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index f06b460ee9..935cef58b9 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -38,6 +38,8 @@ open Constrexpr_ops open Proofview open Proofview.Notations +open Ssrmatching_plugin.Ssrmatching + open Ssrprinters open Ssrcommon open Ssrtacticals @@ -455,9 +457,9 @@ END (* Old kinds of terms *) let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> xInParens - | Tok.KEYWORD "@" -> xWithAt - | _ -> xNoFlag + | Tok.KEYWORD "(" -> InParens + | Tok.KEYWORD "@" -> WithAt + | _ -> NoFlag let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind @@ -554,9 +556,9 @@ END GRAMMAR EXTEND Gram GLOBAL: ssrbwdview; ssrbwdview: [ - [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term xNoFlag c] } + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term NoFlag c] } | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> { - (mk_term xNoFlag c) :: w } ]]; + (mk_term NoFlag c) :: w } ]]; END (* New Views *) @@ -2201,10 +2203,10 @@ let pr_ssrcongrarg _ _ _ ((n, f), dgens) = ARGUMENT EXTEND ssrcongrarg TYPED AS ((int * ssrterm) * ssrdgens) PRINTED BY { pr_ssrcongrarg } -| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term xNoFlag c), dgens } -| [ natural(n) constr(c) ] -> { (n, mk_term xNoFlag c),([[]],[]) } -| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term xNoFlag c), dgens } -| [ constr(c) ] -> { (0, mk_term xNoFlag c), ([[]],[]) } +| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term NoFlag c), dgens } +| [ natural(n) constr(c) ] -> { (n, mk_term NoFlag c),([[]],[]) } +| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term NoFlag c), dgens } +| [ constr(c) ] -> { (0, mk_term NoFlag c), ([[]],[]) } END @@ -2260,7 +2262,7 @@ let pr_rule = function let pr_ssrrule _ _ _ = pr_rule -let noruleterm loc = mk_term xNoFlag (mkCProp loc) +let noruleterm loc = mk_term NoFlag (mkCProp loc) } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 95c8024e89..434568b554 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -15,7 +15,6 @@ open Names open Printer open Tacmach -open Ssrmatching_plugin open Ssrast let pr_spc () = str " " @@ -28,16 +27,6 @@ let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> let pp_term gl t = let t = Reductionops.nf_evar (project gl) t in pr_econstr_env (pf_env gl) (project gl) t -(* FIXME *) -(* terms are pre constr, the kind is parsing/printing flag to distinguish - * between x, @x and (x). It affects automatic clear and let-in preservation. - * Cpattern is a temporary flag that becomes InParens ASAP. *) -(* type ssrtermkind = InParens | WithAt | NoFlag | Cpattern *) -let xInParens = '(' -let xWithAt = '@' -let xNoFlag = ' ' -let xCpattern = 'x' - (* Term printing utilities functions for deciding bracketing. *) let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") (* String lexing utilities *) @@ -45,10 +34,10 @@ let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with +let guard_term kind s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true - | _ -> ch1 = xInParens + | _ -> kind = Ssrmatching_plugin.Ssrmatching.InParens (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) @@ -131,15 +120,4 @@ and pr_block = function (Prefix id) -> str"^" ++ Id.print id | (SuffixId id) -> str"^~" ++ Id.print id | (SuffixNum n) -> str"^~" ++ int n -(* 0 cost pp function. Active only if Debug Ssreflect is Set *) -let ppdebug_ref = ref (fun _ -> ()) -let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) -let () = - Goptions.(declare_bool_option - { optkey = ["Debug";"Ssreflect"]; - optdepr = false; - optread = (fun _ -> !ppdebug_ref == ssr_pp); - optwrite = (fun b -> - Ssrmatching.debug b; - if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) }) -let ppdebug s = !ppdebug_ref s +let debug_ssr = CDebug.create ~name:"ssreflect" () diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 87eb05b667..994577a0c9 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -24,11 +24,6 @@ val pp_concat : Pp.t -> ?sep:Pp.t -> Pp.t list -> Pp.t -val xInParens : ssrtermkind -val xWithAt : ssrtermkind -val xNoFlag : ssrtermkind -val xCpattern : ssrtermkind - val pr_clear : (unit -> Pp.t) -> ssrclear -> Pp.t val pr_clear_ne : ssrclear -> Pp.t val pr_dir : ssrdir -> Pp.t @@ -56,5 +51,4 @@ val pr_guarded : val pr_occ : ssrocc -> Pp.t -val ppdebug : Pp.t Lazy.t -> unit - +val debug_ssr : CDebug.t diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index cbc352126e..c822675589 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -40,7 +40,7 @@ let tclPERM perm tac = let rot_hyps dir i hyps = let n = List.length hyps in if i = 0 then List.rev hyps else - if i > n then CErrors.user_err (Pp.str "Not enough subgoals") else + if i > n then CErrors.user_err (Pp.str "Not enough goals") else let rec rot i l_hyps = function | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' | hyps' -> hyps' @ (List.rev l_hyps) in diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 97926753f5..b3a9e71a3f 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -194,17 +194,17 @@ let mkGApp f args = let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> let env = Goal.env goal in let sigma = Goal.sigma goal in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env sigma glob)); try let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-out: " ++ Printer.pr_econstr_env env sigma term)); tclUNIT (env,sigma,term) with e -> (* XXX this is another catch all! *) let e, info = Exninfo.capture e in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env sigma glob)); tclZERO ~info e end @@ -217,7 +217,7 @@ end let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t let tclADD_CLEAR_IF_ID (env, ist, t) x = - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); let hd, args = EConstr.decompose_app ist t in match EConstr.kind ist hd with @@ -269,11 +269,11 @@ let interp_view ~clear_if_id ist v p = let p_id = DAst.make p_id in match DAst.get v with | Glob_term.GApp (hd, rargs) when is_specialize hd -> - Ssrprinters.ppdebug (lazy Pp.(str "specialize")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "specialize")); interp_glob ist (mkGApp p_id rargs) >>= tclKeepOpenConstr >>= tclPAIR [] | _ -> - Ssrprinters.ppdebug (lazy Pp.(str "view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "view")); (* We find out how to build (v p) eventually using an adaptor *) let adaptors = AdaptorDb.(get Forward) in Proofview.tclORELSE @@ -324,7 +324,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let rigid = rigid_of und0 in let n, p, to_prune, _ucst = pf_abs_evars2 s0 rigid (sigma, p) in let p = if simple_types then pf_abs_cterm s0 n p else p in - Ssrprinters.ppdebug (lazy Pp.(str"view@finalized: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str"view@finalized: " ++ Printer.pr_econstr_env env sigma p)); let sigma = List.fold_left Evd.remove sigma to_prune in Unsafe.tclEVARS sigma <*> @@ -349,26 +349,26 @@ let rec apply_all_views_aux ~clear_if_id vs finalization conclusion s0 = pose_proof name p <*> conclusion ~to_clear:name) <*> tclUNIT false) | v :: vs -> - Ssrprinters.ppdebug (lazy Pp.(str"piling...")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"piling...")); is_tac_in_term ~extra_scope:"ssripat" v >>= function | `Term v -> - Ssrprinters.ppdebug (lazy Pp.(str"..a term")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a term")); pile_up_view ~clear_if_id v <*> apply_all_views_aux ~clear_if_id vs finalization conclusion s0 | `Tac tac -> - Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a tactic")); finalization s0 (fun name p -> (match p with | None -> tclUNIT () | Some p -> pose_proof name p) <*> Tacinterp.eval_tactic tac <*> if vs = [] then begin - Ssrprinters.ppdebug (lazy Pp.(str"..was the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was the last view")); conclusion ~to_clear:name <*> tclUNIT true end else Tactics.clear name <*> tclINDEPENDENTL begin - Ssrprinters.ppdebug (lazy Pp.(str"..was NOT the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was NOT the last view")); Ssrcommon.tacSIGMA >>= apply_all_views_aux ~clear_if_id vs finalization conclusion end >>= reduce_or) diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 2252435658..7022949ab6 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -67,9 +67,9 @@ END { let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> '(' - | Tok.KEYWORD "@" -> '@' - | _ -> ' ' + | Tok.KEYWORD "(" -> InParens + | Tok.KEYWORD "@" -> WithAt + | _ -> NoFlag let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind } @@ -78,8 +78,8 @@ GRAMMAR EXTEND Gram GLOBAL: cpattern; cpattern: [[ k = ssrtermkind; c = constr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some loc && k = '(' - then mk_term 'x' c None + if loc_of_cpattern pattern <> Some loc && k = InParens + then mk_term Cpattern c None else pattern } ]]; END @@ -97,8 +97,8 @@ GRAMMAR EXTEND Gram GLOBAL: lcpattern; lcpattern: [[ k = ssrtermkind; c = lconstr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some loc && k = '(' - then mk_term 'x' c None + if loc_of_cpattern pattern <> Some loc && k = InParens + then mk_term Cpattern c None else pattern } ]]; END diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index ea014250ca..7774258fca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -37,6 +37,8 @@ open Evar_kinds open Constrexpr open Constrexpr_ops +type ssrtermkind = | InParens | WithAt | NoFlag | Cpattern + let errorstrm = CErrors.user_err ~hdr:"ssrmatching" let loc_error loc msg = CErrors.user_err ?loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info @@ -78,10 +80,10 @@ let skip_wschars s = let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop (* We also guard characters that might interfere with the ssreflect *) (* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with +let guard_term kind s i = match s.[i] with | '(' -> false | '{' | '/' | '=' -> true - | _ -> ch1 = '(' + | _ -> kind = InParens (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = @@ -102,14 +104,6 @@ let prl_glob_constr_and_expr env sigma = function let pr_glob_constr_and_expr env sigma = function | _, Some c -> pr_constr_expr env sigma c | c, None -> pr_glob_constr c -let pr_term (k, c, _) = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_guarded (guard_term k) (pr_glob_constr_and_expr env sigma) c -let prl_term (k, c, _) = - let env = Global.env () in - let sigma = Evd.from_env env in - pr_guarded (guard_term k) (prl_glob_constr_and_expr env sigma) c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = @@ -153,28 +147,6 @@ let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) -(* ssrterm conbinators *) -let combineCG t1 t2 f g = - let mk_ist i1 i2 = match i1, i2 with - | None, Some i -> Some i - | Some i, None -> Some i - | None, None -> None - | Some i, Some j when i == j -> Some i - | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in - match t1, t2 with - | (x, (t1, None), i1), (_, (t2, None), i2) -> - x, (g t1 t2, None), mk_ist i1 i2 - | (x, (_, Some t1), i1), (_, (_, Some t2), i2) -> - x, (mkRHole, Some (f t1 t2)), mk_ist i1 i2 - | _, (_, (_, None), _) -> CErrors.anomaly (str"have: mixed C-G constr.") - | _ -> CErrors.anomaly (str"have: mixed G-C constr.") -let loc_ofCG = function - | (_, (s, None), _) -> Glob_ops.loc_of_glob_constr s - | (_, (_, Some s), _) -> Constrexpr_ops.constr_loc s - -let mk_term k c ist = k, (mkRHole, Some c), ist -let mk_lterm = mk_term ' ' - let nf_evar sigma c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) @@ -313,7 +285,8 @@ let iter_constr_LR f c = match kind c with | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, iv, v, b) -> f v; iter_invert f iv; f p; Array.iter f b + | Case (_, _, pms, (_, p), iv, v, b) -> + f v; Array.iter f pms; f p; iter_invert f iv; Array.iter (fun (_, c) -> f c) b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a @@ -777,7 +750,7 @@ let rec uniquize = function EConstr.push_rel ctx_item env, h' + 1 in let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in let f = EConstr.of_constr f in - let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in + let f' = map_constr_with_binders_left_to_right env sigma inc_h self acc f in let f' = EConstr.Unsafe.to_constr f' in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), @@ -803,25 +776,15 @@ type ('ident, 'term) ssrpattern = | E_In_X_In_T of 'term * 'ident * 'term | E_As_X_In_T of 'term * 'ident * 'term -let pr_pattern = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t +let pr_pattern pr_ident pr_term = function + | T t -> pr_term t + | In_T t -> str "in " ++ pr_term t + | X_In_T (x,t) -> pr_ident x ++ str " in " ++ pr_term t + | In_X_In_T (x,t) -> str "in " ++ pr_ident x ++ str " in " ++ pr_term t | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t + pr_term e ++ str " in " ++ pr_ident x ++ str " in " ++ pr_term t | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t - -let pr_pattern_w_ids = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + pr_term e ++ str " as " ++ pr_ident x ++ str " in " ++ pr_term t let pr_pattern_aux pr_constr = function | T t -> pr_constr t @@ -834,16 +797,53 @@ let pr_pattern_aux pr_constr = function pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern env (sigma, p) = pr_pattern_aux (fun t -> pr_econstr_pat env sigma (pi3 (nf_open_term sigma sigma (EConstr.of_constr t)))) p + +type cpattern = + { kind : ssrtermkind + ; pattern : Genintern.glob_constr_and_expr + ; interpretation : Geninterp.interp_sign option } + +let pr_term {kind; pattern; _} = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term kind) (pr_glob_constr_and_expr env sigma) pattern +let prl_term {kind; pattern; _} = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term kind) (prl_glob_constr_and_expr env sigma) pattern + let pr_cpattern = pr_term -let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) +let pr_pattern_w_ids = pr_pattern pr_id prl_term + +let mk_term k c ist = {kind=k; pattern=(mkRHole, Some c); interpretation=ist} +let mk_lterm = mk_term NoFlag let glob_ssrterm gs = function - | k, (_, Some c), None -> - let x = Tacintern.intern_constr gs c in - k, (fst x, Some c), None + | {kind; pattern=(_, Some c); interpretation=None} -> + let x = Tacintern.intern_constr gs c in + {kind; pattern=(fst x, Some c); interpretation=None} | ct -> ct +(* ssrterm conbinators *) +let combineCG t1 t2 f g = + let mk_ist i1 i2 = match i1, i2 with + | None, Some i -> Some i + | Some i, None -> Some i + | None, None -> None + | Some i, Some j when i == j -> Some i + | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in + match t1, t2 with + | {kind=x; pattern=(t1, None); interpretation=i1}, {pattern=(t2, None); interpretation=i2} -> + {kind=x; pattern=(g t1 t2, None); interpretation = mk_ist i1 i2} + | {kind=x; pattern=(_, Some t1); interpretation=i1}, {pattern=(_, Some t2); interpretation=i2} -> + {kind=x; pattern=(mkRHole, Some (f t1 t2)); interpretation = mk_ist i1 i2} + | _, {pattern=(_, None); _} -> CErrors.anomaly (str"have: mixed C-G constr.") + | _ -> CErrors.anomaly (str"have: mixed G-C constr.") +let loc_ofCG = function + | {pattern = (s, None); _} -> Glob_ops.loc_of_glob_constr s + | {pattern = (_, Some s); _} -> Constrexpr_ops.constr_loc s + (* This piece of code asserts the following notations are reserved *) (* Reserved Notation "( a 'in' b )" (at level 0). *) (* Reserved Notation "( a 'as' b )" (at level 0). *) @@ -851,19 +851,19 @@ let glob_ssrterm gs = function (* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) let glob_cpattern gs p = pp(lazy(str"globbing pattern: " ++ pr_term p)); - let glob x = pi2 (glob_ssrterm gs (mk_lterm x None)) in + let glob x = (glob_ssrterm gs (mk_lterm x None)).pattern in let encode k s l = let name = Name (Id.of_string ("_ssrpat_" ^ s)) in - k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None), None in + {kind=k; pattern=(mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None); interpretation=None} in let bind_in t1 t2 = let mkCHole = mkCHole ~loc:None in let n = Name (destCVar t1) in fst (glob (mkCCast mkCHole (mkCLambda n mkCHole t2))) in let check_var t2 = if not (isCVar t2) then loc_error (constr_loc t2) "Only identifiers are allowed here" in match p with - | _, (_, None), _ as x -> x - | k, (v, Some t), _ as orig -> - if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else + | {pattern = (_, None); _} as x -> x + | {kind=k; pattern=(v, Some t); _} as orig -> + if k = Cpattern then glob_ssrterm gs {kind=InParens; pattern=(v, Some t); interpretation=None} else match t.CAst.v with | CNotation(_,(InConstrEntry,"( _ in _ )"), ([t1; t2], [], [], [])) -> (try match glob t1, glob t2 with @@ -891,8 +891,8 @@ let glob_rpattern s p = | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) -let subst_ssrterm s (k, c, ist) = - k, Tacsubst.subst_glob_constr_and_expr s c, ist +let subst_ssrterm s {kind; pattern; interpretation} = + {kind; pattern=Tacsubst.subst_glob_constr_and_expr s pattern; interpretation} let subst_rpattern s = function | T t -> T (subst_ssrterm s t) @@ -902,7 +902,7 @@ let subst_rpattern s = function | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) -let interp_ssrterm ist (k,t,_) = k, t, Some ist +let interp_ssrterm ist {kind; pattern; _} = {kind; pattern; interpretation = Some ist} let interp_rpattern s = function | T t -> T (interp_ssrterm s t) @@ -910,23 +910,24 @@ let interp_rpattern s = function | X_In_T(x,t) -> X_In_T (interp_ssrterm s x,interp_ssrterm s t) | In_X_In_T(x,t) -> In_X_In_T (interp_ssrterm s x,interp_ssrterm s t) | E_In_X_In_T(e,x,t) -> - E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) | E_As_X_In_T(e,x,t) -> - E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) let interp_rpattern0 ist gl t = Tacmach.project gl, interp_rpattern ist t -type cpattern = char * Genintern.glob_constr_and_expr * Geninterp.interp_sign option -let tag_of_cpattern = pi1 +let tag_of_cpattern p = p.kind let loc_of_cpattern = loc_ofCG -let cpattern_of_term (c, t) ist = c, t, Some ist type occ = (bool * int list) option type rpattern = (cpattern, cpattern) ssrpattern +let pr_rpattern = pr_pattern pr_cpattern pr_cpattern + +let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern pr_cpattern pr_cpattern) type pattern = Evd.evar_map * (constr, constr) ssrpattern -let id_of_cpattern (_, (c1, c2), _) = +let id_of_cpattern {pattern = (c1, c2); _} = let open CAst in match DAst.get c1, c2 with | _, Some { v = CRef (qid, _) } when qualid_is_ident qid -> @@ -941,12 +942,12 @@ let id_of_Cterm t = match id_of_cpattern t with let interp_open_constr ist env sigma gc = Tacinterp.interp_open_constr ist env sigma gc -let pf_intern_term env sigma (_, c, ist) = glob_constr ist env sigma c +let pf_intern_term env sigma {pattern = c; interpretation = ist; _} = glob_constr ist env sigma c let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t let interp_term env sigma = function - | (_, c, Some ist) -> + | {pattern = c; interpretation = Some ist; _} -> on_snd EConstr.Unsafe.to_constr (interp_open_constr ist env sigma c) | _ -> errorstrm (str"interpreting a term with no ist") @@ -974,17 +975,17 @@ let pr_ist { lfun= lfun } = *) let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = - pp(lazy(str"interpreting: " ++ pr_pattern red)); + pp(lazy(str"interpreting: " ++ pr_rpattern red)); let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in let eAsXInT e x t = E_As_X_In_T(e,x,t) in - let mkG ?(k=' ') x ist = k,(x,None), ist in - let ist_of (_,_,ist) = ist in - let decode (_,_,ist as t) ?reccall f g = + let mkG ?(k=NoFlag) x ist = {kind = k; pattern = (x,None); interpretation = ist } in + let ist_of x = x.interpretation in + let decode ({interpretation=ist; _} as t) ?reccall f g = try match DAst.get (pf_intern_term env sigma0 t) with | GCast(t,CastConv c) when isGHole t && isGLambda c-> let (x, c) = destGLambda c in - f x (' ',(c,None),ist) + f x {kind = NoFlag; pattern = (c,None); interpretation = ist} | GVar id when Option.has_some ist && let ist = Option.get ist in Id.Map.mem id ist.lfun && @@ -1027,7 +1028,7 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = sigma new_evars in sigma in let red = let rec decode_red = function - | T(k,(t,None),ist) -> + | T {kind=k; pattern=(t,None); interpretation=ist} -> begin match DAst.get t with | GCast (c,CastConv t) when isGHole c && @@ -1058,7 +1059,7 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = let red = match redty with | None -> red - | Some (ty, ist) -> let ty = ' ', ty, Some ist in + | Some (ty, ist) -> let ty = {kind=NoFlag; pattern=ty; interpretation = Some ist} in match red with | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) | X_In_T (x,t) -> @@ -1072,9 +1073,12 @@ let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | red -> red in pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); - let mkXLetIn ?loc x (a,(g,c),ist) = match c with - | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)), ist - | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None), ist in + let mkXLetIn ?loc x {kind; pattern=(g,c); interpretation} = match c with + | Some b -> {kind; pattern=(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)); interpretation} + | None -> { kind + ; pattern = DAst.make ?loc @@ GLetIn + (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None + ; interpretation} in match red with | T t -> let sigma, t = interp_term env sigma0 t in sigma, T t | In_T t -> let sigma, t = interp_term env sigma0 t in sigma, In_T t @@ -1255,16 +1259,16 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (GlobRef.VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) + { kind= NoFlag + ; pattern = DAst.make @@ GRef (GlobRef.VarRef id, None), None + ; interpretation = Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })} -let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with +let is_wildcard ({pattern = (l, r); _} : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true | _ -> false (* "ssrpattern" *) -let pr_rpattern = pr_pattern - let pf_merge_uc uc gl = re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 17b47227cb..2b90cef039 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -20,17 +20,16 @@ open Genintern (** Pattern parsing *) +type ssrtermkind = | InParens | WithAt | NoFlag | Cpattern + (** The type of context patterns, the patterns of the [set] tactic and [:] tactical. These are patterns that identify a precise subterm. *) -type cpattern +type cpattern = + { kind : ssrtermkind + ; pattern : Genintern.glob_constr_and_expr + ; interpretation : Geninterp.interp_sign option } val pr_cpattern : cpattern -> Pp.t -(** The type of rewrite patterns, the patterns of the [rewrite] tactic. - These patterns also include patterns that identify all the subterms - of a context (i.e. "in" prefix) *) -type rpattern -val pr_rpattern : rpattern -> Pp.t - (** Pattern interpretation and matching *) exception NoMatch @@ -48,6 +47,12 @@ type ('ident, 'term) ssrpattern = type pattern = evar_map * (constr, constr) ssrpattern val pp_pattern : env -> pattern -> Pp.t +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern = (cpattern, cpattern) ssrpattern +val pr_rpattern : rpattern -> Pp.t + (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) val redex_of_pattern : @@ -193,9 +198,6 @@ val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * val fill_occ_term : Environ.env -> Evd.evar_map -> EConstr.t -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t -(* It may be handy to inject a simple term into the first form of cpattern *) -val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> cpattern - (** Helpers to make stateful closures. Example: a [find_P] function may be called many times, but the pattern instantiation phase is performed only the first time. The corresponding [conclude] has to return the instantiated @@ -219,7 +221,7 @@ val pf_unify_HO : goal sigma -> EConstr.constr -> EConstr.constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) -val tag_of_cpattern : cpattern -> char +val tag_of_cpattern : cpattern -> ssrtermkind val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool @@ -245,7 +247,7 @@ sig val pr_rpattern : rpattern -> Pp.t val mk_rpattern : (cpattern, cpattern) ssrpattern -> rpattern val mk_lterm : Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern - val mk_term : char -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + val mk_term : ssrtermkind -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern val glob_cpattern : Genintern.glob_sign -> cpattern -> cpattern val subst_ssrterm : Mod_subst.substitution -> cpattern -> cpattern diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml index 89d757a72a..0e7640f430 100644 --- a/plugins/syntax/number.ml +++ b/plugins/syntax/number.ml @@ -387,10 +387,10 @@ let locate_global_inductive allow_params qid = | Globnames.TrueGlobal _ -> raise Not_found | Globnames.SynDef kn -> match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) when allow_params -> i, List.map (function - | Notation_term.NRef r -> Some r + | Notation_term.NRef (r,None) -> Some r | Notation_term.NHole _ -> None | _ -> raise Not_found) l | _ -> raise Not_found in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d2859b1b4e..6370bd4f9a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1165,17 +1165,16 @@ let rec ungeneralize sigma n ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) mkLetIn (na,b,t,ungeneralize sigma (n+1) ng c) - | Case (ci,p,iv,c,brs) -> + | Case (ci,u,pms,p,iv,c,brs) -> (* We traverse a split *) let p = - let sign,p = decompose_lam_assum sigma p in + let (nas, p) = p in let sign2,p = decompose_prod_n_assum sigma ng p in - let p = prod_applist sigma p [mkRel (n+List.length sign+ng)] in - it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in - mkCase (ci,p,iv,c,Array.map2 (fun q c -> - let sign,b = decompose_lam_n_decls sigma q c in - it_mkLambda_or_LetIn (ungeneralize sigma (n+q) ng b) sign) - ci.ci_cstr_ndecls brs) + let p = prod_applist sigma p [mkRel (n+Array.length nas+ng)] in + nas, it_mkProd_or_LetIn p sign2 + in + let map (nas, br) = nas, ungeneralize sigma (n + Array.length nas) ng br in + mkCase (ci, u, pms, p, iv, c, Array.map map brs) | App (f,args) -> (* We traverse an inner generalization *) assert (isCase sigma f); @@ -1195,12 +1194,9 @@ let rec is_dependent_generalization sigma ng body = | LetIn (na,b,t,c) -> (* We traverse an alias *) is_dependent_generalization sigma ng c - | Case (ci,p,iv,c,brs) -> + | Case (ci,u,pms,p,iv,c,brs) -> (* We traverse a split *) - Array.exists2 (fun q c -> - let _,b = decompose_lam_n_decls sigma q c in - is_dependent_generalization sigma ng b) - ci.ci_cstr_ndecls brs + Array.exists (fun (_, b) -> is_dependent_generalization sigma ng b) brs | App (g,args) -> (* We traverse an inner generalization *) assert (isCase sigma g); @@ -1759,7 +1755,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let good = List.filter (fun (_,u,_) -> is_conv_leq !!env sigma t u) subst in match good with | [] -> - map_constr_with_full_binders sigma (push_binder sigma) aux x t + map_constr_with_full_binders !!env sigma (push_binder sigma) aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index bada2c3a60..02fb347d08 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -76,8 +76,7 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert - * case_info * cbv_value subs * cbv_stack + | CASE of Univ.Instance.t * constr array * case_return * case_branch array * Constr.case_invert * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack (* les vars pourraient etre des constr, @@ -143,7 +142,7 @@ let rec stack_concat stk1 stk2 = match stk1 with TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) - | CASE(c,b,iv,i,s,stk1') -> CASE(c,b,iv,i,s,stack_concat stk1' stk2) + | CASE(u,pms,c,b,iv,i,s,stk1') -> CASE(u,pms,c,b,iv,i,s,stack_concat stk1' stk2) | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) @@ -202,10 +201,7 @@ let cofixp_reducible flgs _ stk = else false -let get_debug_cbv = Goptions.declare_bool_option_and_ref - ~depr:false - ~value:false - ~key:["Debug";"Cbv"] +let debug_cbv = CDebug.create ~name:"Cbv" () (* Reduction of primitives *) @@ -357,9 +353,9 @@ let rec reify_stack t = function | TOP -> t | APP (args,st) -> reify_stack (mkApp(t,Array.map reify_value args)) st - | CASE (ty,br,iv,ci,env,st) -> + | CASE (u,pms,ty,br,iv,ci,env,st) -> reify_stack - (mkCase (ci, ty, iv, t, br)) + (mkCase (ci, u, pms, ty, iv, t,br)) st | PROJ (p, st) -> reify_stack (mkProj (p, t)) st @@ -410,6 +406,29 @@ let rec subs_consn v i n s = if Int.equal i n then s else subs_consn v (i + 1) n (subs_cons v.(i) s) +(* TODO: share the common parts with EConstr *) +let expand_branch env u pms (ind, i) br = + let open Declarations in + let nas, _br = br.(i - 1) in + let (mib, mip) = Inductive.lookup_mind_specif env ind in + let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in + let paramsubst = Vars.subst_of_rel_context_instance paramdecl (Array.to_list pms) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + Inductive.instantiate_context u subst nas ctx + +let cbv_subst_of_rel_context_instance mkclos sign args env = + let rec aux subst sign l = + let open Context.Rel.Declaration in + match sign, l with + | LocalAssum _ :: sign', a::args' -> aux (subs_cons a subst) sign' args' + | LocalDef (_,c,_)::sign', args' -> + aux (subs_cons (mkclos subst c) subst) sign' args' + | [], [] -> subst + | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") + in aux env (List.rev sign) (Array.to_list args) + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -429,7 +448,7 @@ let rec norm_head info env t stack = they could be computed when getting out of the stack *) let nargs = Array.map (cbv_stack_term info TOP env) args in norm_head info env head (stack_app nargs stack) - | Case (ci,p,iv,c,v) -> norm_head info env c (CASE(p,v,iv,ci,env,stack)) + | Case (ci,u,pms,p,iv,c,v) -> norm_head info env c (CASE(u,pms,p,v,iv,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack | Proj (p, c) -> @@ -503,7 +522,7 @@ and norm_head_ref k info env stack normt t = if red_set_ref info.reds normt then match cbv_value_cache info normt with | Declarations.Def body -> - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Unfolding " ++ debug_pr_key normt)); strip_appl (shift_value k body) stack | Declarations.Primitive op -> let c = match normt with @@ -512,11 +531,11 @@ and norm_head_ref k info env stack normt t = in (PRIMITIVE(op,c,[||]),stack) | Declarations.OpaqueDef _ | Declarations.Undef _ -> - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Not unfolding " ++ debug_pr_key normt)); (VAL(0,make_constr_ref k normt t),stack) else begin - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Not unfolding " ++ debug_pr_key normt)); (VAL(0,make_constr_ref k normt t),stack) end @@ -557,16 +576,33 @@ and cbv_stack_value info env = function cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,iv,ci,env,stk))) + | (CONSTR(((sp,n),_),[||]), APP(args,CASE(u,pms,_p,br,iv,ci,env,stk))) when red_set info.reds fMATCH -> + let nargs = Array.length args - ci.ci_npar in let cargs = - Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in - cbv_stack_term info (stack_app cargs stk) env br.(n-1) + Array.sub args ci.ci_npar nargs in + let env = + if (Int.equal ci.ci_cstr_ndecls.(n - 1) ci.ci_cstr_nargs.(n - 1)) then (* no lets *) + subs_consn cargs 0 nargs env + else + let mkclos env c = cbv_stack_term info TOP env c in + let ctx = expand_branch info.env u pms (sp, n) br in + cbv_subst_of_rel_context_instance mkclos ctx cargs env + in + cbv_stack_term info stk env (snd br.(n-1)) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR(((_,n),u),[||]), CASE(_,br,_,_,env,stk)) + | (CONSTR(((sp, n), _),[||]), CASE(u,pms,_,br,_,ci,env,stk)) when red_set info.reds fMATCH -> - cbv_stack_term info stk env br.(n-1) + let env = + if (Int.equal ci.ci_cstr_ndecls.(n - 1) ci.ci_cstr_nargs.(n - 1)) then (* no lets *) + env + else + let mkclos env c = cbv_stack_term info TOP env c in + let ctx = expand_branch info.env u pms (sp, n) br in + cbv_subst_of_rel_context_instance mkclos ctx [||] env + in + cbv_stack_term info stk env (snd br.(n-1)) (* constructor in a Projection -> IOTA *) | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) @@ -640,10 +676,31 @@ let rec apply_stack info t = function | TOP -> t | APP (args,st) -> apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st - | CASE (ty,br,iv,ci,env,st) -> + | CASE (u,pms,ty,br,iv,ci,env,st) -> + (* FIXME: Prevent this expansion by caching whether an inductive contains let-bindings *) + let (_, ty, _, _, br) = Inductive.expand_case info.env (ci, u, pms, ty, iv, mkProp, br) in + let ty = + let (_, mip) = Inductive.lookup_mind_specif info.env ci.ci_ind in + Term.decompose_lam_n_decls (mip.Declarations.mind_nrealdecls + 1) ty + in + let mk_br c n = Term.decompose_lam_n_decls n c in + let br = Array.map2 mk_br br ci.ci_cstr_ndecls in + let map_ctx (nas, c) = + let open Context.Rel.Declaration in + let fold decl e = match decl with + | LocalAssum _ -> subs_lift e + | LocalDef (_, b, _) -> + let b = cbv_stack_term info TOP e b in + (* The let-binding persists, so we have to shift *) + subs_shft (1, subs_cons b e) + in + let env = List.fold_right fold nas env in + let nas = Array.of_list (List.rev_map get_annot nas) in + (nas, cbv_norm_term info env c) + in apply_stack info - (mkCase (ci, cbv_norm_term info env ty, iv, t, - Array.map (cbv_norm_term info env) br)) + (mkCase (ci, u, Array.map (cbv_norm_term info env) pms, map_ctx ty, iv, t, + Array.map map_ctx br)) st | PROJ (p, st) -> apply_stack info (mkProj (p, t)) st diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 409f4c0f70..4d81678200 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -42,8 +42,7 @@ type cbv_value = and cbv_stack = | TOP | APP of cbv_value array * cbv_stack - | CASE of constr * constr array * (constr,Univ.Instance.t) case_invert - * case_info * cbv_value subs * cbv_stack + | CASE of Univ.Instance.t * constr array * case_return * case_branch array * Constr.case_invert * case_info * cbv_value subs * cbv_stack | PROJ of Projection.t * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 0e69b814c7..15d1ddb4ec 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -351,9 +351,10 @@ let matches_core env sigma allow_bound_rels sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 - | PIf (a1,b1,b1'), Case (ci,_,_,a2,[|b2;b2'|]) -> - let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in - let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in + | PIf (a1,b1,b1'), Case (ci, u2, pms2, p2, iv, a2, ([|b2;b2'|] as br2)) -> + let (_, _, _, p2, _, _, br2) = EConstr.annotate_case env sigma (ci, u2, pms2, p2, iv, a2, br2) in + let ctx_b2,b2 = br2.(0) in + let ctx_b2',b2' = br2.(1) in let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then @@ -367,7 +368,8 @@ let matches_core env sigma allow_bound_rels else raise PatternMatchingFailure - | PCase (ci1,p1,a1,br1), Case (ci2,p2,_,a2,br2) -> + | PCase (ci1, p1, a1, br1), Case (ci2, u2, pms2, p2, iv, a2, br2) -> + let (_, _, _, p2, _, _, br2) = EConstr.annotate_case env sigma (ci2, u2, pms2, p2, iv, a2, br2) in let n2 = Array.length br2 in let () = match ci1.cip_ind with | None -> () @@ -380,14 +382,37 @@ let matches_core env sigma allow_bound_rels if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) then raise PatternMatchingFailure in + let sorec_under_ctx subst (n, c1) (decls, c2) = + let env = push_rel_context decls env in + let rec fold (ctx, subst) nas decls = match nas, decls with + | [], _ -> + (* Historical corner case: less bound variables are allowed in + destructuring let-bindings. See #13735. *) + (ctx, subst) + | na1 :: nas, d :: decls -> + let na2 = Context.Rel.Declaration.get_annot d in + let t = Context.Rel.Declaration.get_type d in + let ctx = push_binder na1 na2 t ctx in + let subst = add_binders na1 na2 binding_vars subst in + fold (ctx, subst) nas decls + | _, [] -> + assert false + in + let ctx, subst = fold (ctx, subst) (Array.to_list n) (List.rev decls) in + sorec ctx env subst c1 c2 + in let chk_branch subst (j,n,c) = (* (ind,j+1) is normally known to be a correct constructor and br2 a correct match over the same inductive *) assert (j < n2); - sorec ctx env subst c br2.(j) + sorec_under_ctx subst (n, c) br2.(j) + in + let subst = sorec ctx env subst a1 a2 in + let subst = match p1 with + | None -> subst + | Some p1 -> sorec_under_ctx subst p1 p2 in - let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in - List.fold_left chk_branch chk_head br1 + List.fold_left chk_branch subst br1 | PFix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(lna2,tl2,bl2)) when Array.equal Int.equal ln1 ln2 && i1 = i2 -> @@ -504,12 +529,30 @@ let sub_match ?(closed=true) env sigma pat c = | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in try_aux [(env, app); (env, Array.last lc)] mk_ctx next - | Case (ci,hd,iv,c1,lc) -> + | Case (ci,u,pms,hd0,iv,c1,lc0) -> + let (mib, mip) = Inductive.lookup_mind_specif env ci.ci_ind in + let (_, hd, _, _, br) = expand_case env sigma (ci, u, pms, hd0, iv, c1, lc0) in + let hd = + let (ctx, hd) = decompose_lam_assum sigma hd in + (push_rel_context ctx env, hd) + in + let map i br = + let decls = mip.Declarations.mind_consnrealdecls.(i) in + let (ctx, c) = decompose_lam_n_decls sigma decls br in + (push_rel_context ctx env, c) + in + let lc = Array.to_list (Array.mapi map br) in let next_mk_ctx = function - | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,iv,c1,Array.of_list lc)) + | c1 :: rem -> + let pms, rem = List.chop (Array.length pms) rem in + let pms = Array.of_list pms in + let hd, lc = match rem with [] -> assert false | x :: l -> (x, l) in + let hd = (fst hd0, hd) in + let map_br (nas, _) br = (nas, br) in + mk_ctx (mkCase (ci,u,pms,hd,iv,c1,Array.map2 map_br lc0 (Array.of_list lc))) | _ -> assert false in - let sub = (env, c1) :: (env, hd) :: subargs env lc in + let sub = (env, c1) :: Array.fold_right (fun c accu -> (env, c) :: accu) pms (hd :: lc) in try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies as recdefs)) -> let nb_fix = Array.length types in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 402a6f6ed3..48f34e7c6b 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util @@ -33,6 +35,78 @@ type detyping_flags = { flg_isgoal : bool; } +(** Reimplementation of kernel case expansion functions in more lenient way *) +module RobustExpand : +sig +val return_clause : Environ.env -> Evd.evar_map -> Ind.t -> + EInstance.t -> EConstr.t array -> EConstr.case_return -> rel_context * EConstr.t +val branch : Environ.env -> Evd.evar_map -> Construct.t -> + EInstance.t -> EConstr.t array -> EConstr.case_branch -> rel_context * EConstr.t +end = +struct +open CVars +open Declarations +open Univ +open Constr + +let instantiate_context u subst nas ctx = + let rec instantiate i ctx = match ctx with + | [] -> [] + | LocalAssum (_, ty) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + LocalAssum (nas.(i), ty) :: ctx + | LocalDef (_, ty, bdy) :: ctx -> + let ctx = instantiate (pred i) ctx in + let ty = substnl subst i (subst_instance_constr u ty) in + let bdy = substnl subst i (subst_instance_constr u bdy) in + LocalDef (nas.(i), ty, bdy) :: ctx + in + let () = if not (Int.equal (Array.length nas) (List.length ctx)) then raise Exit in + instantiate (Array.length nas - 1) ctx + +let return_clause env sigma ind u params (nas, p) = + try + let u = EConstr.Unsafe.to_instance u in + let params = EConstr.Unsafe.to_constr_array params in + let () = if not @@ Environ.mem_mind (fst ind) env then raise Exit in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let paramdecl = subst_instance_context u mib.mind_params_ctxt in + let paramsubst = subst_of_rel_context_instance paramdecl (Array.to_list params) in + let realdecls, _ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in + let self = + let args = Context.Rel.to_extended_vect mkRel 0 mip.mind_arity_ctxt in + let inst = Instance.of_array (Array.init (Instance.length u) Level.var) in + mkApp (mkIndU (ind, inst), args) + in + let realdecls = LocalAssum (Context.anonR, self) :: realdecls in + let realdecls = instantiate_context u paramsubst nas realdecls in + List.map EConstr.of_rel_decl realdecls, p + with e when CErrors.noncritical e -> + let dummy na = LocalAssum (na, EConstr.mkProp) in + List.rev (Array.map_to_list dummy nas), p + +let branch env sigma (ind, i) u params (nas, br) = + try + let u = EConstr.Unsafe.to_instance u in + let params = EConstr.Unsafe.to_constr_array params in + let () = if not @@ Environ.mem_mind (fst ind) env then raise Exit in + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let paramdecl = subst_instance_context u mib.mind_params_ctxt in + let paramsubst = subst_of_rel_context_instance paramdecl (Array.to_list params) in + let subst = paramsubst @ Inductive.ind_subst (fst ind) mib u in + let (ctx, _) = mip.mind_nf_lc.(i - 1) in + let ctx, _ = List.chop mip.mind_consnrealdecls.(i - 1) ctx in + let ctx = instantiate_context u subst nas ctx in + List.map EConstr.of_rel_decl ctx, br + with e when CErrors.noncritical e -> + let dummy na = LocalAssum (na, EConstr.mkProp) in + List.rev (Array.map_to_list dummy nas), br + +end + module Avoid : sig type t @@ -241,16 +315,9 @@ let print_primproj_params = (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) -let computable sigma p k = +let computable sigma (nas, ccl) = (* We first remove as many lambda as the arity, then we look - if it remains a lambda for a dependent elimination. This function - works for normal eta-expanded term. For non eta-expanded or - non-normal terms, it may affirm the pred is synthetisable - because of an undetected ultimate dependent variable in the second - clause, or else, it may affirm the pred non synthetisable - because of a non normal term in the fourth clause. - A solution could be to store, in the MutCase, the eta-expanded - normal form of pred to decide if it depends on its variables + if it remains a lambda for a dependent elimination. Lorsque le prédicat est dépendant de manière certaine, on ne déclare pas le prédicat synthétisable (même si la @@ -258,10 +325,7 @@ let computable sigma p k = sinon on perd la réciprocité de la synthèse (qui, lui, engendrera un prédicat non dépendant) *) - let sign,ccl = decompose_lam_assum sigma p in - Int.equal (Context.Rel.length sign) (k + 1) - && - noccur_between sigma 1 (k+1) ccl + noccur_between sigma 1 (Array.length nas) ccl let lookup_name_as_displayed env sigma t s = let rec lookup avoid n c = match EConstr.kind sigma c with @@ -393,30 +457,27 @@ let update_name sigma na ((_,(e,_)),c) = | _ -> na -let get_domain env sigma c = - let (_,t,_) = EConstr.destProd sigma (Reductionops.whd_all env sigma (Retyping.get_type_of env sigma c)) in - t - -let rec decomp_branch tags nal flags (avoid,env as e) sigma c = - match tags with - | [] -> (List.rev nal,(e,c)) - | b::tags -> +let decomp_branch flags e sigma (ctx, c) = + let n = List.length ctx in + let rec aux i nal (avoid, env as e) c = + if Int.equal i 0 then (List.rev nal,(e,c)) + else let decl, c, let_in = - match EConstr.kind sigma (strip_outer_cast sigma c), b with - | Lambda (na,t,c),false -> LocalAssum (na,t), c, true - | LetIn (na,b,t,c),true -> LocalDef (na,b,t), c, false - | _, false -> - let na = make_annot (Name default_dependent_ident) Sorts.Relevant (* dummy *) in - LocalAssum (na, get_domain (snd env) sigma c), applist (lift 1 c, [mkRel 1]), false - | _, true -> - let na = make_annot Anonymous Sorts.Relevant (* dummy *) in - LocalDef (na, mkProp (* dummy *), type1), lift 1 c, false + match EConstr.kind sigma c with + | Lambda (na,t,c) -> LocalAssum (na,t), c, true + | LetIn (na,b,t,c) -> LocalDef (na,b,t), c, false + | _ -> assert false in let na',avoid' = compute_name sigma ~let_in ~pattern:true flags avoid env (get_name decl) c in - decomp_branch tags (na'::nal) flags - (avoid', add_name (set_name na' decl) env) sigma c + aux (i - 1) (na'::nal) (avoid', add_name (set_name na' decl) env) c + in + aux n [] e (EConstr.it_mkLambda_or_LetIn c ctx) -let rec build_tree na isgoal e sigma ci cl = +let rec build_tree na isgoal e sigma (ci, u, pms, cl) = + let map i br = + RobustExpand.branch (snd (snd e)) sigma (ci.ci_ind, i + 1) u pms br + in + let cl = Array.mapi map cl in let mkpat n rhs pl = let na = update_name sigma na rhs in na, DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,na) in @@ -429,12 +490,12 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | [] -> [Id.Set.empty,[],rhs] | na::nal -> match EConstr.kind sigma c with - | Case (ci,p,iv,c,cl) when + | Case (ci,u,pms,p,iv,c,cl) when eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) - computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> - let clauses = build_tree na isgoal e sigma ci cl in + computable sigma p (* FIXME: can do better *) -> + let clauses = build_tree na isgoal e sigma (ci, u, pms, cl) in List.flatten (List.map (fun (ids,pat,rhs) -> let lines = align_tree nal isgoal rhs sigma in @@ -447,7 +508,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (ids,hd,rest) -> Nameops.Name.fold_right Id.Set.add na ids,pat::hd,rest) mat and contract_branch isgoal e sigma (cdn,mkpat,rhs) = - let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in + let nal,rhs = decomp_branch isgoal e sigma rhs in let mat = align_tree nal isgoal rhs sigma in List.map (fun (ids,hd,rhs) -> let na, pat = mkpat rhs hd in @@ -457,15 +518,10 @@ and contract_branch isgoal e sigma (cdn,mkpat,rhs) = (* Transform internal representation of pattern-matching into list of *) (* clauses *) -let is_nondep_branch sigma c l = - try - (* FIXME: do better using tags from l *) - let sign,ccl = decompose_lam_n_decls sigma (List.length l) c in - noccur_between sigma 1 (Context.Rel.length sign) ccl - with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *) - false +let is_nondep_branch sigma (nas, ccl) = + noccur_between sigma 1 (Array.length nas) ccl -let extract_nondep_branches test c b l = +let extract_nondep_branches b l = let rec strip l r = match DAst.get r, l with | r', [] -> r @@ -473,7 +529,7 @@ let extract_nondep_branches test c b l = | GLetIn (_,_,_,t), true::l -> strip l t (* FIXME: do we need adjustment? *) | _,_ -> assert false in - if test c l then Some (strip l b) else None + strip l b let it_destRLambda_or_LetIn_names l c = let rec aux l nal c = @@ -498,13 +554,14 @@ let it_destRLambda_or_LetIn_names l c = | _ -> DAst.make @@ GApp (c,[a])) in aux l [] c -let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = +let detype_case computable detype detype_eqns avoid env sigma (ci, univs, params, p, iv, c, bl) = let synth_type = synthetize_type () in let tomatch = detype c in let tomatch = match iv with | NoInvert -> tomatch - | CaseInvert {univs;args} -> - let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + (* XXX use holes instead of params? *) + let t = mkApp (mkIndU (ci.ci_ind,univs), Array.append params indices) in DAst.make @@ GCast (tomatch, CastConv (detype t)) in let alias, aliastyp, pred= @@ -512,6 +569,8 @@ let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = then Anonymous, None, None else + let (ctx, p) = RobustExpand.return_clause (snd env) sigma ci.ci_ind univs params p in + let p = EConstr.it_mkLambda_or_LetIn p ctx in let p = detype p in let nl,typ = it_destRLambda_or_LetIn_names ci.ci_pp_info.ind_tags p in let n,typ = match DAst.get typ with @@ -540,21 +599,29 @@ let detype_case computable detype detype_eqns testdep avoid ci p iv c bl = let constagsl = ci.ci_pp_info.cstr_tags in match tag, aliastyp with | LetStyle, None -> + let map i br = + let (ctx, body) = RobustExpand.branch (snd env) sigma (ci.ci_ind, i + 1) univs params br in + EConstr.it_mkLambda_or_LetIn body ctx + in + let bl = Array.mapi map bl in let bl' = Array.map detype bl in let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in GLetTuple (nal,(alias,pred),tomatch,d) | IfStyle, None -> - let bl' = Array.map detype bl in - let nondepbrs = - Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in - if Array.for_all ((!=) None) nondepbrs then - GIf (tomatch,(alias,pred), - Option.get nondepbrs.(0),Option.get nondepbrs.(1)) + if Array.for_all (fun br -> is_nondep_branch sigma br) bl then + let map i br = + let ctx, body = RobustExpand.branch (snd env) sigma (ci.ci_ind, i + 1) univs params br in + EConstr.it_mkLambda_or_LetIn body ctx + in + let bl = Array.mapi map bl in + let bl' = Array.map detype bl in + let nondepbrs = Array.map2 extract_nondep_branches bl' constagsl in + GIf (tomatch,(alias,pred), nondepbrs.(0), nondepbrs.(1)) else - let eqnl = detype_eqns constructs constagsl bl in + let eqnl = detype_eqns constructs constagsl (ci, univs, params, bl) in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) | _ -> - let eqnl = detype_eqns constructs constagsl bl in + let eqnl = detype_eqns constructs constagsl (ci, univs, params, bl) in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) let rec share_names detype flags n l avoid env sigma c t = @@ -677,9 +744,11 @@ let detype_level sigma l = UNamed (detype_level_name sigma l) let detype_instance sigma l = - let l = EInstance.kind sigma l in - if Univ.Instance.is_empty l then None - else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) + if not !print_universes then None + else + let l = EInstance.kind sigma l in + if Univ.Instance.is_empty l then None + else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) let delay (type a) (d : a delay) (f : a delay -> _ -> _ -> _ -> _ -> _ -> a glob_constr_r) flags env avoid sigma t : a glob_constr_g = match d with @@ -788,12 +857,12 @@ and detype_r d flags avoid env sigma t = GRef (GlobRef.IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> GRef (GlobRef.ConstructRef cstr_sp, detype_instance sigma u) - | Case (ci,p,iv,c,bl) -> - let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in + | Case (ci,u,pms,p,iv,c,bl) -> + let comp = computable sigma p in + let case = (ci, u, pms, p, iv, c, bl) in detype_case comp (detype d flags avoid env sigma) - (detype_eqns d flags avoid env sigma ci comp) - (is_nondep_branch sigma) avoid - ci p iv c bl + (detype_eqns d flags avoid env sigma comp) + avoid env sigma case | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef | Int i -> GInt i @@ -805,18 +874,21 @@ and detype_r d flags avoid env sigma t = let u = detype_instance sigma u in GArray(u, t, def, ty) -and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = +and detype_eqns d flags avoid env sigma computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; - let mat = build_tree Anonymous flags (avoid,env) sigma ci bl in + let mat = build_tree Anonymous flags (avoid,env) sigma bl in List.map (fun (ids,pat,((avoid,env),c)) -> CAst.make (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> + let (ci, u, pms, bl) = bl in Array.to_list - (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) + (Array.map3 (detype_eqn d flags avoid env sigma u pms) constructs consnargsl bl) -and detype_eqn d flags avoid env sigma constr construct_nargs branch = +and detype_eqn d flags avoid env sigma u pms constr construct_nargs br = + let ctx, body = RobustExpand.branch (snd env) sigma constr u pms br in + let branch = EConstr.it_mkLambda_or_LetIn body ctx in let make_pat decl avoid env b ids = if force_wildcard () && noccurn sigma 1 b then DAst.make @@ PatVar Anonymous,avoid,(add_name (set_name Anonymous decl) env),ids @@ -824,39 +896,24 @@ and detype_eqn d flags avoid env sigma constr construct_nargs branch = let na,avoid' = compute_name sigma ~let_in:false ~pattern:true flags avoid env (get_name decl) b in DAst.make (PatVar na),avoid',(add_name (set_name na decl) env),add_vname ids na in - let rec buildrec ids patlist avoid env l b = - match EConstr.kind sigma b, l with - | _, [] -> CAst.make @@ + let rec buildrec ids patlist avoid env n b = + if Int.equal n 0 then + CAst.make @@ (Id.Set.elements ids, [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], detype d flags avoid env sigma b) - | Lambda (x,t,b), false::l -> + else match EConstr.kind sigma b with + | Lambda (x,t,b) -> let pat,new_avoid,new_env,new_ids = make_pat (LocalAssum (x,t)) avoid env b ids in - buildrec new_ids (pat::patlist) new_avoid new_env l b + buildrec new_ids (pat::patlist) new_avoid new_env (pred n) b - | LetIn (x,b,t,b'), true::l -> + | LetIn (x,b,t,b') -> let pat,new_avoid,new_env,new_ids = make_pat (LocalDef (x,b,t)) avoid env b' ids in - buildrec new_ids (pat::patlist) new_avoid new_env l b' - - | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid env l c - - | _, true::l -> - let pat = DAst.make @@ PatVar Anonymous in - buildrec ids (pat::patlist) avoid env l b - - | _, false::l -> - (* eta-expansion : n'arrivera plus lorsque tous les - termes seront construits à partir de la syntaxe Cases *) - (* nommage de la nouvelle variable *) - let new_b = applist (lift 1 b, [mkRel 1]) in - let typ = get_domain (snd env) sigma b in - let pat,new_avoid,new_env,new_ids = - make_pat (LocalAssum (make_annot Anonymous Sorts.Relevant (* dummy *),typ)) avoid env new_b ids in - buildrec new_ids (pat::patlist) new_avoid new_env l new_b + buildrec new_ids (pat::patlist) new_avoid new_env (pred n) b' + | _ -> assert false in - buildrec Id.Set.empty [] avoid env construct_nargs branch + buildrec Id.Set.empty [] avoid env (List.length ctx) branch and detype_binder d flags bk avoid env sigma decl c = let na = get_name decl in @@ -873,10 +930,12 @@ and detype_binder d flags bk avoid env sigma decl c = let c = detype d { flags with flg_isgoal = false } avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) let s = - (* It can fail if ty is an evar, or if run inside ocamldebug or the - OCaml toplevel since their printers don't have access to the proper sigma/env *) - try Retyping.get_sort_family_of (snd env) sigma ty - with Retyping.RetypeError _ -> InType + if !Flags.in_debugger then InType + else + (* It can fail if ty is an evar, or if run inside ocamldebug or the + OCaml toplevel since their printers don't have access to the proper sigma/env *) + try Retyping.get_sort_family_of (snd env) sigma ty + with Retyping.RetypeError _ -> InType in let t = if s != InProp && not !Flags.raw_print then None else Some (detype d { flags with flg_isgoal = false } avoid env sigma ty) in GLetIn (na', c, t, r) @@ -1105,18 +1164,3 @@ let rec subst_glob_constr env subst = DAst.map (function GArray(u,t',def',ty') ) - -(* Utilities to transform kernel cases to simple pattern-matching problem *) - -let simple_cases_matrix_of_branches ind brs = - List.map (fun (i,n,b) -> - let nal,c = it_destRLambda_or_LetIn_names n b in - let mkPatVar na = DAst.make @@ PatVar na in - let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in - let ids = List.map_filter Nameops.Name.to_option nal in - CAst.make @@ (ids,[p],c)) - brs - -let return_type_of_predicate ind nrealargs_tags pred = - let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in - (List.hd nal, Some (CAst.make (ind, List.tl nal))), Some p diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 254f772ff8..6d6f7fa97b 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -72,14 +72,6 @@ val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option val force_wildcard : unit -> bool val synthetize_type : unit -> bool -(** Utilities to transform kernel cases to simple pattern-matching problem *) - -val it_destRLambda_or_LetIn_names : bool list -> glob_constr -> Name.t list * glob_constr -val simple_cases_matrix_of_branches : - inductive -> (int * bool list * glob_constr) list -> cases_clauses -val return_type_of_predicate : - inductive -> bool list -> glob_constr -> predicate_pattern * glob_constr option - val subst_genarg_hook : (substitution -> Genarg.glob_generic_argument -> Genarg.glob_generic_argument) Hook.t diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 4b0974ae03..e1d6fff3e4 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -47,17 +47,9 @@ let default_flags env = let ts = default_transparent_state env in default_flags_of ts -let debug_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"Unification"] - ~value:false - -let debug_ho_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"HO";"Unification"] - ~value:false +let debug_unification = CDebug.create ~name:"unification" () + +let debug_ho_unification = CDebug.create ~name:"ho-unification" () (*******************************************) (* Functions to deal with impossible cases *) @@ -206,7 +198,7 @@ let occur_rigidly flags env evd (evk,_) t = if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true else Reducible | Rel _ | Var _ -> Reducible - | Case (_,_,_,c,_) -> + | Case (_,_,_,_,_,c,_) -> (match aux c with | Rigid b -> Rigid b | _ -> Reducible) @@ -381,7 +373,10 @@ let rec ise_stack2 no_app env evd f sk1 sk2 = else None, x in match revsk1, revsk2 with | [], [] -> None, Success i - | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> + | Stack.Case (ci1,u1,pms1,t1,iv1,c1)::q1, Stack.Case (ci2,u2,pms2,t2,iv2,c2)::q2 -> + let dummy = mkProp in + let (_, t1, _, _, c1) = EConstr.expand_case env evd (ci1,u1,pms1,t1,iv1,dummy,c1) in + let (_, t2, _, _, c2) = EConstr.expand_case env evd (ci2,u2,pms2,t2,iv2,dummy,c2) in begin match ise_and i [ (fun i -> f env i CONV t1 t2); @@ -418,7 +413,10 @@ let rec exact_ise_stack2 env evd f sk1 sk2 = let rec ise_rev_stack2 i revsk1 revsk2 = match revsk1, revsk2 with | [], [] -> Success i - | Stack.Case (_,t1,_,c1)::q1, Stack.Case (_,t2,_,c2)::q2 -> + | Stack.Case (ci1,u1,pms1,t1,iv1,c1)::q1, Stack.Case (ci2,u2,pms2,t2,iv2,c2)::q2 -> + let dummy = mkProp in + let (_, t1, _, _, c1) = EConstr.expand_case env evd (ci1,u1,pms1,t1,iv1,dummy,c1) in + let (_, t2, _, _, c2) = EConstr.expand_case env evd (ci2,u2,pms2,t2,iv2,dummy,c2) in ise_and i [ (fun i -> ise_rev_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); @@ -802,9 +800,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) - let () = if debug_unification () then - let open Pp in - Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in + let () = debug_unification (fun () -> Pp.(v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ()))) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> @@ -1278,22 +1274,22 @@ let apply_on_subterm env evd fixed f test c t = if occur_evars !evdref !fixedref t then match EConstr.kind !evdref t with | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t - | _ -> map_constr_with_binders_left_to_right !evdref + | _ -> map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else - (if debug_ho_unification () then - Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); + (debug_ho_unification (fun () -> + Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t)); let b, evd = try test env !evdref k c t with e when CErrors.noncritical e -> assert false in - if b then (if debug_ho_unification () then Feedback.msg_debug (Pp.str "succeeded"); + if b then (debug_ho_unification (fun () -> Pp.str "succeeded"); let evd', fixed, t' = f !evdref !fixedref k t in fixedref := fixed; evdref := evd'; t') else ( - if debug_ho_unification () then Feedback.msg_debug (Pp.str "failed"); - map_constr_with_binders_left_to_right !evdref + debug_ho_unification (fun () -> Pp.str "failed"); + map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) in @@ -1383,7 +1379,7 @@ let thin_evars env sigma sign c = if not (Id.Set.mem id ctx) then raise (TypingFailed !sigma) else t | _ -> - map_constr_with_binders_left_to_right !sigma + map_constr_with_binders_left_to_right env !sigma (fun d (env,acc) -> (push_rel d env, acc+1)) applyrec (env,acc) t in @@ -1398,9 +1394,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let env_evar = evar_filtered_env env_rhs evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); - Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); + debug_ho_unification (fun () -> + Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs ++ fnl () ++ + str"env evars: " ++ Termops.Internal.print_env env_evar)); let args = List.map (nf_evar evd) args in let argsubst = List.map2 (fun decl c -> (NamedDecl.get_id decl, c)) ctxt args in let instance = evar_identity_subst evi in @@ -1433,17 +1429,17 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let rec set_holes env_rhs evd fixed rhs = function | (id,idty,c,cty,evsref,filter,occs)::subst -> let c = nf_evar evd c in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"set holes for: " ++ + debug_ho_unification (fun () -> + Pp.(str"set holes for: " ++ prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ prc env_rhs evd c ++ str" in " ++ - prc env_rhs evd rhs); + prc env_rhs evd rhs)); let occ = ref 1 in let set_var evd fixed k inst = let oc = !occ in - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"Found one occurrence"); - Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); + debug_ho_unification (fun () -> + Pp.(str"Found one occurrence" ++ fnl () ++ + str"cty: " ++ prc env_rhs evd c)); incr occ; match occs with | AtOccurrences occs -> @@ -1452,10 +1448,10 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | Unspecified prefer_abstraction -> let evd, fixed, evty = set_holes env_rhs evd fixed cty subst in let evty = nf_evar evd evty in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ - str" of type: " ++ prc env_evar evd evty ++ - str " for " ++ prc env_rhs evd c); + debug_ho_unification (fun () -> + Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ + str" of type: " ++ prc env_evar evd evty ++ + str " for " ++ prc env_rhs evd c)); let instance = Filter.filter_list filter instance in (* Allow any type lower than the variable's type as the abstracted subterm might have a smaller type, which could be @@ -1471,8 +1467,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = evd, fixed, mkEvar (evk, instance) in let evd, fixed, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); + debug_ho_unification (fun () -> + Pp.(str"abstracted: " ++ prc env_rhs evd rhs')); let () = check_selected_occs env_rhs evd c !occ occs in let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in set_holes env_rhs' evd fixed rhs' subst @@ -1485,9 +1481,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (* Thin evars making the term typable in env_evar *) let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); - Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + debug_ho_unification (fun () -> + Pp.(str"solve_evars on: " ++ prc env_evar evd rhs' ++ fnl () ++ + str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let evd,rhs' = try !solve_evars env_evar evd rhs' with e when Pretype_errors.precatchable_exception e -> @@ -1495,18 +1491,18 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = raise (TypingFailed evd) in let rhs' = nf_evar evd rhs' in (* We instantiate the evars of which the value is forced by typing *) - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); - Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + debug_ho_unification (fun () -> + Pp.(str"after solve_evars: " ++ prc env_evar evd rhs' ++ fnl () ++ + str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let rec abstract_free_holes evd = function | (id,idty,c,cty,evsref,_,_)::l -> let id = id.binder_name in let c = nf_evar evd c in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracting: " ++ - prc env_rhs evd (mkVar id) ++ spc () ++ - prc env_rhs evd c); + debug_ho_unification (fun () -> + Pp.(str"abstracting: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c)); let rec force_instantiation evd = function | (evk,evty,inst,abstract)::evs -> let evk = Option.default evk (Evarutil.advance evd evk) in @@ -1535,14 +1531,14 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = with IllTypedInstance _ (* from instantiate_evar *) | TypingFailed _ -> user_err (Pp.str "Cannot find an instance.") else - ((if debug_ho_unification () then + ((debug_ho_unification (fun () -> let evi = Evd.find evd evk in let env = Evd.evar_env env_rhs evi in - Feedback.msg_debug Pp.(str"evar is defined: " ++ + Pp.(str"evar is defined: " ++ int (Evar.repr evk) ++ spc () ++ prc env evd (match evar_body evi with Evar_defined c -> c | Evar_empty -> assert false))); - evd) + evd)) in force_instantiation evd evs | [] -> abstract_free_holes evd l in force_instantiation evd !evsref @@ -1550,27 +1546,27 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = if Evd.is_defined evd evk then (* Can happen due to dependencies: instantiating evars in the arguments of evk might instantiate evk itself. *) - (if debug_ho_unification () then + (debug_ho_unification (fun () -> begin let evi = Evd.find evd evk in let evenv = evar_env env_rhs evi in let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in - Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) - end; + Pp.(str"evar was defined already as: " ++ prc evenv evd body) + end); evd) else try let evi = Evd.find_undefined evd evk in let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ - prc evenv evd rhs'); + debug_ho_unification (fun () -> + Pp.(str"abstracted type before second solve_evars: " ++ + prc evenv evd rhs')); (* solve_evars is not commuting with nf_evar, because restricting an evar might provide a more specific type. *) let evd, _ = !solve_evars evenv evd rhs' in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); + debug_ho_unification (fun () -> + Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs'))); let flags = default_flags_of TransparentState.full in Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' with IllTypedInstance _ -> raise (TypingFailed evd) @@ -1623,11 +1619,10 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in - let () = if debug_unification () then - let open Pp in - Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ + let () = debug_unification (fun () -> + Pp.(v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ - Termops.Internal.print_constr_env env evd t2 ++ cut ())) in + Termops.Internal.print_constr_env env evd t2 ++ cut ()))) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar (evk1,args1), (Rel _|Var _) when app_empty diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index f9f6f74a66..cb3eef9df0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -232,7 +232,7 @@ let recheck_applications unify flags env evdref t = else () in aux 0 fty | _ -> - iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t + iter_with_full_binders env !evdref (fun d env -> push_rel d env) aux env t in aux env t @@ -304,7 +304,7 @@ let noccur_evar env evd evk c = | LocalAssum _ -> () | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr b))) | Proj (p,c) -> occur_rec true acc c - | _ -> iter_with_full_binders evd (fun rd (k,env) -> (succ k, push_rel rd env)) + | _ -> iter_with_full_binders env evd (fun rd (k,env) -> (succ k, push_rel rd env)) (occur_rec check_types) acc c in try occur_rec false (0,env) c; true with Occur -> false @@ -490,14 +490,14 @@ let expansion_of_var sigma aliases x = | Some a, _ -> (true, Alias.repr sigma a) | None, a :: _ -> (true, Some a) -let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with +let rec expand_vars_in_term_using env sigma aliases t = match EConstr.kind sigma t with | Rel n -> of_alias (normalize_alias sigma aliases (RelAlias n)) | Var id -> of_alias (normalize_alias sigma aliases (VarAlias id)) | _ -> - let self aliases c = expand_vars_in_term_using sigma aliases c in - map_constr_with_full_binders sigma (extend_alias sigma) self aliases t + let self aliases c = expand_vars_in_term_using env sigma aliases c in + map_constr_with_full_binders env sigma (extend_alias sigma) self aliases t -let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) +let expand_vars_in_term env sigma = expand_vars_in_term_using env sigma (make_alias_map env sigma) let free_vars_and_rels_up_alias_expansion env sigma aliases c = let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in @@ -533,7 +533,7 @@ let free_vars_and_rels_up_alias_expansion env sigma aliases c = | Const _ | Ind _ | Construct _ -> acc2 := Id.Set.union (vars_of_global env (fst @@ EConstr.destRef sigma c)) !acc2 | _ -> - iter_with_full_binders sigma + iter_with_full_binders env sigma (fun d (aliases,depth) -> (extend_alias sigma d aliases,depth+1)) frec (aliases,depth) c in @@ -1645,7 +1645,7 @@ let rec invert_definition unify flags choose imitate_defs let candidates = try let t = - map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + map_constr_with_full_binders env' !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in (* Less dependent solutions come last *) l@[t] @@ -1659,7 +1659,7 @@ let rec invert_definition unify flags choose imitate_defs evar'') | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + map_constr_with_full_binders env' !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in let rhs = whd_beta env evd rhs (* heuristic *) in diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 52e3364109..9f84b7683f 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -73,7 +73,7 @@ type 'a testing_function = { (b,l), b=true means no occurrence except the ones in l and b=false, means all occurrences except the ones in l *) -let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = +let replace_term_occ_gen_modulo env sigma occs like_first test bywhat cl occ t = let count = ref (Locusops.initialize_occurrence_counter occs) in let nested = ref false in let add_subst pos t subst = @@ -107,23 +107,23 @@ let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = with NotUnifiable _ -> subst_below k t and subst_below k t = - map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t + map_constr_with_binders_left_to_right env sigma (fun d k -> k+1) substrec k t in let t' = substrec 0 t in (!count, t') -let replace_term_occ_modulo evd occs test bywhat t = +let replace_term_occ_modulo env evd occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in proceed_with_occurrences - (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t + (replace_term_occ_gen_modulo env evd occs' like_first test bywhat None) occs' t -let replace_term_occ_decl_modulo evd occs test bywhat d = +let replace_term_occ_decl_modulo env evd occs test bywhat d = let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in proceed_with_occurrences (map_named_declaration_with_hyploc - (replace_term_occ_gen_modulo evd plocs like_first test bywhat) + (replace_term_occ_gen_modulo env evd plocs like_first test bywhat) hyploc) plocs d @@ -145,7 +145,7 @@ let make_eq_univs_test env evd c = let subst_closed_term_occ env evd occs c t = let test = make_eq_univs_test env evd c in let bywhat () = mkRel 1 in - let t' = replace_term_occ_modulo evd occs test bywhat t in + let t' = replace_term_occ_modulo env evd occs test bywhat t in t', test.testing_state let subst_closed_term_occ_decl env evd occs c d = @@ -155,6 +155,6 @@ let subst_closed_term_occ_decl env evd occs c d = let bywhat () = mkRel 1 in proceed_with_occurrences (map_named_declaration_with_hyploc - (fun _ -> replace_term_occ_gen_modulo evd plocs like_first test bywhat None) + (fun _ -> replace_term_occ_gen_modulo env evd plocs like_first test bywhat None) hyploc) plocs d, test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 1ddae01e2b..c71cb207ab 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -43,13 +43,13 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function matching subterms at the indicated occurrences [occl] with [mk ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) -val replace_term_occ_modulo : evar_map -> occurrences or_like_first -> +val replace_term_occ_modulo : env -> evar_map -> occurrences or_like_first -> 'a testing_function -> (unit -> constr) -> constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : - evar_map -> + env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> named_declaration -> named_declaration diff --git a/pretyping/heads.ml b/pretyping/heads.ml index d1ac0862ed..f6e45613e1 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -32,31 +32,29 @@ type head_approximation = | FlexibleHead of int * int * int * bool (* [true] if a surrounding case *) | NotImmediatelyComputableHead -(* FIXME: maybe change interface here *) -let rec compute_head env = function - | EvalConstRef cst -> - let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in - (match body with - | None -> RigidHead (RigidParameter cst) - | Some c -> kind_of_head env c) - | EvalVarRef id -> - (match lookup_named id env with - | LocalDef (_,c,_) -> kind_of_head env c - | _ -> RigidHead RigidOther) +let rec compute_head_const env cst = + let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in + match body with + | None -> RigidHead (RigidParameter cst) + | Some c -> kind_of_head env c + +and compute_head_var env id = match lookup_named id env with +| LocalDef (_,c,_) -> kind_of_head env c +| _ -> RigidHead RigidOther and kind_of_head env t = let rec aux k l t b = match kind (Reduction.whd_betaiotazeta env t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) | Var id -> - (try on_subterm k l b (compute_head env (EvalVarRef id)) + (try on_subterm k l b (compute_head_var env id) with Not_found -> (* a goal variable *) match lookup_named id env with | LocalDef (_,c,_) -> aux k l c b | LocalAssum _ -> NotImmediatelyComputableHead) | Const (cst,_) -> - (try on_subterm k l b (compute_head env (EvalConstRef cst)) + (try on_subterm k l b (compute_head_const env cst) with Not_found -> CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ @@ -78,7 +76,7 @@ and kind_of_head env t = | App (c,al) -> aux k (Array.to_list al @ l) c b | Proj (p,c) -> RigidHead RigidOther - | Case (_,_,_,c,_) -> aux k [] c true + | Case (_,_,_,_,_,c,_) -> aux k [] c true | Int _ | Float _ | Array _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 5ffd919312..dd7cf8abaa 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -122,12 +122,24 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = | None -> let iv = make_case_invert env (find_rectype env sigma (EConstr.of_constr (lift 1 depind))) ci in let iv = EConstr.Unsafe.to_case_invert iv in - mkCase (ci, lift ndepar p, iv, mkRel 1, Termops.rel_vect ndepar k) + let ncons = Array.length mip.mind_consnames in + let mk_branch i = + (* eta-expansion to please branch contraction *) + let ft = get_type (lookup_rel (ncons - i) env) in + (* we need that to get the generated names for the branch *) + let (ctx, _) = decompose_prod_assum ft in + let n = mkRel (List.length ctx + 1) in + let args = Context.Rel.to_extended_vect mkRel 0 ctx in + let br = it_mkLambda_or_LetIn (mkApp (n, args)) ctx in + lift (ndepar + ncons - i - 1) br + in + let br = Array.init ncons mk_branch in + mkCase (Inductive.contract_case env (ci, lift ndepar p, iv, mkRel 1, br)) | Some ps -> let term = mkApp (mkRel 2, - Array.map - (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in + Array.map + (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in if dep then let ty = mkApp (mkRel 3, [| mkRel 1 |]) in mkCast (term, DEFAULTcast, ty) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index bd875cf68b..d02b015604 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -344,11 +344,7 @@ let get_projections = Environ.get_projections let make_case_invert env (IndType (((ind,u),params),indices)) ci = if Typeops.should_invert_case env ci - then - let univs = EConstr.EInstance.make u in - let params = Array.map_of_list EConstr.of_constr params in - let args = Array.append params (Array.of_list indices) in - CaseInvert {univs;args} + then CaseInvert {indices=Array.of_list indices} else NoInvert let make_case_or_project env sigma indt ci pred c branches = @@ -356,8 +352,7 @@ let make_case_or_project env sigma indt ci pred c branches = let IndType (((ind,_),_),_) = indt in let projs = get_projections env ind in match projs with - | None -> - mkCase (ci, pred, make_case_invert env indt ci, c, branches) + | None -> (mkCase (EConstr.contract_case env sigma (ci, pred, make_case_invert env indt ci, c, branches))) | Some ps -> assert(Array.length branches == 1); let na, ty, t = destLambda sigma pred in @@ -749,6 +744,6 @@ let control_only_guard env sigma c = in let rec iter env c = check_fix_cofix env c; - EConstr.iter_with_full_binders sigma EConstr.push_rel iter env c + EConstr.iter_with_full_binders env sigma EConstr.push_rel iter env c in iter env c diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 3705d39280..8e83814fa0 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -213,7 +213,7 @@ val make_case_or_project : (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr val make_case_invert : env -> inductive_type -> case_info - -> (EConstr.constr,EConstr.EInstance.t) case_invert + -> EConstr.case_invert (*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index d06d6e01d1..28621aa92e 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -320,13 +320,13 @@ and nf_atom_type env sigma atom = | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env sigma accu in let ((mind,_),u as ind),allargs = find_rectype_a env ta in - let iv = if Typeops.should_invert_case env ans.asw_ci then - CaseInvert {univs=u; args=allargs} - else NoInvert - in let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in + let iv = if Typeops.should_invert_case env ans.asw_ci then + CaseInvert {indices=realargs} + else NoInvert + in let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in let pT = hnf_prod_applist_assum env nparamdecls @@ -343,7 +343,8 @@ and nf_atom_type env sigma atom = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs a in - mkCase(ans.asw_ci, p, iv, a, branchs), tcase + let ci = ans.asw_ci in + mkCase (Inductive.contract_case env (ci, p, iv, a, branchs)), tcase | Afix(tt,ft,rp,s) -> let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in let tt = Array.map fst tt and rt = Array.map snd tt in @@ -468,15 +469,15 @@ let start_profiler_linux profile_fn = Unix.stdin dev_null dev_null in (* doesn't seem to be a way to test whether process creation succeeded *) - if !Flags.debug then - Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); + debug_native_compiler (fun () -> + Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); Some profiler_pid (* kill profiler via SIGINT *) let stop_profiler_linux m_pid = match m_pid with | Some pid -> ( - let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in + let _ = debug_native_compiler (fun () -> Pp.str "Stopping native code profiler") in try Unix.kill pid Sys.sigint; let _ = Unix.waitpid [] pid in () diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index f6d61f4892..553511f1bf 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -18,7 +18,6 @@ type patvar = Id.t type case_info_pattern = { cip_style : Constr.case_style; cip_ind : inductive option; - cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) cip_extensible : bool (** does this match end with _ => _ ? *) } type constr_pattern = @@ -35,8 +34,8 @@ type constr_pattern = | PSort of Sorts.family | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern - | PCase of case_info_pattern * constr_pattern * constr_pattern * - (int * bool list * constr_pattern) list (** index of constructor, nb of args *) + | PCase of case_info_pattern * (Name.t array * constr_pattern) option * constr_pattern * + (int * Name.t array * constr_pattern) list (** index of constructor, nb of args *) | PFix of (int array * int) * (Name.t array * constr_pattern array * constr_pattern array) | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) | PInt of Uint63.t diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b259945d9e..0c4bbf71e2 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -24,7 +24,6 @@ open Environ let case_info_pattern_eq i1 i2 = i1.cip_style == i2.cip_style && Option.equal Ind.CanOrd.equal i1.cip_ind i2.cip_ind && - Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags && i1.cip_extensible == i2.cip_extensible let rec constr_pattern_eq p1 p2 = match p1, p2 with @@ -51,7 +50,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 | PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) -> case_info_pattern_eq info1 info2 && - constr_pattern_eq p1 p2 && + Option.equal (fun (nas1, p1) (nas2, p2) -> Array.equal Name.equal nas1 nas2 && constr_pattern_eq p1 p2) p1 p2 && constr_pattern_eq r1 r2 && List.equal pattern_eq l1 l2 | PFix ((ln1,i1),f1), PFix ((ln2,i2),f2) -> @@ -74,7 +73,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = - Int.equal i1 i2 && List.equal (==) j1 j2 && constr_pattern_eq p1 p2 + Int.equal i1 i2 && Array.equal Name.equal j1 j2 && constr_pattern_eq p1 p2 and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = Array.equal Name.equal n1 n2 && @@ -92,8 +91,8 @@ let rec occur_meta_pattern = function | PIf (c,c1,c2) -> (occur_meta_pattern c) || (occur_meta_pattern c1) || (occur_meta_pattern c2) - | PCase(_,p,c,br) -> - (occur_meta_pattern p) || + | PCase(_, p,c,br) -> + Option.cata (fun (_, p) -> occur_meta_pattern p) false p || (occur_meta_pattern c) || (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) | PArray (t,def,ty) -> @@ -115,10 +114,10 @@ let rec occurn_pattern n = function | PIf (c,c1,c2) -> (occurn_pattern n c) || (occurn_pattern n c1) || (occurn_pattern n c2) - | PCase(_,p,c,br) -> - (occurn_pattern n p) || + | PCase(_, p, c, br) -> + Option.cata (fun (nas, p) -> occurn_pattern (Array.length nas + n) p) false p || (occurn_pattern n c) || - (List.exists (fun (_,_,p) -> occurn_pattern n p) br) + (List.exists (fun (_, nas, p) -> occurn_pattern (Array.length nas + n) p) br) | PMeta _ | PSoApp _ -> true | PEvar (_,args) -> List.exists (occurn_pattern n) args | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false @@ -202,18 +201,26 @@ let pattern_of_constr env sigma t = | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) - | Case (ci,p,_,a,br) -> + | Case (ci, u, pms, p0, iv, a, br0) -> + let (ci, p, iv, a, br) = Inductive.expand_case env (ci, u, pms, p0, iv, a, br0) in + let pattern_of_ctx c (nas, c0) = + let ctx, c = Term.decompose_lam_n_decls (Array.length nas) c in + let env = push_rel_context ctx env in + let c = pattern_of_constr env c in + (Array.map Context.binder_name nas, c) + in + let p = pattern_of_ctx p p0 in let cip = { cip_style = ci.ci_pp_info.style; cip_ind = Some ci.ci_ind; - cip_ind_tags = Some ci.ci_pp_info.ind_tags; cip_extensible = false } in let branch_of_constr i c = - (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) + let nas, c = pattern_of_ctx c br0.(i) in + (i, nas, c) in - PCase (cip, pattern_of_constr env p, pattern_of_constr env a, - Array.to_list (Array.mapi branch_of_constr br)) + PCase (cip, Some p, pattern_of_constr env a, + Array.to_list (Array.mapi branch_of_constr br)) | Fix (lni,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in @@ -241,7 +248,10 @@ let map_pattern_with_binders g f l = function | PLetIn (n,a,t,b) -> PLetIn (n,f l a,Option.map (f l) t,f (g n l) b) | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> - PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + let fold nas l = Array.fold_left (fun l na -> g na l) l nas in + let map_branch (i, n, c) = (i, n, f (fold n l) c) in + let po = Option.map (fun (nas, po) -> nas, (f (fold nas l) po)) po in + PCase (ci,po,f l p, List.map map_branch pl) | PProj (p,pc) -> PProj (p, f l pc) | PFix (lni,(lna,tl,bl)) -> let l' = Array.fold_left (fun l na -> g na l) l lna in @@ -351,7 +361,11 @@ let rec subst_pattern env sigma subst pat = let ind = cip.cip_ind in let ind' = Option.Smart.map (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in - let typ' = subst_pattern env sigma subst typ in + let map ((nas, typ) as t) = + let typ' = subst_pattern env sigma subst typ in + if typ' == typ then t else (nas, typ') + in + let typ' = Option.Smart.map map typ in let c' = subst_pattern env sigma subst c in let subst_branch ((i,n,c) as br) = let c' = subst_pattern env sigma subst c in @@ -381,8 +395,6 @@ let rec subst_pattern env sigma subst pat = let mkPLetIn na b t c = PLetIn(na,b,t,c) let mkPProd na t u = PProd(na,t,u) let mkPLambda na t b = PLambda(na,t,b) -let mkPLambdaUntyped na b = PLambda(na,PMeta None,b) -let rev_it_mkPLambdaUntyped = List.fold_right mkPLambdaUntyped let mkPProd_or_LetIn (na,_,bo,t) c = match bo with @@ -445,18 +457,14 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (nal,(_,None),b,c) -> - let mkGLambda na c = DAst.make ?loc @@ - GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None),c) in - let c = List.fold_right mkGLambda nal c in let cip = { cip_style = LetStyle; cip_ind = None; - cip_ind_tags = None; cip_extensible = false } in - let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in - PCase (cip, PMeta None, pat_of_raw metas vars b, - [0,tags,pat_of_raw metas vars c]) + let tags = Array.of_list nal (* Approximation which can be without let-ins... *) in + PCase (cip, None, pat_of_raw metas vars b, + [0,tags,pat_of_raw metas (List.rev_append (Array.to_list tags) vars) c]) | GCases (sty,p,[c,(na,indnames)],brs) -> let get_ind p = match DAst.get p with | PatCstr((ind,_),_,_) -> Some ind @@ -475,18 +483,17 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function let pred = match p,indnames with | Some p, Some {CAst.v=(_,nal)} -> let nvars = na :: List.rev nal @ vars in - rev_it_mkPLambdaUntyped nal (mkPLambdaUntyped na (pat_of_raw metas nvars p)) - | None, _ -> PMeta None + Some (Array.rev_of_list (na :: List.rev nal), pat_of_raw metas nvars p) + | None, _ -> None | Some p, None -> match DAst.get p with - | GHole _ -> PMeta None + | GHole _ -> None | _ -> user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; cip_ind = ind; - cip_ind_tags = None; cip_extensible = ext } in (* Nota : when we have a non-trivial predicate, @@ -555,10 +562,10 @@ and pats_of_glob_branches loc metas vars ind brs = err ?loc (str "No unique branch for " ++ int j ++ str"-th constructor."); let lna = List.map get_arg lv in - let vars' = List.rev lna @ vars in - let pat = rev_it_mkPLambdaUntyped lna (pat_of_raw metas vars' br) in + let vars' = List.rev_append lna vars in + let tags = Array.of_list lna in + let pat = pat_of_raw metas vars' br in let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in - let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in ext, ((j-1, tags, pat) :: pats) | _ -> err ?loc:loc' (Pp.str "Non supported pattern.") diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 9dbded75ba..e86a8a28c9 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1043,7 +1043,7 @@ struct if not record then let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info !!env (ind_of_ind_type indt) rci LetStyle in - mkCase (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|]) + mkCase (EConstr.contract_case !!env sigma (ci, p, make_case_invert !!env indt ci, cj.uj_val,[|f|])) else it_mkLambda_or_LetIn f fsign in (* Make dependencies from arity signature impossible *) @@ -1159,7 +1159,7 @@ struct let pred = nf_evar sigma pred in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in let ci = make_case_info !!env (fst ind) rci IfStyle in - mkCase (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|]) + mkCase (EConstr.contract_case !!env sigma (ci, pred, make_case_invert !!env indty ci, cj.uj_val, [|b1;b2|])) in let cj = { uj_val = v; uj_type = p } in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 52f60fbc5e..4083d3bc23 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -177,9 +177,12 @@ sig type 'a app_node val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -230,9 +233,12 @@ struct ) + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -245,9 +251,9 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,_,br) -> + | Case (_,_,_,_,_,br) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) (fun (_, c) -> pr_c c) br ++ str ")" | Proj p -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -284,7 +290,7 @@ struct ([],[]) -> Int.equal bal 0 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 - | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> + | (Case _ :: s1, Case _::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Proj (p)::s1, Proj(p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 @@ -304,8 +310,9 @@ struct let t1,l1 = decomp_node_last n1 q1 in let t2,l2 = decomp_node_last n2 q2 in aux (f o t1 t2) l1 l2 - | Case (_,t1,_,a1) :: q1, Case (_,t2,_,a2) :: q2 -> - aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 + | Case ((_,_,pms1,(_, t1),_,a1)) :: q1, Case ((_,_,pms2, (_, t2),_,a2)) :: q2 -> + let f' o (_, t1) (_, t2) = f o t1 t2 in + aux (Array.fold_left2 f' (f (Array.fold_left2 f o pms1 pms2) t1 t2) a1 a2) q1 q2 | Proj (p1) :: q1, Proj (p2) :: q2 -> aux o q1 q2 | Fix ((_,(_,a1,b1)),s1) :: q1, Fix ((_,(_,a2,b2)),s2) :: q2 -> @@ -320,8 +327,8 @@ struct | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) - | Case (info,ty,iv,br) -> - Case (info, f ty, map_invert f iv, Array.map f br) + | Case (info,u,pms,ty,iv,br) -> + Case (info, u, Array.map f pms, on_snd f ty, iv, Array.map (on_snd f) br) | Fix ((r,(na,ty,bo)),arg) -> Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg) | Primitive (p,c,args,kargs) -> @@ -408,7 +415,7 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,iv,br)::s) -> zip (mkCase (ci,rt,iv,f,br), s) + | f, (Case (ci,u,pms,rt,iv,br)::s) -> zip (mkCase (ci,u,pms,rt,iv,f,br), s) | f, (Fix (fix,st)::s) -> zip (mkFix fix, st @ (append_app [|f|] s)) | f, (Proj (p)::s) -> zip (mkProj (p,f),s) @@ -461,23 +468,6 @@ let safe_meta_value sigma ev = try Some (Evd.meta_value sigma ev) with Not_found -> None -let strong_with_flags whdfun flags env sigma t = - let push_rel_check_zeta d env = - let open CClosure.RedFlags in - let d = match d with - | LocalDef (na,c,t) when not (red_set flags fZETA) -> LocalAssum (na,t) - | d -> d in - push_rel d env in - let rec strongrec env t = - map_constr_with_full_binders sigma - push_rel_check_zeta strongrec env (whdfun flags env sigma t) in - strongrec env t - -let strong whdfun env sigma t = - let rec strongrec env t = - map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in - strongrec env t - (*************************************) (*** Reduction using bindingss ***) (*************************************) @@ -696,27 +686,37 @@ module CredNative = RedNative(CNativeEntries) contract_* in any case . *) -let debug_RAKAM = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"RAKAM"] - ~value:false +let debug_RAKAM = CDebug.create ~name:"RAKAM" () + +let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = + let args = Stack.tail ci.ci_npar args in + let args = Option.get (Stack.list_of_app_stack args) in + let br = lf.(i - 1) in + if Int.equal ci.ci_cstr_nargs.(i - 1) ci.ci_cstr_ndecls.(i - 1) then + (* No let-bindings *) + let subst = List.rev args in + Vars.substl subst (snd br) + else + (* For backwards compat with unification, we do not reduce the let-bindings + upfront. *) + let ctx = expand_branch env sigma u pms (ind, i) br in + applist (it_mkLambda_or_LetIn (snd br) ctx, args) let rec whd_state_gen flags env sigma = let open Context.Named.Declaration in let rec whrec (x, stack) : state = - let () = if debug_RAKAM () then + let () = let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_debug + debug_RAKAM (fun () -> (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str ">>"))) in let c0 = EConstr.kind sigma x in let fold () = - let () = if debug_RAKAM () then - let open Pp in Feedback.msg_debug (str "<><><><><>") in + let () = debug_RAKAM (fun () -> + let open Pp in str "<><><><><>") in ((EConstr.of_kind c0, stack)) in match c0 with @@ -785,8 +785,8 @@ let rec whd_state_gen flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,iv,d,lf) -> - whrec (d, Stack.Case (ci,p,iv,lf) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,u,pms,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -794,13 +794,14 @@ let rec whd_state_gen flags env sigma = |Some (bef,arg,s') -> whrec (arg, Stack.Fix(f,bef)::s')) - | Construct ((ind,c),u) -> + | Construct (cstr ,u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case case::s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec (r, s') |args, (Stack.Proj (p)::s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s')::s'') when use_fix -> @@ -850,7 +851,7 @@ let rec whd_state_gen flags env sigma = whrec (** reduction machine without global env and refold machinery *) -let local_whd_state_gen flags _env sigma = +let local_whd_state_gen flags env sigma = let rec whrec (x, stack) = let c0 = EConstr.kind sigma x in let s = (EConstr.of_kind c0, stack) in @@ -882,8 +883,8 @@ let local_whd_state_gen flags _env sigma = | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> (whrec (c, Stack.Proj (p) :: stack)) - | Case (ci,p,iv,d,lf) -> - whrec (d, Stack.Case (ci,p,iv,lf) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec (d, Stack.Case (ci,u,pms,p,iv,lf) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -896,13 +897,14 @@ let local_whd_state_gen flags _env sigma = Some c -> whrec (c,stack) | None -> s) - | Construct ((ind,c),u) -> + | Construct (cstr, u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case case :: s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec (r, s') |args, (Stack.Proj (p) :: s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s')::s'') when use_fix -> @@ -955,6 +957,9 @@ let whd_betalet = red_of_state_red whd_betalet_state (* 2. Delta Reduction Functions *) +let whd_const_state c e = raw_whd_state_gen CClosure.RedFlags.(mkflags [fCONST c]) e +let whd_const c = red_of_state_red (whd_const_state c) + let whd_delta_state e = raw_whd_state_gen CClosure.delta e let whd_delta_stack = stack_red_of_state_red whd_delta_state let whd_delta = red_of_state_red whd_delta_state @@ -1258,7 +1263,9 @@ let plain_instance sigma s c = match s with let instance env sigma s c = (* if s = [] then c else *) - strong whd_betaiota env sigma (plain_instance sigma s c) + (* No need to compute contexts under binders as whd_betaiota is local *) + let rec strongrec t = EConstr.map sigma strongrec (whd_betaiota env sigma t) in + strongrec (plain_instance sigma s c) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index ae93eb48b4..09bcc860d0 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -19,7 +19,7 @@ open Environ exception Elimconst -val debug_RAKAM : unit -> bool +val debug_RAKAM : CDebug.t module CredNative : Primred.RedNative with type elem = EConstr.t and type args = EConstr.t array and type evd = Evd.evar_map @@ -57,9 +57,12 @@ module Stack : sig val pr_app_node : ('a -> Pp.t) -> 'a app_node -> Pp.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array + type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array + | Case of 'a case_stk | Proj of Projection.t | Fix of ('a, 'a) pfixpoint * 'a t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red @@ -140,13 +143,6 @@ type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type stack_reduction_function = env -> evar_map -> constr -> constr * constr list -(** {6 Reduction Function Operators } *) - -val strong_with_flags : - (CClosure.RedFlags.reds -> reduction_function) -> - (CClosure.RedFlags.reds -> reduction_function) -val strong : reduction_function -> reduction_function - (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function @@ -182,6 +178,7 @@ val whd_betalet_stack : stack_reduction_function (** {6 Head normal forms } *) +val whd_const : Constant.t -> reduction_function val whd_delta_stack : stack_reduction_function val whd_delta : reduction_function val whd_betadeltazeta_stack : stack_reduction_function diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 34bcd0982c..064990f6bf 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -129,7 +129,8 @@ let retype ?(polyprop=true) sigma = | Evar ev -> existential_type sigma ev | Ind (ind, u) -> EConstr.of_constr (rename_type_of_inductive env (ind, EInstance.kind sigma u)) | Construct (cstr, u) -> EConstr.of_constr (rename_type_of_constructor env (cstr, EInstance.kind sigma u)) - | Case (_,p,_iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> + let (_,p,iv,c,lf) = EConstr.expand_case env sigma (ci,u,pms,p,iv,c,lf) in let Inductiveops.IndType(indf,realargs) = let t = type_of env c in try Inductiveops.find_rectype env sigma t @@ -309,7 +310,7 @@ let relevance_of_term env sigma c = | Const (c,_) -> Relevanceops.relevance_of_constant env c | Ind _ -> Sorts.Relevant | Construct (c,_) -> Relevanceops.relevance_of_constructor env c - | Case (ci, _, _, _, _) -> ci.ci_relevance + | Case (ci, _, _, _, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> Relevanceops.relevance_of_projection env p diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index c705ac16e7..430813e874 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -43,14 +43,32 @@ exception ReductionTacticError of reduction_tactic_error exception Elimconst exception Redelimination +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + +(* Better to have it here that in closure, since used in grammar.cma *) +let eq_egr e1 e2 = match e1, e2 with + EvalConstRef con1, EvalConstRef con2 -> Constant.CanOrd.equal con1 con2 + | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 + | _, _ -> false + +(* Here the semantics is completely unclear. + What does "Hint Unfold t" means when "t" is a parameter? + Does the user mean "Unfold X.t" or does she mean "Unfold y" + where X.t is later on instantiated with y? I choose the first + interpretation (i.e. an evaluable reference is never expanded). *) +let subst_evaluable_reference subst = function + | EvalVarRef id -> EvalVarRef id + | EvalConstRef kn -> EvalConstRef (Mod_subst.subst_constant subst kn) + let error_not_evaluable r = user_err ~hdr:"error_not_evaluable" (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && - (evaluable_constant cst env || is_primitive env cst) + is_transparent env (ConstKey cst) && evaluable_constant cst env let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -144,6 +162,10 @@ let reference_value env sigma c u = | None -> raise NotEvaluable | Some d -> d +let is_primitive_val sigma c = match EConstr.kind sigma c with + | Int _ | Float _ | Array _ -> true + | _ -> false + (************************************************************************) (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) (* One reuses the name of the function after reduction of the fixpoint *) @@ -277,8 +299,8 @@ let compute_consteval_direct env sigma ref = | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) - | Case (_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n - | Case (_,_,_,d,_) -> srec env n labs true d + | Case (_,_,_,_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n + | Case (_,_,_,_,_,d,_) -> srec env n labs true d | Proj (p, d) when isRel sigma d -> EliminationProj n | _ -> NotAnElimination in @@ -362,11 +384,6 @@ let x = Name default_dependent_ident do so that the reduction uses this extra information *) let dummy = mkProp -let vfx = Id.of_string "_expanded_fix_" -let vfun = Id.of_string "_eliminator_function_" -let venv = let open Context.Named.Declaration in - val_of_named_context [LocalAssum (make_annot vfx Sorts.Relevant, dummy); - LocalAssum (make_annot vfun Sorts.Relevant, dummy)] (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -381,10 +398,10 @@ let substl_with_function subst sigma constr = match v.(i-k-1) with | (fx, Some (min, ref)) -> let sigma = !evd in - let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in + let (sigma, evk) = Evarutil.new_pure_evar empty_named_context_val sigma dummy in evd := sigma; - minargs := Evar.Map.add evk min !minargs; - Vars.lift k (mkEvar (evk, [fx; ref])) + minargs := Evar.Map.add evk (min, fx, ref) !minargs; + mkEvar (evk, []) | (fx, None) -> Vars.lift k fx else mkRel (i - Array.length v) | _ -> @@ -397,14 +414,14 @@ exception Partial (* each problem variable that cannot be made totally applied even by reduction is solved by the expanded fix term. *) let solve_arity_problem env sigma fxminargs c = - let evm = ref sigma in - let set_fix i = evm := Evd.define i (mkVar vfx) !evm in + let set = ref Evar.Set.empty in + let set_fix i = set := Evar.Set.add i !set in let rec check strict c = let c' = whd_betaiotazeta env sigma c in let (h,rcargs) = decompose_app_vect sigma c' in match EConstr.kind sigma h with - Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> - let minargs = Evar.Map.find i fxminargs in + Evar(i,_) when Evar.Map.mem i fxminargs && not (Evar.Set.mem i !set) -> + let minargs, _, _ = Evar.Map.find i fxminargs in if Array.length rcargs < minargs then if strict then set_fix i else raise Partial; @@ -413,45 +430,95 @@ let solve_arity_problem env sigma fxminargs c = (let ev, u = destEvalRefU sigma h in match reference_opt_value env sigma ev u with | Some h' -> - let bak = !evm in + let bak = !set in (try Array.iter (check false) rcargs with Partial -> - evm := bak; + set := bak; check strict (mkApp(h',rcargs))) | None -> Array.iter (check strict) rcargs) | _ -> EConstr.iter sigma (check strict) c' in check true c; - !evm + !set let substl_checking_arity env subst sigma c = (* we initialize the problem: *) let body,sigma,minargs = substl_with_function subst sigma c in (* we collect arity constraints *) - let sigma' = solve_arity_problem env sigma minargs body in + let ans = solve_arity_problem env sigma minargs body in (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) - let rec nf_fix c = match EConstr.kind sigma c with - | Evar (i,[fx;f]) when Evar.Map.mem i minargs -> + let rec nf_fix k c = match EConstr.kind sigma c with + | Evar (i, []) -> (* FIXME: find a less hackish way of doing this *) - begin match EConstr.kind sigma' c with - | Evar _ -> f - | c -> EConstr.of_kind c + begin match Evar.Map.find i minargs with + | (_, fx, ref) -> + if Evar.Set.mem i ans then Vars.lift k fx + else Vars.lift k ref + | exception Not_found -> + (* An argumentless evar that was not generated by substl_with_function *) + c end - | _ -> EConstr.map sigma nf_fix c + | _ -> EConstr.map_with_binders sigma succ nf_fix k c in - nf_fix body + nf_fix 0 body type fix_reduction_result = NotReducible | Reduced of (constr * constr list) let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = + let (names, (nbfix, lv, n)), u, largs = f in + let lu = List.firstn n largs in + let p = List.length lv in + let lyi = List.map fst lv in + let la = + List.map_i (fun q aq -> + (* k from the comment is q+1 *) + try mkRel (p+1-(List.index Int.equal (n-q) lyi)) + with Not_found -> Vars.lift p aq) + 0 lu + in + let f i = match names.(i) with + | None -> None + | Some (minargs,ref) -> + let body = applist (mkEvalRef ref u, la) in + let g = + List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> + let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in + let tij' = Vars.substl (List.rev subst) tij in + let x = make_annot x Sorts.Relevant in (* TODO relevance *) + mkLambda (x,tij',c)) 1 body (List.rev lv) + in Some (minargs,g) + in let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = List.init nbodies make_Fi in - substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) + let c = substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum)) in + nf_beta env sigma c let contract_cofix_use_function env sigma f - (bodynum,(_names,_,bodies as typedbodies)) = + (bodynum,(names,_,bodies as typedbodies)) args = + let f = + if isConst sigma f then + let minargs = List.length args in + fun i -> + if Int.equal i bodynum then Some (minargs, f) + else match names.(i).binder_name with + | Anonymous -> None + | Name id -> + (* In case of a call to another component of a block of + mutual inductive, try to reuse the global name if + the block was indeed initially built as a global + definition *) + let (kn, u) = destConst sigma f in + let kn = Constant.change_label kn (Label.of_id id) in + let cst = (kn, EInstance.kind sigma u) in + try match constant_opt_value_in env cst with + | None -> None + (* TODO: check kn is correct *) + | Some _ -> Some (minargs,mkConstU (kn, u)) + with Not_found -> None + else + fun _ -> None in let nbodies = Array.length bodies in let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = List.init nbodies make_Fi in @@ -459,56 +526,40 @@ let contract_cofix_use_function env sigma f sigma (nf_beta env sigma bodies.(bodynum)) type 'a miota_args = { - mP : constr; (** the result type *) + mU : EInstance.t; (* Universe instance of the return clause *) + mParams : constr array; (* Parameters of the inductive *) + mP : case_return; (* the result type *) mconstr : constr; (** the constructor *) mci : case_info; (** special info to re-build pattern *) mcargs : 'a list; (** the constructor's arguments *) - mlf : 'a array } (** the branch code vector *) + mlf : 'a pcase_branch array } (** the branch code vector *) -let reduce_mind_case sigma mia = +let reduce_mind_case env sigma mia = match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> -(* let ncargs = (fst mia.mci).(i-1) in*) + | Construct ((_, i as cstr), u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1),real_cargs) + let br = mia.mlf.(i - 1) in + let ctx = EConstr.expand_branch env sigma mia.mU mia.mParams cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + applist (br, real_cargs) | CoFix cofix -> let cofix_def = contract_cofix sigma cofix in (* XXX Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false -let reduce_mind_case_use_function func env sigma mia = +let reduce_mind_case_use_function f env sigma mia = match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> + | Construct ((_, i as cstr),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1), real_cargs) + let br = mia.mlf.(i - 1) in + let ctx = EConstr.expand_branch env sigma mia.mU mia.mParams cstr br in + let br = it_mkLambda_or_LetIn (snd br) ctx in + applist (br, real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> - let build_cofix_name = - if isConst sigma func then - let minargs = List.length mia.mcargs in - fun i -> - if Int.equal i bodynum then Some (minargs,func) - else match names.(i).binder_name with - | Anonymous -> None - | Name id -> - (* In case of a call to another component of a block of - mutual inductive, try to reuse the global name if - the block was indeed initially built as a global - definition *) - let (kn, u) = destConst sigma func in - let kn = Constant.change_label kn (Label.of_id id) in - let cst = (kn, EInstance.kind sigma u) in - try match constant_opt_value_in env cst with - | None -> None - (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConstU (kn, u)) - with Not_found -> None - else - fun _ -> None in let cofix_def = - contract_cofix_use_function env sigma build_cofix_name cofix in - (* Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + contract_cofix_use_function env sigma f cofix mia.mcargs in + mkCase (mia.mci, mia.mU, mia.mParams, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -658,7 +709,7 @@ let rec red_elim_const env sigma ref u largs = let f = ([|Some (minfxargs,ref)|],infos), u, largs in (match reduce_fix_use_function env sigma f (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) + | Reduced (c,rest) -> (c, rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend (ref,u) args = let c = reference_value env sigma ref u in @@ -672,7 +723,7 @@ let rec red_elim_const env sigma ref u largs = let f = refinfos, u, midargs in (match reduce_fix_use_function env sigma f (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) + | Reduced (c,rest) -> (c, rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in (whd_betaiotazeta env sigma (applist (c, largs)), []), nocase @@ -689,7 +740,8 @@ and reduce_params env sigma stack l = let arg = List.nth stack i in let rarg = whd_construct_stack env sigma arg in match EConstr.kind sigma (fst rarg) with - | Construct _ -> List.assign stack i (applist rarg) + | Construct _ | Int _ | Float _ | Array _ -> + List.assign stack i (applist rarg) | _ -> raise Redelimination) stack l @@ -709,9 +761,9 @@ and whd_simpl_stack env sigma = | LetIn (n,b,t,c) -> redrec (Vars.substl [b] c, stack) | App (f,cl) -> assert false (* see push_app above *) | Cast (c,_,_) -> redrec (c, stack) - | Case (ci,p,iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> (try - redrec (special_red_case env sigma (ci,p,iv,c,lf), stack) + redrec (special_red_case env sigma (ci,u,pms,p,iv,c,lf), stack) with Redelimination -> s') | Fix fix -> @@ -745,6 +797,16 @@ and whd_simpl_stack env sigma = else s' with Redelimination -> s') + | Const (cst, _) when is_primitive env cst -> + (try + let args = + List.map_filter_i (fun i a -> + match a with CPrimitives.Kwhnf -> Some i | _ -> None) + (CPrimitives.kind (Option.get (get_primitive env cst))) in + let stack = reduce_params env sigma stack args in + whd_const cst env sigma (applist (x, stack)), [] + with Redelimination -> s') + | _ -> match match_eval_ref env sigma x stack with | Some (ref, u) -> @@ -786,29 +848,6 @@ and reduce_fix_use_function env sigma f fix stack = let stack' = List.assign stack recargnum (applist recarg') in (match EConstr.kind sigma recarg'hd with | Construct _ -> - let (names, (nbfix, lv, n)), u, largs = f in - let lu = List.firstn n largs in - let p = List.length lv in - let lyi = List.map fst lv in - let la = - List.map_i (fun q aq -> - (* k from the comment is q+1 *) - try mkRel (p+1-(List.index Int.equal (n-q) lyi)) - with Not_found -> Vars.lift p aq) - 0 lu - in - let f i = match names.(i) with - | None -> None - | Some (minargs,ref) -> - let body = applist (mkEvalRef ref u, la) in - let g = - List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> - let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in - let tij' = Vars.substl (List.rev subst) tij in - let x = make_annot x Sorts.Relevant in (* TODO relevance *) - mkLambda (x,tij',c)) 1 body (List.rev lv) - in Some (minargs,g) - in Reduced (contract_fix_use_function env sigma f fix,stack') | _ -> NotReducible) @@ -823,15 +862,15 @@ and reduce_proj env sigma c = let proj_narg = Projection.npars proj + Projection.arg proj in List.nth cargs proj_narg | _ -> raise Redelimination) - | Case (n,p,iv,c,brs) -> + | Case (n,u,pms,p,iv,c,brs) -> let c' = redrec c in - let p = (n,p,iv,c',brs) in + let p = (n,u,pms,p,iv,c',brs) in (try special_red_case env sigma p with Redelimination -> mkCase p) | _ -> raise Redelimination in redrec c -and special_red_case env sigma (ci, p, iv, c, lf) = +and special_red_case env sigma (ci, u, pms, p, iv, c, lf) = let rec redrec s = let (constr, cargs) = whd_simpl_stack env sigma s in match match_eval_ref env sigma constr cargs with @@ -841,25 +880,25 @@ and special_red_case env sigma (ci, p, iv, c, lf) = | Some gvalue -> if reducible_mind_case sigma gvalue then reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; + {mP=p; mU = u; mParams = pms; mconstr=gvalue; mcargs=cargs; mci=ci; mlf=lf} else redrec (gvalue, cargs)) | None -> if reducible_mind_case sigma constr then - reduce_mind_case sigma - {mP=p; mconstr=constr; mcargs=cargs; + reduce_mind_case env sigma + {mP=p; mU = u; mParams = pms; mconstr=constr; mcargs=cargs; mci=ci; mlf=lf} else raise Redelimination in redrec (push_app sigma (c, [])) -(* reduce until finding an applied constructor or fail *) +(* reduce until finding an applied constructor (or primitive value) or fail *) and whd_construct_stack env sigma s = let (constr, cargs as s') = whd_simpl_stack env sigma (s, []) in - if reducible_mind_case sigma constr then s' + if reducible_mind_case sigma constr || is_primitive_val sigma constr then s' else match match_eval_ref env sigma constr cargs with | Some (ref, u) -> (match reference_opt_value env sigma ref u with @@ -896,7 +935,7 @@ let try_red_product env sigma c = let open Context.Rel.Declaration in mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) - | Case (ci,p,iv,d,lf) -> simpfun (mkCase (ci,p,iv,redrec env d,lf)) + | Case (ci,u,pms,p,iv,d,lf) -> simpfun (mkCase (ci,u,pms,p,iv,redrec env d,lf)) | Proj (p, c) -> let c' = match EConstr.kind sigma c with @@ -1015,7 +1054,10 @@ let hnf_constr env sigma c = whd_simpl_orelse_delta_but_fix env sigma (c, []) let whd_simpl env sigma c = applist (whd_simpl_stack env sigma (c, [])) -let simpl env sigma c = strong whd_simpl env sigma c +let simpl env sigma c = + let rec strongrec env t = + map_constr_with_full_binders env sigma push_rel strongrec env (whd_simpl env sigma t) in + strongrec env c (* Reduction at specific subterms *) @@ -1043,7 +1085,7 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = (* Still the same projection, we ignore the change in parameters *) mkProj (p, a') else mkApp (app', [| a' |]) - | _ -> map_constr_with_binders_left_to_right sigma g f acc c + | _ -> map_constr_with_binders_left_to_right env sigma g f acc c let e_contextually byhead (occs,c) f = begin fun env sigma t -> let count = ref (Locusops.initialize_occurrence_counter occs) in @@ -1112,7 +1154,7 @@ let substlin env sigma evalref occs c = count := count'; if ok then value u else c | None -> - map_constr_with_binders_left_to_right sigma + map_constr_with_binders_left_to_right env sigma (fun _ () -> ()) substrec () c in @@ -1276,9 +1318,9 @@ let one_step_reduce env sigma c = | App (f,cl) -> redrec (f, (Array.to_list cl)@stack) | LetIn (_,f,_,cl) -> (Vars.subst1 f cl,stack) | Cast (c,_,_) -> redrec (c,stack) - | Case (ci,p,iv,c,lf) -> + | Case (ci,u,pms,p,iv,c,lf) -> (try - (special_red_case env sigma (ci,p,iv,c,lf), stack) + (special_red_case env sigma (ci,u,pms,p,iv,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> (try match reduce_fix env sigma fix stack with diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 65e3421736..aa232175bb 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -18,6 +18,21 @@ open Locus open Univ open Ltac_pretype +(* XXX: Move to a module *) +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + +val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool + +(** Here the semantics is completely unclear. + What does "Hint Unfold t" means when "t" is a parameter? + Does the user mean "Unfold X.t" or does she mean "Unfold y" + where X.t is later on instantiated with y? I choose the first + interpretation (i.e. an evaluable reference is never expanded). *) +val subst_evaluable_reference : + Mod_subst.substitution -> evaluable_global_reference -> evaluable_global_reference + type reduction_tactic_error = InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index e3e5244a8c..5b8b367ff2 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -178,7 +178,7 @@ let type_case_branches env sigma (ind,largs) pj c = let ty = whd_betaiota env sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in sigma, (lc, ty, Sorts.relevance_of_sort ps) -let judge_of_case env sigma ci pj iv cj lfj = +let judge_of_case env sigma case ci pj iv cj lfj = let ((ind, u), spec) = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in @@ -189,7 +189,7 @@ let judge_of_case env sigma ci pj iv cj lfj = let () = if (match iv with | NoInvert -> false | CaseInvert _ -> true) != should_invert_case env ci then Type_errors.error_bad_invert env in - sigma, { uj_val = mkCase (ci, pj.uj_val, iv, cj.uj_val, Array.map j_val lfj); + sigma, { uj_val = mkCase case; uj_type = rslty } let check_type_fixpoint ?loc env sigma lna lar vdefj = @@ -383,20 +383,23 @@ let rec execute env sigma cstr = let sigma, ty = type_of_constructor env sigma ctor in sigma, make_judge cstr ty - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> + let case = (ci, u, pms, p, iv, c, lf) in + let (ci, p, iv, c, lf) = EConstr.expand_case env sigma case in let sigma, cj = execute env sigma c in let sigma, pj = execute env sigma p in let sigma, lfj = execute_array env sigma lf in let sigma = match iv with | NoInvert -> sigma - | CaseInvert {univs;args} -> - let t = mkApp (mkIndU (ci.ci_ind,univs), args) in + | CaseInvert {indices} -> + let args = Array.append pms indices in + let t = mkApp (mkIndU (ci.ci_ind,u), args) in let sigma, tj = execute env sigma t in let sigma, tj = type_judgment env sigma tj in let sigma = check_actual_type env sigma cj tj.utj_val in sigma in - judge_of_case env sigma ci pj iv cj lfj + judge_of_case env sigma case ci pj iv cj lfj | Fix ((vn,i as vni),recdef) -> let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 3d3010d1a4..df0f49a033 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -49,11 +49,7 @@ let is_keyed_unification = ~key:["Keyed";"Unification"] ~value:false -let debug_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"Tactic";"Unification"] - ~value:false +let debug_tactic_unification = CDebug.create ~name:"tactic-unification" () (** Making this unification algorithm correct w.r.t. the evar-map abstraction breaks too much stuff. So we redefine incorrect functions here. *) @@ -563,7 +559,7 @@ let is_rigid_head sigma flags t = | Construct _ | Int _ | Float _ | Array _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ - | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _, _) + | Lambda _ | LetIn _ | App (_, _) | Case _ | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = @@ -652,7 +648,7 @@ let rec is_neutral env sigma ts t = not (TransparentState.is_transparent_variable ts id) | Rel n -> true | Evar _ | Meta _ -> true - | Case (_, p, _, c, _) -> is_neutral env sigma ts c + | Case (_, _, _, _, _, c, _) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) @@ -698,13 +694,22 @@ let careful_infer_conv ~pb ~ts env sigma m n = (fun sigma -> infer_conv ~pb ~ts env sigma m n) else infer_conv ~pb ~ts env sigma m n +type maybe_ground = Ground | NotGround | Unknown + +let error_cannot_unify_local env sigma (m, n, p) = + error_cannot_unify_local env sigma (fst m, fst n, p) + +let fast_occur_meta_or_undefined_evar sigma (c, gnd) = match gnd with +| Unknown -> occur_meta_or_undefined_evar sigma c +| Ground -> false +| NotGround -> true + let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in let () = - if debug_unification () then - Feedback.msg_debug ( + debug_tactic_unification (fun () -> Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ Termops.Internal.print_constr_env curenv sigma cN) in @@ -795,7 +800,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else Evd.set_eq_sort curenv sigma s1 s2 in (sigma', metasubst, evarsubst) with e when CErrors.noncritical e -> - error_cannot_unify curenv sigma (m,n)) + error_cannot_unify curenv sigma (fst m,fst n)) | Lambda (na,t1,c1), Lambda (__,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} @@ -853,7 +858,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) - | Case (ci1,p1,_,c1,cl1), Case (ci2,p2,_,c2,cl2) -> + | Case (ci1, u1, pms1, p1, iv1, c1, cl1), Case (ci2, u2, pms2, p2, iv2, c2, cl2) -> + let (ci1, p1, iv1, c1, cl1) = EConstr.expand_case env sigma (ci1, u1, pms1, p1, iv1, c1, cl1) in + let (ci2, p2, iv2, c2, cl2) = EConstr.expand_case env sigma (ci2, u2, pms2, p2, iv2, c2, cl2) in (try if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in @@ -963,7 +970,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e modulo_delta = TransparentState.full; modulo_eta = true; modulo_betaiota = true } - ty1 ty2 + (ty1, Unknown) (ty2, Unknown) with RetypeError _ -> substn and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = @@ -1126,15 +1133,17 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - if debug_unification () then Feedback.msg_debug (str "Starting unification"); + debug_tactic_unification (fun () -> str "Starting unification"); let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in try let res = if subterm_restriction opt flags || - occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n + fast_occur_meta_or_undefined_evar sigma m || fast_occur_meta_or_undefined_evar sigma n then None else + let (m, _) = m in + let (n, _) = n in let ans = match flags.modulo_conv_on_closed_terms with | Some convflags -> careful_infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb env sigma flags m n in @@ -1150,15 +1159,16 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e in let a = match res with | Some sigma -> sigma, ms, es - | None -> unirec_rec (env,0) cv_pb opt subst m n in - if debug_unification () then Feedback.msg_debug (str "Leaving unification with success"); + | None -> unirec_rec (env,0) cv_pb opt subst (fst m) (fst n) in + debug_tactic_unification (fun () -> str "Leaving unification with success"); a with e -> let e = Exninfo.capture e in - if debug_unification () then Feedback.msg_debug (str "Leaving unification with failure"); + debug_tactic_unification (fun () -> str "Leaving unification with failure"); Exninfo.iraise e -let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env +let unify_0 env sigma pb flags c1 c2 = + unify_0_with_initial_metas (sigma,[],[]) true env pb flags (c1, Unknown) (c2, Unknown) let left = true let right = false @@ -1492,13 +1502,13 @@ let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta sigma (head_app env sigma m) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma n) - (get_type_of env sigma m) + (get_type_of env sigma n, Unknown) + (get_type_of env sigma m, Unknown) else if isEvar_or_Meta sigma (head_app env sigma n) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma m) - (get_type_of env sigma n) + (get_type_of env sigma m, Unknown) + (get_type_of env sigma n, Unknown) else subst let try_resolve_typeclasses env evd flag m n = @@ -1509,7 +1519,7 @@ let try_resolve_typeclasses env evd flag m n = let w_unify_core_0 env evd with_types cv_pb flags m n = let (mc1,evd') = retract_coercible_metas evd in - let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) m n in + let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) (fst m) (fst n) in let subst2 = unify_0_with_initial_metas (sigma,ms,es) false env cv_pb flags.core_unify_flags m n @@ -1522,7 +1532,7 @@ let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_array env evd flags f1 l1 f2 l2 = let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in let (mc1,evd') = retract_coercible_metas evd in - let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in + let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags (m, Unknown) (n, Unknown) in let subst = fold_subst (evd', [], []) f1 f2 in let subst = Array.fold_left2 fold_subst subst l1 l2 in let evd = w_merge env true flags.merge_unify_flags subst in @@ -1609,6 +1619,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = restrict_conv_on_strict_subterms = true } } else default_matching_flags pending in let n = Array.length (snd (decompose_app_vect sigma c)) in + let cgnd = if occur_meta_or_undefined_evar sigma c then NotGround else Ground in let matching_fun _ t = try let t',l2 = @@ -1622,7 +1633,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else applist (t,l1), l2 else t, [] in - let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in + let sigma = w_typed_unify env sigma Reduction.CONV flags (c, cgnd) (t', Unknown) in let ty = Retyping.get_type_of env sigma t in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) @@ -1678,7 +1689,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val d sign,depdecls) | (AllOccurrences | AtLeastOneOccurrence), InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in + let newdecl = replace_term_occ_decl_modulo env sigma occ test mkvarid d in if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl && not (indirectly_dependent sigma c d depdecls) then @@ -1689,7 +1700,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val newdecl sign, newdecl :: depdecls) | occ -> (* There are specific occurrences, hence not like first *) - let newdecl = replace_term_occ_decl_modulo sigma (AtOccs occ) test mkvarid d in + let newdecl = replace_term_occ_decl_modulo env sigma (AtOccs occ) test mkvarid d in (push_named_context_val newdecl sign, newdecl :: depdecls) in try let sign,depdecls = @@ -1699,7 +1710,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo sigma occ test mkvarid concl + replace_term_occ_modulo env sigma occ test mkvarid concl in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in @@ -1763,6 +1774,7 @@ let keyed_unify env evd kop = let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let bestexn = ref None in let kop = Keys.constr_key (fun c -> EConstr.kind evd c) op in + let opgnd = if occur_meta_or_undefined_evar evd op then NotGround else Ground in let rec matchrec cl = let cl = strip_outer_cast evd cl in (try @@ -1772,7 +1784,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let f1, l1 = decompose_app_vect evd op in let f2, l2 = decompose_app_vect evd cl in w_typed_unify_array env evd flags f1 l1 f2 l2,cl - else w_typed_unify env evd CONV flags op cl,cl + else w_typed_unify env evd CONV flags (op, opgnd) (cl, Unknown),cl with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; user_err Pp.(str "Unsat")) else user_err Pp.(str "Bound 1") @@ -1787,11 +1799,11 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec c1 with ex when precatchable_exception ex -> matchrec c2) - | Case(_,_,_,c,lf) -> (* does not search in the predicate *) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) (try matchrec c with ex when precatchable_exception ex -> - iter_fail matchrec lf) + iter_fail matchrec (Array.map snd lf)) | LetIn(_,c1,_,c2) -> (try matchrec c1 @@ -1867,11 +1879,12 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = else bind (f a.(i)) (ffail (i+1)) in ffail 0 in + let opgnd = if occur_meta_or_undefined_evar evd op then NotGround else Ground in let rec matchrec cl = let cl = strip_outer_cast evd cl in (bind (if closed0 evd cl - then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) + then return (fun () -> w_typed_unify env evd CONV flags (op, opgnd) (cl, Unknown),cl) else fail "Bound 1") (match EConstr.kind evd cl with | App (f,args) -> @@ -1881,8 +1894,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let c2 = args.(n-1) in bind (matchrec c1) (matchrec c2) - | Case(_,_,_,c,lf) -> (* does not search in the predicate *) - bind (matchrec c) (bind_iter matchrec lf) + | Case(_,_,_,_,_,c,lf) -> (* does not search in the predicate *) + bind (matchrec c) (bind_iter matchrec (Array.map snd lf)) | Proj (p,c) -> matchrec c @@ -2050,7 +2063,7 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = raise ex) (* General case: try first order *) - | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + | _ -> w_typed_unify env evd cv_pb flags (ty1, Unknown) (ty2, Unknown) (* Profiling *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 077597c278..c4de353d18 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -116,13 +116,3 @@ val unify_0 : Environ.env -> types -> types -> subst0 - -val unify_0_with_initial_metas : - subst0 -> - bool -> - Environ.env -> - Evd.conv_pb -> - core_unify_flags -> - types -> - types -> - subst0 diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 1420401875..cf6d581066 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -284,10 +284,10 @@ and nf_stk ?from:(from=0) env sigma c t stk = let tcase = build_case_type p realargs c in let ci = Inductiveops.make_case_info env ind relevance RegularStyle in let iv = if Typeops.should_invert_case env ci then - CaseInvert {univs=u; args=allargs} + CaseInvert {indices=realargs} else NoInvert in - nf_stk env sigma (mkCase(ci, p, iv, c, branchs)) tcase stk + nf_stk env sigma (mkCase (Inductive.contract_case env (ci, p, iv, c, branchs))) tcase stk | Zproj p :: stk -> assert (from = 0) ; let p' = Projection.make p true in diff --git a/printing/printer.ml b/printing/printer.ml index 1425cebafc..ca9dee2df6 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -480,7 +480,7 @@ let pr_goal_name sigma g = let pr_goal_header nme sigma g = let (g,sigma) = Goal.V82.nf_evar sigma g in - str "subgoal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") + str "goal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") ++ (if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g) else mt ()) (* display the conclusion of a goal *) @@ -753,10 +753,10 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | [] -> let exl = Evd.undefined_map sigma in if Evar.Map.is_empty exl then - v 0 (str "No more subgoals." ++ pr_evar_info None sigma seeds) + v 0 (str "No more goals." ++ pr_evar_info None sigma seeds) else let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in - v 0 ((str "No more subgoals," + v 0 ((str "No more goals," ++ str " but there are non-instantiated existential variables:" ++ cut () ++ (hov 0 pei) ++ pr_evar_info None sigma seeds @@ -765,9 +765,9 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map let goals = print_multiple_goals g1 rest in let ngoals = List.length rest+1 in v 0 ( - int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") + int ngoals ++ focused_if_needed ++ str(String.plural ngoals "goal") ++ print_extra - ++ str (if pr_first && (should_gname()) && ngoals > 1 then ", subgoal 1" else "") + ++ str (if pr_first && (should_gname()) && ngoals > 1 then ", goal 1" else "") ++ (if pr_first && should_tag() then pr_goal_tag g1 else str"") ++ (if pr_first then pr_goal_name sigma g1 else mt()) ++ cut () ++ goals ++ (if unfocused=[] then str "" @@ -792,7 +792,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = begin match bgoals,shelf,given_up with | [] , [] , g when Evar.Set.is_empty g -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals | [] , [] , _ -> - Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); + Feedback.msg_info (str "No more goals, but there are some goals you gave up:"); fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:(Evar.Set.elements given_up) ++ fnl () ++ str "You need to go back and solve them." diff --git a/printing/printer.mli b/printing/printer.mli index 732af5570d..524c715455 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -154,7 +154,7 @@ val pr_existential_key : evar_map -> Evar.t -> Pp.t val pr_existential : env -> evar_map -> existential -> Pp.t val pr_constructor : env -> constructor -> Pp.t val pr_inductive : env -> inductive -> Pp.t -val pr_evaluable_reference : evaluable_global_reference -> Pp.t +val pr_evaluable_reference : Tacred.evaluable_global_reference -> Pp.t val pr_pconstant : env -> evar_map -> pconstant -> Pp.t val pr_pinductive : env -> evar_map -> pinductive -> Pp.t diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 00ac5a0624..44d3b44077 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -268,7 +268,7 @@ let meta_reducible_instance env evd b = let rec irec u = let u = whd_betaiota env Evd.empty u (* FIXME *) in match EConstr.kind evd u with - | Case (ci,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + | Case (ci,u,pms,p,iv,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in (match try @@ -277,8 +277,10 @@ let meta_reducible_instance env evd b = if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None with - | Some g -> irec (mkCase (ci,p,iv,g,bl)) - | None -> mkCase (ci,irec p,iv,c,Array.map irec bl)) + | Some g -> irec (mkCase (ci,u,pms,p,iv,g,bl)) + | None -> + let on_ctx (na, c) = (na, irec c) in + mkCase (ci,u,Array.map irec pms,on_ctx p,iv,c,Array.map on_ctx bl)) | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> let m = destMeta evd (strip_outer_cast evd f) in (match @@ -627,8 +629,10 @@ let clenv_cast_meta clenv = else mkCast (mkMeta mv, DEFAULTcast, b) with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) - | Case(ci,p,iv,c,br) -> - mkCase (ci, crec_hd p, map_invert crec_hd iv, crec_hd c, Array.map crec br) + | Case(ci,u,pms,p,iv,c,br) -> + (* FIXME: we only change c because [p] is always a lambda and [br] is + most of the time??? *) + mkCase (ci, u, pms, p, iv, crec_hd c, br) | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in diff --git a/proofs/logic.ml b/proofs/logic.ml index f159395177..8b31c07f5e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -265,15 +265,12 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | Case(ci,p,iv,c,br) -> - (* Hack assuming only two situations: the legacy one that branches, - if with Metas, are Meta, and the new one with eta-let-expanded - branches *) - let br = Array.map2 (fun n b -> try snd (Term.decompose_lam_n_decls n b) with UserError _ -> b) ci.ci_cstr_ndecls br in - let acc = Constr.fold (collrec deep) acc p in + | Case(ci,u,pms,p,iv,c,br) -> + let acc = Array.fold_left (collrec deep) acc pms in + let acc = Constr.fold (collrec deep) acc (snd p) in let acc = Constr.fold_invert (collrec deep) acc iv in let acc = Constr.fold (collrec deep) acc c in - Array.fold_left (collrec deep) acc br + Array.fold_left (fun accu (_, br) -> collrec deep accu br) acc br | App _ -> Constr.fold (collrec deep) acc c | Proj (_, c) -> collrec deep acc c | _ -> Constr.fold (collrec true) acc c @@ -369,15 +366,16 @@ let rec mk_refgoals ~check env sigma goalacc conclty trm = let ty = EConstr.Unsafe.to_constr ty in (acc',ty,sigma,c) - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> (* XXX Is ignoring iv OK? *) + let (ci, p, iv, c, lf) = Inductive.expand_case env (ci, u, pms, p, iv, c, lf) in let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let sigma = check_conv_leq_goal ~check env sigma trm conclty' conclty in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',iv,c',lf') + else mkCase (Inductive.contract_case env (ci,p',iv,c',lf')) in (acc'',conclty',sigma, ans) @@ -418,14 +416,15 @@ and mk_hdgoals ~check env sigma goalacc trm = let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) - | Case (ci,p,iv,c,lf) -> + | Case (ci, u, pms, p, iv, c, lf) -> (* XXX is ignoring iv OK? *) + let (ci, p, iv, c, lf) = Inductive.expand_case env (ci, u, pms, p, iv, c, lf) in let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm - else mkCase (ci,p',iv,c',lf') + else mkCase (Inductive.contract_case env (ci,p',iv,c',lf')) in (acc'',conclty',sigma, ans) @@ -479,13 +478,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = | App (f,cl) -> (f, cl) | _ -> (c,[||]) in Array.fold_left3 - (fun (lacc,sigma,bacc) ty fi l -> - if isMeta (strip_outer_cast fi) then - (* Support for non-eta-let-expanded Meta as found in *) - (* destruct/case with an non eta-let expanded elimination scheme *) - let (r,_,s,fi') = mk_refgoals ~check env sigma lacc ty fi in - r,s,(fi'::bacc) - else + (fun (lacc,sigma,bacc) ty fi n -> (* Deal with a branch in expanded form of the form Case(ci,p,c,[|eta-let-exp(Meta);...;eta-let-exp(Meta)|]) as if it were not so, so as to preserve compatibility with when @@ -494,7 +487,6 @@ and treat_case ~check env sigma ci lbrty lf acc' = CAUTION: it does not deal with the general case of eta-zeta reduced branches having a form different from Meta, as it would be theoretically the case with third-party code *) - let n = List.length l in let ctx, body = Term.decompose_lam_n_decls n fi in let head, args = decompose_app_vect body in (* Strip cast because clenv_cast_meta adds a cast when the branch is @@ -503,8 +495,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = let head = strip_outer_cast head in if isMeta head then begin assert (args = Context.Rel.to_extended_vect mkRel 0 ctx); - let head' = lift (-n) head in - let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head' in + let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head in let fi' = it_mkLambda_or_LetIn (mkApp (head'',args)) ctx in (r,s,fi'::bacc) end @@ -513,7 +504,7 @@ and treat_case ~check env sigma ci lbrty lf acc' = let sigma, t'ty = goal_type_of ~check env sigma fi in let sigma = check_conv_leq_goal ~check env sigma fi t'ty ty in (lacc,sigma,fi::bacc)) - (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags + (acc',sigma,[]) lbrty lf ci.ci_cstr_ndecls let convert_hyp ~check ~reorder env sigma d = let id = NamedDecl.get_id d in diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 41cb7399da..dc5a1b0ac2 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -68,7 +68,7 @@ module Strict = struct match sugg with | NeedClosingBrace -> Pp.(str"Try unfocusing with \"}\".") | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> Pp.(str"No more subgoals.") + | ProofFinished -> Pp.(str"No more goals.") | Suggest b -> Pp.(str"Expecting " ++ pr_bullet b ++ str".") | Unfinished b -> Pp.(str"Current bullet " ++ pr_bullet b ++ str" is not finished.") diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 08f88d46c1..6a6dd783e4 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -69,7 +69,7 @@ val pf_reduce_to_atomic_ind : Goal.goal sigma -> types -> (inductive * EInst [@@ocaml.deprecated "Use Tacred.pf_reduce_to_atomic_ind"] val pf_compute : Goal.goal sigma -> constr -> constr [@@ocaml.deprecated "Use the version in Tacmach.New"] -val pf_unfoldn : (occurrences * evaluable_global_reference) list +val pf_unfoldn : (occurrences * Tacred.evaluable_global_reference) list -> Goal.goal sigma -> constr -> constr [@@ocaml.deprecated "Use Tacred.unfoldn"] diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 4c4c26f47e..dd80ff21aa 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -13,7 +13,7 @@ open Pp open Util let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.pp_with pp -let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () +let stm_prerr_endline s = if CDebug.(get_flag misc) then begin stm_pr_err (str s) end else () type cancel_switch = bool ref let async_proofs_flags_for_workers = ref [] @@ -3,4 +3,4 @@ (synopsis "Coq's Document Manager and Proof Checking Scheduler") (public_name coq.stm) (wrapped false) - (libraries vernac)) + (libraries sysinit)) diff --git a/stm/partac.ml b/stm/partac.ml index 8232b017f9..6143ac450b 100644 --- a/stm/partac.ml +++ b/stm/partac.ml @@ -125,7 +125,7 @@ end = struct (* {{{ *) str" existentials remain unsolved: " ++ prlist (Termops.pr_existential_key sigma) (Evar.Set.elements evars)) ) with e when CErrors.noncritical e -> - RespError (CErrors.print e ++ spc() ++ str "(for subgoal "++int r_goalno ++ str ")") + RespError (CErrors.print e ++ spc() ++ str "(for goal "++int r_goalno ++ str ")") let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name @@ -163,7 +163,7 @@ let enable_par ~nworkers = ComTactic.set_par_implementation let open TacTask in let results = (Proof.data p).Proof.goals |> CList.map_i (fun i g -> let g_solution, t_assign = - Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) + Future.create_delegate ~name:(Printf.sprintf "goal %d" i) (fun x -> x) in TaskQueue.enqueue_task queue ~cancel_switch:(ref false) diff --git a/stm/spawned.ml b/stm/spawned.ml index 5cc8be78f5..ee9c8e9942 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -11,7 +11,7 @@ open Spawn let pr_err s = Printf.eprintf "(Spawned,%d) %s\n%!" (Unix.getpid ()) s -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if CDebug.(get_flag misc) then begin pr_err s end else () type chandescr = AnonPipe | Socket of string * int * int diff --git a/stm/stm.ml b/stm/stm.ml index 1c06c1efb7..5ed6adbd63 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -9,7 +9,7 @@ (************************************************************************) (* enable in case of stm problems *) -(* let stm_debug () = !Flags.debug *) +(* let stm_debug () = CDebug.(get_flag misc) *) let stm_debug = ref false let stm_pr_err s = Format.eprintf "%s] %s\n%!" (Spawned.process_id ()) s @@ -18,7 +18,7 @@ let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.p let stm_prerr_endline s = if !stm_debug then begin stm_pr_err (s ()) end else () let stm_pperr_endline s = if !stm_debug then begin stm_pp_err (s ()) end else () -let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () +let stm_prerr_debug s = if CDebug.(get_flag misc) then begin stm_pr_err (s ()) end else () open Pp open CErrors @@ -297,13 +297,11 @@ end (* }}} *) (*************************** THE DOCUMENT *************************************) (******************************************************************************) -type interactive_top = TopLogical of DirPath.t | TopPhysical of string - (* The main document type associated to a VCS *) type stm_doc_type = | VoDoc of string | VioDoc of string - | Interactive of interactive_top + | Interactive of Coqargs.top (* Dummy until we land the functional interp patch + fixed start_library *) type doc = int @@ -517,7 +515,7 @@ end = struct (* {{{ *) type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) - let doc_type = ref (Interactive (TopLogical (Names.DirPath.make []))) + let doc_type = ref (Interactive (Coqargs.TopLogical (Names.DirPath.make []))) let ldir = ref Names.DirPath.empty let init dt id ps = @@ -787,7 +785,7 @@ end = struct (* {{{ *) end let print ?(now=false) () = - if !Flags.debug then NB.command ~now (print_dag !vcs) + if CDebug.(get_flag misc) then NB.command ~now (print_dag !vcs) let backup () = !vcs let restore v = vcs := v @@ -801,6 +799,9 @@ let state_of_id ~doc id = | EmptyState | ParsingState _ -> `Valid None with VCS.Expired -> `Expired +let () = + Stateid.set_is_valid (fun ~doc id -> state_of_id ~doc id <> `Expired) + (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig @@ -1532,7 +1533,7 @@ end = struct (* {{{ *) when is_tac expr && Vernacstate.Stm.same_env o n -> (* A pure tactic *) Some (id, `ProofOnly (prev, Vernacstate.Stm.pstate n)) | Some _, Some s -> - if !Flags.debug then msg_debug (Pp.str "STM: sending back a fat state"); + if CDebug.(get_flag misc) then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function @@ -2305,34 +2306,13 @@ end (* }}} *) (** STM initialization options: *) -type option_command = OptionSet of string option | OptionUnset - -type injection_command = - | OptionInjection of (Goptions.option_name * option_command) - (** Set flags or options before the initial state is ready. *) - | RequireInjection of (string * string option * bool option) - (** Require libraries before the initial state is - ready. Parameters follow [Library], that is to say, - [lib,prefix,import_export] means require library [lib] from - optional [prefix] and [import_export] if [Some false/Some true] - is used. *) - (* -load-vernac-source interleaving is not supported yet *) - (* | LoadInjection of (string * bool) *) - type stm_init_options = { doc_type : stm_doc_type (** The STM does set some internal flags differently depending on the specified [doc_type]. This distinction should disappear at some some point. *) - ; ml_load_path : CUnix.physical_path list - (** OCaml load paths for the document. *) - - ; vo_load_path : Loadpath.vo_path list - (** [vo] load paths for the document. Usually extracted from -R - options / _CoqProject *) - - ; injections : injection_command list + ; injections : Coqargs.injection_command list (** Injects Require and Set/Unset commands before the initial state is ready *) @@ -2349,67 +2329,17 @@ let doc_type_module_name (std : stm_doc_type) = | Interactive mn -> Names.DirPath.to_string mn *) +let init_process stm_flags = + Spawned.init_channels (); + CoqworkmgrApi.(init stm_flags.AsyncOpts.async_proofs_worker_priority) + let init_core () = if !cur_opt.async_proofs_mode = APon then Control.enable_thread_delay := true; if !Flags.async_proofs_worker_id = "master" then Partac.enable_par ~nworkers:!cur_opt.async_proofs_n_tacworkers; State.register_root_state () -let dirpath_of_file f = - let ldir0 = - try - let lp = Loadpath.find_load_path (Filename.dirname f) in - Loadpath.logical lp - with Not_found -> Libnames.default_root_prefix - in - let f = try Filename.chop_extension (Filename.basename f) with Invalid_argument _ -> f in - let id = Id.of_string f in - let ldir = Libnames.add_dirpath_suffix ldir0 id in - ldir - -let new_doc { doc_type ; ml_load_path; vo_load_path; injections; stm_options } = - - let require_file (dir, from, exp) = - let mp = Libnames.qualid_of_string dir in - let mfrom = Option.map Libnames.qualid_of_string from in - Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in - - let interp_set_option opt v old = - let open Goptions in - let err expect = - let opt = String.concat " " opt in - let got = v in (* avoid colliding with Pp.v *) - CErrors.user_err - Pp.(str "-set: " ++ str opt ++ - str" expects " ++ str expect ++ - str" but got " ++ str got) - in - match old with - | BoolValue _ -> - let v = match String.trim v with - | "true" -> true - | "false" | "" -> false - | _ -> err "a boolean" - in - BoolValue v - | IntValue _ -> - let v = String.trim v in - let v = match int_of_string_opt v with - | Some _ as v -> v - | None -> if v = "" then None else err "an int" - in - IntValue v - | StringValue _ -> StringValue v - | StringOptValue _ -> StringOptValue (Some v) in - - let set_option = let open Goptions in function - | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt - | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true - | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v in - let handle_injection = function - | RequireInjection r -> require_file r - (* | LoadInjection l -> *) - | OptionInjection o -> set_option o in +let new_doc { doc_type ; injections; stm_options } = (* Set the options from the new documents *) AsyncOpts.cur_opt := stm_options; @@ -2419,37 +2349,27 @@ let new_doc { doc_type ; ml_load_path; vo_load_path; injections; stm_options } = let doc = VCS.init doc_type Stateid.initial (Vernacstate.Parser.init ()) in - (* Set load path; important, this has to happen before we declare - the library below as [Declaremods/Library] will infer the module - name by looking at the load path! *) - List.iter Mltop.add_ml_dir ml_load_path; - List.iter Loadpath.add_vo_path vo_load_path; - Safe_typing.allow_delayed_constants := !cur_opt.async_proofs_mode <> APoff; - begin match doc_type with - | Interactive ln -> - let dp = match ln with - | TopLogical dp -> dp - | TopPhysical f -> dirpath_of_file f - in - Declaremods.start_library dp + let top = + match doc_type with + | Interactive top -> Coqargs.dirpath_of_top top | VoDoc f -> - let ldir = dirpath_of_file f in - let () = Flags.verbosely Declaremods.start_library ldir in + let ldir = Coqargs.(dirpath_of_top (TopPhysical f)) in VCS.set_ldir ldir; - set_compilation_hints f + set_compilation_hints f; + ldir | VioDoc f -> - let ldir = dirpath_of_file f in - let () = Flags.verbosely Declaremods.start_library ldir in + let ldir = Coqargs.(dirpath_of_top (TopPhysical f)) in VCS.set_ldir ldir; - set_compilation_hints f - end; + set_compilation_hints f; + ldir + in - (* Import initial libraries. *) - List.iter handle_injection injections; + (* Start this library and import initial libraries. *) + Coqinit.start_library ~top injections; (* We record the state at this point! *) State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; diff --git a/stm/stm.mli b/stm/stm.mli index 097bcbe0ca..bd42359cea 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -42,29 +42,13 @@ module AsyncOpts : sig end -type interactive_top = TopLogical of DirPath.t | TopPhysical of string - (** The STM document type [stm_doc_type] determines some properties such as what uncompleted proofs are allowed and what gets recorded to aux files. *) type stm_doc_type = | VoDoc of string (* file path *) | VioDoc of string (* file path *) - | Interactive of interactive_top (* module path *) - -type option_command = OptionSet of string option | OptionUnset - -type injection_command = - | OptionInjection of (Goptions.option_name * option_command) - (** Set flags or options before the initial state is ready. *) - | RequireInjection of (string * string option * bool option) - (** Require libraries before the initial state is - ready. Parameters follow [Library], that is to say, - [lib,prefix,import_export] means require library [lib] from - optional [prefix] and [import_export] if [Some false/Some true] - is used. *) - (* -load-vernac-source interleaving is not supported yet *) - (* | LoadInjection of (string * bool) *) + | Interactive of Coqargs.top (* module path *) (** STM initialization options: *) type stm_init_options = @@ -73,14 +57,7 @@ type stm_init_options = the specified [doc_type]. This distinction should disappear at some some point. *) - ; ml_load_path : CUnix.physical_path list - (** OCaml load paths for the document. *) - - ; vo_load_path : Loadpath.vo_path list - (** [vo] load paths for the document. Usually extracted from -R - options / _CoqProject *) - - ; injections : injection_command list + ; injections : Coqargs.injection_command list (** Injects Require and Set/Unset commands before the initial state is ready *) @@ -91,8 +68,10 @@ type stm_init_options = (** The type of a STM document *) type doc -(** [init_core] performs some low-level initialization; should go away - in future releases. *) +(** [init_process] performs some low-level initialization, call early *) +val init_process : AsyncOpts.stm_opt -> unit + +(** [init_core] snapshorts the initial system state *) val init_core : unit -> unit (** [new_doc opt] Creates a new document with options [opt] *) diff --git a/stm/stm.mllib b/stm/stm.mllib index 831369625f..a77e0c79e7 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -3,10 +3,10 @@ Dag Vcs TQueue WorkerPool -Vernac_classifier CoqworkmgrApi AsyncTaskQueue Partac Stm +Stmargs ProofBlockDelimiter Vio_checking diff --git a/stm/stmargs.ml b/stm/stmargs.ml new file mode 100644 index 0000000000..e2c7649a8f --- /dev/null +++ b/stm/stmargs.ml @@ -0,0 +1,140 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let fatal_error exn = + Topfmt.(in_phase ~phase:ParsingCommandLine print_err_exn exn); + let exit_code = if (CErrors.is_anomaly exn) then 129 else 1 in + exit exit_code + +let set_worker_id opt s = + assert (s <> "master"); + Flags.async_proofs_worker_id := s + +let get_host_port opt s = + match String.split_on_char ':' s with + | [host; portr; portw] -> + Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) + | ["stdfds"] -> Some Spawned.AnonPipe + | _ -> + Coqargs.error_wrong_arg ("Error: host:portr:portw or stdfds expected after option "^opt) + +let get_error_resilience opt = function + | "on" | "all" | "yes" -> `All + | "off" | "no" -> `None + | s -> `Only (String.split_on_char ',' s) + +let get_priority opt s = + try CoqworkmgrApi.priority_of_string s + with Invalid_argument _ -> + Coqargs.error_wrong_arg ("Error: low/high expected after "^opt) + +let get_async_proofs_mode opt = let open Stm.AsyncOpts in function + | "no" | "off" -> APoff + | "yes" | "on" -> APon + | "lazy" -> APonLazy + | _ -> + Coqargs.error_wrong_arg ("Error: on/off/lazy expected after "^opt) + +let get_cache opt = function + | "force" -> Some Stm.AsyncOpts.Force + | _ -> + Coqargs.error_wrong_arg ("Error: force expected after "^opt) + +let parse_args ~init arglist : Stm.AsyncOpts.stm_opt * string list = + let args = ref arglist in + let extras = ref [] in + let rec parse oval = match !args with + | [] -> + (oval, List.rev !extras) + | opt :: rem -> + args := rem; + let next () = match !args with + | x::rem -> args := rem; x + | [] -> Coqargs.error_missing_arg opt + in + let noval = begin match opt with + + |"-async-proofs" -> + { oval with + Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next()) + } + |"-async-proofs-j" -> + { oval with + Stm.AsyncOpts.async_proofs_n_workers = (Coqargs.get_int ~opt (next ())) + } + |"-async-proofs-cache" -> + { oval with + Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ()) + } + + |"-async-proofs-tac-j" -> + let j = Coqargs.get_int ~opt (next ()) in + if j <= 0 then begin + Coqargs.error_wrong_arg ("Error: -async-proofs-tac-j only accepts values greater than or equal to 1") + end; + { oval with + Stm.AsyncOpts.async_proofs_n_tacworkers = j + } + + |"-async-proofs-worker-priority" -> + { oval with + Stm.AsyncOpts.async_proofs_worker_priority = get_priority opt (next ()) + } + + |"-async-proofs-private-flags" -> + { oval with + Stm.AsyncOpts.async_proofs_private_flags = Some (next ()); + } + + |"-async-proofs-tactic-error-resilience" -> + { oval with + Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ()) + } + + |"-async-proofs-command-error-resilience" -> + { oval with + Stm.AsyncOpts.async_proofs_cmd_error_resilience = Coqargs.get_bool ~opt (next ()) + } + + |"-async-proofs-delegation-threshold" -> + { oval with + Stm.AsyncOpts.async_proofs_delegation_threshold = Coqargs.get_float ~opt (next ()) + } + + |"-worker-id" -> set_worker_id opt (next ()); oval + + |"-main-channel" -> + Spawned.main_channel := get_host_port opt (next()); oval + + |"-control-channel" -> + Spawned.control_channel := get_host_port opt (next()); oval + + (* Options with zero arg *) + |"-async-queries-always-delegate" + |"-async-proofs-always-delegate" + |"-async-proofs-never-reopen-branch" -> + { oval with + Stm.AsyncOpts.async_proofs_never_reopen_branch = true + } + |"-stm-debug" -> Stm.stm_debug := true; oval + (* Unknown option *) + | s -> + extras := s :: !extras; + oval + end in + parse noval + in + try + parse init + with any -> fatal_error any + +let usage = "\ +\n -stm-debug STM debug mode (will trace every transaction)\ +" diff --git a/stm/stmargs.mli b/stm/stmargs.mli new file mode 100644 index 0000000000..f760afdc98 --- /dev/null +++ b/stm/stmargs.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val parse_args : init:Stm.AsyncOpts.stm_opt -> string list -> Stm.AsyncOpts.stm_opt * string list + +val usage : string diff --git a/toplevel/coqargs.ml b/sysinit/coqargs.ml index fbf3b4873b..8be73ca028 100644 --- a/toplevel/coqargs.ml +++ b/sysinit/coqargs.ml @@ -22,39 +22,37 @@ let error_missing_arg s = exit 1 (******************************************************************************) -(* Imperative effects! This must be fixed at some point. *) -(******************************************************************************) -let set_worker_id opt s = - assert (s <> "master"); - Flags.async_proofs_worker_id := s -let set_type_in_type () = - let typing_flags = Environ.typing_flags (Global.env ()) in - Global.set_typing_flags { typing_flags with Declarations.check_universes = false } +type native_compiler = Coq_config.native_compiler = + NativeOff | NativeOn of { ondemand : bool } -(******************************************************************************) +type top = TopLogical of Names.DirPath.t | TopPhysical of string -type color = [`ON | `AUTO | `EMACS | `OFF] +type option_command = + | OptionSet of string option + | OptionUnset + | OptionAppend of string -type native_compiler = Coq_config.native_compiler = - NativeOff | NativeOn of { ondemand : bool } +type injection_command = + | OptionInjection of (Goptions.option_name * option_command) + | RequireInjection of (string * string option * bool option) + | WarnNoNative of string type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; - toplevel_name : Stm.interactive_top; + type_in_type : bool; + toplevel_name : top; } type coqargs_config = { logic : coqargs_logic_config; rcfile : string option; coqlib : string option; - color : color; enable_VM : bool; native_compiler : native_compiler; native_output_dir : CUnix.physical_path; native_include_dirs : CUnix.physical_path list; - stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; time : bool; print_emacs : bool; @@ -69,13 +67,11 @@ type coqargs_pre = { vo_includes : Loadpath.vo_path list; load_vernacular_list : (string * bool) list; - injections : Stm.injection_command list; - - inputstate : string option; + injections : injection_command list; } type coqargs_query = - | PrintTags | PrintWhere | PrintConfig + | PrintWhere | PrintConfig | PrintVersion | PrintMachineReadableVersion | PrintHelp of Usage.specific_usage @@ -85,7 +81,6 @@ type coqargs_main = type coqargs_post = { memory_stat : bool; - output_context : bool; } type t = { @@ -102,19 +97,18 @@ let default_native = Coq_config.native_compiler let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; - toplevel_name = Stm.TopLogical default_toplevel; + type_in_type = false; + toplevel_name = TopLogical default_toplevel; } let default_config = { logic = default_logic_config; rcfile = None; coqlib = None; - color = `AUTO; enable_VM = true; native_compiler = default_native; native_output_dir = ".coq-native"; native_include_dirs = []; - stm_flags = Stm.AsyncOpts.default_opts; debug = false; time = false; print_emacs = false; @@ -130,14 +124,12 @@ let default_pre = { vo_includes = []; load_vernacular_list = []; injections = []; - inputstate = None; } let default_queries = [] let default_post = { memory_stat = false; - output_context = false; } let default = { @@ -160,105 +152,67 @@ let add_vo_include opts unix_path coq_path implicit = unix_path; coq_path; has_ml = false; implicit; recursive = true } :: opts.pre.vo_includes }} let add_vo_require opts d p export = - { opts with pre = { opts.pre with injections = Stm.RequireInjection (d, p, export) :: opts.pre.injections }} + { opts with pre = { opts.pre with injections = RequireInjection (d, p, export) :: opts.pre.injections }} let add_load_vernacular opts verb s = { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} let add_set_option opts opt_name value = - { opts with pre = { opts.pre with injections = Stm.OptionInjection (opt_name, value) :: opts.pre.injections }} + { opts with pre = { opts.pre with injections = OptionInjection (opt_name, value) :: opts.pre.injections }} + +let add_set_debug opts flags = + add_set_option opts ["Debug"] (OptionAppend flags) (** Options for proof general *) let set_emacs opts = - Goptions.set_bool_option_value Printer.print_goal_tag_opt_name true; - { opts with config = { opts.config with color = `EMACS; print_emacs = true }} + let opts = add_set_option opts Printer.print_goal_tag_opt_name (OptionSet None) in + { opts with config = { opts.config with print_emacs = true }} let set_logic f oval = { oval with config = { oval.config with logic = f oval.config.logic }} -let set_color opts = function - | "yes" | "on" -> { opts with config = { opts.config with color = `ON }} - | "no" | "off" -> { opts with config = { opts.config with color = `OFF }} - | "auto" -> { opts with config = { opts.config with color = `AUTO }} - | _ -> - error_wrong_arg ("Error: on/off/auto expected after option color") - let set_query opts q = { opts with main = match opts.main with | Run -> Queries (default_queries@[q]) | Queries queries -> Queries (queries@[q]) } -let warn_deprecated_sprop_cumul = - CWarnings.create ~name:"deprecated-spropcumul" ~category:"deprecated" - (fun () -> Pp.strbrk "Use the \"Cumulative StrictProp\" flag instead.") - -let warn_deprecated_inputstate = - CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" - (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") - -let set_inputstate opts s = - warn_deprecated_inputstate (); - { opts with pre = { opts.pre with inputstate = Some s }} - (******************************************************************************) (* Parsing helpers *) (******************************************************************************) -let get_bool opt = function +let get_bool ~opt = function | "yes" | "on" -> true | "no" | "off" -> false | _ -> error_wrong_arg ("Error: yes/no expected after option "^opt) -let get_int opt n = +let get_int ~opt n = try int_of_string n with Failure _ -> error_wrong_arg ("Error: integer expected after option "^opt) +let get_int_opt ~opt n = + if n = "" then None + else Some (get_int ~opt n) -let get_float opt n = +let get_float ~opt n = try float_of_string n with Failure _ -> error_wrong_arg ("Error: float expected after option "^opt) -let get_host_port opt s = - match String.split_on_char ':' s with - | [host; portr; portw] -> - Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) - | ["stdfds"] -> Some Spawned.AnonPipe - | _ -> - error_wrong_arg ("Error: host:portr:portw or stdfds expected after option "^opt) - -let get_error_resilience opt = function - | "on" | "all" | "yes" -> `All - | "off" | "no" -> `None - | s -> `Only (String.split_on_char ',' s) - -let get_priority opt s = - try CoqworkmgrApi.priority_of_string s - with Invalid_argument _ -> - error_wrong_arg ("Error: low/high expected after "^opt) - -let get_async_proofs_mode opt = let open Stm.AsyncOpts in function - | "no" | "off" -> APoff - | "yes" | "on" -> APon - | "lazy" -> APonLazy - | _ -> - error_wrong_arg ("Error: on/off/lazy expected after "^opt) - -let get_cache opt = function - | "force" -> Some Stm.AsyncOpts.Force - | _ -> - error_wrong_arg ("Error: force expected after "^opt) - - -let get_native_name s = - (* We ignore even critical errors because this mode has to be super silent *) - try - Filename.(List.fold_left concat (dirname s) - [ !Nativelib.output_dir - ; Library.native_name_from_filename s - ]) - with _ -> "" +let interp_set_option opt v old = + let open Goptions in + let opt = String.concat " " opt in + match old with + | BoolValue _ -> BoolValue (get_bool ~opt v) + | IntValue _ -> IntValue (get_int_opt ~opt v) + | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) + +let set_option = let open Goptions in function + | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt + | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true + | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v + | opt, OptionAppend v -> set_string_option_append_value_gen ~locality:OptLocal opt v let get_compat_file = function | "8.14" -> "Coq.Compat.Coq814" @@ -282,12 +236,6 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v -let warn_no_native_compiler = - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - Pp.(fun s -> strbrk "Native compiler is disabled," ++ - strbrk " -native-compiler " ++ strbrk s ++ - strbrk " option ignored.") - let get_native_compiler s = (* We use two boolean flags because the four states make sense, even if only three are accessible to the user at the moment. The selection of the @@ -301,15 +249,13 @@ let get_native_compiler s = | _ -> error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in if Coq_config.native_compiler = NativeOff && n <> NativeOff then - let () = warn_no_native_compiler s in - NativeOff - else - n + NativeOff, Some (WarnNoNative s) + else n, None (* Main parsing routine *) (*s Parsing of the command line *) -let parse_args ~help ~init arglist : t * string list = +let parse_args ~usage ~init arglist : t * string list = let args = ref arglist in let extras = ref [] in let rec parse oval = match !args with @@ -351,55 +297,6 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = { oval.config with coqlib = Some (next ()) }} - |"-async-proofs" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next()) - }}} - |"-async-proofs-j" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_n_workers = (get_int opt (next ())) - }}} - |"-async-proofs-cache" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ()) - }}} - - |"-async-proofs-tac-j" -> - let j = get_int opt (next ()) in - if j <= 0 then begin - error_wrong_arg ("Error: -async-proofs-tac-j only accepts values greater than or equal to 1") - end; - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_n_tacworkers = j - }}} - - |"-async-proofs-worker-priority" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_worker_priority = get_priority opt (next ()) - }}} - - |"-async-proofs-private-flags" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_private_flags = Some (next ()); - }}} - - |"-async-proofs-tactic-error-resilience" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ()) - }}} - - |"-async-proofs-command-error-resilience" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_cmd_error_resilience = get_bool opt (next ()) - }}} - - |"-async-proofs-delegation-threshold" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_delegation_threshold = get_float opt (next ()) - }}} - - |"-worker-id" -> set_worker_id opt (next ()); oval - |"-compat" -> add_vo_require oval (get_compat_file (next ())) None (Some false) @@ -409,9 +306,6 @@ let parse_args ~help ~init arglist : t * string list = |"-init-file" -> { oval with config = { oval.config with rcfile = Some (next ()); }} - |"-inputstate"|"-is" -> - set_inputstate oval (next ()) - |"-load-vernac-object" -> add_vo_require oval (next ()) None None @@ -422,16 +316,12 @@ let parse_args ~help ~init arglist : t * string list = add_load_vernacular oval true (next ()) |"-mangle-names" -> - Goptions.set_bool_option_value ["Mangle"; "Names"] true; - Goptions.set_string_option_value ["Mangle"; "Names"; "Prefix"] (next ()); - oval - - |"-print-mod-uid" -> - let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0 + let oval = add_set_option oval ["Mangle"; "Names"] (OptionSet None) in + add_set_option oval ["Mangle"; "Names"; "Prefix"] (OptionSet(Some(next ()))) |"-profile-ltac-cutoff" -> Flags.profile_ltac := true; - Flags.profile_ltac_cutoff := get_float opt (next ()); + Flags.profile_ltac_cutoff := get_float ~opt (next ()); oval |"-rfrom" -> @@ -451,39 +341,30 @@ let parse_args ~help ~init arglist : t * string list = let topname = Libnames.dirpath_of_string (next ()) in if Names.DirPath.is_empty topname then CErrors.user_err Pp.(str "Need a non empty toplevel module name"); - { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = Stm.TopLogical topname }}} + { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = TopLogical topname }}} |"-topfile" -> - { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = Stm.TopPhysical (next()) }}} - - |"-main-channel" -> - Spawned.main_channel := get_host_port opt (next()); oval - - |"-control-channel" -> - Spawned.control_channel := get_host_port opt (next()); oval + { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = TopPhysical (next()) }}} |"-w" | "-W" -> let w = next () in - if w = "none" then - (CWarnings.set_flags w; oval) - else - let w = CWarnings.get_flags () ^ "," ^ w in - CWarnings.set_flags (CWarnings.normalize_flags_string w); - oval + if w = "none" then add_set_option oval ["Warnings"] (OptionSet(Some w)) + else add_set_option oval ["Warnings"] (OptionAppend w) |"-bytecode-compiler" -> - { oval with config = { oval.config with enable_VM = get_bool opt (next ()) }} + { oval with config = { oval.config with enable_VM = get_bool ~opt (next ()) }} |"-native-compiler" -> - let native_compiler = get_native_compiler (next ()) in - { oval with config = { oval.config with native_compiler }} + let native_compiler, warn = get_native_compiler (next ()) in + { oval with config = { oval.config with native_compiler }; + pre = { oval.pre with injections = Option.List.cons warn oval.pre.injections }} | "-set" -> let opt, v = parse_option_set @@ next() in - add_set_option oval opt (Stm.OptionSet v) + add_set_option oval opt (OptionSet v) | "-unset" -> - add_set_option oval (to_opt_key @@ next ()) Stm.OptionUnset + add_set_option oval (to_opt_key @@ next ()) OptionUnset |"-native-output-dir" -> let native_output_dir = next () in @@ -494,49 +375,41 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = {oval.config with native_include_dirs = include_dir :: oval.config.native_include_dirs } } (* Options with zero arg *) - |"-async-queries-always-delegate" - |"-async-proofs-always-delegate" - |"-async-proofs-never-reopen-branch" -> - { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with - Stm.AsyncOpts.async_proofs_never_reopen_branch = true - }}} |"-test-mode" -> Vernacinterp.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-bt" -> Exninfo.record_backtrace true; oval - |"-color" -> set_color oval (next ()) + |"-bt" -> add_set_debug oval "backtrace" |"-config"|"--config" -> set_query oval PrintConfig - |"-debug" -> Coqinit.set_debug (); oval - |"-xml-debug" -> Flags.xml_debug := true; Coqinit.set_debug (); oval + + |"-debug" -> add_set_debug oval "all" + |"-d" | "-D" -> add_set_debug oval (next()) + + (* -xml-debug implies -debug. TODO don't be imperative here. *) + |"-xml-debug" -> Flags.xml_debug := true; add_set_debug oval "all" + |"-diffs" -> - add_set_option oval Proof_diffs.opt_name @@ Stm.OptionSet (Some (next ())) - |"-stm-debug" -> Stm.stm_debug := true; oval + add_set_option oval Proof_diffs.opt_name @@ OptionSet (Some (next ())) |"-emacs" -> set_emacs oval |"-impredicative-set" -> set_logic (fun o -> { o with impredicative_set = Declarations.ImpredicativeSet }) oval |"-allow-sprop" -> - add_set_option oval Vernacentries.allow_sprop_opt_name (Stm.OptionSet None) + add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) |"-disallow-sprop" -> - add_set_option oval Vernacentries.allow_sprop_opt_name Stm.OptionUnset - |"-sprop-cumulative" -> - warn_deprecated_sprop_cumul(); - add_set_option oval Vernacentries.cumul_sprop_opt_name (Stm.OptionSet None) + add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval - |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} + |"-m"|"--memory" -> { oval with post = { memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} |"-boot" -> { oval with pre = { oval.pre with boot = true }} - |"-output-context" -> { oval with post = { oval.post with output_context = true }} |"-profile-ltac" -> Flags.profile_ltac := true; oval |"-q" -> { oval with pre = { oval.pre with load_rcfile = false; }} |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false; oval - |"-list-tags" -> set_query oval PrintTags |"-time" -> { oval with config = { oval.config with time = true }} - |"-type-in-type" -> set_type_in_type (); oval + |"-type-in-type" -> set_logic (fun o -> { o with type_in_type = true }) oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> set_query oval PrintWhere - |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp help) + |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp usage) |"-v"|"--version" -> set_query oval PrintVersion |"-print-version"|"--print-version" -> set_query oval PrintMachineReadableVersion @@ -552,8 +425,8 @@ let parse_args ~help ~init arglist : t * string list = with any -> fatal_error any (* We need to reverse a few lists *) -let parse_args ~help ~init args = - let opts, extra = parse_args ~help ~init args in +let parse_args ~usage ~init args = + let opts, extra = parse_args ~usage ~init args in let opts = { opts with pre = { opts.pre with @@ -572,13 +445,29 @@ let parse_args ~help ~init args = let prelude_data = "Prelude", Some "Coq", Some false let injection_commands opts = - if opts.pre.load_init then Stm.RequireInjection prelude_data :: opts.pre.injections else opts.pre.injections + if opts.pre.load_init then RequireInjection prelude_data :: opts.pre.injections else opts.pre.injections let build_load_path opts = let ml_path, vo_path = if opts.pre.boot then [],[] else let coqlib = Envars.coqlib () in - Coqinit.libs_init_load_path ~coqlib in + Coqloadpath.init_load_path ~coqlib in ml_path @ opts.pre.ml_includes , vo_path @ opts.pre.vo_includes + +let dirpath_of_file f = + let ldir0 = + try + let lp = Loadpath.find_load_path (Filename.dirname f) in + Loadpath.logical lp + with Not_found -> Libnames.default_root_prefix + in + let f = try Filename.chop_extension (Filename.basename f) with Invalid_argument _ -> f in + let id = Names.Id.of_string f in + let ldir = Libnames.add_dirpath_suffix ldir0 id in + ldir + +let dirpath_of_top = function + | TopPhysical f -> dirpath_of_file f + | TopLogical dp -> dp diff --git a/toplevel/coqargs.mli b/sysinit/coqargs.mli index f6222e4ec4..9725a849a4 100644 --- a/toplevel/coqargs.mli +++ b/sysinit/coqargs.mli @@ -8,29 +8,48 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type color = [`ON | `AUTO | `EMACS | `OFF] - val default_toplevel : Names.DirPath.t type native_compiler = Coq_config.native_compiler = NativeOff | NativeOn of { ondemand : bool } +type top = TopLogical of Names.DirPath.t | TopPhysical of string + +type option_command = + | OptionSet of string option + | OptionUnset + | OptionAppend of string + +type injection_command = + | OptionInjection of (Goptions.option_name * option_command) + (** Set flags or options before the initial state is ready. *) + | RequireInjection of (string * string option * bool option) + (** Require libraries before the initial state is + ready. Parameters follow [Library], that is to say, + [lib,prefix,import_export] means require library [lib] from + optional [prefix] and [import_export] if [Some false/Some true] + is used. *) + | WarnNoNative of string + (** Used so that "-w -native-compiler-disabled -native-compiler yes" + does not cause a warning. The native option must be processed + before injections (because it affects require), so the + instruction to emit a message is separated. *) + type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; - toplevel_name : Stm.interactive_top; + type_in_type : bool; + toplevel_name : top; } type coqargs_config = { logic : coqargs_logic_config; rcfile : string option; coqlib : string option; - color : color; enable_VM : bool; native_compiler : native_compiler; native_output_dir : CUnix.physical_path; native_include_dirs : CUnix.physical_path list; - stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; time : bool; print_emacs : bool; @@ -45,13 +64,11 @@ type coqargs_pre = { vo_includes : Loadpath.vo_path list; load_vernacular_list : (string * bool) list; - injections : Stm.injection_command list; - - inputstate : string option; + injections : injection_command list; } type coqargs_query = - | PrintTags | PrintWhere | PrintConfig + | PrintWhere | PrintConfig | PrintVersion | PrintMachineReadableVersion | PrintHelp of Usage.specific_usage @@ -61,7 +78,6 @@ type coqargs_main = type coqargs_post = { memory_stat : bool; - output_context : bool; } type t = { @@ -74,8 +90,20 @@ type t = { (* Default options *) val default : t -val parse_args : help:Usage.specific_usage -> init:t -> string list -> t * string list -val error_wrong_arg : string -> unit +val parse_args : usage:Usage.specific_usage -> init:t -> string list -> t * string list -val injection_commands : t -> Stm.injection_command list +val injection_commands : t -> injection_command list val build_load_path : t -> CUnix.physical_path list * Loadpath.vo_path list + +val dirpath_of_top : top -> Names.DirPath.t + +(* Common utilities *) + +val get_int : opt:string -> string -> int +val get_int_opt : opt:string -> string -> int option +val get_bool : opt:string -> string -> bool +val get_float : opt:string -> string -> float +val error_missing_arg : string -> 'a +val error_wrong_arg : string -> 'a + +val set_option : Goptions.option_name * option_command -> unit diff --git a/sysinit/coqinit.ml b/sysinit/coqinit.ml new file mode 100644 index 0000000000..25da2c5302 --- /dev/null +++ b/sysinit/coqinit.ml @@ -0,0 +1,142 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** GC tweaking *) + +(** Coq is a heavy user of persistent data structures and symbolic ASTs, so the + minor heap is heavily solicited. Unfortunately, the default size is far too + small, so we enlarge it a lot (128 times larger). + + To better handle huge memory consumers, we also augment the default major + heap increment and the GC pressure coefficient. +*) + +let set_gc_policy () = + Gc.set { (Gc.get ()) with + Gc.minor_heap_size = 32*1024*1024 (* 32Mwords x 8 bytes/word = 256Mb *) + ; Gc.space_overhead = 120 + } + +let set_gc_best_fit () = + Gc.set { (Gc.get ()) with + Gc.allocation_policy = 2 (* best-fit *) + ; Gc.space_overhead = 200 + } + +let init_gc () = + try + (* OCAMLRUNPARAM environment variable is set. + * In that case, we let ocamlrun to use the values provided by the user. + *) + ignore (Sys.getenv "OCAMLRUNPARAM") + + with Not_found -> + (* OCAMLRUNPARAM environment variable is not set. + * In this case, we put in place our preferred configuration. + *) + set_gc_policy (); + if Coq_config.caml_version_nums >= [4;10;0] then set_gc_best_fit () else () + +let init_ocaml () = + CProfile.init_profile (); + init_gc (); + Sys.catch_break false (* Ctrl-C is fatal during the initialisation *) + +let init_coqlib opts = match opts.Coqargs.config.Coqargs.coqlib with + | None when opts.Coqargs.pre.Coqargs.boot -> () + | None -> + Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + | Some s -> + Envars.set_user_coqlib s + +let print_query opts = let open Coqargs in function + | PrintVersion -> Usage.version () + | PrintMachineReadableVersion -> Usage.machine_readable_version () + | PrintWhere -> + let () = init_coqlib opts in + print_endline (Envars.coqlib ()) + | PrintHelp h -> Usage.print_usage stderr h + | PrintConfig -> + let () = init_coqlib opts in + Envars.print_config stdout Coq_config.all_src_dirs + +let parse_arguments ~parse_extra ~usage ?(initial_args=Coqargs.default) () = + let opts, extras = + Coqargs.parse_args ~usage ~init:initial_args + (List.tl (Array.to_list Sys.argv)) in + let customopts, extras = parse_extra extras in + if not (CList.is_empty extras) then begin + prerr_endline ("Don't know what to do with "^String.concat " " extras); + prerr_endline "See -help for the list of supported options"; + exit 1 + end; + match opts.Coqargs.main with + | Coqargs.Queries q -> List.iter (print_query opts) q; exit 0 + | Coqargs.Run -> opts, customopts + +let print_memory_stat () = + let open Pp in + (* -m|--memory from the command-line *) + Feedback.msg_notice + (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); + (* operf-macro interface: + https://github.com/OCamlPro/operf-macro *) + try + let fn = Sys.getenv "OCAML_GC_STATS" in + let oc = open_out fn in + Gc.print_stat oc; + close_out oc + with _ -> () + +let init_runtime opts = + let open Coqargs in + Lib.init (); + init_coqlib opts; + if opts.post.memory_stat then at_exit print_memory_stat; + Mltop.init_known_plugins (); + + (* Configuration *) + Global.set_engagement opts.config.logic.impredicative_set; + Global.set_indices_matter opts.config.logic.indices_matter; + Global.set_check_universes (not opts.config.logic.type_in_type); + Global.set_VM opts.config.enable_VM; + Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); + Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); + + (* Native output dir *) + Nativelib.output_dir := opts.config.native_output_dir; + Nativelib.include_dirs := opts.config.native_include_dirs; + + (* Paths for loading stuff *) + let ml_load_path, vo_load_path = Coqargs.build_load_path opts in + List.iter Mltop.add_ml_dir ml_load_path; + List.iter Loadpath.add_vo_path vo_load_path; + + injection_commands opts + +let require_file (dir, from, exp) = + let mp = Libnames.qualid_of_string dir in + let mfrom = Option.map Libnames.qualid_of_string from in + Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] + +let warn_no_native_compiler = + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + Pp.(fun s -> strbrk "Native compiler is disabled," ++ + strbrk " -native-compiler " ++ strbrk s ++ + strbrk " option ignored.") + +let handle_injection = let open Coqargs in function + | RequireInjection r -> require_file r + | OptionInjection o -> set_option o + | WarnNoNative s -> warn_no_native_compiler s + +let start_library ~top injections = + Flags.verbosely Declaremods.start_library top; + List.iter handle_injection injections diff --git a/sysinit/coqinit.mli b/sysinit/coqinit.mli new file mode 100644 index 0000000000..bea2186d81 --- /dev/null +++ b/sysinit/coqinit.mli @@ -0,0 +1,58 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Main etry point to the sysinit component, all other modules are private. + + The following API shoud be called in order, and the first 3 steps only once + since they initialize global data. On the contrary step 4 can be called + many times to init the compilation of a unit. +*) + +(** 1 initialization of OCaml's runtime + + Profiling, GC parameters and signals. Nothing specific to Coq per se, but + the defaults here are good for Coq. + This API should be called up very early, or not at all. *) +val init_ocaml : unit -> unit + +(** 2 parsing of Sys.argv + + This API parses command line options which are known by Coq components. + Ideally it is functional, but some values in the `Flags` modules are set + on the spot instead of being represented as "injection commands" (a field + of Coqargs.t). + + [parse_extra] and [usage] can be used to parse/document more options. *) +val parse_arguments : + parse_extra:(string list -> 'a * string list) -> + usage:Usage.specific_usage -> + ?initial_args:Coqargs.t -> + unit -> + Coqargs.t * 'a + +(** 3 initialization of global runtime data + + All global setup is done here, like COQLIB and the paths for native + compilation. If Coq is used to process multiple libraries, what is set up + here is really global and common to all of them. + + The returned injections are options (as in "Set This Thing" or "Require + that") as specified on the command line. + The prelude is one of these (unless "-nois" is passed). + + This API must be called, typically jsut after parsing arguments. *) +val init_runtime : Coqargs.t -> Coqargs.injection_command list + +(** 4 Start a library (sets options and loads objects like the prelude) + + Given the logical name [top] of the current library and the set of initial + options and required libraries, it starts its processing (see also + Declaremods.start_library) *) +val start_library : top:Names.DirPath.t -> Coqargs.injection_command list -> unit diff --git a/toplevel/coqinit.ml b/sysinit/coqloadpath.ml index 501047c520..8635345e00 100644 --- a/toplevel/coqinit.ml +++ b/sysinit/coqloadpath.ml @@ -13,44 +13,6 @@ open Pp let ( / ) s1 s2 = Filename.concat s1 s2 -let set_debug () = - let () = Exninfo.record_backtrace true in - Flags.debug := true - -(* Loading of the resource file. - rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one - does not exist. *) - -let rcdefaultname = "coqrc" - -let load_rcfile ~rcfile ~state = - try - match rcfile with - | Some rcfile -> - if CUnix.file_readable_p rcfile then - Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state rcfile - else raise (Sys_error ("Cannot read rcfile: "^ rcfile)) - | None -> - try - let warn x = Feedback.msg_warning (str x) in - let inferedrc = List.find CUnix.file_readable_p [ - Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; - Envars.xdg_config_home warn / rcdefaultname; - Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; - Envars.home ~warn / "."^rcdefaultname - ] in - Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state inferedrc - with Not_found -> state - (* - Flags.if_verbose - mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ - " found. Skipping rcfile loading.")) - *) - with reraise -> - let reraise = Exninfo.capture reraise in - let () = Feedback.msg_info (str"Load of rcfile failed.") in - Exninfo.iraise reraise - (* Recursively puts `.v` files in the LoadPath *) let build_stdlib_vo_path ~unix_path ~coq_path = let open Loadpath in @@ -73,7 +35,7 @@ let build_userlib_path ~unix_path = else [], [] (* LoadPath for Coq user libraries *) -let libs_init_load_path ~coqlib = +let init_load_path ~coqlib = let open Loadpath in let user_contrib = coqlib/"user-contrib" in diff --git a/toplevel/coqinit.mli b/sysinit/coqloadpath.mli index b96a0ef162..d853e9ea54 100644 --- a/toplevel/coqinit.mli +++ b/sysinit/coqloadpath.mli @@ -8,15 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Initialization. *) - -val set_debug : unit -> unit - -val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t - (** Standard LoadPath for Coq user libraries; in particular it includes (in-order) Coq's standard library, Coq's [user-contrib] folder, and directories specified in [COQPATH] and [XDG_DIRS] *) -val libs_init_load_path +val init_load_path : coqlib:CUnix.physical_path -> CUnix.physical_path list * Loadpath.vo_path list diff --git a/sysinit/dune b/sysinit/dune new file mode 100644 index 0000000000..04b46fb2a2 --- /dev/null +++ b/sysinit/dune @@ -0,0 +1,7 @@ +(library + (name sysinit) + (public_name coq.sysinit) + (synopsis "Coq's initialization") + (wrapped false) + (libraries coq.vernac) + ) diff --git a/sysinit/sysinit.mllib b/sysinit/sysinit.mllib new file mode 100644 index 0000000000..6e86536648 --- /dev/null +++ b/sysinit/sysinit.mllib @@ -0,0 +1,4 @@ +Usage +Coqloadpath +Coqargs +Coqinit diff --git a/toplevel/usage.ml b/sysinit/usage.ml index 6fb5f821ee..d00b916f23 100644 --- a/toplevel/usage.ml +++ b/sysinit/usage.ml @@ -9,9 +9,8 @@ (************************************************************************) let version () = - Printf.printf "The Coq Proof Assistant, version %s (%s)\n" - Coq_config.version Coq_config.date; - Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version + Printf.printf "The Coq Proof Assistant, version %s\n" Coq_config.version; + Printf.printf "compiled with OCaml %s\n" Coq_config.caml_version let machine_readable_version () = Printf.printf "%s %s\n" @@ -74,13 +73,11 @@ let print_usage_common co command = \n -debug debug mode (implies -bt)\ \n -xml-debug debug mode and print XML messages to/from coqide\ \n -diffs (on|off|removed) highlight differences between proof steps\ -\n -stm-debug STM debug mode (will trace every transaction)\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ \n -allow-sprop allow using the proof irrelevant SProp sort\ \n -disallow-sprop forbid using the proof irrelevant SProp sort\ -\n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ diff --git a/toplevel/usage.mli b/sysinit/usage.mli index cbc3b4f7e8..2d1a8e94cc 100644 --- a/toplevel/usage.mli +++ b/sysinit/usage.mli @@ -26,4 +26,3 @@ type specific_usage = { given executable. } *) val print_usage : out_channel -> specific_usage -> unit - diff --git a/tactics/auto.ml b/tactics/auto.ml index 369508c2a3..353e138599 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -277,8 +277,8 @@ let hintmap_of env sigma secvars hdc concl = else Hint_db.map_auto env sigma ~secvars hdc concl let exists_evaluable_reference env = function - | EvalConstRef _ -> true - | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false + | Tacred.EvalConstRef _ -> true + | Tacred.EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false let dbg_intro dbg = tclLOG dbg (fun _ _ -> str "intro") intro let dbg_assumption dbg = tclLOG dbg (fun _ _ -> str "assumption") assumption diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index cc56de066d..1d876537ef 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -206,9 +206,15 @@ let subst_hintrewrite (subst,(rbase,list as node)) = (rbase,list') (* Declaration of the Hint Rewrite library object *) -let inHintRewrite : string * HintDN.t -> Libobject.obj = +let inGlobalHintRewrite : string * HintDN.t -> Libobject.obj = let open Libobject in - declare_object @@ superglobal_object_nodischarge "HINT_REWRITE" + declare_object @@ superglobal_object_nodischarge "HINT_REWRITE_GLOBAL" + ~cache:cache_hintrewrite + ~subst:(Some subst_hintrewrite) + +let inExportHintRewrite : string * HintDN.t -> Libobject.obj = + let open Libobject in + declare_object @@ global_object_nodischarge "HINT_REWRITE_EXPORT" ~cache:cache_hintrewrite ~subst:(Some subst_hintrewrite) @@ -250,7 +256,8 @@ let find_applied_relation ?loc env sigma c left2right = spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) -let add_rew_rules base lrul = +let add_rew_rules ~locality base lrul = + let () = Hints.check_hint_locality locality in let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in @@ -267,5 +274,9 @@ let add_rew_rules base lrul = rew_tac = Option.map intern t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul - in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) - + in + let open Goptions in + match locality with + | OptLocal -> cache_hintrewrite ((),(base,lrul)) + | OptDefault | OptGlobal -> Lib.add_anonymous_leaf (inGlobalHintRewrite (base,lrul)) + | OptExport -> Lib.add_anonymous_leaf (inExportHintRewrite (base,lrul)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 974aef8e8f..dec6cc5ef4 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -17,7 +17,7 @@ open Equality type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t (** To add rewriting rules to a base *) -val add_rew_rules : string -> raw_rew_rule list -> unit +val add_rew_rules : locality:Goptions.option_locality -> string -> raw_rew_rule list -> unit (** The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 31873ea6b0..167f7d4026 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -104,9 +104,11 @@ sig | Cst_const of pconstant | Cst_proj of Projection.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t + | Case of 'a case_stk * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -121,7 +123,7 @@ sig val append_app : 'a array -> 'a t -> 'a t val decomp : 'a t -> ('a * 'a t) option val equal : ('a -> 'a -> bool) -> (('a, 'a) pfixpoint -> ('a, 'a) pfixpoint -> bool) - -> 'a t -> 'a t -> bool + -> ('a case_stk -> 'a case_stk -> bool) -> 'a t -> 'a t -> bool val strip_app : 'a t -> 'a t * 'a t val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option val will_expose_iota : 'a t -> bool @@ -156,9 +158,11 @@ struct | Cst_const of pconstant | Cst_proj of Projection.t + type 'a case_stk = + case_info * EInstance.t * 'a array * 'a pcase_return * 'a pcase_invert * 'a pcase_branch array type 'a member = | App of 'a app_node - | Case of case_info * 'a * ('a, EInstance.t) case_invert * 'a array * Cst_stack.t + | Case of 'a case_stk * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Primitive of CPrimitives.t * (Constant.t * EInstance.t) * 'a t * CPrimitives.args_red * Cst_stack.t @@ -172,9 +176,9 @@ struct let pr_c x = hov 1 (pr_c x) in match member with | App app -> str "ZApp" ++ pr_app_node pr_c app - | Case (_,_,_,br,cst) -> + | Case ((_,_,_,_,_,br),cst) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) (fun (_, b) -> pr_c b) br ++ str ")" | Proj (p,cst) -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -221,7 +225,7 @@ struct if i < j then (l.(j), App (i,l,pred j) :: sk) else (l.(j), sk) - let equal f f_fix sk1 sk2 = + let equal f f_fix f_case sk1 sk2 = let equal_cst_member x y = match x, y with | Cst_const (c1,u1), Cst_const (c2, u2) -> @@ -236,8 +240,8 @@ struct let t1,s1' = decomp_node_last a1 s1 in let t2,s2' = decomp_node_last a2 s2 in (f t1 t2) && (equal_rec s1' s2') - | Case (_,t1,_,a1,_) :: s1, Case (_,t2,_,a2,_) :: s2 -> - f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 + | Case ((ci1,pms1,p1,t1,iv1,a1),_) :: s1, Case ((ci2,pms2,p2,iv2,t2,a2),_) :: s2 -> + f_case (ci1,pms1,p1,t1,iv1,a1) (ci2,pms2,p2,iv2,t2,a2) && equal_rec s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> Projection.Repr.CanOrd.equal (Projection.repr p) (Projection.repr p2) && equal_rec s1 s2 @@ -284,7 +288,7 @@ struct let will_expose_iota args = List.exists - (function (Fix (_,_,l) | Case (_,_,_,_,l) | + (function (Fix (_,_,l) | Case (_,l) | Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) args @@ -346,9 +350,9 @@ struct then a else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) - | f, (Case (ci,rt,iv,br,cst_l)::s) when refold -> - zip (best_state sigma (mkCase (ci,rt,iv,f,br), s) cst_l) - | f, (Case (ci,rt,iv,br,_)::s) -> zip (mkCase (ci,rt,iv,f,br), s) + | f, (Case ((ci,u,pms,rt,iv,br),cst_l)::s) when refold -> + zip (best_state sigma (mkCase (ci,u,pms,rt,iv,f,br), s) cst_l) + | f, (Case ((ci,u,pms,rt,iv,br),_)::s) -> zip (mkCase (ci,u,pms,rt,iv,f,br), s) | f, (Fix (fix,st,cst_l)::s) when refold -> zip (best_state sigma (mkFix fix, st @ (append_app [|f|] s)) cst_l) | f, (Fix (fix,st,_)::s) -> zip @@ -533,25 +537,43 @@ let debug_RAKAM = Reductionops.debug_RAKAM let equal_stacks sigma (x, l) (y, l') = let f_equal x y = eq_constr sigma x y in let eq_fix a b = f_equal (mkFix a) (mkFix b) in - Stack.equal f_equal eq_fix l l' && f_equal x y + let eq_case (ci1, u1, pms1, p1, _, br1) (ci2, u2, pms2, p2, _, br2) = + Array.equal f_equal pms1 pms2 && + f_equal (snd p1) (snd p2) && + Array.equal (fun (_, c1) (_, c2) -> f_equal c1 c2) br1 br2 + in + Stack.equal f_equal eq_fix eq_case l l' && f_equal x y + +let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = + let args = Stack.tail ci.ci_npar args in + let args = Option.get (Stack.list_of_app_stack args) in + let br = lf.(i - 1) in + let subst = + if Int.equal ci.ci_cstr_nargs.(i - 1) ci.ci_cstr_ndecls.(i - 1) then + (* No let-bindings *) + List.rev args + else + let ctx = expand_branch env sigma u pms (ind, i) br in + subst_of_rel_context_instance ctx args + in + Vars.substl subst (snd br) let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in let open ReductionBehaviour in let rec whrec cst_l (x, stack) = - let () = if debug_RAKAM () then + let () = debug_RAKAM (fun () -> let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_debug (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str ">>"))) in let c0 = EConstr.kind sigma x in let fold () = - let () = if debug_RAKAM () then - let open Pp in Feedback.msg_debug (str "<><><><><>") in + let () = debug_RAKAM (fun () -> + Pp.(str "<><><><><>")) in ((EConstr.of_kind c0, stack),cst_l) in match c0 with @@ -699,8 +721,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | _ -> fold ()) | _ -> fold ()) - | Case (ci,p,iv,d,lf) -> - whrec Cst_stack.empty (d, Stack.Case (ci,p,iv,lf,cst_l) :: stack) + | Case (ci,u,pms,p,iv,d,lf) -> + whrec Cst_stack.empty (d, Stack.Case ((ci,u,pms,p,iv,lf),cst_l) :: stack) | Fix ((ri,n),_ as f) -> (match Stack.strip_n_app ri.(n) stack with @@ -708,13 +730,14 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s')) - | Construct ((ind,c),u) -> + | Construct (cstr ,u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, _, lf,_)::s') when use_match -> - whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Case(case,_)::s') when use_match -> + let r = apply_branch env sigma cstr args case in + whrec Cst_stack.empty (r, s') |args, (Stack.Proj (p,_)::s') when use_match -> whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> @@ -796,3 +819,15 @@ let whd_cbn flags env sigma t = (whd_state_gen ~refold:true ~tactic_mode:true flags env sigma (t, Stack.empty)) in Stack.zip ~refold:true sigma state + +let norm_cbn flags env sigma t = + let push_rel_check_zeta d env = + let open CClosure.RedFlags in + let d = match d with + | LocalDef (na,c,t) when not (red_set flags fZETA) -> LocalAssum (na,t) + | d -> d in + push_rel d env in + let rec strongrec env t = + map_constr_with_full_binders env sigma + push_rel_check_zeta strongrec env (whd_cbn flags env sigma t) in + strongrec env t diff --git a/tactics/cbn.mli b/tactics/cbn.mli index af54771382..a02a74f9e4 100644 --- a/tactics/cbn.mli +++ b/tactics/cbn.mli @@ -8,6 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** Weak-head cbn reduction. Despite the name, the cbn reduction is a complex + reduction distinct from call-by-name or call-by-need. *) val whd_cbn : CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr + +(** Strong variant of cbn reduction. *) +val norm_cbn : + CClosure.RedFlags.reds -> + Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 9e66e8668f..d93501eea6 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1014,10 +1014,11 @@ let deps_of_constraints cstrs evm p = cstrs let evar_dependencies pred evm p = + let cache = Evarutil.create_undefined_evars_cache () in Evd.fold_undefined (fun ev evi _ -> if Evd.is_typeclass_evar evm ev && pred evm ev evi then - let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + let evars = Evar.Set.add ev (Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi) in Intpart.union_set evars p else ()) evm () diff --git a/tactics/eauto.ml b/tactics/eauto.ml index e920093648..20c557b282 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -386,6 +386,7 @@ let make_dimension n = function | Some d -> (false,d) let autounfolds ids csts gl cls = + let open Tacred in let hyps = Tacmach.New.pf_ids_of_hyps gl in let env = Tacmach.New.pf_env gl in let ids = List.filter (fun id -> List.mem id hyps && Tacred.is_evaluable env (EvalVarRef id)) ids in diff --git a/tactics/elim.ml b/tactics/elim.ml index 9a55cabc86..9e7843b2bb 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -19,7 +19,6 @@ open Tacmach.New open Tacticals.New open Clenv open Tactics -open Proofview.Notations type branch_args = { branchnum : int; (* the branch number *) @@ -28,8 +27,6 @@ type branch_args = { true=assumption, false=let-in *) branchnames : Tactypes.intro_patterns} -module NamedDecl = Context.Named.Declaration - type elim_kind = Case of bool | Elim (* Find the right elimination suffix corresponding to the sort of the goal *) @@ -217,52 +214,3 @@ let h_decompose l c = decompose_these c l let h_decompose_or = decompose_or let h_decompose_and = decompose_and - -(* The tactic Double performs a double induction *) - -let induction_trailer abs_i abs_j bargs = - tclTHEN - (tclDO (abs_j - abs_i) intro) - (onLastHypId - (fun id -> - Proofview.Goal.enter begin fun gl -> - let idty = pf_get_type_of gl (mkVar id) in - let fvty = global_vars (pf_env gl) (project gl) idty in - let possible_bring_hyps = - (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs - in - let (hyps,_) = - List.fold_left - (fun (bring_ids,leave_ids) d -> - let cid = NamedDecl.get_id d in - if not (List.mem cid leave_ids) - then (d::bring_ids,leave_ids) - else (bring_ids,cid::leave_ids)) - ([],fvty) possible_bring_hyps - in - let ids = List.rev (ids_of_named_context hyps) in - (tclTHENLIST - [revert ids; elimination_then (fun _ -> tclIDTAC) id]) - end - )) - -let double_ind h1 h2 = - Proofview.Goal.enter begin fun gl -> - let abs_i = depth_of_quantified_hypothesis true h1 gl in - let abs_j = depth_of_quantified_hypothesis true h2 gl in - let abs = - if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else - if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else - let info = Exninfo.reify () in - tclZEROMSG ~info (Pp.str "Both hypotheses are the same.") in - abs >>= fun (abs_i,abs_j) -> - (tclTHEN (tclDO abs_i intro) - (onLastHypId - (fun id -> - elimination_then - (introElimAssumsThen (induction_trailer abs_i abs_j)) id))) - end - -let h_double_induction = double_ind - - diff --git a/tactics/elim.mli b/tactics/elim.mli index 01053502e4..a603b472f7 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -21,4 +21,3 @@ val case_tac : bool -> or_and_intro_pattern option -> val h_decompose : inductive list -> constr -> unit Proofview.tactic val h_decompose_or : constr -> unit Proofview.tactic val h_decompose_and : constr -> unit Proofview.tactic -val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index f90c143a1a..54e9a87c96 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -216,7 +216,7 @@ let build_sym_scheme env ind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat @@ -225,7 +225,7 @@ let build_sym_scheme env ind = rel_vect (2*nrealargs+2) nrealargs])), NoInvert, mkRel 1 (* varH *), - [|cstr (nrealargs+1)|])))) + [|cstr (nrealargs+1)|]))))) in c, UState.of_context_set ctx let sym_scheme_kind = @@ -279,13 +279,13 @@ let build_sym_involutive_scheme env ind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + (mkCase (Inductive.contract_case env (ci, + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs]); mkApp (sym,Array.concat @@ -300,7 +300,7 @@ let build_sym_involutive_scheme env ind = mkRel 1|])), NoInvert, mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))) in (c, UState.of_context_set ctx) let sym_involutive_scheme_kind = @@ -437,11 +437,11 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect 4 nrealargs; [|mkRel 2|]])|]]) in let main_body = - mkCase (ci, + mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, NoInvert, applied_sym_C 3, - [|mkVar varHC|]) + [|mkVar varHC|])) in let c = (my_it_mkLambda_or_LetIn paramsctxt @@ -451,7 +451,7 @@ let build_l2r_rew_scheme dep env ind kind = (mkNamedLambda (make_annot varHC indr) applied_PC (mkNamedLambda (make_annot varH indr) (lift 2 applied_ind) (if dep then (* we need a coercion *) - mkCase (cieq, + mkCase (Inductive.contract_case env (cieq, mkLambda (make_annot (Name varH) indr,lift 3 applied_ind, mkLambda (make_annot Anonymous indr, mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), @@ -459,7 +459,7 @@ let build_l2r_rew_scheme dep env ind kind = NoInvert, mkApp (sym_involutive, Array.append (Context.Rel.to_extended_vect mkRel 3 mip.mind_arity_ctxt) [|mkVar varH|]), - [|main_body|]) + [|main_body|])) else main_body)))))) in (c, UState.of_context_set ctx) @@ -540,7 +540,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda (make_annot varH indr) applied_ind - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkNamedProd (make_annot varP indr) @@ -553,7 +553,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda (make_annot varHC indr) applied_PC' - (mkVar varHC))|]))))) + (mkVar varHC))|])))))) in c, UState.of_context_set ctx (**********************************************************************) @@ -620,7 +620,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = (if dep then realsign_ind else realsign)) s) (mkNamedLambda (make_annot varHC indr) (lift 1 applied_PG) (mkApp - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+3) realsign_ind) (mkArrow applied_PG indr (lift (2*nrealargs+5) applied_PC)), @@ -629,7 +629,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = [|mkLambda (make_annot (Name varHC) indr, lift (nrealargs+3) applied_PC, - mkRel 1)|]), + mkRel 1)|])), [|mkVar varHC|])))))) in c, UState.of_context_set ctx @@ -825,7 +825,7 @@ let build_congr env (eq,refl,ctx) ind = (mkIndU indu, Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ Context.Rel.to_extended_list mkRel 0 realsign)) - (mkCase (ci, + (mkCase (Inductive.contract_case env (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) (mkLambda @@ -843,7 +843,7 @@ let build_congr env (eq,refl,ctx) ind = mkVar varH, [|mkApp (refl, [|mkVar varB; - mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))) in c, UState.of_context_set ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" diff --git a/tactics/genredexpr.ml b/tactics/genredexpr.ml index 9939490e79..a9100efddb 100644 --- a/tactics/genredexpr.ml +++ b/tactics/genredexpr.ml @@ -76,7 +76,7 @@ type 'a and_short_name = 'a * Names.lident option let wit_red_expr : ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, - (Genintern.glob_constr_and_expr,Names.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, - (EConstr.t,Names.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) + (Genintern.glob_constr_and_expr,Tacred.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, + (EConstr.t,Tacred.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) Genarg.genarg_type = make0 "redexpr" diff --git a/tactics/hints.ml b/tactics/hints.ml index ace51c40d4..058602acfd 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -46,7 +46,7 @@ let rec head_bound sigma t = match EConstr.kind sigma t with | Prod (_, _, b) -> head_bound sigma b | LetIn (_, _, _, b) -> head_bound sigma b | App (c, _) -> head_bound sigma c -| Case (_, _, _, c, _) -> head_bound sigma c +| Case (_, _, _, _, _, c, _) -> head_bound sigma c | Ind (ind, _) -> GlobRef.IndRef ind | Const (c, _) -> GlobRef.ConstRef c | Construct (c, _) -> GlobRef.ConstructRef c @@ -591,7 +591,7 @@ struct let head_evar sigma c = let rec hrec c = match EConstr.kind sigma c with | Evar (evk,_) -> evk - | Case (_,_,_,c,_) -> hrec c + | Case (_,_,_,_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | Proj (p, c) -> hrec c @@ -1187,6 +1187,28 @@ let create_hint_db l n st b = let hint = make_hint ~local:l n (CreateDB (b, st)) in Lib.add_anonymous_leaf (inAutoHint hint) +let warn_deprecated_hint_without_locality = + CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" + (fun () -> strbrk "The default value for hint locality is currently \ + \"local\" in a section and \"global\" otherwise, but is scheduled to change \ + in a future release. For the time being, adding hints outside of sections \ + without specifying an explicit locality is therefore deprecated. It is \ + recommended to use \"export\" whenever possible.") + +let check_hint_locality = let open Goptions in function +| OptGlobal -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the global attribute in sections."); +| OptExport -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the export attribute in sections."); +| OptDefault -> + if not @@ Global.sections_are_opened () then + warn_deprecated_hint_without_locality () +| OptLocal -> () + let interp_locality = function | Goptions.OptDefault | Goptions.OptGlobal -> false, true | Goptions.OptExport -> false, false diff --git a/tactics/hints.mli b/tactics/hints.mli index 54f4716652..381c7a1951 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -36,7 +36,7 @@ type 'a hint_ast = | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) - | Unfold_nth of evaluable_global_reference (* Hint Unfold *) + | Unfold_nth of Tacred.evaluable_global_reference (* Hint Unfold *) | Extern of Pattern.constr_pattern option * Genarg.glob_generic_argument (* Hint Extern *) type hint = private { @@ -173,8 +173,8 @@ type hints_entry = | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * hint_term) list | HintsCutEntry of hints_path - | HintsUnfoldEntry of evaluable_global_reference list - | HintsTransparencyEntry of evaluable_global_reference hints_transparency_target * bool + | HintsUnfoldEntry of Tacred.evaluable_global_reference list + | HintsTransparencyEntry of Tacred.evaluable_global_reference hints_transparency_target * bool | HintsModeEntry of GlobRef.t * hint_mode list | HintsExternEntry of hint_info * Genarg.glob_generic_argument @@ -182,6 +182,8 @@ val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit +val check_hint_locality : Goptions.option_locality -> unit + (** [create_hint_db local name st use_dn]. [st] is a transparency state for unification using this db [use_dn] switches the use of the discrimination net for all hints diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index 9c2df71f82..87cae3abe5 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -46,9 +46,6 @@ let cbv_native env sigma c = let whd_cbn = Cbn.whd_cbn -let strong_cbn flags = - strong_with_flags whd_cbn flags - let simplIsCbn = Goptions.declare_bool_option_and_ref ~depr:false ~key:["SimplIsCbn"] ~value:false @@ -81,7 +78,7 @@ let subst_strategy (subs,(local,obj)) = local, List.Smart.map (fun (k,ql as entry) -> - let ql' = List.Smart.map (Mod_subst.subst_evaluable_reference subs) ql in + let ql' = List.Smart.map (Tacred.subst_evaluable_reference subs) ql in if ql==ql' then entry else (k,ql')) obj @@ -248,11 +245,11 @@ let reduction_of_red_expr_val = function | Hnf -> (e_red hnf_constr,DEFAULTcast) | Simpl (f,o) -> let whd_am = if simplIsCbn () then whd_cbn f else whd_simpl in - let am = if simplIsCbn () then strong_cbn f else simpl in + let am = if simplIsCbn () then Cbn.norm_cbn f else simpl in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) | Cbv f -> (e_red (cbv_norm_flags f),DEFAULTcast) | Cbn f -> - (e_red (strong_cbn f), DEFAULTcast) + (e_red (Cbn.norm_cbn f), DEFAULTcast) | Lazy f -> (e_red (clos_norm_flags f),DEFAULTcast) | Unfold ubinds -> (e_red (unfoldn (List.map out_with_occurrences ubinds)),DEFAULTcast) | Fold cl -> (e_red (fold_commands cl),DEFAULTcast) @@ -344,7 +341,7 @@ let subst_red_expr subs = let sigma = Evd.from_env env in Redops.map_red_expr_gen (subst_mps subs) - (Mod_subst.subst_evaluable_reference subs) + (Tacred.subst_evaluable_reference subs) (Patternops.subst_pattern env sigma subs) let inReduction : bool * string * red_expr -> obj = diff --git a/tactics/redexpr.mli b/tactics/redexpr.mli index 5f3a7b689b..fb0043db8d 100644 --- a/tactics/redexpr.mli +++ b/tactics/redexpr.mli @@ -10,7 +10,6 @@ (** Interpretation layer of redexprs such as hnf, cbv, etc. *) -open Names open Constr open EConstr open Pattern @@ -19,7 +18,7 @@ open Reductionops open Locus type red_expr = - (constr, evaluable_global_reference, constr_pattern) red_expr_gen + (constr, Tacred.evaluable_global_reference, constr_pattern) red_expr_gen type red_expr_val @@ -50,7 +49,7 @@ val declare_red_expr : bool -> string -> red_expr -> unit true, the effect is non-synchronous (i.e. it does not survive section and module closure). *) val set_strategy : - bool -> (Conv_oracle.level * evaluable_global_reference list) list -> unit + bool -> (Conv_oracle.level * Tacred.evaluable_global_reference list) list -> unit (** call by value normalisation function using the virtual machine *) val cbv_vm : reduction_function diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 39c5c9562f..cbf12ac22f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -156,9 +156,6 @@ let convert_hyp ~check ~reorder d = end end -let convert_concl_no_check = convert_concl ~check:false -let convert_hyp_no_check = convert_hyp ~check:false ~reorder:false - let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with @@ -1244,8 +1241,6 @@ let force_destruction_arg with_evars env sigma c = (* tactic "cut" (actually modus ponens) *) (****************************************) -let normalize_cut = false - let cut c = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1260,8 +1255,6 @@ let cut c = | sigma, s -> let r = Sorts.relevance_of_sort s in let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in - (* Backward compat: normalize [c]. *) - let c = if normalize_cut then strong whd_betaiota env sigma c else c in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun h -> let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in @@ -1299,7 +1292,7 @@ let do_replace id = function [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) -let clenv_refine_in ?err with_evars targetid id sigma0 clenv tac = +let clenv_refine_in ?err with_evars targetid replace sigma0 clenv tac = let clenv = Clenv.clenv_pose_dependent_evars ~with_evars clenv in let evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd in let clenv = Clenv.update_clenv_evd clenv evd in @@ -1310,11 +1303,10 @@ let clenv_refine_in ?err with_evars targetid id sigma0 clenv tac = let new_hyp_prf = clenv_value clenv in let exact_tac = Logic.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf) in let naming = NamingMustBe (CAst.make targetid) in - let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas evd)) (Tacticals.New.tclTHENLAST - (assert_after_then_gen ?err with_clear naming new_hyp_typ tac) exact_tac) + (assert_after_then_gen ?err replace naming new_hyp_typ tac) exact_tac) (********************************************) (* Elimination tactics *) @@ -1365,7 +1357,7 @@ let elimination_in_clause_scheme env sigma with_evars ~flags if EConstr.eq_constr sigma hyp_typ new_hyp_typ then user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ Id.print id ++ str"."); - clenv_refine_in with_evars id id sigma elimclause'' + clenv_refine_in with_evars id true sigma elimclause'' (fun id -> Proofview.tclUNIT ()) (* @@ -1814,6 +1806,7 @@ let apply_in_once ?(respect_opaque = false) with_delta let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (LocalAssum (make_annot Anonymous Sorts.Relevant,t')) naming gl in + let replace = Id.equal id targetid in let rec aux ?err idstoclear with_destruct c = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1826,7 +1819,7 @@ let apply_in_once ?(respect_opaque = false) with_delta if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in try let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in - clenv_refine_in ?err with_evars targetid id sigma clause + clenv_refine_in ?err with_evars targetid replace sigma clause (fun id -> replace_error_option err ( apply_clear_request clear_flag false c <*> @@ -2324,26 +2317,31 @@ let rewrite_hyp_then with_evars thin l2r id tac = tclEVARSTHEN sigma (Tacticals.New.tclTHENFIRST eqtac (tac thin)) end -let prepare_naming ?loc = function - | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) - | IntroAnonymous -> NamingAvoid Id.Set.empty - | IntroFresh id -> NamingBasedOn (id, Id.Set.empty) - -let rec explicit_intro_names = let open CAst in function -| {v=IntroForthcoming _} :: l -> explicit_intro_names l -| {v=IntroNaming (IntroIdentifier id)} :: l -> Id.Set.add id (explicit_intro_names l) +let rec collect_intro_names = let open CAst in function +| {v=IntroForthcoming _} :: l -> collect_intro_names l +| {v=IntroNaming (IntroIdentifier id)} :: l -> + let ids1, ids2 = collect_intro_names l in Id.Set.add id ids1, ids2 | {v=IntroAction (IntroOrAndPattern l)} :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in - let fold accu l = Id.Set.union accu (explicit_intro_names (l@l')) in - List.fold_left fold Id.Set.empty ll + let fold (ids1',ids2') l = + let ids1, ids2 = collect_intro_names (l@l') in + Id.Set.union ids1 ids1', Id.Set.union ids2 ids2' in + List.fold_left fold (Id.Set.empty,Id.Set.empty) ll | {v=IntroAction (IntroInjection l)} :: l' -> - explicit_intro_names (l@l') + collect_intro_names (l@l') | {v=IntroAction (IntroApplyOn (c,pat))} :: l' -> - explicit_intro_names (pat::l') -| {v=(IntroNaming (IntroAnonymous | IntroFresh _) + collect_intro_names (pat::l') +| {v=IntroNaming (IntroFresh id)} :: l -> + let ids1, ids2 = collect_intro_names l in ids1, Id.Set.add id ids2 +| {v=(IntroNaming IntroAnonymous | IntroAction (IntroWildcard | IntroRewrite _))} :: l -> - explicit_intro_names l -| [] -> Id.Set.empty + collect_intro_names l +| [] -> Id.Set.empty, Id.Set.empty + +let explicit_intro_names l = fst (collect_intro_names l) + +let explicit_all_intro_names l = + let ids1,ids2 = collect_intro_names l in Id.Set.union ids1 ids2 let rec check_name_unicity env ok seen = let open CAst in function | {v=IntroForthcoming _} :: l -> check_name_unicity env ok seen l @@ -2368,30 +2366,33 @@ let rec check_name_unicity env ok seen = let open CAst in function check_name_unicity env ok seen l | [] -> () -let wild_id = Id.of_string "_tmp" - -let rec list_mem_assoc_right id = function - | [] -> false - | {CAst.v=id'}::l -> Id.equal id id' || list_mem_assoc_right id l +let fresh_wild ids = + let rec aux s = + if Id.Set.exists (fun id -> String.is_prefix s (Id.to_string id)) ids + then aux (s ^ "'") + else Id.of_string s in + aux "_H" -let check_thin_clash_then id thin avoid tac = - if list_mem_assoc_right id thin then - let newid = next_ident_away (add_suffix id "'") avoid in - let thin = - List.map CAst.(map (fun id' -> if Id.equal id id' then newid else id')) thin in - Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin) - else - tac thin +let make_naming ?loc avoid l = function + | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) + | IntroAnonymous -> NamingAvoid (Id.Set.union avoid (explicit_intro_names l)) + | IntroFresh id -> NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l)) -let make_tmp_naming avoid l = function +let rec make_naming_action avoid l = function (* In theory, we could use a tmp id like "wild_id" for all actions but we prefer to avoid it to avoid this kind of "ugly" names *) - (* Alternatively, we could have called check_thin_clash_then on - IntroAnonymous, but at the cost of a "renaming"; Note that in the - case of IntroFresh, we should use check_thin_clash_then anyway to - prevent the case of an IntroFresh precisely using the wild_id *) - | IntroWildcard -> NamingBasedOn (wild_id, Id.Set.union avoid (explicit_intro_names l)) - | pat -> NamingAvoid(Id.Set.union avoid (explicit_intro_names ((CAst.make @@ IntroAction pat)::l))) + | IntroWildcard -> + NamingBasedOn (fresh_wild (Id.Set.union avoid (explicit_all_intro_names l)), Id.Set.empty) + | IntroApplyOn (_,{CAst.v=pat;loc}) -> make_naming_pattern avoid ?loc l pat + | (IntroOrAndPattern _ | IntroInjection _ | IntroRewrite _) as pat -> + NamingAvoid(Id.Set.union avoid (explicit_intro_names ((CAst.make @@ IntroAction pat)::l))) + +and make_naming_pattern ?loc avoid l = function + | IntroNaming pat -> make_naming ?loc avoid l pat + | IntroAction pat -> make_naming_action avoid l pat + | IntroForthcoming _ -> NamingAvoid (Id.Set.union avoid (explicit_intro_names l)) + +let prepare_naming ?loc pat = make_naming ?loc Id.Set.empty [] pat let fit_bound n = function | None -> true @@ -2430,38 +2431,21 @@ let rec intro_patterns_core with_evars avoid ids thin destopt bound n tac = [CAst.make @@ IntroNaming IntroAnonymous] | {CAst.loc;v=pat} :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else + let naming = make_naming_pattern avoid l pat in match pat with | IntroForthcoming onlydeps -> - intro_forthcoming_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt onlydeps bound n + intro_forthcoming_then_gen naming destopt onlydeps bound n (fun ids -> intro_patterns_core with_evars avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> - intro_then_gen (make_tmp_naming avoid l pat) - destopt true false + intro_then_gen naming destopt true false (intro_pattern_action ?loc with_evars pat thin destopt (fun thin bound' -> intro_patterns_core with_evars avoid ids thin destopt bound' 0 (fun ids thin -> intro_patterns_core with_evars avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> - intro_pattern_naming loc with_evars avoid ids pat thin destopt bound (n+1) tac l - - (* Pi-introduction rule, used backwards *) -and intro_pattern_naming loc with_evars avoid ids pat thin destopt bound n tac l = - match pat with - | IntroIdentifier id -> - check_thin_clash_then id thin avoid (fun thin -> - intro_then_gen (NamingMustBe CAst.(make ?loc id)) destopt true false - (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l)) - | IntroAnonymous -> - intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt true false - (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l) - | IntroFresh id -> - (* todo: avoid thinned names to interfere with generation of fresh name *) - intro_then_gen (NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l))) - destopt true false - (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound n tac l) + intro_then_gen naming destopt true false + (fun id -> intro_patterns_core with_evars avoid (id::ids) thin destopt bound (n+1) tac l) and intro_pattern_action ?loc with_evars pat thin destopt tac id = match pat with @@ -2474,24 +2458,16 @@ and intro_pattern_action ?loc with_evars pat thin destopt tac id = | IntroRewrite l2r -> rewrite_hyp_then with_evars thin l2r id (fun thin -> tac thin None []) | IntroApplyOn ({CAst.loc=loc';v=f},{CAst.loc;v=pat}) -> - let naming,tac_ipat = - prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in - let doclear = - if naming = NamingMustBe (CAst.make ?loc id) then - Proofview.tclUNIT () (* apply_in_once do a replacement *) - else - clear [id] in - let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) - in + let naming = NamingMustBe (CAst.make ?loc id) in + let tac_ipat = prepare_action ?loc with_evars destopt pat in + let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) in apply_in_delayed_once true true with_evars naming id (None,CAst.make ?loc:loc' f) - (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) + (fun id -> Tacticals.New.tclTHENLIST [tac_ipat id; tac thin None []]) -and prepare_intros ?loc with_evars dft destopt = function +and prepare_action ?loc with_evars destopt = function | IntroNaming ipat -> - prepare_naming ?loc ipat, - (fun id -> move_hyp id destopt) + (fun _ -> Proofview.tclUNIT ()) | IntroAction ipat -> - prepare_naming ?loc dft, (let tac thin bound = intro_patterns_core with_evars Id.Set.empty [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in @@ -2528,9 +2504,19 @@ let intros_patterns with_evars = function (* Forward reasoning *) (**************************) -let prepare_intros_opt with_evars dft destopt = function - | None -> prepare_naming dft, (fun _id -> Proofview.tclUNIT ()) - | Some {CAst.loc;v=ipat} -> prepare_intros ?loc with_evars dft destopt ipat +let prepare_intros_opt with_evars dft destopt ipat = + let naming, loc, ipat = match ipat with + | None -> + let pat = IntroNaming dft in make_naming_pattern Id.Set.empty [] pat, None, pat + | Some {CAst.loc;v=(IntroNaming pat as ipat)} -> + (* "apply ... in H as id" needs to use id and H is kept iff id<>H *) + prepare_naming ?loc pat, loc, ipat + | Some {CAst.loc;v=(IntroAction pat as ipat)} -> + (* "apply ... in H as pat" reuses H so that old H is always cleared *) + (match dft with IntroIdentifier _ -> prepare_naming ?loc dft | _ -> make_naming_action Id.Set.empty [] pat), + loc, ipat + | Some {CAst.loc;v=(IntroForthcoming _)} -> assert false in + naming, prepare_action ?loc with_evars destopt ipat let ipat_of_name = function | Anonymous -> None @@ -3045,8 +3031,7 @@ let specialize (c,lbind) ipat = match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> (* Like assert (id:=id args) but with the concept of specialization *) - let naming,tac = - prepare_intros_opt false (IntroIdentifier id) MoveLast ipat in + let naming,tac = prepare_intros_opt false (IntroIdentifier id) MoveLast ipat in let repl = do_replace (Some id) naming in Tacticals.New.tclTHENFIRST (assert_before_then_gen repl naming typ tac) @@ -3059,10 +3044,10 @@ let specialize (c,lbind) ipat = (* TODO: add intro to be more homogeneous. It will break scripts but will be easy to fix *) (Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)) - | Some {CAst.loc;v=ipat} -> + | Some _ as ipat -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) - let naming,tac = prepare_intros ?loc false IntroAnonymous MoveLast ipat in + let naming, tac = prepare_intros_opt false IntroAnonymous MoveLast ipat in Tacticals.New.tclTHENFIRST (assert_before_then_gen false naming typ tac) (exact_no_check term) @@ -3293,7 +3278,7 @@ let expand_projections env sigma c = let rec aux env c = match EConstr.kind sigma c with | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] - | _ -> map_constr_with_full_binders sigma push_rel aux env c + | _ -> map_constr_with_full_binders env sigma push_rel aux env c in aux env c diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 0fd2f1253f..c07073a91a 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -35,10 +35,6 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool val introduction : Id.t -> unit Proofview.tactic val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : check:bool -> reorder:bool -> named_declaration -> unit Proofview.tactic -val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic -[@@ocaml.deprecated "use [Tactics.convert_concl]"] -val convert_hyp_no_check : named_declaration -> unit Proofview.tactic -[@@ocaml.deprecated "use [Tactics.convert_hyp]"] val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t -> int -> unit Proofview.tactic @@ -81,11 +77,6 @@ val auto_intros_tac : Names.Name.t list -> unit Proofview.tactic val intros : unit Proofview.tactic -(** [depth_of_quantified_hypothesis b h g] returns the index of [h] in - the conclusion of goal [g], up to head-reduction if [b] is [true] *) -val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> Proofview.Goal.t -> int - val intros_until : quantified_hypothesis -> unit Proofview.tactic val intros_clearing : bool list -> unit Proofview.tactic @@ -179,11 +170,11 @@ val normalise_in_hyp : hyp_location -> unit Proofview.tactic val normalise_option : goal_location -> unit Proofview.tactic val normalise_vm_in_concl : unit Proofview.tactic val unfold_in_concl : - (occurrences * evaluable_global_reference) list -> unit Proofview.tactic + (occurrences * Tacred.evaluable_global_reference) list -> unit Proofview.tactic val unfold_in_hyp : - (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic + (occurrences * Tacred.evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic val unfold_option : - (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic + (occurrences * Tacred.evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index df07dcbca7..f12d4e5de5 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -335,8 +335,9 @@ struct meta in Meta meta - | Case (ci,c1,_iv,c2,ca) -> - Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) + | Case (ci,u1,pms1,c1,_iv,c2,ca) -> + let f_ctx (_, p) = pat_of_constr p in + Term(DCase(ci,f_ctx c1,pat_of_constr c2,Array.map f_ctx ca)) | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) | CoFix (i,(_,ta,ca)) -> diff --git a/test-suite/bugs/closed/bug_13413.v b/test-suite/bugs/closed/bug_13413.v new file mode 100644 index 0000000000..b4414a6a1d --- /dev/null +++ b/test-suite/bugs/closed/bug_13413.v @@ -0,0 +1,20 @@ +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H ?%H H0. +exact H1. +Qed. + +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H ?H%H H0. +exact H1. +Qed. + +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H J%H H0. +exact J. +Qed. + +Set Mangle Names. +Goal forall (A B : Prop) (H : A -> B), A -> A -> B. +intros A B H ?%H _0. +assumption. +Qed. diff --git a/test-suite/bugs/closed/bug_13732.v b/test-suite/bugs/closed/bug_13732.v new file mode 100644 index 0000000000..24840abdf6 --- /dev/null +++ b/test-suite/bugs/closed/bug_13732.v @@ -0,0 +1,16 @@ +Module Sort. + Set Printing Universes. + + Implicit Types TT : Type. + + Check fun TT => nat. +End Sort. + +Module Ref. + Set Universe Polymorphism. + + Axiom tele : Type. + + Implicit Types TT : tele. + Check fun TT => nat. +End Ref. diff --git a/test-suite/bugs/closed/bug_13755.v b/test-suite/bugs/closed/bug_13755.v new file mode 100644 index 0000000000..cc25157b9b --- /dev/null +++ b/test-suite/bugs/closed/bug_13755.v @@ -0,0 +1,5 @@ +Module M1. +Lemma t1 : True. +Fail End M1. +Proof. exact I. Qed. +End M1. diff --git a/test-suite/bugs/opened/bug_3166.v b/test-suite/bugs/closed/bug_3166.v index baf87631f0..3b3375fdd8 100644 --- a/test-suite/bugs/opened/bug_3166.v +++ b/test-suite/bugs/closed/bug_3166.v @@ -80,5 +80,5 @@ Goal forall T (x y : T) (p : x = y), True. ) as H0. compute in H0. change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. - Fail pose proof (fun k => @eq_trans _ _ _ k H0). + pose proof (fun k => @eq_trans _ _ _ k H0). Abort. diff --git a/test-suite/bugs/closed/bug_6157.v b/test-suite/bugs/closed/bug_6157.v new file mode 100644 index 0000000000..cd24e4c7ee --- /dev/null +++ b/test-suite/bugs/closed/bug_6157.v @@ -0,0 +1,15 @@ +(* Check that universe instances of refs are preserved *) + +Section U. +Set Universe Polymorphism. +Definition U@{i} := Type@{i}. + +Section foo. +Universe i. +Fail Check U@{i} : U@{i}. +Notation Ui := U@{i}. (* syndef path *) +Fail Check Ui : Type@{i}. +Notation "#" := U@{i}. (* non-syndef path *) +Fail Check # : Type@{i}. +End foo. +End U. diff --git a/test-suite/coqdoc/verbatim.html.out b/test-suite/coqdoc/verbatim.html.out index bf9f975ee8..070f80e771 100644 --- a/test-suite/coqdoc/verbatim.html.out +++ b/test-suite/coqdoc/verbatim.html.out @@ -90,7 +90,7 @@ verbatim <tr class="infruleassumption"> <td class="infrule">Γ ⊢ A ∨ B</td> <td></td> -</td> +</tr> </table></center> <div class="paragraph"> </div> diff --git a/test-suite/micromega/bug_13794.v b/test-suite/micromega/bug_13794.v new file mode 100644 index 0000000000..5e303a0b7f --- /dev/null +++ b/test-suite/micromega/bug_13794.v @@ -0,0 +1,39 @@ +From Coq Require Import Lia ZArith.ZArith NArith.NArith. +Unset Nia Cache. + +Open Scope N_scope. + + +Lemma over (n0 n1 n2 n3 n4 n5 n6 : N) + (e0 : 1 + 8 * n0 = n1 * n1 + n2) + (e1 : n1 - 1 = 2 * n3 + n4) + (e2 : n3 * (1 + n3) = 2 * n5) + (e3 : n2 + 2 * n4 * n1 - n4 = 8 * n6) + (o0 : n4 = 0 \/ n4 = 1) : + n6 = n0 - n5. +Proof. + Time nia. +Qed. + +Lemma over2 (n0 n1 n2 n3 n4 n5 n6 : N) + (e0 : 1 + 8 * n0 = n1 * n1 + n2) + (e1 : n1 + 1 = 2 * n3 + n4) + (e2 : n3 * (1 + n3) = 2 * n5) + (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n6) + (o0 : n4 = 0) : + n6 = n0 + n5. +Proof. + Fail nia. +Abort. + +Open Scope Z_scope. + +Lemma over3 (n1 n2 n3 n4 n5 : Z) + (e : 0 <= n1 /\ 0 <= n2 /\ 0 <= n3 /\ 0 <= n4 + /\ 0 <= n5) + (e1 : n1 + 1 = 20 * n3 + n4) + (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n5) : + n5 = 0. +Proof. +Time Fail nia. +Abort. diff --git a/test-suite/micromega/reify_bool.v b/test-suite/micromega/reify_bool.v new file mode 100644 index 0000000000..501fafc0b3 --- /dev/null +++ b/test-suite/micromega/reify_bool.v @@ -0,0 +1,18 @@ +Require Import ZArith. +Require Import Lia. +Import Z. +Unset Lia Cache. + +Goal forall (x y : Z), + implb (Z.eqb x y) (Z.eqb y x) = true. +Proof. + intros. + lia. +Qed. + +Goal forall (x y :Z), implb (Z.eqb x 0) (Z.eqb y 0) = true <-> + orb (negb (Z.eqb x 0))(Z.eqb y 0) = true. +Proof. + intro. + lia. +Qed. diff --git a/test-suite/misc/coqtop_print-mod-uid.sh b/test-suite/misc/coqtop_print-mod-uid.sh new file mode 100755 index 0000000000..db1df4bb4b --- /dev/null +++ b/test-suite/misc/coqtop_print-mod-uid.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +[ "$(coqtop -print-mod-uid prerequisite/admit.vo)" = "prerequisite/.coq-native/NTestSuite_admit" ] diff --git a/test-suite/misc/non-marshalable-state.sh b/test-suite/misc/non-marshalable-state.sh new file mode 100755 index 0000000000..eef7786ebc --- /dev/null +++ b/test-suite/misc/non-marshalable-state.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash + +set -e + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +cd misc/non-marshalable-state/ + +coq_makefile -f _CoqProject -o Makefile + +make clean + +make src/evil_plugin.cmxs +make src/good_plugin.cmxs + +RC=1 +# must fail +coqc -async-proofs on -I src -Q theories Marshal theories/evil.v 2> log1 1>&2 || RC=0 +# for this reason +grep -q 'Marshalling error' log1 || RC=1 + +# must work +coqc -async-proofs off -I src -Q theories Marshal theories/evil.v + +# must work +coqc -async-proofs on -I src -Q theories Marshal theories/good.v + + +exit $RC diff --git a/test-suite/misc/non-marshalable-state/_CoqProject b/test-suite/misc/non-marshalable-state/_CoqProject new file mode 100644 index 0000000000..09e68d866c --- /dev/null +++ b/test-suite/misc/non-marshalable-state/_CoqProject @@ -0,0 +1,9 @@ +-Q theories Marshal +-I src + +src/evil.mlg +src/good.mlg +src/evil_plugin.mlpack +src/good_plugin.mlpack +theories/evil.v +theories/good.v diff --git a/test-suite/misc/non-marshalable-state/src/evil.mlg b/test-suite/misc/non-marshalable-state/src/evil.mlg new file mode 100644 index 0000000000..59b2b5a8ac --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/evil.mlg @@ -0,0 +1,15 @@ +DECLARE PLUGIN "evil_plugin" + +{ + +let state = Summary.ref + ~name:"elpi-compiler-cache" + None + +} + +VERNAC COMMAND EXTEND magic CLASSIFIED AS SIDEFF +| [ "magic" ] -> { + state := Some (fun () -> ()) +} +END diff --git a/test-suite/misc/non-marshalable-state/src/evil_plugin.mlpack b/test-suite/misc/non-marshalable-state/src/evil_plugin.mlpack new file mode 100644 index 0000000000..6382aa69e1 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/evil_plugin.mlpack @@ -0,0 +1 @@ +Evil diff --git a/test-suite/misc/non-marshalable-state/src/good.mlg b/test-suite/misc/non-marshalable-state/src/good.mlg new file mode 100644 index 0000000000..c6b9cbefd5 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/good.mlg @@ -0,0 +1,16 @@ +DECLARE PLUGIN "good_plugin" + +{ + +let state = Summary.Local.ref + ~name:"elpi-compiler-cache" + None + +} + +VERNAC COMMAND EXTEND magic CLASSIFIED AS SIDEFF +| [ "magic" ] -> { + let open Summary.Local in + state := Some (fun () -> ()) +} +END diff --git a/test-suite/misc/non-marshalable-state/src/good_plugin.mlpack b/test-suite/misc/non-marshalable-state/src/good_plugin.mlpack new file mode 100644 index 0000000000..cd9dd73b78 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/src/good_plugin.mlpack @@ -0,0 +1 @@ +Good diff --git a/test-suite/misc/non-marshalable-state/theories/evil.v b/test-suite/misc/non-marshalable-state/theories/evil.v new file mode 100644 index 0000000000..661482a975 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/theories/evil.v @@ -0,0 +1,5 @@ +Declare ML Module "evil_plugin". + +magic. + +Lemma x : True. Proof. trivial. Qed. diff --git a/test-suite/misc/non-marshalable-state/theories/good.v b/test-suite/misc/non-marshalable-state/theories/good.v new file mode 100644 index 0000000000..eab9a043e1 --- /dev/null +++ b/test-suite/misc/non-marshalable-state/theories/good.v @@ -0,0 +1,5 @@ +Declare ML Module "good_plugin". + +magic. + +Lemma x : True. Proof. trivial. Qed. diff --git a/test-suite/output-coqtop/DependentEvars.out b/test-suite/output-coqtop/DependentEvars.out index 2e69b94505..11d1ca0bdb 100644 --- a/test-suite/output-coqtop/DependentEvars.out +++ b/test-suite/output-coqtop/DependentEvars.out @@ -1,6 +1,6 @@ Coq < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R @@ -8,12 +8,12 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) strange_imp_trans < -strange_imp_trans < No more subgoals. +strange_imp_trans < No more goals. (dependent evars: ; in current goal:) strange_imp_trans < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q : Prop, (P -> Q) /\ P -> Q @@ -21,7 +21,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) modpon < -modpon < No more subgoals. +modpon < No more goals. (dependent evars: ; in current goal:) @@ -38,7 +38,7 @@ Coq < p123 is declared Coq < p34 is declared -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal P1, P2, P3, P4 : Prop p12 : P1 -> P2 @@ -50,7 +50,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) p14 < -p14 < 4 focused subgoals +p14 < 4 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -60,16 +60,16 @@ p14 < 4 focused subgoals ============================ ?Q -> P4 -subgoal 2 is: +goal 2 is: ?P -> ?Q -subgoal 3 is: +goal 3 is: ?P -> ?Q -subgoal 4 is: +goal 4 is: ?P (dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) -p14 < 3 focused subgoals +p14 < 3 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -79,9 +79,9 @@ p14 < 3 focused subgoals ============================ ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal: ?X4 ?X5 ?X10 ?X11) diff --git a/test-suite/output-coqtop/DependentEvars2.out b/test-suite/output-coqtop/DependentEvars2.out index 63bfafa88d..6bf2c35ad4 100644 --- a/test-suite/output-coqtop/DependentEvars2.out +++ b/test-suite/output-coqtop/DependentEvars2.out @@ -1,6 +1,6 @@ Coq < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R @@ -8,12 +8,12 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) strange_imp_trans < -strange_imp_trans < No more subgoals. +strange_imp_trans < No more goals. (dependent evars: ; in current goal:) strange_imp_trans < -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal ============================ forall P Q : Prop, (P -> Q) /\ P -> Q @@ -21,7 +21,7 @@ Coq < Coq < 1 subgoal (dependent evars: ; in current goal:) modpon < -modpon < No more subgoals. +modpon < No more goals. (dependent evars: ; in current goal:) @@ -38,7 +38,7 @@ Coq < p123 is declared Coq < p34 is declared -Coq < Coq < 1 subgoal +Coq < Coq < 1 goal P1, P2, P3, P4 : Prop p12 : P1 -> P2 @@ -52,7 +52,7 @@ Coq < Coq < 1 subgoal p14 < p14 < Second proof: -p14 < 4 focused subgoals +p14 < 4 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -62,16 +62,16 @@ p14 < 4 focused subgoals ============================ ?Q -> P4 -subgoal 2 is: +goal 2 is: ?P -> ?Q -subgoal 3 is: +goal 3 is: ?P -> ?Q -subgoal 4 is: +goal 4 is: ?P (dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) -p14 < 1 focused subgoal +p14 < 1 focused goal (shelved: 2) P1, P2, P3, P4 : Prop @@ -86,19 +86,19 @@ p14 < 1 focused subgoal p14 < This subproof is complete, but there are some unfocused goals. Try unfocusing with "}". -3 subgoals +3 goals (shelved: 2) -subgoal 1 is: +goal 1 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal:) -p14 < 3 focused subgoals +p14 < 3 focused goals (shelved: 2) P1, P2, P3, P4 : Prop @@ -108,9 +108,9 @@ p14 < 3 focused subgoals ============================ ?P -> (?P0 -> P4) /\ ?P0 -subgoal 2 is: +goal 2 is: ?P -> (?P0 -> P4) /\ ?P0 -subgoal 3 is: +goal 3 is: ?P (dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?P0; in current goal: ?X4 ?X5 ?X10 ?X11) diff --git a/test-suite/output-coqtop/ShowGoal.out b/test-suite/output-coqtop/ShowGoal.out index 42d9ff31e9..467112f153 100644 --- a/test-suite/output-coqtop/ShowGoal.out +++ b/test-suite/output-coqtop/ShowGoal.out @@ -1,52 +1,52 @@ -Coq < 1 subgoal
+Coq < 1 goal
============================
forall i : nat, exists j k : nat, i = j /\ j = k /\ i = k
x <
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
i : nat
============================
exists k : nat, i = ?j /\ ?j = k /\ i = k
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 2)
i : nat
============================
i = ?j /\ ?j = ?k /\ i = ?k
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 2)
i : nat
============================
i = ?j
-subgoal 2 is:
+goal 2 is:
?j = ?k /\ i = ?k
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
i : nat
============================
i = ?k /\ i = ?k
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 1)
i : nat
============================
i = ?k
-subgoal 2 is:
+goal 2 is:
i = ?k
-x < 1 subgoal
+x < 1 goal
i : nat
============================
diff --git a/test-suite/output-coqtop/ShowProofDiffs.out b/test-suite/output-coqtop/ShowProofDiffs.out index 285a3bcd89..a37e3e5af4 100644 --- a/test-suite/output-coqtop/ShowProofDiffs.out +++ b/test-suite/output-coqtop/ShowProofDiffs.out @@ -1,11 +1,11 @@ -Coq < Coq < 1 subgoal
+Coq < Coq < 1 goal
============================
[48;2;0;91;0m[48;2;0;141;0;4m[1mforall[22m i : nat, [37mexists[39m j k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k[48;2;0;91;0;24m[0m
x <
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 1)
[48;2;0;91;0m[48;2;0;141;0;4mi : nat[48;2;0;91;0;24m[0m
============================
@@ -14,7 +14,7 @@ x < 1 focused subgoal [48;2;0;91;0m[48;2;0;141;0;4m([1mfun[22m i : nat =>[49;24m
[48;2;0;141;0;4mex_intro ([1mfun[22m j : nat => [37mexists[39m k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k) [94m?[39m[94mj[39m[48;2;0;91;0;24m ?Goal[48;2;0;141;0;4m)[48;2;0;91;0;24m[0m
-x < 1 focused subgoal
+x < 1 focused goal
(shelved: 2)
i : nat
============================
@@ -24,13 +24,13 @@ x < 1 focused subgoal [48;2;0;91;0mex_intro ([1mfun[22m j : nat => [37mexists[39m k : nat[37m,[39m i[37m =[39m j[37m /\[39m j[37m =[39m k[37m /\[39m i[37m =[39m k) [49m
[48;2;0;91;0m[48;2;0;141;0;4m[94m?[39m[94mj[39m (ex_intro ([1mfun[22m k : nat => i[37m =[39m ?j[37m /\[39m[48;2;0;91;0;24m ?j[37m [39m[48;2;0;141;0;4m[37m=[39m k[37m /\[39m i[37m =[39m k) [94m?[39m[94mk[39m[48;2;0;91;0;24m ?Goal[48;2;0;141;0;4m)[48;2;0;91;0;24m)[0m
-x < 2 focused subgoals
+x < 2 focused goals
(shelved: 2)
i : nat
============================
[48;2;0;91;0mi[37m =[39m ?j[0m
-subgoal 2 is:
+goal 2 is:
[48;2;0;91;0m?j[37m =[39m ?k[37m /\[39m i[37m =[39m ?k[0m
[48;2;0;91;0m([1mfun[22m i : nat =>[49m
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index e46774f68a..9fd846ac16 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -11,7 +11,7 @@ eq_refl : ?y = ?y where ?y : [ |- nat] -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x. Arguments eq {A}%type_scope _ _ Arguments eq_refl {B}%type_scope {y}, [_] _ @@ -22,7 +22,7 @@ eq_refl is not universe polymorphic Arguments eq_refl {B}%type_scope {y}, [_] _ (where some original arguments have been renamed) Expands to: Constructor Coq.Init.Logic.eq_refl -Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x +Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x. Arguments myEq _%type_scope _ _ Arguments myrefl {C}%type_scope x _ @@ -55,7 +55,7 @@ Expands to: Constant Arguments_renaming.Test1.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat Inductive myEq (A B : Type) (x : A) : A -> Prop := - myrefl : B -> myEq A B x x + myrefl : B -> myEq A B x x. Arguments myEq (_ _)%type_scope _ _ Arguments myrefl A%type_scope {C}%type_scope x _ diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 984ac4e527..ea647a990a 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -50,10 +50,11 @@ f = fun H : B => match H with | AC x => - let b0 := b in - (if b0 as b return (P b -> True) - then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) x + (fun x0 : P b => + let b0 := b in + (if b0 as b return (P b -> True) + then fun _ : P true => Logic.I + else fun _ : P false => Logic.I) x0) x end : B -> True The command has indeed failed with message: @@ -88,7 +89,7 @@ Arguments lem2 _%bool_scope lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k -1 subgoal +1 goal x : nat n, n0 := match x + 0 with @@ -108,7 +109,7 @@ fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl end : x = x ============================ x + 0 = 0 -1 subgoal +1 goal p : nat a, diff --git a/test-suite/output/CompactContexts.out b/test-suite/output/CompactContexts.out index 9d1d19877e..f0a8019b67 100644 --- a/test-suite/output/CompactContexts.out +++ b/test-suite/output/CompactContexts.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal hP1 : True a : nat b : list nat h : forall x : nat, {y : nat | y > x} diff --git a/test-suite/output/DebugFlags.out b/test-suite/output/DebugFlags.out new file mode 100644 index 0000000000..0385413937 --- /dev/null +++ b/test-suite/output/DebugFlags.out @@ -0,0 +1,44 @@ +File "stdin", line 1, characters 0-16: +Warning: There is no debug flag "cbn". [unknown-debug-flag,option] +Debug: [RAKAM] <<forall A : Type, A -> A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<forall A : Type, A -> A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<?A -> ?A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<?A -> ?A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> Prop|>> +Debug: [RAKAM] <><><><><> +2 + 3 = 0 + : Prop diff --git a/test-suite/output/DebugFlags.v b/test-suite/output/DebugFlags.v new file mode 100644 index 0000000000..32c0f2d24b --- /dev/null +++ b/test-suite/output/DebugFlags.v @@ -0,0 +1,5 @@ +Set Debug "cbn". + +Set Debug "RAKAM". + +Check 2 + 3 = 0. diff --git a/test-suite/output/Function.out b/test-suite/output/Function.out new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/output/Function.out diff --git a/test-suite/output/Function.v b/test-suite/output/Function.v new file mode 100644 index 0000000000..b3e2a93895 --- /dev/null +++ b/test-suite/output/Function.v @@ -0,0 +1,31 @@ +Require Import FunInd List. + +(* Explanations: This kind of pattern matching displays a legitimate + unused variable warning in v8.13. + +Fixpoint f (l:list nat) : nat := + match l with + | nil => O + | S n :: nil => 1 + | x :: l' => f l' + end. +*) + +(* In v8.13 the same code with "Function" generates a lot more + warnings about variables created automatically by Function. These + are not legitimate. PR #13776 (post v8.13) removes all warnings + about pattern matching variables (and non truly recursive fixpoint) + for "Function". So this should not generate any warning. Note that + this PR removes also the legitimate warnings. It would be better if + this test generate the same warning as the Fixpoint above. This + test would then need to be updated. *) + +(* Ensuring the warning is a warning. *) +Set Warnings "matching-variable". +(* But no warning generated here. *) +Function f (l:list nat) : nat := + match l with + | nil => O + | S n :: nil => 1 + | n :: l' => f l' + end. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 8e10107673..fc3b6fbd99 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -5,7 +5,7 @@ A : Set a : A l : list' A Unable to unify "list' (A * A)%type" with "list' A". -Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x +Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x. Arguments foo _%type_scope _ Arguments Foo _%type_scope _ diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index 02e58775b5..fdd609f5b2 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,5 +1,5 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := - exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} + exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x}. Arguments sig2 [A]%type_scope (_ _)%type_scope Arguments exist2 [A]%type_scope (_ _)%function_scope _ _ _ diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out index ca8e1b58a8..7ca4de1e46 100644 --- a/test-suite/output/Int63Syntax.out +++ b/test-suite/output/Int63Syntax.out @@ -56,3 +56,21 @@ t = 2%i63 : int = 37151199385380486 : int + = 4 + : int + = 4 + : int + = 4 + : int + = add + : int -> int -> int + = 12 + : int + = 12 + : int + = 12 + : int + = 3 + x + : int + = 1 + 2 + x + : int diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v index 6f1046f7a5..50910264f2 100644 --- a/test-suite/output/Int63Syntax.v +++ b/test-suite/output/Int63Syntax.v @@ -40,3 +40,18 @@ Open Scope int63_scope. Check (2+2). Eval vm_compute in 2+2. Eval vm_compute in 65675757 * 565675998. + +Eval simpl in 2+2. +Eval hnf in 2+2. +Eval cbn in 2+2. +Eval hnf in PrimInt63.add. + +Eval simpl in (2 * 3) + (2 * 3). +Eval hnf in (2 * 3) + (2 * 3). +Eval cbn in (2 * 3) + (2 * 3). + +Section TestNoSimpl. +Variable x : int. +Eval simpl in 1 + 2 + x. +Eval hnf in 1 + 2 + x. +End TestNoSimpl. diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out index f2bf25ca65..e273307d75 100644 --- a/test-suite/output/Intuition.out +++ b/test-suite/output/Intuition.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal m, n : Z H : (m >= n)%Z diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out index 0a989646cf..2daa5a6bb5 100644 --- a/test-suite/output/Naming.out +++ b/test-suite/output/Naming.out @@ -1,23 +1,23 @@ -1 subgoal +1 goal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0 -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, x + x1 = x4 + x3 ============================ x + x1 = x4 + x0 -1 subgoal +1 goal x3 : nat ============================ forall x x1 x4 x0 : nat, (forall x2 x5 : nat, x2 + x1 = x4 + x5 -> foo (S x2 + x1)) -> x + x1 = x4 + x0 -> foo (S x) -1 subgoal +1 goal x3 : nat ============================ @@ -27,7 +27,7 @@ forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat ============================ @@ -36,7 +36,7 @@ forall x6 x7 x8 S0 : nat, x6 + S0 = x7 + x8 + (S x2 + x1)) -> x + x1 = x4 + x0 -> forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, @@ -45,7 +45,7 @@ H0 : x + x1 = x4 + x0 ============================ forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, x, x1, x4, x0 : nat H : forall x x3 : nat, @@ -55,7 +55,7 @@ x5, x6, x7, S : nat ============================ x5 + S = x6 + x7 + Datatypes.S x -1 subgoal +1 goal x3, a : nat H : a = 0 -> forall a : nat, a = 0 diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index a9bed49922..60213cab0c 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -238,7 +238,7 @@ Notation "'exists' ! x .. y , p" := (default interpretation) Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) -1 subgoal +1 goal ============================ ##@% diff --git a/test-suite/output/Partac.out b/test-suite/output/Partac.out index 889e698fa2..ce5dbdedb4 100644 --- a/test-suite/output/Partac.out +++ b/test-suite/output/Partac.out @@ -1,6 +1,6 @@ The command has indeed failed with message: The term "false" has type "bool" while it is expected to have type "nat". -(for subgoal 1) +(for goal 1) The command has indeed failed with message: The term "0" has type "nat" while it is expected to have type "bool". -(for subgoal 2) +(for goal 2) diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index fe16dba496..03b9e3b527 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -4,14 +4,14 @@ existT is template universe polymorphic on sigT.u0 sigT.u1 Arguments existT [A]%type_scope _%function_scope _ _ Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := - existT : forall x : A, P x -> {x : A & P x} + existT : forall x : A, P x -> {x : A & P x}. Arguments sigT [A]%type_scope _%type_scope Arguments existT [A]%type_scope _%function_scope _ _ existT : forall [A : Type] (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x. Arguments eq {A}%type_scope _ _ Arguments eq_refl {A}%type_scope {x}, [_] _ @@ -50,7 +50,7 @@ Arguments plus_n_O _%nat_scope plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O Inductive le (n : nat) : nat -> Prop := - le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m + le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m. Arguments le (_ _)%nat_scope Arguments le_n _%nat_scope @@ -60,7 +60,7 @@ comparison : Set comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison Inductive comparison : Set := - Eq : comparison | Lt : comparison | Gt : comparison + Eq : comparison | Lt : comparison | Gt : comparison. bar : foo bar is not universe polymorphic @@ -78,7 +78,7 @@ Arguments bar {x} Module Coq.Init.Peano Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq -Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x. Arguments eq {A}%type_scope _ _ Arguments eq_refl {A}%type_scope {x}, {_} _ diff --git a/test-suite/output/PrintModule.out b/test-suite/output/PrintModule.out index 1a9bc068c5..7c7600b786 100644 --- a/test-suite/output/PrintModule.out +++ b/test-suite/output/PrintModule.out @@ -7,3 +7,11 @@ Module N : S with Module T := K := M Module N : S with Module T := M Module Type Func = Funsig (T0:Test) Sig Parameter x : T0.t. End +Module +A +:= Struct + Variant I : Set := C : nat -> I. + Record R : Set := Build_R { n : nat }. + Definition n : R -> nat. + End + diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v index 54ef305be4..b4de03b556 100644 --- a/test-suite/output/PrintModule.v +++ b/test-suite/output/PrintModule.v @@ -60,3 +60,10 @@ Print Func. End Shortest_path. End QUX. + +Module A. +Variant I := C : nat -> I. +Record R := { n : nat }. +End A. + +Print Module A. diff --git a/test-suite/output/SearchHead.v b/test-suite/output/SearchHead.v deleted file mode 100644 index 2ee8a0d184..0000000000 --- a/test-suite/output/SearchHead.v +++ /dev/null @@ -1,19 +0,0 @@ -(* Some tests of the Search command *) - -SearchHead le. (* app nodes *) -SearchHead bool. (* no apps *) -SearchHead (@eq nat). (* complex pattern *) - -Definition newdef := fun x:nat => x = x. - -Goal forall n:nat, newdef n -> False. - intros n h. - SearchHead newdef. (* search hypothesis *) -Abort. - - -Goal forall n (P:nat -> Prop), P n -> False. - intros n P h. - SearchHead P. (* search hypothesis also for patterns *) -Abort. - diff --git a/test-suite/output/SearchHead.out b/test-suite/output/Search_headconcl.out index 2f0d854ac6..24e2ee76af 100644 --- a/test-suite/output/SearchHead.out +++ b/test-suite/output/Search_headconcl.out @@ -1,17 +1,9 @@ -File "stdin", line 3, characters 0-14: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] le_n: forall n : nat, n <= n le_0_n: forall n : nat, 0 <= n le_S: forall n m : nat, n <= m -> n <= S m le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m le_n_S: forall n m : nat, n <= m -> S n <= S m le_S_n: forall n m : nat, S n <= S m -> n <= m -File "stdin", line 4, characters 0-16: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] false: bool true: bool negb: bool -> bool @@ -35,10 +27,6 @@ Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool Decimal.int_beq: Decimal.int -> Decimal.int -> bool Decimal.uint_beq: Decimal.uint -> Decimal.uint -> bool -File "stdin", line 5, characters 0-21: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] mult_n_O: forall n : nat, 0 = n * 0 plus_O_n: forall n : nat, 0 + n = n plus_n_O: forall n : nat, n = n + 0 @@ -57,13 +45,5 @@ f_equal2_plus: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 f_equal2_mult: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 -File "stdin", line 11, characters 2-20: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] h: newdef n -File "stdin", line 17, characters 2-15: -Warning: -SearchHead is deprecated. Use the headconcl: clause of Search instead. -[deprecated-searchhead,deprecated] h: P n diff --git a/test-suite/output/Search_headconcl.v b/test-suite/output/Search_headconcl.v new file mode 100644 index 0000000000..8b168dcd25 --- /dev/null +++ b/test-suite/output/Search_headconcl.v @@ -0,0 +1,18 @@ +(* Some tests of the Search command *) + +Search headconcl: le. (* app nodes *) +Search headconcl: bool. (* no apps *) +Search headconcl: (@eq nat). (* complex pattern *) + +Definition newdef := fun x:nat => x = x. + +Goal forall n:nat, newdef n -> False. + intros n h. + Search headconcl: newdef. (* search hypothesis *) +Abort. + + +Goal forall n (P:nat -> Prop), P n -> False. + intros n P h. + Search headconcl: P. (* search hypothesis also for patterns *) +Abort. diff --git a/test-suite/output/Show.out b/test-suite/output/Show.out index f02e442be5..3db00be048 100644 --- a/test-suite/output/Show.out +++ b/test-suite/output/Show.out @@ -1,10 +1,10 @@ -3 subgoals (ID 29) +3 goals (ID 29) H : 0 = 0 ============================ 1 = 1 -subgoal 2 (ID 33) is: +goal 2 (ID 33) is: 1 = S (S m') -subgoal 3 (ID 20) is: +goal 3 (ID 20) is: S (S n') = S m diff --git a/test-suite/output/Unicode.out b/test-suite/output/Unicode.out index a57b3bbad5..abe6c39e8f 100644 --- a/test-suite/output/Unicode.out +++ b/test-suite/output/Unicode.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -8,7 +8,7 @@ → True → ∀ (x : very_very_long_type_name1) (y : very_very_long_type_name2), f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -18,7 +18,7 @@ → True → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) (z : very_very_long_type_name2), f y x ∧ f y z -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type @@ -29,7 +29,7 @@ → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) (z : very_very_long_type_name2), f y x ∧ f y z ∧ f y x ∧ f y z ∧ f y x ∧ f y z -1 subgoal +1 goal very_very_long_type_name1 : Type very_very_long_type_name2 : Type diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 95b6c6ee95..4993b747fa 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,6 +1,7 @@ -Inductive Empty@{uu} : Type@{uu} := +Inductive Empty@{uu} : Type@{uu} := . (* uu |= *) -Record PWrap (A : Type@{uu}) : Type@{uu} := pwrap { punwrap : A } +Record PWrap (A : Type@{uu}) : Type@{uu} := pwrap + { punwrap : A }. (* uu |= *) PWrap has primitive projections with eta conversion. @@ -12,7 +13,8 @@ fun (A : Type@{uu}) (p : PWrap@{uu} A) => punwrap _ p (* uu |= *) Arguments punwrap _%type_scope _ -Record RWrap (A : Type@{uu}) : Type@{uu} := rwrap { runwrap : A } +Record RWrap (A : Type@{uu}) : Type@{uu} := rwrap + { runwrap : A }. (* uu |= *) Arguments RWrap _%type_scope @@ -80,9 +82,9 @@ foo@{uu u v} = Type@{u} -> Type@{v} -> Type@{uu} : Type@{max(uu+1,u+1,v+1)} (* uu u v |= *) -Inductive Empty@{E} : Type@{E} := +Inductive Empty@{E} : Type@{E} := . (* E |= *) -Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } +Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A }. (* E |= *) PWrap has primitive projections with eta conversion. @@ -107,7 +109,7 @@ insec@{v} = Type@{uu} -> Type@{v} : Type@{max(uu+1,v+1)} (* v |= *) Inductive insecind@{k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{k} + inseccstr : Type@{k} -> insecind@{k}. (* k |= *) Arguments inseccstr _%type_scope @@ -115,7 +117,7 @@ insec@{uu v} = Type@{uu} -> Type@{v} : Type@{max(uu+1,v+1)} (* uu v |= *) Inductive insecind@{uu k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{uu k} + inseccstr : Type@{k} -> insecind@{uu k}. (* uu k |= *) Arguments inseccstr _%type_scope diff --git a/test-suite/output/bug_13821_native_command_line_warn.out b/test-suite/output/bug_13821_native_command_line_warn.out new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/output/bug_13821_native_command_line_warn.out diff --git a/test-suite/output/bug_13821_native_command_line_warn.v b/test-suite/output/bug_13821_native_command_line_warn.v new file mode 100644 index 0000000000..a28210b6c2 --- /dev/null +++ b/test-suite/output/bug_13821_native_command_line_warn.v @@ -0,0 +1 @@ +(* -*- coq-prog-args: ("-w" "-native-compiler-disabled" "-native-compiler" "ondemand"); -*- *) diff --git a/test-suite/output/bug_9370.out b/test-suite/output/bug_9370.out index 0ff151c8b4..8d34b7143a 100644 --- a/test-suite/output/bug_9370.out +++ b/test-suite/output/bug_9370.out @@ -1,12 +1,12 @@ -1 subgoal +1 goal ============================ 1 = 1 -1 subgoal +1 goal ============================ 1 = 1 -1 subgoal +1 goal ============================ 1 = 1 diff --git a/test-suite/output/bug_9403.out b/test-suite/output/bug_9403.out index 850760d5ed..cd1030bd2e 100644 --- a/test-suite/output/bug_9403.out +++ b/test-suite/output/bug_9403.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal X : tele α, β, γ1, γ2 : X → Prop diff --git a/test-suite/output/bug_9569.out b/test-suite/output/bug_9569.out index 2d474e4933..e49449679f 100644 --- a/test-suite/output/bug_9569.out +++ b/test-suite/output/bug_9569.out @@ -1,16 +1,16 @@ -1 subgoal +1 goal ============================ exists I : True, I = Logic.I -1 subgoal +1 goal ============================ f True False True False (Logic.True /\ Logic.False) -1 subgoal +1 goal ============================ [I | I = Logic.I; I = Logic.I] = [I | I = Logic.I; I = Logic.I] -1 subgoal +1 goal ============================ [I & I = Logic.I | I = Logic.I; Logic.I = I] diff --git a/test-suite/output/clear.out b/test-suite/output/clear.out index 42e3abf26f..ea01ac50d7 100644 --- a/test-suite/output/clear.out +++ b/test-suite/output/clear.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal z := 0 : nat ============================ diff --git a/test-suite/output/goal_output.out b/test-suite/output/goal_output.out index 17c1aaa55b..453f6ee615 100644 --- a/test-suite/output/goal_output.out +++ b/test-suite/output/goal_output.out @@ -2,79 +2,79 @@ Nat.t = nat : Set Nat.t = nat : Set -2 subgoals +2 goals ============================ True -subgoal 2 is: +goal 2 is: True -2 subgoals, subgoal 1 (?Goal) +2 goals, goal 1 (?Goal) ============================ True -subgoal 2 (?Goal0) is: +goal 2 (?Goal0) is: True -1 subgoal +1 goal ============================ True -1 subgoal (?Goal0) +1 goal (?Goal0) ============================ True -1 subgoal (?Goal0) +1 goal (?Goal0) ============================ True *** Unfocused goals: -subgoal 2 (?Goal1) is: +goal 2 (?Goal1) is: True -subgoal 3 (?Goal) is: +goal 3 (?Goal) is: True -1 subgoal +1 goal ============================ True *** Unfocused goals: -subgoal 2 is: +goal 2 is: True -subgoal 3 is: +goal 3 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -2 subgoals +2 goals -subgoal 1 is: +goal 1 is: True -subgoal 2 is: +goal 2 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -2 subgoals +2 goals -subgoal 1 (?Goal0) is: +goal 1 (?Goal0) is: True -subgoal 2 (?Goal) is: +goal 2 (?Goal) is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -1 subgoal +1 goal -subgoal 1 is: +goal 1 is: True This subproof is complete, but there are some unfocused goals. Focus next goal with bullet -. -1 subgoal +1 goal -subgoal 1 (?Goal) is: +goal 1 (?Goal) is: True diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index efdc94fb1e..ed42429f85 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -38,7 +38,7 @@ Ltac foo := let w := () in let z := 1 in pose v -2 subgoals +2 goals n : nat ============================ @@ -47,5 +47,5 @@ Ltac foo := | S n1 => a n1 end) n = n -subgoal 2 is: +goal 2 is: forall a : nat, a = 0 diff --git a/test-suite/output/names.out b/test-suite/output/names.out index 48be63a46a..051bce7701 100644 --- a/test-suite/output/names.out +++ b/test-suite/output/names.out @@ -3,7 +3,7 @@ In environment y : nat The term "a y" has type "{y0 : nat | y = y0}" while it is expected to have type "{x : nat | x = y}". -1 focused subgoal +1 focused goal (shelved: 1) H : ?n <= 3 -> 3 <= ?n -> ?n = 3 diff --git a/test-suite/output/optimize_heap.out b/test-suite/output/optimize_heap.out index 94a0b19118..b6ee61a971 100644 --- a/test-suite/output/optimize_heap.out +++ b/test-suite/output/optimize_heap.out @@ -1,8 +1,8 @@ -1 subgoal +1 goal ============================ True -1 subgoal +1 goal ============================ True diff --git a/test-suite/output/set.out b/test-suite/output/set.out index 4b72d73eb3..61f3c52656 100644 --- a/test-suite/output/set.out +++ b/test-suite/output/set.out @@ -1,16 +1,16 @@ -1 subgoal +1 goal y1 := 0 : nat x := 0 + 0 : nat ============================ x = x -1 subgoal +1 goal y1, y2 := 0 : nat x := y2 + 0 : nat ============================ x = x -1 subgoal +1 goal y1, y2, y3 := 0 : nat x := y2 + y3 : nat diff --git a/test-suite/output/simpl.out b/test-suite/output/simpl.out index 526e468f5b..fd35c5e339 100644 --- a/test-suite/output/simpl.out +++ b/test-suite/output/simpl.out @@ -1,14 +1,14 @@ -1 subgoal +1 goal x : nat ============================ x = S x -1 subgoal +1 goal x : nat ============================ 0 + x = S x -1 subgoal +1 goal x : nat ============================ diff --git a/test-suite/output/subst.out b/test-suite/output/subst.out index 209b2bc26f..9cc515b7ba 100644 --- a/test-suite/output/subst.out +++ b/test-suite/output/subst.out @@ -1,4 +1,4 @@ -1 subgoal +1 goal y, z : nat Hy : y = 0 @@ -11,7 +11,7 @@ H4 : z = 4 ============================ True -1 subgoal +1 goal x, z : nat Hx : x = 0 @@ -24,7 +24,7 @@ H4 : z = 4 ============================ True -1 subgoal +1 goal x, y : nat Hx : x = 0 @@ -37,7 +37,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal H1 : 0 = 1 HA : True @@ -47,7 +47,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal y, z : nat Hy : y = 0 @@ -60,7 +60,7 @@ H2 : 0 = 2 ============================ True -1 subgoal +1 goal x, z : nat Hx : x = 0 @@ -73,7 +73,7 @@ H3 : 0 = 3 ============================ True -1 subgoal +1 goal x, y : nat Hx : x = 0 @@ -86,7 +86,7 @@ H4 : 0 = 4 ============================ True -1 subgoal +1 goal HA, HB : True H4 : 0 = 4 diff --git a/test-suite/output/unifconstraints.out b/test-suite/output/unifconstraints.out index 2fadd747b7..abcb8d7e0c 100644 --- a/test-suite/output/unifconstraints.out +++ b/test-suite/output/unifconstraints.out @@ -1,44 +1,44 @@ -3 focused subgoals +3 focused goals (shelved: 1) ============================ ?Goal 0 -subgoal 2 is: +goal 2 is: forall n : nat, ?Goal n -> ?Goal (S n) -subgoal 3 is: +goal 3 is: nat unification constraint: ?Goal ?Goal2 <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) n, m : nat ============================ ?Goal@{n:=n; m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal@{n:=n; m:=m} n0 -> ?Goal@{n:=n; m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: ?Goal@{n:=n; m:=m} ?Goal2@{n:=n; m:=m} <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) m : nat ============================ ?Goal1@{m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal1@{m:=m} n0 -> ?Goal1@{m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: @@ -46,16 +46,16 @@ unification constraint: True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = veeryyyyyyyyyyyyloooooooooooooonggidentifier -3 focused subgoals +3 focused goals (shelved: 1) m : nat ============================ ?Goal0@{m:=m} 0 -subgoal 2 is: +goal 2 is: forall n0 : nat, ?Goal0@{m:=m} n0 -> ?Goal0@{m:=m} (S n0) -subgoal 3 is: +goal 3 is: nat unification constraint: diff --git a/test-suite/output/unification.out b/test-suite/output/unification.out index cf31871e5a..4db5c2d161 100644 --- a/test-suite/output/unification.out +++ b/test-suite/output/unification.out @@ -9,25 +9,25 @@ Unable to unify "T" with "?X@{x0:=x; x:=C a}" (cannot instantiate The command has indeed failed with message: The term "id" has type "ID" while it is expected to have type "Type -> ?T" (cannot instantiate "?T" because "A" is not in its scope). -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S (S (S x)) = x ============================ ?x = 0 -1 focused subgoal +1 focused goal (shelved: 1) H : forall x : nat, S x = x diff --git a/test-suite/success/autorewrite.v b/test-suite/success/autorewrite.v index 71d333d439..0ac62fcdc9 100644 --- a/test-suite/success/autorewrite.v +++ b/test-suite/success/autorewrite.v @@ -4,25 +4,35 @@ Axiom Ack0 : forall m : nat, Ack 0 m = S m. Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1. Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m). -Hint Rewrite Ack0 Ack1 Ack2 : base0. +Module M. + #[export] Hint Rewrite Ack0 Ack1 Ack2 : base0. -Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False. + Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False. + Proof. + intros. + autorewrite with base0 in H using try (apply H; reflexivity). + Qed. +End M. + +Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False. Proof. intros. - autorewrite with base0 in H using try (apply H; reflexivity). -Qed. + Fail autorewrite with base0 in *. +Abort. + +Import M. Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False. Proof. intros. autorewrite with base0 in *. - apply H;reflexivity. + apply H;reflexivity. Qed. (* Check autorewrite does not solve existing evars *) (* See discussion started by A. Chargueraud in Oct 2010 on coqdev *) -Hint Rewrite <- plus_n_O : base1. +Global Hint Rewrite <- plus_n_O : base1. Goal forall y, exists x, y+x = y. eexists. autorewrite with base1. Fail reflexivity. diff --git a/test-suite/success/case_let_conversion.v b/test-suite/success/case_let_conversion.v new file mode 100644 index 0000000000..3f1ab96fe1 --- /dev/null +++ b/test-suite/success/case_let_conversion.v @@ -0,0 +1,39 @@ +Axiom checker_flags : Set. + +Inductive Box (R : Type) : Type := box : Box R. + +Inductive typing (H : checker_flags) : Type := +| type_Rel : typing H -> typing H +| type_Case : let i := tt in Box (typing H) -> typing H. + +Definition unbox (P : Type) (b : Box P) := match b with box _ => 0 end. + +Definition size (H : checker_flags) (d : typing H) : nat. +Proof. +revert d. +fix size 1. +destruct 1. +- exact (size d). +- exact (unbox _ b). +Defined. + +Definition foo (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +simpl. +reflexivity. +Qed. + +Definition bar (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +vm_compute. +reflexivity. +Qed. + +Definition qux (H : checker_flags) (a : typing H) : + size H (type_Rel H a) = size H a. +Proof. +native_compute. +reflexivity. +Qed. diff --git a/test-suite/success/case_let_param.v b/test-suite/success/case_let_param.v new file mode 100644 index 0000000000..46d8c26e83 --- /dev/null +++ b/test-suite/success/case_let_param.v @@ -0,0 +1,15 @@ +Inductive foo (x := tt) := Foo : forall (y := x), foo. + +Definition get (t : foo) := match t with Foo _ y => y end. + +Goal get Foo = tt. +Proof. +reflexivity. +Qed. + +Goal forall x : foo, + match x with Foo _ y => y end = match x with Foo _ _ => tt end. +Proof. +intros. +reflexivity. +Qed. diff --git a/test-suite/success/change.v b/test-suite/success/change.v index 2f676cf9ad..053429a5a9 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -14,8 +14,8 @@ Abort. (* Check the combination of at, with and in (see bug #2146) *) Goal 3=3 -> 3=3. intro H. -change 3 at 2 with (1+2). -change 3 at 2 with (1+2) in H |-. +change 3 with (1+2) at 2. +change 3 with (1+2) in H at 2 |-. change 3 with (1+2) in H at 1 |- * at 1. (* Now check that there are no more 3's *) change 3 with (1+2) in * || reflexivity. diff --git a/test-suite/success/forward.v b/test-suite/success/forward.v index 4e36dec15b..62c788e910 100644 --- a/test-suite/success/forward.v +++ b/test-suite/success/forward.v @@ -27,3 +27,7 @@ Fail match goal with |- (?f ?a) => idtac end. (* should be beta-iota reduced *) 2:match goal with _: (?f ?a) |- _ => idtac end. (* should not be beta-iota reduced *) Abort. +Goal nat. +assert nat as J%S by exact 0. +exact J. +Qed. diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 4983ee3c0d..615350c58c 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -154,50 +154,6 @@ induction H. change (0 = z -> True) in IHrepr''. Abort. -(* Test double induction *) - -(* This was failing in 8.5 and before because of a bug in the order of - hypotheses *) - -Set Warnings "-deprecated". - -Inductive I2 : Type := - C2 : forall x:nat, x=x -> I2. -Goal forall a b:I2, a = b. -double induction a b. -Abort. - -(* This was leaving useless hypotheses in 8.5 and before because of - the same bug. This is a change of compatibility. *) - -Inductive I3 : Prop := - C3 : forall x:nat, x=x -> I3. -Goal forall a b:I3, a = b. -double induction a b. -Fail clear H. (* H should have been erased *) -Abort. - -(* This one had quantification in reverse order in 8.5 and before *) -(* This is a change of compatibility. *) - -Goal forall m n, le m n -> le n m -> n=m. -intros m n. double induction 1 2. -3:destruct 1. (* Should be "S m0 <= m0" *) -Abort. - -(* Idem *) - -Goal forall m n p q, le m n -> le p q -> n+p=m+q. -intros *. double induction 1 2. -3:clear H2. (* H2 should have been erased *) -Abort. - -(* This is unchanged *) - -Goal forall m n:nat, n=m. -double induction m n. -Abort. - (* Mentioned as part of bug #12944 *) Inductive test : Set := cons : forall (IHv : nat) (v : test), test. diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index d37ad9f528..b8fbff05c6 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -152,3 +152,15 @@ Definition d := ltac:(intro x; exact (x*x)). Definition d' : nat -> _ := ltac:(intros;exact 0). End Evar. + +Module Wildcard. + +(* We check that the wildcard internal name does not interfere with + user fresh names (currently the prefix is "_H") *) + +Goal nat -> bool -> nat -> bool. +intros _ ?_H ?_H. +exact _H. +Qed. + +End Wildcard. diff --git a/test-suite/success/let_pattern_mismatch.v b/test-suite/success/let_pattern_mismatch.v new file mode 100644 index 0000000000..a56a8fff4f --- /dev/null +++ b/test-suite/success/let_pattern_mismatch.v @@ -0,0 +1,18 @@ +(* Weird corner case accepted by the pattern-matching algorithm. Destructuring + let-bindings in patterns can actually be shorter than the case they match. *) + +Inductive ascii : Set := +| Ascii : bool -> bool -> bool -> bool -> bool -> bool -> bool -> bool -> ascii. + +Definition dummy (a : ascii) : unit := + let (a0,a1,a2,a3,a4,a5,a6,a7) := a in tt. + +Goal forall (a : ascii) (H : tt = dummy a), True. +Proof. +intros a H. +unfold dummy in *. +(* Two bound variables in the pattern, eight in the term. *) +match goal with +| H:context [ let (x, y) := ?X in _ ] |- _ => destruct X eqn:? +end. +Abort. diff --git a/test-suite/success/match_case_pattern_variables.v b/test-suite/success/match_case_pattern_variables.v new file mode 100644 index 0000000000..bb9117d033 --- /dev/null +++ b/test-suite/success/match_case_pattern_variables.v @@ -0,0 +1,34 @@ +(** Check that bound variables in case patterns are handled correctly. *) + +Goal forall (ch : unit) (t : list unit) (s : list unit), + match s with + | nil => False + | cons a l => ch = a /\ l = t + end. +Proof. +intros. +match goal with +| |- match ?e with + | nil => ?N + | cons a b => ?P + end => + let f := + constr:((fun (e' : list unit) => match e' with + | nil => N + | cons a b => P + end)) + in + change (f e) +end. +Abort. + +Goal forall (ch : unit) (n : nat) (s : prod unit nat), + let (a, l) := s in ch = a /\ l = n. +Proof. +intros. +match goal with +| [ |- let (a, b) := ?e in ?P ] => + let f := constr:((fun (e' : prod unit nat) => match e' with pair a b => P end)) in + change (f e) +end. +Abort. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index d597c0404a..5fe2cade3b 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -489,7 +489,7 @@ the above form: variables. We are going to use them with [autorewrite]. *) - Hint Rewrite + Global Hint Rewrite F.empty_iff F.singleton_iff F.add_iff F.remove_iff F.union_iff F.inter_iff F.diff_iff : set_simpl. @@ -499,7 +499,7 @@ the above form: now split. Qed. - Hint Rewrite eq_refl_iff : set_eq_simpl. + Global Hint Rewrite eq_refl_iff : set_eq_simpl. (** ** Decidability of FSet Propositions *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 115c7cb365..d6277b3bb5 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -3327,7 +3327,7 @@ Ltac invlist f := (** * Exporting hints and tactics *) -Hint Rewrite +Global Hint Rewrite rev_involutive (* rev (rev l) = l *) rev_unit (* rev (l ++ a :: nil) = a :: rev l *) map_nth (* nth n (map f l) (f d) = f (nth n l d) *) diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index aa0c419f0e..579e5e9630 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -489,7 +489,7 @@ the above form: variables. We are going to use them with [autorewrite]. *) - Hint Rewrite + Global Hint Rewrite F.empty_iff F.singleton_iff F.add_iff F.remove_iff F.union_iff F.inter_iff F.diff_iff : set_simpl. @@ -499,7 +499,7 @@ the above form: now split. Qed. - Hint Rewrite eq_refl_iff : set_eq_simpl. + Global Hint Rewrite eq_refl_iff : set_eq_simpl. (** ** Decidability of MSet Propositions *) diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index f80929e320..2d210e24a6 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -651,7 +651,7 @@ Proof. destruct (rbal'_match l x r); ok. Qed. -Hint Rewrite In_node_iff In_leaf_iff +Global Hint Rewrite In_node_iff In_leaf_iff makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb. Ltac descolor := destruct_all Color.t. @@ -670,7 +670,7 @@ Proof. - descolor; autorew; rewrite IHl; intuition_in. - descolor; autorew; rewrite IHr; intuition_in. Qed. -Hint Rewrite ins_spec : rb. +Global Hint Rewrite ins_spec : rb. Instance ins_ok s x `{Ok s} : Ok (ins x s). Proof. @@ -685,7 +685,7 @@ Proof. unfold add. now autorew. Qed. -Hint Rewrite add_spec' : rb. +Global Hint Rewrite add_spec' : rb. Lemma add_spec s x y `{Ok s} : InT y (add x s) <-> X.eq y x \/ InT y s. @@ -754,7 +754,7 @@ Proof. * ok. apply lbal_ok; ok. Qed. -Hint Rewrite lbalS_spec rbalS_spec : rb. +Global Hint Rewrite lbalS_spec rbalS_spec : rb. (** ** Append for deletion *) @@ -807,7 +807,7 @@ Proof. [intros a y b | intros t Ht]; autorew; tauto. Qed. -Hint Rewrite append_spec : rb. +Global Hint Rewrite append_spec : rb. Lemma append_ok : forall x l r `{Ok l, Ok r}, lt_tree x l -> gt_tree x r -> Ok (append l r). @@ -861,7 +861,7 @@ induct s x. rewrite ?IHr by trivial; intuition_in; order. Qed. -Hint Rewrite del_spec : rb. +Global Hint Rewrite del_spec : rb. Instance del_ok s x `{Ok s} : Ok (del x s). Proof. @@ -882,7 +882,7 @@ Proof. unfold remove. now autorew. Qed. -Hint Rewrite remove_spec : rb. +Global Hint Rewrite remove_spec : rb. Instance remove_ok s x `{Ok s} : Ok (remove x s). Proof. diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 48df5fe884..420c17c9a4 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -127,7 +127,7 @@ Qed. End N2Nat. -Hint Rewrite N2Nat.inj_double N2Nat.inj_succ_double +Global Hint Rewrite N2Nat.inj_double N2Nat.inj_succ_double N2Nat.inj_succ N2Nat.inj_add N2Nat.inj_mul N2Nat.inj_sub N2Nat.inj_pred N2Nat.inj_div2 N2Nat.inj_max N2Nat.inj_min N2Nat.id @@ -147,7 +147,7 @@ Proof. induction n; simpl; trivial. apply SuccNat2Pos.id_succ. Qed. -Hint Rewrite id : Nnat. +Global Hint Rewrite id : Nnat. Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat. (** [N.of_nat] is hence injective *) @@ -206,7 +206,7 @@ Proof. now rewrite N2Nat.inj_iter, !id. Qed. End Nat2N. -Hint Rewrite Nat2N.id : Nnat. +Global Hint Rewrite Nat2N.id : Nnat. (** Compatibility notations *) diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index e3e8f532b3..374af6de63 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -348,7 +348,7 @@ Local Notation "- x" := (ZnZ.opp x). Local Infix "*" := ZnZ.mul. Local Notation wB := (base ZnZ.digits). -Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul +Global Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_opp ZnZ.spec_sub : cyclic. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 7c5b43096a..f74a78e876 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -51,7 +51,7 @@ Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul. -Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred +Global Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic. Ltac zify := unfold eq, zero, one, two, succ, pred, add, sub, mul in *; diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index f324bbf52b..7bb725538b 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -954,6 +954,7 @@ Proof. intros _ HH; generalize (HH H1); discriminate. clear H. generalize (ltb_spec j i); case Int63.ltb; intros H2; unfold bit; simpl. + change 62%int63 with (digits - 1)%int63. assert (F2: (φ j < φ i)%Z) by (case H2; auto); clear H2. replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. case (to_Z_bounded j); intros H1j H2j. diff --git a/theories/Numbers/DecimalPos.v b/theories/Numbers/DecimalPos.v index 5611329b12..f86246d3c2 100644 --- a/theories/Numbers/DecimalPos.v +++ b/theories/Numbers/DecimalPos.v @@ -216,7 +216,7 @@ Proof. - trivial. - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). rewrite N.mul_succ_r. - change 10 at 2 with (Nat.iter 10%nat N.succ 0). + change 10 with (Nat.iter 10%nat N.succ 0) at 2. rewrite ?nat_iter_S, nat_iter_0. rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. destruct (to_lu (N.pos p)); simpl; auto. diff --git a/theories/Numbers/HexadecimalNat.v b/theories/Numbers/HexadecimalNat.v index 94a14b90bd..696e89bd8e 100644 --- a/theories/Numbers/HexadecimalNat.v +++ b/theories/Numbers/HexadecimalNat.v @@ -230,7 +230,7 @@ Proof. simpl_of_lu; rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_sixteenfold by assumption; - unfold lnorm; simpl; now destruct nztail. + unfold lnorm; cbn; now destruct nztail. Qed. (** Second bijection result *) diff --git a/theories/Numbers/HexadecimalPos.v b/theories/Numbers/HexadecimalPos.v index 47f6d983b7..29029cb839 100644 --- a/theories/Numbers/HexadecimalPos.v +++ b/theories/Numbers/HexadecimalPos.v @@ -235,7 +235,7 @@ Proof. - trivial. - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). rewrite N.mul_succ_r. - change 0x10 at 2 with (Nat.iter 0x10%nat N.succ 0). + change 0x10 with (Nat.iter 0x10%nat N.succ 0) at 2. rewrite ?nat_iter_S, nat_iter_0. rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. destruct (to_lu (N.pos p)); simpl; auto. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index 0c097b6773..9d9244eefb 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -18,7 +18,7 @@ Include ZBaseProp Z. (** Theorems that are either not valid on N or have different proofs on N and Z *) -Hint Rewrite opp_0 : nz. +Global Hint Rewrite opp_0 : nz. Theorem add_pred_l n m : P n + m == P (n + m). Proof. diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v index 4d2361689d..832931e5ef 100644 --- a/theories/Numbers/Integer/Abstract/ZBits.v +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -26,7 +26,7 @@ Include BoolEqualityFacts A. Ltac order_nz := try apply pow_nonzero; order'. Ltac order_pos' := try apply abs_nonneg; order_pos. -Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. +Global Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. (** Some properties of power and division *) @@ -566,7 +566,7 @@ Tactic Notation "bitwise" "as" simple_intropattern(m) simple_intropattern(Hm) Ltac bitwise := bitwise as ?m ?Hm. -Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. +Global Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. (** The streams of bits that correspond to a numbers are exactly the ones which are stationary after some point. *) diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index 66cbba9e08..2ad8dfcedb 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -14,9 +14,9 @@ Require Import NZAxioms NZBase. Module Type NZAddProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ). -Hint Rewrite +Global Hint Rewrite pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. -Hint Rewrite one_succ two_succ : nz'. +Global Hint Rewrite one_succ two_succ : nz'. Ltac nzsimpl := autorewrite with nz. Ltac nzsimpl' := autorewrite with nz nz'. @@ -39,7 +39,7 @@ Proof. intros n m. now rewrite add_succ_r, add_succ_l. Qed. -Hint Rewrite add_0_r add_succ_r : nz. +Global Hint Rewrite add_0_r add_succ_r : nz. Theorem add_comm : forall n m, n + m == m + n. Proof. @@ -58,7 +58,7 @@ Proof. intro n; now nzsimpl'. Qed. -Hint Rewrite add_1_l add_1_r : nz. +Global Hint Rewrite add_1_l add_1_r : nz. Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. Proof. @@ -104,6 +104,6 @@ Proof. intro n; now nzsimpl'. Qed. -Hint Rewrite sub_1_r : nz. +Global Hint Rewrite sub_1_r : nz. End NZAddProp. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 3d6465191d..14728eaf40 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -28,7 +28,7 @@ Proof. now rewrite add_cancel_r. Qed. -Hint Rewrite mul_0_r mul_succ_r : nz. +Global Hint Rewrite mul_0_r mul_succ_r : nz. Theorem mul_comm : forall n m, n * m == m * n. Proof. @@ -69,7 +69,7 @@ Proof. intro n. now nzsimpl'. Qed. -Hint Rewrite mul_1_l mul_1_r : nz. +Global Hint Rewrite mul_1_l mul_1_r : nz. Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m. Proof. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index 3b2a496229..00edcd641f 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -45,7 +45,7 @@ Module Type NZPowProp (Import B : NZPow' A) (Import C : NZMulOrderProp A). -Hint Rewrite pow_0_r pow_succ_r : nz. +Global Hint Rewrite pow_0_r pow_succ_r : nz. (** Power and basic constants *) @@ -76,14 +76,14 @@ Proof. - now nzsimpl. Qed. -Hint Rewrite pow_1_r pow_1_l : nz. +Global Hint Rewrite pow_1_r pow_1_l : nz. Lemma pow_2_r : forall a, a^2 == a*a. Proof. intros. rewrite two_succ. nzsimpl; order'. Qed. -Hint Rewrite pow_2_r : nz. +Global Hint Rewrite pow_2_r : nz. (** Power and nullity *) diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v index 313b9adfd1..427a18d4ae 100644 --- a/theories/Numbers/Natural/Abstract/NBits.v +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -23,7 +23,7 @@ Module Type NBitsProp Include BoolEqualityFacts A. Ltac order_nz := try apply pow_nonzero; order'. -Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. +Global Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. (** Some properties of power and division *) @@ -368,7 +368,7 @@ Proof. split. apply bits_inj. intros EQ; now rewrite EQ. Qed. -Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. +Global Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. Tactic Notation "bitwise" "as" simple_intropattern(m) := apply bits_inj; intros m; autorewrite with bitwise. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index e97f2dc748..7d50bdacad 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -876,7 +876,7 @@ Lemma compare_xO_xI p q : (p~0 ?= q~1) = switch_Eq Lt (p ?= q). Proof. exact (compare_cont_spec p q Lt). Qed. -Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. +Global Hint Rewrite compare_xO_xO compare_xI_xI compare_xI_xO compare_xO_xI : compare. Ltac simpl_compare := autorewrite with compare. Ltac simpl_compare_in H := autorewrite with compare in H. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index 8813131d7b..18e55aefc6 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -40,8 +40,8 @@ Proof. reflexivity. Qed. -Hint Rewrite @compose_id_left @compose_id_right : core. -Hint Rewrite <- @compose_assoc : core. +Global Hint Rewrite @compose_id_left @compose_id_right : core. +Global Hint Rewrite <- @compose_assoc : core. (** [flip] is involutive. *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 25af2d5ffb..090322054e 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -162,7 +162,7 @@ Ltac pi_eq_proofs := repeat pi_eq_proof. Ltac clear_eq_proofs := abstract_eq_proofs ; pi_eq_proofs. -Hint Rewrite <- eq_rect_eq : refl_id. +Global Hint Rewrite <- eq_rect_eq : refl_id. (** The [refl_id] database should be populated with lemmas of the form [coerce_* t eq_refl = t]. *) @@ -178,7 +178,7 @@ Lemma inj_pairT2_refl A (x : A) (P : A -> Type) (p : P x) : Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl. Proof. apply UIP_refl. Qed. -Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. +Global Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. Ltac rewrite_refl_id := autorewrite with refl_id. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index fce69437d7..d852ad24fe 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -319,7 +319,3 @@ Create HintDb program discriminated. Ltac program_simpl := program_simplify ; try typeclasses eauto 10 with program ; try program_solve_wf. Obligation Tactic := program_simpl. - -Definition obligation (A : Type) {a : A} := a. - -Register obligation as program.tactics.obligation. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 5a23a20811..620ed6b5b7 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -180,4 +180,4 @@ intros; rewrite Q2R_mult. rewrite Q2R_inv; auto. Qed. -Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. +Global Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v index 60fad8795a..5a599587d0 100644 --- a/theories/Reals/Abstract/ConstructiveReals.v +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -285,14 +285,14 @@ Lemma CRlt_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), Proof. intros. apply (CRlt_le_trans _ y _ H). apply CRlt_asym. exact H0. -Defined. +Qed. Lemma CRlt_trans_flip : forall {R : ConstructiveReals} (x y z : CRcarrier R), y < z -> x < y -> x < z. Proof. intros. apply (CRlt_le_trans _ y). exact H0. apply CRlt_asym. exact H. -Defined. +Qed. Lemma CReq_refl : forall {R : ConstructiveReals} (x : CRcarrier R), x == x. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v index 53b5aca38c..6ed5845440 100644 --- a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -232,7 +232,7 @@ Proof. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CRle_refl. apply CR_of_Q_lt. exact H. -Defined. +Qed. Lemma CRplus_neg_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 069a1292cd..9a00408de3 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -112,7 +112,7 @@ Proof. pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; apply H | apply H1 ]. -Defined. +Qed. Lemma Alembert_C2 : forall An:nat -> R, @@ -330,7 +330,7 @@ Proof. rewrite <- Rabs_Ropp; apply RRle_abs. rewrite double; pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H. -Defined. +Qed. Lemma AlembertC3_step1 : forall (An:nat -> R) (x:R), @@ -374,7 +374,7 @@ Proof. [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ]. intro; unfold Bn; apply prod_neq_R0; [ apply H0 | apply pow_nonzero; assumption ]. -Defined. +Qed. Lemma AlembertC3_step2 : forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }. @@ -405,7 +405,7 @@ Proof. cut (x <> 0). intro; apply AlembertC3_step1; assumption. red; intro; rewrite H1 in Hgt; elim (Rlt_irrefl _ Hgt). -Defined. +Qed. Lemma Alembert_C4 : forall (An:nat -> R) (k:R), diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 8a11c155ce..4fb3846abc 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -320,7 +320,6 @@ Proof. - contradiction. - exact Hxltz. Qed. -(* Todo: this was Defined. Why *) Lemma CReal_lt_le_trans : forall x y z : CReal, x < y -> y <= z -> x < z. @@ -330,7 +329,6 @@ Proof. - exact Hxltz. - contradiction. Qed. -(* Todo: this was Defined. Why *) Lemma CReal_le_trans : forall x y z : CReal, x <= y -> y <= z -> x <= z. @@ -347,7 +345,6 @@ Proof. apply (CReal_lt_le_trans _ y _ Hxlty). apply CRealLt_asym; exact Hyltz. Qed. -(* Todo: this was Defined. Why *) Lemma CRealEq_trans : forall x y z : CReal, CRealEq x y -> CRealEq y z -> CRealEq x z. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index a180e13444..bc45868244 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -733,13 +733,11 @@ Definition CReal_inv_pos (x : CReal) (Hxpos : 0 < x) : CReal := bound := CReal_inv_pos_bound x Hxpos |}. -(* ToDo: make this more obviously computing *) - Definition CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x. Proof. intros x [n nmaj]. exists n. - apply (Qlt_le_trans _ _ _ nmaj). destruct x. simpl. - unfold Qminus. rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl. + simpl in *. unfold CReal_opp_seq, Qminus. + abstract now rewrite Qplus_0_r, <- (Qplus_0_l (- seq x n)). Defined. Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 70d2861d17..c2b60e6478 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -75,7 +75,7 @@ Proof. rewrite inject_Q_plus, (opp_inject_Q 2). ring_simplify. exact H. rewrite Qinv_plus_distr. reflexivity. -Defined. +Qed. (* ToDo: Move to ConstructiveCauchyAbs.v *) Lemma Qabs_Rabs : forall q : Q, @@ -688,21 +688,7 @@ Proof. exact (a i j H0 H1). exists l. intros p. destruct (cv p). exists x. exact c. -Defined. - -(* ToDO: Belongs into sumbool.v *) -Section connectives. - - Variables A B : Prop. - - Hypothesis H1 : {A} + {~A}. - Hypothesis H2 : {B} + {~B}. - - Definition sumbool_or_not_or : {A \/ B} + {~(A \/ B)}. - case H1; case H2; tauto. - Defined. - -End connectives. +Qed. Lemma Qnot_le_iff_lt: forall x y : Q, ~ (x <= y)%Q <-> (y < x)%Q. @@ -740,13 +726,11 @@ Proof. clear maj. right. exists n. apply H0. - clear H0 H. intro n. - apply sumbool_or_not_or. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q). - * left; assumption. - * right; apply Qle_not_lt; assumption. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q). - * left; assumption. - * right; apply Qle_not_lt; assumption. + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q) as [H1|H1]. + + now left; left. + + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q) as [H2|H2]. + * now left; right. + * now right; intros [H3|H3]; apply Qle_not_lt with (2 := H3). Qed. Definition CRealConstructive : ConstructiveReals diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v index 500838ed26..0736b09761 100644 --- a/theories/Reals/ClassicalDedekindReals.v +++ b/theories/Reals/ClassicalDedekindReals.v @@ -233,17 +233,12 @@ Qed. (** *** Conversion from CReal to DReal *) -Definition DRealAbstr : CReal -> DReal. +Lemma DRealAbstr_aux : + forall x H, + isLowerCut (fun q : Q => + if sig_forall_dec (fun n : nat => seq x (- Z.of_nat n) <= q + 2 ^ (- Z.of_nat n)) (H q) + then true else false). Proof. - intro x. - assert (forall (q : Q) (n : nat), - {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + - {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). - { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). - right. apply (Qlt_not_le _ _ q0). left. exact q0. } - - exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) - then true else false). repeat split. - intros. destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q) @@ -303,6 +298,20 @@ Proof. apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0. apply (Qplus_le_l _ _ (-seq x (-Z.of_nat n))) in q0. ring_simplify in q0. contradiction. reflexivity. +Qed. + +Definition DRealAbstr : CReal -> DReal. +Proof. + intro x. + assert (forall (q : Q) (n : nat), + {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + + {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). + { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). + right. apply (Qlt_not_le _ _ q0). left. exact q0. } + + exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) + then true else false). + apply DRealAbstr_aux. Defined. (** *** Conversion from DReal to CReal *) diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 6692119738..6107775003 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -170,7 +170,7 @@ Proof. reg. exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. assumption. -Defined. +Qed. (**********) Lemma antiderivative_P1 : diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 7f5a859c81..2004f40f00 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -41,9 +41,13 @@ Proof. red; intro; rewrite H0 in H; elim (lt_irrefl _ H). Qed. -Lemma exist_exp0 : { l:R | exp_in 0 l }. +(* Value of [exp 0] *) +Lemma exp_0 : exp 0 = 1. Proof. - exists 1. + cut (exp_in 0 1). + cut (exp_in 0 (exp 0)). + apply uniqueness_sum. + exact (proj2_sig (exist_exp 0)). unfold exp_in; unfold infinite_sum; intros. exists 0%nat. intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1. @@ -56,18 +60,6 @@ Proof. simpl. ring. unfold ge; apply le_O_n. -Defined. - -(* Value of [exp 0] *) -Lemma exp_0 : exp 0 = 1. -Proof. - cut (exp_in 0 (exp 0)). - cut (exp_in 0 1). - unfold exp_in; intros; eapply uniqueness_sum. - apply H0. - apply H. - exact (proj2_sig exist_exp0). - exact (proj2_sig (exist_exp 0)). Qed. (*****************************************) @@ -384,9 +376,14 @@ Proof. intros; ring. Qed. -Lemma exist_cos0 : { l:R | cos_in 0 l }. +(* Value of [cos 0] *) +Lemma cos_0 : cos 0 = 1. Proof. - exists 1. + cut (cos_in 0 1). + cut (cos_in 0 (cos 0)). + apply uniqueness_sum. + rewrite <- Rsqr_0 at 1. + exact (proj2_sig (exist_cos (Rsqr 0))). unfold cos_in; unfold infinite_sum; intros; exists 0%nat. intros. unfold R_dist. @@ -400,17 +397,4 @@ Proof. rewrite Rplus_0_r. apply Hrecn; unfold ge; apply le_O_n. simpl; ring. -Defined. - -(* Value of [cos 0] *) -Lemma cos_0 : cos 0 = 1. -Proof. - cut (cos_in 0 (cos 0)). - cut (cos_in 0 1). - unfold cos_in; intros; eapply uniqueness_sum. - apply H0. - apply H. - exact (proj2_sig exist_cos0). - assert (H := proj2_sig (exist_cos (Rsqr 0))); unfold cos; - pattern 0 at 1; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ]. Qed. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 06b02ab211..37d30a282c 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -173,6 +173,14 @@ Proof. apply N_ascii_bounded. Qed. +Definition ltb (a b : ascii) : bool := + (N_of_ascii a <? N_of_ascii b)%N. + +Definition leb (a b : ascii) : bool := + (N_of_ascii a <=? N_of_ascii b)%N. + +Infix "<?" := ltb : char_scope. +Infix "<=?" := leb : char_scope. (** * Concrete syntax *) diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 4ac54d280a..c3e67b9d5a 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -53,7 +53,7 @@ Module Type CompareFacts (Import O:DecStrOrder'). rewrite compare_gt_iff; intuition. Qed. - Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. + Global Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. Proof. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index abf7f681b0..c709149109 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -146,7 +146,7 @@ Module MoreInt (Import I:Int). (** A magic (but costly) tactic that goes from [int] back to the [Z] friendly world ... *) - Hint Rewrite -> + Global Hint Rewrite -> i2z_0 i2z_1 i2z_2 i2z_3 i2z_add i2z_opp i2z_sub i2z_mul i2z_max i2z_eqb i2z_ltb i2z_leb : i2z. diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 6ebf9b71d6..b8d5032373 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -87,8 +87,7 @@ let obsolete s = course). *) let banner () = - eprintf "This is coqdoc version %s, compiled on %s\n" - Coq_config.version Coq_config.compile_date; + eprintf "This is coqdoc version %s\n" Coq_config.version; flush stderr let target_full_name f = diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index a87dfb5b2e..9cb3baf92c 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -42,13 +42,13 @@ let is_keyword = "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; - "Search"; "SearchHead"; "SearchPattern"; "SearchRewrite"; + "Search"; "SearchPattern"; "SearchRewrite"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; - "subgoal"; "subgoals"; "vm_compute"; + "goal"; "goals"; "vm_compute"; "Opaque"; "Transparent"; "Time"; "Extraction"; "Extract"; "Variant"; @@ -783,7 +783,7 @@ module Html = struct printf " <td class=\"infrule\">%s</td>\n" (replace_spaces line)) in let end_assumption () = (printf " <td></td>\n"; - printf "</td>\n") in + printf "</tr>\n") in let rec print_assumptions hyps = match hyps with | [] -> start_assumption " " diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index b75a4199ea..ca09bad441 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -24,7 +24,7 @@ let fatal_error msg = let load_init_file opts ~state = if opts.pre.load_rcfile then Topfmt.(in_phase ~phase:LoadingRcFile) (fun () -> - Coqinit.load_rcfile ~rcfile:opts.config.rcfile ~state) () + Coqrc.load_rcfile ~rcfile:opts.config.rcfile ~state) () else begin Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); state @@ -93,7 +93,7 @@ let create_empty_file filename = close_out f (* Compile a vernac file *) -let compile opts copts ~echo ~f_in ~f_out = +let compile opts stm_options injections copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = let pfs = Vernacstate.Declare.get_all_proof_names () [@ocaml.warning "-3"] in @@ -104,9 +104,6 @@ let compile opts copts ~echo ~f_in ~f_out = |> prlist_with_sep pr_comma Names.Id.print) ++ str ".") in - let ml_load_path, vo_load_path = build_load_path opts in - let injections = injection_commands opts in - let stm_options = opts.config.stm_flags in let output_native_objects = match opts.config.native_compiler with | NativeOff -> false | NativeOn {ondemand} -> not ondemand in @@ -129,9 +126,7 @@ let compile opts copts ~echo ~f_in ~f_out = | BuildVo | BuildVok -> let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VoDoc long_f_dot_out; ml_load_path; - vo_load_path; injections; stm_options; - } in + Stm.{ doc_type = VoDoc long_f_dot_out; injections; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in @@ -181,8 +176,7 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VioDoc long_f_dot_out; ml_load_path; - vo_load_path; injections; stm_options; + Stm.{ doc_type = VioDoc long_f_dot_out; injections; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in @@ -209,22 +203,22 @@ let compile opts copts ~echo ~f_in ~f_out = dump_empty_vos(); create_empty_file (long_f_dot_out ^ "k") -let compile opts copts ~echo ~f_in ~f_out = +let compile opts stm_opts copts injections ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile opts copts ~echo ~f_in ~f_out; + compile opts stm_opts injections copts ~echo ~f_in ~f_out; CoqworkmgrApi.giveback 1 -let compile_file opts copts (f_in, echo) = +let compile_file opts stm_opts copts injections (f_in, echo) = let f_out = copts.compilation_output_name in if !Flags.beautify then Flags.with_option Flags.beautify_file - (fun f_in -> compile opts copts ~echo ~f_in ~f_out) f_in + (fun f_in -> compile opts stm_opts copts injections ~echo ~f_in ~f_out) f_in else - compile opts copts ~echo ~f_in ~f_out + compile opts stm_opts copts injections ~echo ~f_in ~f_out -let compile_files opts copts = +let compile_files (opts, stm_opts) copts injections = let compile_list = copts.compile_list in - List.iter (compile_file opts copts) compile_list + List.iter (compile_file opts stm_opts copts injections) compile_list (******************************************************************************) (* VIO Dispatching *) @@ -248,14 +242,7 @@ let schedule_vio copts = else Vio_checking.schedule_vio_compilation copts.vio_files_j l -let do_vio opts copts = - (* We must initialize the loadpath here as the vio scheduling - process happens outside of the STM *) - if copts.vio_files <> [] || copts.vio_tasks <> [] then - let ml_lp, vo_lp = build_load_path opts in - List.iter Mltop.add_ml_dir ml_lp; - List.iter Loadpath.add_vo_path vo_lp; - +let do_vio opts copts _injections = (* Vio compile pass *) if copts.vio_files <> [] then schedule_vio copts; (* Vio task pass *) diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index 8c154488d0..9f3783f32e 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -13,7 +13,7 @@ val load_init_vernaculars : Coqargs.t -> state:Vernac.State.t-> Vernac.State.t (** [compile_files opts] compile files specified in [opts] *) -val compile_files : Coqargs.t -> Coqcargs.t -> unit +val compile_files : Coqargs.t * Stm.AsyncOpts.stm_opt -> Coqcargs.t -> Coqargs.injection_command list -> unit (** [do_vio opts] process [.vio] files in [opts] *) -val do_vio : Coqargs.t -> Coqcargs.t -> unit +val do_vio : Coqargs.t -> Coqcargs.t -> Coqargs.injection_command list -> unit diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 03c53d6991..a403640149 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -13,10 +13,11 @@ let outputstate opts = let fname = CUnix.make_suffix ostate_file ".coq" in Vernacstate.System.dump fname) opts.Coqcargs.outputstate -let coqc_init _copts ~opts = +let coqc_init ((_,color_mode),_) injections ~opts = Flags.quiet := true; System.trust_file_cache := true; - Coqtop.init_color opts.Coqargs.config + Coqtop.init_color (if opts.Coqargs.config.Coqargs.print_emacs then `EMACS else color_mode); + injections let coqc_specific_usage = Usage.{ executable_name = "coqc"; @@ -41,30 +42,30 @@ coqc specific options:\ \n" } -let coqc_main copts ~opts = +let coqc_main ((copts,_),stm_opts) injections ~opts = Topfmt.(in_phase ~phase:CompilationPhase) - Ccompile.compile_files opts copts; + Ccompile.compile_files (opts,stm_opts) copts injections; (* Careful this will modify the load-path and state so after this point some stuff may not be safe anymore. *) Topfmt.(in_phase ~phase:CompilationPhase) - Ccompile.do_vio opts copts; + Ccompile.do_vio opts copts injections; (* Allow the user to output an arbitrary state *) outputstate copts; flush_all(); - if opts.Coqargs.post.Coqargs.output_context then begin + if copts.Coqcargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () -let coqc_run copts ~opts () = +let coqc_run copts ~opts injections = let _feeder = Feedback.add_feeder Coqloop.coqloop_feed in try - coqc_main ~opts copts; + coqc_main ~opts copts injections; exit 0 with exn -> flush_all(); @@ -73,12 +74,17 @@ let coqc_run copts ~opts () = let exit_code = if (CErrors.is_anomaly exn) then 129 else 1 in exit exit_code -let custom_coqc = Coqtop.{ - parse_extra = (fun ~opts extras -> Coqcargs.parse extras, []); - help = coqc_specific_usage; - init = coqc_init; +let custom_coqc : ((Coqcargs.t * Coqtop.color) * Stm.AsyncOpts.stm_opt, 'b) Coqtop.custom_toplevel + = Coqtop.{ + parse_extra = (fun extras -> + let color_mode, extras = Coqtop.parse_extra_colors extras in + let stm_opts, extras = Stmargs.parse_args ~init:Stm.AsyncOpts.default_opts extras in + let coqc_opts = Coqcargs.parse extras in + ((coqc_opts, color_mode), stm_opts), []); + usage = coqc_specific_usage; + init_extra = coqc_init; run = coqc_run; - opts = Coqargs.default; + initial_args = Coqargs.default; } let main () = diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 402a4d83c9..f84d73ed17 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -25,6 +25,8 @@ type t = ; outputstate : string option ; glob_out : Dumpglob.glob_output + + ; output_context : bool } let default = @@ -42,6 +44,8 @@ let default = ; outputstate = None ; glob_out = Dumpglob.MultFiles + + ; output_context = false } let depr opt = @@ -162,6 +166,10 @@ let parse arglist : t = depr opt; let _ = next () in oval + + (* Non deprecated options *) + | "-output-context" -> + { oval with output_context = true } (* Verbose == echo mode *) | "-verbose" -> echo := true; diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli index a9fc27b1b4..905250e363 100644 --- a/toplevel/coqcargs.mli +++ b/toplevel/coqcargs.mli @@ -39,6 +39,8 @@ type t = ; outputstate : string option ; glob_out : Dumpglob.glob_output + + ; output_context : bool } val default : t diff --git a/toplevel/coqrc.ml b/toplevel/coqrc.ml new file mode 100644 index 0000000000..e074e621da --- /dev/null +++ b/toplevel/coqrc.ml @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +let ( / ) s1 s2 = Filename.concat s1 s2 + +(* Loading of the resource file. + rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one + does not exist. *) + +let rcdefaultname = "coqrc" + +let load_rcfile ~rcfile ~state = + try + match rcfile with + | Some rcfile -> + if CUnix.file_readable_p rcfile then + Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state rcfile + else raise (Sys_error ("Cannot read rcfile: "^ rcfile)) + | None -> + try + let warn x = Feedback.msg_warning (Pp.str x) in + let inferedrc = List.find CUnix.file_readable_p [ + Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; + Envars.xdg_config_home warn / rcdefaultname; + Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; + Envars.home ~warn / "."^rcdefaultname + ] in + Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state inferedrc + with Not_found -> state + (* + Flags.if_verbose + mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ + " found. Skipping rcfile loading.")) + *) + with reraise -> + let reraise = Exninfo.capture reraise in + let () = Feedback.msg_info (Pp.str"Load of rcfile failed.") in + Exninfo.iraise reraise diff --git a/toplevel/coqrc.mli b/toplevel/coqrc.mli new file mode 100644 index 0000000000..3b8a31b2a5 --- /dev/null +++ b/toplevel/coqrc.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index d0d50aee70..bb44d9cdee 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -18,41 +18,19 @@ let () = at_exit flush_all let ( / ) = Filename.concat -let get_version_date () = +let get_version () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in - (ver,rev) - with e when CErrors.noncritical e -> - (Coq_config.version,Coq_config.date) + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let print_header () = - let (ver,rev) = get_version_date () in - Feedback.msg_info (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); + Feedback.msg_info (str "Welcome to Coq " ++ str (get_version ())); flush_all () -let print_memory_stat () = - (* -m|--memory from the command-line *) - Feedback.msg_notice - (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); - (* operf-macro interface: - https://github.com/OCamlPro/operf-macro *) - try - let fn = Sys.getenv "OCAML_GC_STATS" in - let oc = open_out fn in - Gc.print_stat oc; - close_out oc - with _ -> () - -(******************************************************************************) -(* Input/Output State *) -(******************************************************************************) -let inputstate opts = - Option.iter (fun istate_file -> - let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in - Vernacstate.System.load fname) opts.inputstate (******************************************************************************) (* Fatal Errors *) @@ -68,11 +46,44 @@ let fatal_error_exn exn = in exit exit_code -(******************************************************************************) -(* Color Options *) -(******************************************************************************) +type ('a,'b) custom_toplevel = + { parse_extra : string list -> 'a * string list + ; usage : Usage.specific_usage + ; init_extra : 'a -> Coqargs.injection_command list -> opts:Coqargs.t -> 'b + ; initial_args : Coqargs.t + ; run : 'a -> opts:Coqargs.t -> 'b -> unit + } + +(** Main init routine *) +let init_toplevel { parse_extra; init_extra; usage; initial_args } = + Coqinit.init_ocaml (); + let opts, customopts = Coqinit.parse_arguments ~parse_extra ~usage ~initial_args () in + Stm.init_process (snd customopts); + let injections = Coqinit.init_runtime opts in + (* This state will be shared by all the documents *) + Stm.init_core (); + let customstate = init_extra ~opts customopts injections in + opts, customopts, customstate + +let start_coq custom = + let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in + (* Init phase *) + let opts, custom_opts, state = + try init_toplevel custom + with any -> + flush_all(); + fatal_error_exn any in + Feedback.del_feeder init_feeder; + (* Run phase *) + custom.run ~opts custom_opts state + +(** ****************************************) +(** Specific support for coqtop executable *) + +type color = [`ON | `AUTO | `EMACS | `OFF] + let init_color opts = - let has_color = match opts.color with + let has_color = match opts with | `OFF -> false | `EMACS -> false | `ON -> true @@ -95,7 +106,7 @@ let init_color opts = Topfmt.default_styles (); false (* textual markers, no color *) end in - if opts.color = `EMACS then + if opts = `EMACS then Topfmt.set_emacs_print_strings () else if not term_color then begin Proof_diffs.write_color_enabled term_color; @@ -120,131 +131,15 @@ let print_style_tags opts = let () = List.iter iter tags in flush_all () -let init_coqlib opts = match opts.config.coqlib with - | None when opts.pre.boot -> () - | None -> - Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - | Some s -> - Envars.set_user_coqlib s - -let print_query opts = function - | PrintVersion -> Usage.version () - | PrintMachineReadableVersion -> Usage.machine_readable_version () - | PrintWhere -> - let () = init_coqlib opts in - print_endline (Envars.coqlib ()) - | PrintHelp h -> Usage.print_usage stderr h - | PrintConfig -> - let () = init_coqlib opts in - Envars.print_config stdout Coq_config.all_src_dirs - | PrintTags -> print_style_tags opts.config - -(** GC tweaking *) - -(** Coq is a heavy user of persistent data structures and symbolic ASTs, so the - minor heap is heavily solicited. Unfortunately, the default size is far too - small, so we enlarge it a lot (128 times larger). +type query = PrintTags | PrintModUid of string list +type run_mode = Interactive | Batch | Query of query - To better handle huge memory consumers, we also augment the default major - heap increment and the GC pressure coefficient. -*) - -let set_gc_policy () = - Gc.set { (Gc.get ()) with - Gc.minor_heap_size = 32*1024*1024 (* 32Mwords x 8 bytes/word = 256Mb *) - ; Gc.space_overhead = 120 - } - -let set_gc_best_fit () = - Gc.set { (Gc.get ()) with - Gc.allocation_policy = 2 (* best-fit *) - ; Gc.space_overhead = 200 - } - -let init_gc () = - try - (* OCAMLRUNPARAM environment variable is set. - * In that case, we let ocamlrun to use the values provided by the user. - *) - ignore (Sys.getenv "OCAMLRUNPARAM") - - with Not_found -> - (* OCAMLRUNPARAM environment variable is not set. - * In this case, we put in place our preferred configuration. - *) - set_gc_policy (); - if Coq_config.caml_version_nums >= [4;10;0] then set_gc_best_fit () else () - -let init_process () = - (* Coq's init process, phase 1: - OCaml parameters, basic structures, and IO - *) - CProfile.init_profile (); - init_gc (); - Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - Lib.init () - -let init_parse parse_extra help init_opts = - let opts, extras = - parse_args ~help:help ~init:init_opts - (List.tl (Array.to_list Sys.argv)) in - let customopts, extras = parse_extra ~opts extras in - if not (CList.is_empty extras) then begin - prerr_endline ("Don't know what to do with "^String.concat " " extras); - prerr_endline "See -help for the list of supported options"; - exit 1 - end; - opts, customopts - -(** Coq's init process, phase 2: Basic Coq environment, plugins. *) -let init_execution opts custom_init = - (* If we have been spawned by the Spawn module, this has to be done - * early since the master waits us to connect back *) - Spawned.init_channels (); - if opts.post.memory_stat then at_exit print_memory_stat; - CoqworkmgrApi.(init opts.config.stm_flags.Stm.AsyncOpts.async_proofs_worker_priority); - Mltop.init_known_plugins (); - (* Configuration *) - Global.set_engagement opts.config.logic.impredicative_set; - Global.set_indices_matter opts.config.logic.indices_matter; - Global.set_VM opts.config.enable_VM; - Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - - (* Native output dir *) - Nativelib.output_dir := opts.config.native_output_dir; - Nativelib.include_dirs := opts.config.native_include_dirs; - - (* Allow the user to load an arbitrary state here *) - inputstate opts.pre; - - (* This state will be shared by all the documents *) - Stm.init_core (); - custom_init ~opts - -type 'a extra_args_fn = opts:Coqargs.t -> string list -> 'a * string list - -type ('a,'b) custom_toplevel = - { parse_extra : 'a extra_args_fn - ; help : Usage.specific_usage - ; init : 'a -> opts:Coqargs.t -> 'b - ; run : 'a -> opts:Coqargs.t -> 'b -> unit - ; opts : Coqargs.t - } - -(** Main init routine *) -let init_toplevel custom = - let () = init_process () in - let opts, customopts = init_parse custom.parse_extra custom.help custom.opts in - (* Querying or running? *) - match opts.main with - | Queries q -> List.iter (print_query opts) q; exit 0 - | Run -> - let () = init_coqlib opts in - let customstate = init_execution opts (custom.init customopts) in - opts, customopts, customstate +type toplevel_options = { + run_mode : run_mode; + color_mode : color; +} -let init_document opts = +let init_document opts stm_options injections = (* Coq init process, phase 3: Stm initialization, backtracking state. It is essential that the module system is in a consistent @@ -253,57 +148,70 @@ let init_document opts = *) (* Next line allows loading .vos files when in interactive mode *) Flags.load_vos_libraries := true; - let ml_load_path, vo_load_path = build_load_path opts in - let injections = injection_commands opts in - let stm_options = opts.config.stm_flags in let open Vernac.State in let doc, sid = Stm.(new_doc { doc_type = Interactive opts.config.logic.toplevel_name; - ml_load_path; vo_load_path; injections; stm_options; + injections; stm_options; }) in { doc; sid; proof = None; time = opts.config.time } -let start_coq custom = - let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in - (* Init phase *) - let opts, custom_opts, state = - try init_toplevel custom - with any -> - flush_all(); - fatal_error_exn any in - Feedback.del_feeder init_feeder; - (* Run phase *) - custom.run ~opts custom_opts state - -(** ****************************************) -(** Specific support for coqtop executable *) - -type run_mode = Interactive | Batch - -let init_toploop opts = - let state = init_document opts in +let init_toploop opts stm_opts injections = + let state = init_document opts stm_opts injections in let state = Ccompile.load_init_vernaculars opts ~state in state -let coqtop_init run_mode ~opts = - if run_mode = Batch then Flags.quiet := true; - init_color opts.config; +let coqtop_init ({ run_mode; color_mode }, async_opts) injections ~opts = + if run_mode != Interactive then Flags.quiet := true; + init_color (if opts.config.print_emacs then `EMACS else color_mode); Flags.if_verbose print_header (); - init_toploop opts - -let coqtop_parse_extra ~opts extras = - let rec parse_extra run_mode = function - | "-batch" :: rest -> parse_extra Batch rest + init_toploop opts async_opts injections + +let set_color = function + | "yes" | "on" -> `ON + | "no" | "off" -> `OFF + | "auto" ->`AUTO + | _ -> + error_wrong_arg ("Error: on/off/auto expected after option color") + +let parse_extra_colors extras = + let rec parse_extra color_mode = function + | "-color" :: next :: rest -> parse_extra (set_color next) rest + | "-list-tags" :: rest -> parse_extra color_mode rest | x :: rest -> + let color_mode, rest = parse_extra color_mode rest in color_mode, x :: rest + | [] -> color_mode, [] in + parse_extra `AUTO extras + +let coqtop_parse_extra extras = + let rec parse_extra run_mode = function + | "-batch" :: rest -> parse_extra Batch rest + | "-print-mod-uid" :: rest -> Query (PrintModUid rest), [] + | x :: rest -> let run_mode, rest = parse_extra run_mode rest in run_mode, x :: rest | [] -> run_mode, [] in let run_mode, extras = parse_extra Interactive extras in - run_mode, extras + let color_mode, extras = parse_extra_colors extras in + let async_opts, extras = Stmargs.parse_args ~init:Stm.AsyncOpts.default_opts extras in + ({ run_mode; color_mode}, async_opts), extras + +let get_native_name s = + (* We ignore even critical errors because this mode has to be super silent *) + try + Filename.(List.fold_left concat (dirname s) + [ !Nativelib.output_dir + ; Library.native_name_from_filename s + ]) + with _ -> "" -let coqtop_run run_mode ~opts state = +let coqtop_run ({ run_mode; color_mode },_) ~opts state = match run_mode with | Interactive -> Coqloop.loop ~opts ~state; + | Query PrintTags -> print_style_tags color_mode; exit 0 + | Query (PrintModUid sl) -> + let s = String.concat " " (List.map get_native_name sl) in + print_endline s; + exit 0 | Batch -> exit 0 let coqtop_specific_usage = Usage.{ @@ -317,8 +225,8 @@ coqtop specific options:\n\ let coqtop_toplevel = { parse_extra = coqtop_parse_extra - ; help = coqtop_specific_usage - ; init = coqtop_init + ; usage = coqtop_specific_usage + ; init_extra = coqtop_init ; run = coqtop_run - ; opts = Coqargs.default + ; initial_args = Coqargs.default } diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index e535c19252..c675c6adec 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -9,18 +9,16 @@ (************************************************************************) (** Definition of custom toplevels. - [init] is used to do custom command line argument parsing. + [init_extra] is used to do custom initialization [run] launches a custom toplevel. *) -type 'a extra_args_fn = opts:Coqargs.t -> string list -> 'a * string list - type ('a,'b) custom_toplevel = - { parse_extra : 'a extra_args_fn - ; help : Usage.specific_usage - ; init : 'a -> opts:Coqargs.t -> 'b + { parse_extra : string list -> 'a * string list + ; usage : Usage.specific_usage + ; init_extra : 'a -> Coqargs.injection_command list -> opts:Coqargs.t -> 'b + ; initial_args : Coqargs.t ; run : 'a -> opts:Coqargs.t -> 'b -> unit - ; opts : Coqargs.t } (** The generic Coq main module. [start custom] will parse the command line, @@ -28,18 +26,28 @@ type ('a,'b) custom_toplevel = load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [custom.run]. *) -val start_coq : ('a,'b) custom_toplevel -> unit +val start_coq : ('a * Stm.AsyncOpts.stm_opt,'b) custom_toplevel -> unit (** Initializer color for output *) -val init_color : Coqargs.coqargs_config -> unit +type color = [`ON | `AUTO | `EMACS | `OFF] + +val init_color : color -> unit +val parse_extra_colors : string list -> color * string list +val print_style_tags : color -> unit (** Prepare state for interactive loop *) -val init_toploop : Coqargs.t -> Vernac.State.t +val init_toploop : Coqargs.t -> Stm.AsyncOpts.stm_opt -> Coqargs.injection_command list -> Vernac.State.t (** The specific characterization of the coqtop_toplevel *) -type run_mode = Interactive | Batch +type query = PrintTags | PrintModUid of string list +type run_mode = Interactive | Batch | Query of query + +type toplevel_options = { + run_mode : run_mode; + color_mode : color; +} -val coqtop_toplevel : (run_mode,Vernac.State.t) custom_toplevel +val coqtop_toplevel : (toplevel_options * Stm.AsyncOpts.stm_opt,Vernac.State.t) custom_toplevel diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index ddd11fd160..90f8fb9686 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -1,7 +1,5 @@ Vernac -Usage -Coqinit -Coqargs +Coqrc Coqcargs G_toplevel Coqloop diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index 59e10b09a0..e72940d189 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -8,10 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let worker_parse_extra ~opts extra_args = - (), extra_args +let worker_parse_extra extra_args = + let stm_opts, extra_args = Stmargs.parse_args ~init:Stm.AsyncOpts.default_opts extra_args in + ((),stm_opts), extra_args -let worker_init init () ~opts = +let worker_init init ((),_) _injections ~opts = Flags.quiet := true; init (); Coqtop.init_toploop opts @@ -27,9 +28,9 @@ let start ~init ~loop name = let open Coqtop in let custom = { parse_extra = worker_parse_extra; - help = worker_specific_usage name; - opts = Coqargs.default; - init = worker_init init; - run = (fun () ~opts:_ _state (* why is state not used *) -> loop ()); + usage = worker_specific_usage name; + initial_args = Coqargs.default; + init_extra = worker_init init; + run = (fun ((),_) ~opts:_ _state (* why is state not used *) -> loop ()); } in start_coq custom diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 4cc9d99c64..72cac900cd 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -24,7 +24,7 @@ Ltac2 Type case. Ltac2 Type case_invert := [ | NoInvert -| CaseInvert (instance,constr array) +| CaseInvert (constr array) ]. Ltac2 Type kind := [ diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 65b61a0d93..548e12d611 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -213,7 +213,7 @@ GRAMMAR EXTEND Gram | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } + | IDENT "pat"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } | IDENT "ltac1"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1 loc qid } | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1val loc qid } diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 8663691c0a..241ca7ad66 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -109,15 +109,14 @@ let to_rec_declaration (nas, cs) = let of_case_invert = let open Constr in function | NoInvert -> ValInt 0 - | CaseInvert {univs;args} -> - v_blk 0 [|of_instance univs; of_array of_constr args|] + | CaseInvert {indices} -> + v_blk 0 [|of_array of_constr indices|] let to_case_invert = let open Constr in function | ValInt 0 -> NoInvert - | ValBlk (0, [|univs;args|]) -> - let univs = to_instance univs in - let args = to_array to_constr args in - CaseInvert {univs;args} + | ValBlk (0, [|indices|]) -> + let indices = to_array to_constr indices in + CaseInvert {indices} | _ -> CErrors.anomaly Pp.(str "unexpected value shape") let of_result f = function @@ -378,6 +377,7 @@ end let () = define1 "constr_kind" constr begin fun c -> let open Constr in Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> return begin match EConstr.kind sigma c with | Rel n -> v_blk 0 [|Value.of_int n|] @@ -434,7 +434,9 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_constructor cstr; of_instance u; |] - | Case (ci, c, iv, t, bl) -> + | Case (ci, u, pms, c, iv, t, bl) -> + (* FIXME: also change representation Ltac2-side? *) + let (ci, c, iv, t, bl) = EConstr.expand_case env sigma (ci, u, pms, c, iv, t, bl) in v_blk 13 [| Value.of_ext Value.val_case ci; Value.of_constr c; @@ -472,6 +474,8 @@ let () = define1 "constr_kind" constr begin fun c -> end let () = define1 "constr_make" valexpr begin fun knd -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclENV >>= fun env -> let c = match Tac2ffi.to_block knd with | (0, [|n|]) -> let n = Value.to_int n in @@ -529,7 +533,7 @@ let () = define1 "constr_make" valexpr begin fun knd -> let iv = to_case_invert iv in let t = Value.to_constr t in let bl = Value.to_array Value.to_constr bl in - EConstr.mkCase (ci, c, iv, t, bl) + EConstr.mkCase (EConstr.contract_case env sigma (ci, c, iv, t, bl)) | (14, [|recs; i; nas; cs|]) -> let recs = Value.to_array Value.to_int recs in let i = Value.to_int i in @@ -1147,7 +1151,7 @@ let () = let sigma = Evd.from_env env in Patternops.subst_pattern env sigma subst c in - let print env sigma pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env sigma pat ++ str ")" in + let print env sigma pat = str "pat:(" ++ Printer.pr_lconstr_pattern_env env sigma pat ++ str ")" in let interp _ c = return (Value.of_pattern c) in let obj = { ml_intern = intern; diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml index fe62de1fb3..a54eb45f61 100644 --- a/user-contrib/Ltac2/tac2print.ml +++ b/user-contrib/Ltac2/tac2print.ml @@ -466,7 +466,7 @@ end let () = register_init "pattern" begin fun env sigma c -> let c = to_pattern c in let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in - str "pattern:(" ++ c ++ str ")" + str "pat:(" ++ c ++ str ")" end let () = register_init "message" begin fun _ _ pp -> diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 69758b3f37..54f5a2cf68 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -209,13 +209,13 @@ let letin_pat_tac ev ipat na c cl = Instead, we parse indifferently any pattern and dispatch when the tactic is called. *) let map_pattern_with_occs (pat, occ) = match pat with -| Pattern.PRef (GlobRef.ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) -| Pattern.PRef (GlobRef.VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| Pattern.PRef (GlobRef.ConstRef cst) -> (mk_occurrences_expr occ, Inl (Tacred.EvalConstRef cst)) +| Pattern.PRef (GlobRef.VarRef id) -> (mk_occurrences_expr occ, Inl (Tacred.EvalVarRef id)) | _ -> (mk_occurrences_expr occ, Inr pat) let get_evaluable_reference = function -| GlobRef.VarRef id -> Proofview.tclUNIT (EvalVarRef id) -| GlobRef.ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| GlobRef.VarRef id -> Proofview.tclUNIT (Tacred.EvalVarRef id) +| GlobRef.ConstRef cst -> Proofview.tclUNIT (Tacred.EvalConstRef cst) | r -> Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 792f07bb89..9c5f111e28 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -176,7 +176,10 @@ let fold_with_full_binders g f n acc c = | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c | Evar (_,l) -> List.fold_left (f n) acc l - | Case (_,p,iv,c,bl) -> Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl + | Case (ci, u, pms, p, iv, c, bl) -> + let mib = lookup_mind (fst ci.ci_ind) in + let (ci, p, iv, c, bl) = Inductive.expand_case_specif mib (ci, u, pms, p, iv, c, bl) in + Array.fold_left (f n) (f n (fold_invert (f n) (f n acc p) iv) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in @@ -201,12 +204,11 @@ let rec traverse current ctx accu t = | Construct (((mind, _), _) as cst, _) -> traverse_inductive accu mind (ConstructRef cst) | Meta _ | Evar _ -> assert false -| Case (_,oty,_,c,[||]) -> +| Case (_, _, _, ([|_|], oty), _, c, [||]) when Vars.noccurn 1 oty -> (* non dependent match on an inductive with no constructors *) - begin match Constr.(kind oty, kind c) with - | Lambda(_,_,oty), Const (kn, _) - when Vars.noccurn 1 oty && - not (Declareops.constant_has_body (lookup_constant kn)) -> + begin match Constr.kind c with + | Const (kn, _) + when not (Declareops.constant_has_body (lookup_constant kn)) -> let body () = Option.map pi1 (Global.body_of_constant_body Library.indirect_accessor (lookup_constant kn)) in traverse_object ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f715459616..cc59a96834 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -351,13 +351,13 @@ let build_beq_scheme mode kn = done; ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (ci,do_predicate rel_list nb_cstr_args,NoInvert, - mkVar (Id.of_string "Y") ,ar2)) + (mkCase (Inductive.contract_case env ((ci,do_predicate rel_list nb_cstr_args, + NoInvert, mkVar (Id.of_string "Y") ,ar2)))) (constrsi.(i).cs_args)) done; mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar))) + mkCase (Inductive.contract_case env (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar)))) in (* build_beq_scheme *) let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and diff --git a/vernac/classes.mli b/vernac/classes.mli index e1816fb138..89ff4e6939 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -81,7 +81,7 @@ val add_class : env -> Evd.evar_map -> typeclass -> unit (** Setting opacity *) -val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit +val set_typeclass_transparency : Tacred.evaluable_global_reference -> bool -> bool -> unit (** For generation on names based on classes only *) diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index c54adb45f9..2e48313630 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -69,9 +69,10 @@ let protect_pattern_in_binder bl c ctypopt = | LetIn (x,b,t,c) -> let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in evd, mkLetIn (x,t,b,c) - | Case (ci,p,iv,a,bl) -> + | Case (ci,u,pms,p,iv,a,bl) -> + let (ci, p, iv, a, bl) = EConstr.expand_case env evd (ci, u, pms, p, iv, a, bl) in let evd,bl = Array.fold_left_map (aux env) evd bl in - evd, mkCase (ci,p,iv,a,bl) + evd, mkCase (EConstr.contract_case env evd (ci, p, iv, a, bl)) | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) (* This last case may happen when reaching the proof of an impossible case, as when pattern-matching on a vector of length 1 *) @@ -110,6 +111,10 @@ let interp_definition ~program_mode env evd impl_env bl red_option c ctypopt = let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in evd, (c, tyopt), imps +let definition_using env evd ~body ~types ~using = + let terms = Option.List.cons types [body] in + Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using + let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl red_option c ctypopt = let program_mode = false in let env = Global.env() in @@ -119,11 +124,7 @@ let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl r let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in - let using = using |> Option.map (fun expr -> - let terms = body :: match types with Some x -> [x] | None -> [] in - let l = Proof_using.process_expr (Global.env()) evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let using = definition_using env evd ~body ~types ~using in let kind = Decls.IsDefinition kind in let cinfo = Declare.CInfo.make ~name ~impargs ~typ:types ?using () in let info = Declare.Info.make ~scope ~kind ?hook ~udecl ~poly ?typing_flags () in @@ -140,11 +141,7 @@ let do_definition_program ?hook ~pm ~name ~scope ~poly ?typing_flags ~kind ?usin let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in - let using = using |> Option.map (fun expr -> - let terms = body :: match types with Some x -> [x] | None -> [] in - let l = Proof_using.process_expr (Global.env()) evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let using = definition_using env evd ~body ~types ~using in let term, typ, uctx, obls = Declare.Obls.prepare_obligation ~name ~body ~types evd in let pm, _ = let cinfo = Declare.CInfo.make ~name ~typ ~impargs ?using () in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 0cf0b07822..0f817ffbd1 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -259,13 +259,10 @@ let build_recthms ~indexes ?using fixnames fixtypes fiximps = in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - let using = using |> Option.map (fun expr -> - let terms = [EConstr.of_constr typ] in - let env = Global.env() in - let sigma = Evd.from_env env in - let l = Proof_using.process_expr env sigma expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let env = Global.env() in + let evd = Evd.from_env env in + let terms = [EConstr.of_constr typ] in + let using = Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using in let args = List.map Context.Rel.Declaration.get_name ctx in Declare.CInfo.make ~name ~typ ~args ~impargs ?using () ) fixnames fixtypes fiximps diff --git a/vernac/comHints.ml b/vernac/comHints.ml index f642411fa4..1c36e10e83 100644 --- a/vernac/comHints.ml +++ b/vernac/comHints.ml @@ -76,6 +76,7 @@ let warn_deprecated_hint_constr = *) let soft_evaluable = let open GlobRef in + let open Tacred in function | ConstRef c -> EvalConstRef c | VarRef id -> EvalVarRef id diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 2be6097184..a91771f22d 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -492,7 +492,7 @@ let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams ~binders:k c = end) sigma args | _ -> Termops.fold_constr_with_full_binders - sigma + env sigma (fun d (env,k) -> EConstr.push_rel d env, k+1) aux envk sigma c in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3c4a651cf5..0651f3330e 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -259,10 +259,9 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?typing_flags ?using r let evars, _, evars_def, evars_typ = RetrieveObl.retrieve_obligations env recname sigma 0 def typ in - let using = using |> Option.map (fun expr -> + let using = let terms = List.map EConstr.of_constr [evars_def; evars_typ] in - let l = Proof_using.process_expr env sigma expr terms in - Names.Id.Set.(List.fold_right add l empty)) + Option.map (fun using -> Proof_using.definition_using env sigma ~using ~terms) using in let uctx = Evd.evar_universe_context sigma in let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ ?using () in @@ -294,11 +293,8 @@ let do_program_recursive ~pm ~scope ~poly ?typing_flags ?using fixkind fixl = let evd = nf_evar_map_undefined evd in let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) - let using = using |> Option.map (fun expr -> - let terms = [def; typ] in - let l = Proof_using.process_expr env evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let terms = [def; typ] in + let using = Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using in let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml index af51f4fafb..1b811f3db7 100644 --- a/vernac/comSearch.ml +++ b/vernac/comSearch.ml @@ -105,12 +105,6 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let deprecated_searchhead = - CWarnings.create - ~name:"deprecated-searchhead" - ~category:"deprecated" - (fun () -> Pp.str("SearchHead is deprecated. Use the headconcl: clause of Search instead.")) - let interp_search env sigma s r = let r = interp_search_restriction r in let get_pattern c = snd (Constrintern.intern_constr_pattern env sigma c) in @@ -138,9 +132,6 @@ let interp_search env sigma s r = (Search.search_pattern env sigma (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> (Search.search_rewrite env sigma (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchHead c -> - deprecated_searchhead (); - (Search.search_by_head env sigma (get_pattern c) r |> Search.prioritize_search) pr_search | Search sl -> (Search.search env sigma (List.map (interp_search_request env Evd.(from_env env)) sl) r |> Search.prioritize_search) pr_search); diff --git a/vernac/declare.ml b/vernac/declare.ml index fafee13bf6..607ba18a95 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -57,7 +57,7 @@ module CInfo = struct (** Names to pre-introduce *) ; impargs : Impargs.manual_implicits (** Explicitily declared implicit arguments *) - ; using : Names.Id.Set.t option + ; using : Proof_using.t option (** Explicit declaration of section variables used by the constant *) } @@ -883,19 +883,12 @@ let shrink_body c ty = (* Saving an obligation *) (***********************************************************************) -let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] +let unfold_entry cst = Hints.HintsUnfoldEntry [Tacred.EvalConstRef cst] let add_hint local prg cst = let locality = if local then Goptions.OptLocal else Goptions.OptExport in Hints.add_hints ~locality [Id.to_string prg.prg_cinfo.CInfo.name] (unfold_entry cst) -(* true = hide obligations *) -let get_hide_obligations = - Goptions.declare_bool_option_and_ref - ~depr:true - ~key:["Hide"; "Obligations"] - ~value:false - let declare_obligation prg obl ~uctx ~types ~body = let poly = prg.prg_info.Info.poly in let univs = UState.univ_entry ~poly uctx in @@ -1046,51 +1039,10 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let hide_obligation () = - Coqlib.check_required_library ["Coq"; "Program"; "Tactics"]; - UnivGen.constr_of_monomorphic_global - (Coqlib.lib_ref "program.tactics.obligation") - -(* XXX: Is this the right place? *) -let rec prod_app t n = - match - Constr.kind - (EConstr.Unsafe.to_constr - (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) - (* FIXME *) - with - | Prod (_, _, b) -> Vars.subst1 n b - | LetIn (_, b, t, b') -> prod_app (Vars.subst1 b b') n - | _ -> - CErrors.user_err ~hdr:"prod_app" - Pp.(str "Needed a product, but didn't find one" ++ fnl ()) - -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL - -let replace_appvars subst = - let rec aux c = - let f, l = decompose_app c in - if isVar f then - try - let c' = List.map (Constr.map aux) l in - let t, b = Id.List.assoc (destVar f) subst in - mkApp - ( delayed_force hide_obligation - , [|prod_applist t c'; Term.applistc b c'|] ) - with Not_found -> Constr.map aux c - else Constr.map aux c - in - Constr.map aux - let subst_prog subst prg = - if get_hide_obligations () then - ( replace_appvars subst prg.prg_body - , replace_appvars subst (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) - else - let subst' = List.map (fun (n, (_, b)) -> (n, b)) subst in - ( Vars.replace_vars subst' prg.prg_body - , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) + let subst' = List.map (fun (n, (_, b)) -> (n, b)) subst in + ( Vars.replace_vars subst' prg.prg_body + , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_cinfo.CInfo.typ ) let declare_definition ~pm prg = let varsubst = obligation_substitution true prg in @@ -1526,11 +1478,10 @@ let start_mutual_with_initialization ~info ~cinfo ~mutual_info sigma snl = let get_used_variables pf = pf.using let get_universe_decl pf = pf.pinfo.Proof_info.info.Info.udecl -let set_used_variables ps l = +let set_used_variables ps ~using = let open Context.Named.Declaration in let env = Global.env () in - let ids = List.fold_right Id.Set.add l Id.Set.empty in - let ctx = Environ.keep_hyps env ids in + let ctx = Environ.keep_hyps env using in let ctx_set = List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in diff --git a/vernac/declare.mli b/vernac/declare.mli index 37a61cc4f0..81558e6f6b 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -79,7 +79,7 @@ module CInfo : sig -> typ:'constr -> ?args:Name.t list -> ?impargs:Impargs.manual_implicits - -> ?using:Names.Id.Set.t + -> ?using:Proof_using.t -> unit -> 'constr t @@ -244,7 +244,7 @@ module Proof : sig (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) *) - val set_used_variables : t -> Names.Id.t list -> Constr.named_context * t + val set_used_variables : t -> using:Proof_using.t -> Constr.named_context * t (** Gets the set of variables declared to be used by the proof. None means no "Proof using" or #[using] was given *) diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 834ef0d29a..91ab17575d 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -74,6 +74,10 @@ let input_univ_names : universe_name_decl -> Libobject.obj = subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } +let input_univ_names (src, l) = + if CList.is_empty l then () + else Lib.add_anonymous_leaf (input_univ_names (src, l)) + let invent_name (named,cnt) u = let rec aux i = let na = Id.of_string ("u"^(string_of_int i)) in @@ -120,7 +124,7 @@ let declare_univ_binders gr pl = aux, (id,univ) :: univs) (LSet.diff levels named) ((pl,0),univs) in - Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) + input_univ_names (QualifiedUniv l, univs) let do_universe ~poly l = let in_section = Global.sections_are_opened () in @@ -134,7 +138,7 @@ let do_universe ~poly l = Univ.LSet.empty l, Univ.Constraint.empty in let src = if poly then BoundUniv else UnqualifiedUniv in - let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in + let () = input_univ_names (src, l) in DeclareUctx.declare_universe_context ~poly ctx let do_constraint ~poly l = diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index d2eeebc246..15e6d4ef37 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -301,7 +301,10 @@ and load_keep i ((sp,kn),kobjs) = let mark_object f obj (exports,acc) = (exports, (f,obj)::acc) -let rec collect_module_objects (f,mp) acc = +let rec collect_modules mpl acc = + List.fold_left (fun acc fmp -> collect_module fmp acc) acc (List.rev mpl) + +and collect_module (f,mp) acc = (* May raise Not_found for unknown module and for functors *) let modobjs = ModObjs.get mp in let prefix = modobjs.module_prefix in @@ -310,14 +313,16 @@ let rec collect_module_objects (f,mp) acc = and collect_object f i (name, obj as o) acc = match obj with - | ExportObject { mpl } -> collect_export f i mpl acc + | ExportObject { mpl } -> collect_exports f i mpl acc | AtomicObject _ | IncludeObject _ | KeepObject _ | ModuleObject _ | ModuleTypeObject _ -> mark_object f o acc and collect_objects f i prefix objs acc = - List.fold_right (fun (id, obj) acc -> collect_object f i (Lib.make_oname prefix id, obj) acc) objs acc + List.fold_left (fun acc (id, obj) -> + collect_object f i (Lib.make_oname prefix id, obj) acc + ) acc (List.rev objs) -and collect_one_export f (f',mp) (exports,objs as acc) = +and collect_export f (f',mp) (exports,objs as acc) = match filter_and f f' with | None -> acc | Some f -> @@ -334,12 +339,12 @@ and collect_one_export f (f',mp) (exports,objs as acc) = *) if exports == exports' then acc else - collect_module_objects (f,mp) (exports', objs) + collect_module (f,mp) (exports', objs) -and collect_export f i mpl acc = +and collect_exports f i mpl acc = if Int.equal i 1 then - List.fold_right (collect_one_export f) mpl acc + List.fold_left (fun acc fmp -> collect_export f fmp acc) acc (List.rev mpl) else acc let open_modtype i ((sp,kn),_) = @@ -388,7 +393,7 @@ and open_include f i ((sp,kn), aobjs) = open_objects f i prefix o and open_export f i mpl = - let _,objs = collect_export f i mpl (MPmap.empty, []) in + let _,objs = collect_exports f i mpl (MPmap.empty, []) in List.iter (fun (f,o) -> open_object f 1 o) objs and open_keep f i ((sp,kn),kobjs) = @@ -1056,7 +1061,7 @@ let end_library ?except ~output_native_objects dir = cenv,(substitute,keep),ast let import_modules ~export mpl = - let _,objs = List.fold_right collect_module_objects mpl (MPmap.empty, []) in + let _,objs = collect_modules mpl (MPmap.empty, []) in List.iter (fun (f,o) -> open_object f 1 o) objs; if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 5c329f60a9..f8a28332b1 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -965,8 +965,6 @@ GRAMMAR EXTEND Gram (* Searching the environment *) | IDENT "About"; qid = smart_global; l = OPT univ_name_list; "." -> { fun g -> VernacPrint (PrintAbout (qid,l,g)) } - | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchHead c,g, l) } | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules; "." -> { fun g -> VernacSearch (SearchPattern c,g, l) } | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." -> diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index e6244ee3b5..2fe402ff08 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1793,15 +1793,9 @@ let remove_delimiters local scope = let add_class_scope local scope cl = Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeClasses cl)) -(* Check if abbreviation to a name and avoid early insertion of - maximal implicit arguments *) -let try_interp_name_alias = function - | [], { CAst.v = CRef (ref,_) } -> intern_reference ref - | _ -> raise Not_found - let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing } = let acvars,pat,reversibility = - try Id.Map.empty, NRef (try_interp_name_alias (vars,c)), APrioriReversible + try Id.Map.empty, try_interp_name_alias (vars,c), APrioriReversible with Not_found -> let fold accu id = Id.Map.add id NtnInternTypeAny accu in let i_vars = List.fold_left fold Id.Map.empty vars in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index ff4365c8d3..8e5942440b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -242,7 +242,6 @@ let pr_search a gopt b pr_p = pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt ++ match a with - | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b | Search sl -> diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 0fc6c7f87b..79a0cdf8d1 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -947,7 +947,7 @@ let print_about_any ?loc env sigma k udecl = [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> let () = match Syntax_def.search_syntactic_definition kn with - | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref + | [],Notation_term.NRef (ref,_) -> Dumpglob.add_glob ?loc ref | _ -> () in v 0 ( print_syntactic_def env kn ++ fnl () ++ diff --git a/vernac/printmod.ml b/vernac/printmod.ml index fdf7f6c74a..ba4a7857e7 100644 --- a/vernac/printmod.ml +++ b/vernac/printmod.ml @@ -124,7 +124,7 @@ let print_mutual_inductive env mind mib udecl = let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") - (print_one_inductive env sigma mib) inds ++ + (print_one_inductive env sigma mib) inds ++ str "." ++ Printer.pr_universes sigma ?variance:mib.mind_variance mib.mind_universes) let get_fields = @@ -173,7 +173,7 @@ let print_record env mind mib udecl = prlist_with_sep (fun () -> str ";" ++ brk(2,0)) (fun (id,b,c) -> Id.print id ++ str (if b then " : " else " := ") ++ - Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++ + Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }." ++ Printer.pr_universes sigma ?variance:mib.mind_variance mib.mind_universes ) diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index bdb0cabacf..01e7b7cc3d 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -64,6 +64,12 @@ let process_expr env sigma e ty = let s = Id.Set.union v_ty (process_expr env sigma e v_ty) in Id.Set.elements s +type t = Names.Id.Set.t + +let definition_using env evd ~using ~terms = + let l = process_expr env evd using terms in + Names.Id.Set.(List.fold_right add l empty) + let name_set id expr = known_names := (id,expr) :: !known_names let minimize_hyps env ids = @@ -91,13 +97,14 @@ let remove_ids_and_lets env s ids = let record_proof_using expr = Aux_file.record_in_aux "suggest_proof_using" expr +let debug_proof_using = CDebug.create ~name:"proof-using" () + (* Variables in [skip] come from after the definition, so don't count for "All". Used in the variable case since the env contains the variable itself. *) let suggest_common env ppid used ids_typ skip = let module S = Id.Set in let open Pp in - let print x = Feedback.msg_debug x in let pr_set parens s = let wrap ppcmds = if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" @@ -111,13 +118,13 @@ let suggest_common env ppid used ids_typ skip = in let all = S.diff all skip in let fwd_typ = close_fwd env (Evd.from_env env) ids_typ in - if !Flags.debug then begin - print (str "All " ++ pr_set false all); - print (str "Type " ++ pr_set false ids_typ); - print (str "needed " ++ pr_set false needed); - print (str "all_needed " ++ pr_set false all_needed); - print (str "Type* " ++ pr_set false fwd_typ); - end; + let () = debug_proof_using (fun () -> + str "All " ++ pr_set false all ++ fnl() ++ + str "Type " ++ pr_set false ids_typ ++ fnl() ++ + str "needed " ++ pr_set false needed ++ fnl() ++ + str "all_needed " ++ pr_set false all_needed ++ fnl() ++ + str "Type* " ++ pr_set false fwd_typ) + in let valid_exprs = ref [] in let valid e = valid_exprs := e :: !valid_exprs in if S.is_empty needed then valid (str "Type"); diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index 93dbd33ae4..60db4d60e6 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -10,10 +10,17 @@ (** Utility code for section variables handling in Proof using... *) -val process_expr : - Environ.env -> Evd.evar_map -> - Vernacexpr.section_subset_expr -> EConstr.types list -> - Names.Id.t list +(** At some point it would be good to make this abstract *) +type t = Names.Id.Set.t + +(** Process a [using] expression in definitions to provide the list of + used terms *) +val definition_using + : Environ.env + -> Evd.evar_map + -> using:Vernacexpr.section_subset_expr + -> terms:EConstr.constr list + -> t val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit diff --git a/vernac/record.ml b/vernac/record.ml index 583164a524..96e4a47d2d 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -366,7 +366,7 @@ let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramde let ci = Inductiveops.make_case_info env indsp rci LetStyle in (* Record projections are always NoInvert because they're at constant relevance *) - mkCase (ci, p, NoInvert, mkRel 1, [|branch|]), None + mkCase (Inductive.contract_case env (ci, p, NoInvert, mkRel 1, [|branch|])), None in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in @@ -625,7 +625,7 @@ let build_class_constant ~univs ~rdata field implfs params paramimpls coers bind let cref = GlobRef.ConstRef cst in Impargs.declare_manual_implicits false cref paramimpls; Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd implfs); - Classes.set_typeclass_transparency (EvalConstRef cst) false false; + Classes.set_typeclass_transparency (Tacred.EvalConstRef cst) false false; let sub = List.hd coers in let m = { meth_name = Name proj_name; @@ -744,7 +744,7 @@ let add_constant_class env sigma cst = } in Classes.add_class env sigma tc; - Classes.set_typeclass_transparency (EvalConstRef cst) false false + Classes.set_typeclass_transparency (Tacred.EvalConstRef cst) false false let add_inductive_class env sigma ind = let mind, oneind = Inductive.lookup_mind_specif env ind in diff --git a/vernac/search.ml b/vernac/search.ml index 501e5b1a91..98e231de19 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -185,14 +185,6 @@ let rec pattern_filter pat ref env sigma typ = | LetIn (_, _, _, typ) -> pattern_filter pat ref env sigma typ | _ -> false -let rec head_filter pat ref env sigma typ = - let typ = Termops.strip_outer_cast sigma typ in - if Constr_matching.is_matching_head env sigma pat typ then true - else match EConstr.kind sigma typ with - | Prod (_, _, typ) - | LetIn (_, _, _, typ) -> head_filter pat ref env sigma typ - | _ -> false - let full_name_of_reference ref = let (dir,id) = repr_path (Nametab.path_of_global ref) in DirPath.to_string dir ^ "." ^ Id.to_string id @@ -274,19 +266,6 @@ let search_rewrite env sigma pat mods pr_search = (** Search *) -let search_by_head env sigma pat mods pr_search = - let filter ref kind env typ = - module_filter mods ref kind env sigma typ && - head_filter pat ref env sigma (EConstr.of_constr typ) && - blacklist_filter ref kind env sigma typ - in - let iter ref kind env typ = - if filter ref kind env typ then pr_search ref kind env typ - in - generic_search env iter - -(** Search *) - let search env sigma items mods pr_search = let filter ref kind env typ = let eqb b1 b2 = if b1 then b2 else not b2 in diff --git a/vernac/search.mli b/vernac/search.mli index 09847f4e03..6557aa5986 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -47,8 +47,6 @@ val search_filter : glob_search_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool - -> display_function -> unit val search_rewrite : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool -> display_function -> unit val search_pattern : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index cd0dd5e9a6..007a3b05fc 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -45,3 +45,4 @@ ComArguments Vernacentries ComTactic Vernacinterp +Vernac_classifier diff --git a/stm/vernac_classifier.ml b/vernac/vernac_classifier.ml index ffae2866c0..ffae2866c0 100644 --- a/stm/vernac_classifier.ml +++ b/vernac/vernac_classifier.ml diff --git a/stm/vernac_classifier.mli b/vernac/vernac_classifier.mli index 61bf3a503a..61bf3a503a 100644 --- a/stm/vernac_classifier.mli +++ b/vernac/vernac_classifier.mli diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index a3726daf63..38ca836b32 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -309,6 +309,17 @@ let print_registered () = in hov 0 (prlist_with_sep fnl pr_lib_ref @@ Coqlib.get_lib_refs ()) +let dump_universes output g = + let open Univ in + let dump_arc u = function + | UGraph.Node ltle -> + Univ.LMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u v) ltle; + | UGraph.Alias v -> + output Eq u v + in + Univ.LMap.iter dump_arc g let dump_universes_gen prl g s = let output = open_out s in @@ -342,7 +353,7 @@ let dump_universes_gen prl g s = in let output_constraint k l r = output_constraint k (prl l) (prl r) in try - UGraph.dump_universes output_constraint g; + dump_universes output_constraint g; close (); str "Universes written to file \"" ++ str s ++ str "\"." with reraise -> @@ -367,13 +378,66 @@ let universe_subgraph ?loc kept univ = let univ = LSet.fold add kept UGraph.initial_universes in UGraph.merge_constraints csts univ +let sort_universes g = + let open Univ in + let rec normalize u = match LMap.find u g with + | UGraph.Alias u -> normalize u + | UGraph.Node _ -> u + in + let get_next u = match LMap.find u g with + | UGraph.Alias u -> assert false (* nodes are normalized *) + | UGraph.Node ltle -> ltle + in + (* Compute the longest chain of Lt constraints from Set to any universe *) + let rec traverse accu todo = match todo with + | [] -> accu + | (u, n) :: todo -> + let () = assert (Level.equal (normalize u) u) in + let n = match LMap.find u accu with + | m -> if m < n then Some n else None + | exception Not_found -> Some n + in + match n with + | None -> traverse accu todo + | Some n -> + let accu = LMap.add u n accu in + let next = get_next u in + let fold v lt todo = + let v = normalize v in + if lt then (v, n + 1) :: todo else (v, n) :: todo + in + let todo = LMap.fold fold next todo in + traverse accu todo + in + (* Only contains normalized nodes *) + 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.cons Level.set ulevels in + (* Add the normal universes *) + let fold (cur, ans) u = + let ans = LMap.add cur (UGraph.Node (LMap.singleton u true)) ans in + (u, ans) + in + let _, ans = Array.fold_left fold (Level.prop, LMap.empty) ulevels in + (* Add alias pointers *) + let fold u _ ans = + if Level.is_small u then ans + else + let n = LMap.find (normalize u) levels in + LMap.add u (UGraph.Alias ulevels.(n)) ans + in + LMap.fold fold g ans + let print_universes ?loc ~sort ~subgraph dst = let univ = Global.universes () in let univ = match subgraph with | None -> univ | Some g -> universe_subgraph ?loc g univ in - let univ = if sort then UGraph.sort_universes univ else univ in + let univ = UGraph.repr univ in + let univ = if sort then sort_universes univ else univ in let pr_remaining = if Global.is_joined_environment () then mt () else str"There may remain asynchronous universe constraints" @@ -499,19 +563,19 @@ let program_inference_hook env sigma ev = user_err Pp.(str "The statement obligations could not be resolved \ automatically, write a statement definition first.") -let vernac_set_used_variables ~pstate e : Declare.Proof.t = +let vernac_set_used_variables ~pstate using : Declare.Proof.t = let env = Global.env () in let sigma, _ = Declare.Proof.get_current_context pstate in let initial_goals pf = Proofview.initial_goals Proof.((data pf).entry) in - let tys = List.map snd (initial_goals (Declare.Proof.get pstate)) in - let l = Proof_using.process_expr env sigma e tys in + let terms = List.map snd (initial_goals (Declare.Proof.get pstate)) in + let using = Proof_using.definition_using env sigma ~using ~terms in let vars = Environ.named_context env in - List.iter (fun id -> - if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then - user_err ~hdr:"vernac_set_used_variables" - (str "Unknown variable: " ++ Id.print id)) - l; - let _, pstate = Declare.Proof.set_used_variables pstate l in + Names.Id.Set.iter (fun id -> + if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" + (str "Unknown variable: " ++ Id.print id)) + using; + let _, pstate = Declare.Proof.set_used_variables pstate ~using in pstate let vernac_set_used_variables_opt ?using pstate = @@ -1151,9 +1215,11 @@ let msg_of_subsection ss id = in Pp.str kind ++ spc () ++ Id.print id -let vernac_end_segment ~pm ({v=id} as lid) = +let vernac_end_segment ~pm ~stack ({v=id} as lid) = let ss = Lib.find_opening_node id in let what_for = msg_of_subsection ss lid.v in + if Option.has_some stack then + CErrors.user_err (Pp.str "Command not supported (Open proofs remain)"); Declare.Obls.check_solved_obligations ~pm ~what_for; match ss with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid @@ -1337,31 +1403,9 @@ let warn_implicit_core_hint_db = (fun () -> strbrk "Adding and removing hints in the core database implicitly is deprecated. " ++ strbrk"Please specify a hint database.") -let warn_deprecated_hint_without_locality = - CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" - (fun () -> strbrk "The default value for hint locality is currently \ - \"local\" in a section and \"global\" otherwise, but is scheduled to change \ - in a future release. For the time being, adding hints outside of sections \ - without specifying an explicit locality is therefore deprecated. It is \ - recommended to use \"export\" whenever possible.") - -let check_hint_locality = function -| OptGlobal -> - if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the global attribute in sections."); -| OptExport -> - if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the export attribute in sections."); -| OptDefault -> - if not @@ Global.sections_are_opened () then - warn_deprecated_hint_without_locality () -| OptLocal -> () - let vernac_remove_hints ~atts dbnames ids = let locality = Attributes.(parse option_locality atts) in - let () = check_hint_locality locality in + let () = Hints.check_hint_locality locality in let dbnames = if List.is_empty dbnames then (warn_implicit_core_hint_db (); ["core"]) @@ -1376,7 +1420,7 @@ let vernac_hints ~atts dbnames h = else dbnames in let locality, poly = Attributes.(parse Notations.(option_locality ++ polymorphic) atts) in - let () = check_hint_locality locality in + let () = Hints.check_hint_locality locality in Hints.add_hints ~locality dbnames (ComHints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = @@ -1394,7 +1438,10 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) t in + let t = Flags.without_option Detyping.print_universes (fun () -> + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) t) + () + in let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1598,6 +1645,13 @@ let () = optwrite = CWarnings.set_flags } let () = + declare_string_option + { optdepr = false; + optkey = ["Debug"]; + optread = CDebug.get_flags; + optwrite = CDebug.set_flags } + +let () = declare_bool_option { optdepr = false; optkey = ["Guard"; "Checking"]; @@ -1628,6 +1682,7 @@ let () = } let vernac_set_strategy ~local l = + let open Tacred in let local = Option.default false local in let glob_ref r = match smart_global r with @@ -1639,6 +1694,7 @@ let vernac_set_strategy ~local l = Redexpr.set_strategy local l let vernac_set_opacity ~local (v,l) = + let open Tacred in let local = Option.default true local in let glob_ref r = match smart_global r with @@ -1661,9 +1717,9 @@ let vernac_set_append_option ~locality key s = let vernac_set_option ~locality table v = match v with | OptionSetString s -> - (* We make a special case for warnings because appending is their - natural semantics *) - if CString.List.equal table ["Warnings"] then + (* We make a special case for warnings and debug flags because appending is + their natural semantics *) + if CString.List.equal table ["Warnings"] || CString.List.equal table ["Debug"] then vernac_set_append_option ~locality table s else let (last, prefix) = List.sep_last table in @@ -2018,7 +2074,7 @@ let vernac_check_guard ~pstate = (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) -let translate_vernac ~atts v = let open Vernacextend in match v with +let translate_vernac ?loc ~atts v = let open Vernacextend in match v with | VernacAbortAll | VernacRestart | VernacUndo _ @@ -2129,9 +2185,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtNoProof(fun () -> vernac_begin_section ~poly:(only_polymorphism atts) lid) | VernacEndSegment lid -> - VtReadProgram(fun ~pm -> + VtReadProgram(fun ~stack ~pm -> unsupported_attributes atts; - vernac_end_segment ~pm lid) + vernac_end_segment ~pm ~stack lid) | VernacNameSectionHypSet (lid, set) -> VtDefault(fun () -> unsupported_attributes atts; @@ -2343,4 +2399,4 @@ let translate_vernac ~atts v = let open Vernacextend in match v with (* Extensions *) | VernacExtend (opn,args) -> - Vernacextend.type_vernac ~atts opn args + Vernacextend.type_vernac ?loc ~atts opn args diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index cf233248d7..b30bbc3ce7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -10,7 +10,8 @@ (** Vernac Translation into the Vernac DSL *) val translate_vernac - : atts:Attributes.vernac_flags + : ?loc:Loc.t + -> atts:Attributes.vernac_flags -> Vernacexpr.vernac_expr -> Vernacextend.typed_vernac @@ -26,4 +27,3 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr val command_focus : unit Proof.focus_kind val allow_sprop_opt_name : string list -val cumul_sprop_opt_name : string list diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 2e360cf969..46acaf7264 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -75,7 +75,6 @@ type search_request = type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr - | SearchHead of constr_pattern_expr | Search of (bool * search_request) list type locatable = diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index ed63332861..df82382041 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -59,12 +59,12 @@ type typed_vernac = | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) | VtReadProof of (pstate:Declare.Proof.t -> unit) - | VtReadProgram of (pm:Declare.OblState.t -> unit) + | VtReadProgram of (stack:Vernacstate.LemmaStack.t option -> pm:Declare.OblState.t -> unit) | VtModifyProgram of (pm:Declare.OblState.t -> Declare.OblState.t) | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) -type vernac_command = atts:Attributes.vernac_flags -> typed_vernac +type vernac_command = ?loc:Loc.t -> atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list @@ -94,7 +94,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let type_vernac opn converted_args ~atts = +let type_vernac opn converted_args ?loc ~atts = let depr, callback = vinterp_map opn in let () = if depr then let rules = Egramml.get_extend_vernac_rule opn in @@ -106,7 +106,7 @@ let type_vernac opn converted_args ~atts = warn_deprecated_command pr; in let hunk = callback converted_args in - hunk ~atts + hunk ?loc ~atts (** VERNAC EXTEND registering *) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index e1e3b4cfe5..27f6930dec 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -77,12 +77,12 @@ type typed_vernac = | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) | VtReadProof of (pstate:Declare.Proof.t -> unit) - | VtReadProgram of (pm:Declare.OblState.t -> unit) + | VtReadProgram of (stack:Vernacstate.LemmaStack.t option -> pm:Declare.OblState.t -> unit) | VtModifyProgram of (pm:Declare.OblState.t -> Declare.OblState.t) | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) -type vernac_command = atts:Attributes.vernac_flags -> typed_vernac +type vernac_command = ?loc:Loc.t -> atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index e5971e1aaa..4098401bf0 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -48,7 +48,7 @@ let interp_typed_vernac c ~pm ~stack = vernac_require_open_lemma ~stack (Vernacstate.LemmaStack.with_top ~f:(fun pstate -> f ~pstate)); stack, pm - | VtReadProgram f -> f ~pm; stack, pm + | VtReadProgram f -> f ~stack ~pm; stack, pm | VtModifyProgram f -> let pm = f ~pm in stack, pm | VtDeclareProgram f -> @@ -82,7 +82,7 @@ let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = match !default_timeout, timeout with | _, Some n | Some n, None -> - (match Control.timeout n f x with + (match Control.timeout (float_of_int n) f x with | None -> Exninfo.iraise (Exninfo.capture CErrors.Timeout) | Some x -> x) | None, None -> @@ -151,7 +151,7 @@ let interp_control_flag ~time_header (f : control_flag) ~st * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let rec interp_expr ~atts ~st c = +let rec interp_expr ?loc ~atts ~st c = let stack = st.Vernacstate.lemmas in let program = st.Vernacstate.program in vernac_pperr_endline Pp.(fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); @@ -174,7 +174,7 @@ let rec interp_expr ~atts ~st c = Attributes.unsupported_attributes atts; vernac_load ~verbosely fname | v -> - let fv = Vernacentries.translate_vernac ~atts v in + let fv = Vernacentries.translate_vernac ?loc ~atts v in interp_typed_vernac ~pm:program ~stack fv and vernac_load ~verbosely fname = @@ -206,13 +206,13 @@ and vernac_load ~verbosely fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); stack, pm -and interp_control ~st ({ CAst.v = cmd } as vernac) = +and interp_control ~st ({ CAst.v = cmd; loc } as vernac) = let time_header = mk_time_header vernac in List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) cmd.control (fun ~st -> let before_univs = Global.universes () in - let pstack, pm = interp_expr ~atts:cmd.attrs ~st cmd.expr in + let pstack, pm = interp_expr ?loc ~atts:cmd.attrs ~st cmd.expr in let after_univs = Global.universes () in if before_univs == after_univs then pstack, pm else |
