diff options
154 files changed, 4673 insertions, 2146 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index bb0beb142a..b7418f54bd 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -106,6 +106,7 @@ /kernel/native* @coq/vm-native-maintainers /kernel/vm* @coq/vm-native-maintainers /kernel/vconv.* @coq/vm-native-maintainers +/kernel/genOpcodefiles.* @coq/vm-native-maintainers /kernel/sorts.* @coq/universes-maintainers /kernel/uGraph.* @coq/universes-maintainers diff --git a/.gitignore b/.gitignore index 557655317c..92e9fd2105 100644 --- a/.gitignore +++ b/.gitignore @@ -154,7 +154,7 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe -kernel/copcodes.ml +kernel/vmopcodes.ml kernel/uint63.ml ide/coqide/default.bindings ide/coqide/default_bindings_src.exe diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ab06123aed..cc8a4d34c9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -19,7 +19,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-08-18-V29" + CACHEKEY: "bionic_coq-V2020-08-28-V92" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -27,6 +27,9 @@ variables: OPAM_VARIANT: "" GIT_DEPTH: "10" +include: + - local: '/dev/bench/gitlab-bench.yml' + docker-boot: stage: docker image: docker:stable @@ -597,7 +600,7 @@ test-suite:edge:dune:dev: - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - opam install ocaml-variants=$OCAMLVER - - opam install dune num + - opam install dune num zarith - eval $(opam env) - export COQ_UNIT_TEST=noop - make -f Makefile.dune test-suite @@ -921,35 +924,3 @@ plugin:ci-rewriter: name: "$CI_JOB_NAME" paths: - _build_ci - -bench: - stage: stage-1 - when: manual - before_script: - - printenv -0 | sort -z | tr '\0' '\n' - script: - - . ~/.opam/opam-init/init.sh - - ./dev/bench/gitlab.sh - tags: - - timing - variables: - GIT_DEPTH: "" - coq_pr_number: "" - coq_pr_comment_id: "" - new_ocaml_switch: "ocaml-base-compiler.4.07.1" - old_ocaml_switch: "ocaml-base-compiler.4.07.1" - new_coq_repository: "https://gitlab.com/coq/coq.git" - old_coq_repository: "https://gitlab.com/coq/coq.git" - new_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" - old_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" - new_coq_opam_archive_git_branch: "master" - old_coq_opam_archive_git_branch: "master" - num_of_iterations: 1 - coq_opam_packages: "coq-performance-tests coq-engine-bench 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" - artifacts: - name: "$CI_JOB_NAME" - paths: - - _bench/html/**/*.v.html - - _bench/logs - when: always - expire_in: 1 year diff --git a/INSTALL.md b/INSTALL.md index c44c3dde7d..2b5986ded4 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -12,6 +12,8 @@ To compile Coq yourself, you need: - The [num](https://github.com/ocaml/num) library; note that it is included in the OCaml distribution for OCaml versions < 4.06.0 +- The [ZArith library](https://github.com/ocaml/Zarith) >= 1.8 + - The [findlib](http://projects.camlcity.org/projects/findlib.html) library (version >= 1.8.0) - GNU Make (version >= 3.81) diff --git a/META.coq.in b/META.coq.in index 095f54dde7..5aaa8cc8a6 100644 --- a/META.coq.in +++ b/META.coq.in @@ -120,7 +120,7 @@ package "interp" ( description = "Coq Term Interpretation" version = "8.13" - requires = "coq.pretyping" + requires = "zarith, coq.pretyping" directory = "interp" archive(byte) = "interp.cma" @@ -327,7 +327,7 @@ package "plugins" ( description = "Coq micromega plugin" version = "8.13" - requires = "num,coq.plugins.ltac" + requires = "num, coq.plugins.ltac" directory = "micromega" archive(byte) = "micromega_plugin.cmo" @@ -462,7 +462,7 @@ package "plugins" ( description = "Coq nsatz plugin" version = "8.13" - requires = "num,coq.plugins.ltac" + requires = "zarith, coq.plugins.ltac" directory = "nsatz" archive(byte) = "nsatz_plugin.cmo" @@ -507,7 +507,7 @@ package "plugins" ( description = "Coq string_notation plugin" version = "8.13" - requires = "" + requires = "coq.vernac" directory = "syntax" archive(byte) = "string_notation_plugin.cmo" @@ -517,6 +517,20 @@ package "plugins" ( plugin(native) = "string_notation_plugin.cmxs" ) + package "numeral_notation" ( + description = "Coq numeral notation plugin" + version = "8.13" + + requires = "coq.vernac" + directory = "numeral_notation" + + archive(byte) = "numeral_notation_plugin.cmo" + archive(native) = "numeral_notation_plugin.cmx" + + plugin(byte) = "numeral_notation_plugin.cmo" + plugin(native) = "numeral_notation_plugin.cmxs" + ) + package "derive" ( description = "Coq derive plugin" diff --git a/Makefile.build b/Makefile.build index 7806dce79c..061489f47f 100644 --- a/Makefile.build +++ b/Makefile.build @@ -245,7 +245,7 @@ COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) BOOTCOQC=$(TIMER) $(COQC) -coqlib . -q $(COQOPTS) LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) -MLINCLUDES=$(LOCALINCLUDES) +MLINCLUDES=$(LOCALINCLUDES) -package zarith USERCONTRIBINCLUDES=$(addprefix -I user-contrib/,$(USERCONTRIBDIRS)) @@ -302,7 +302,7 @@ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^ endef # Main packages linked by Coq. -SYSMOD:=-package num,str,unix,dynlink,threads +SYSMOD:=-package str,unix,dynlink,threads,num,zarith ########################################################################### # Infrastructure for the rest of the Makefile @@ -367,7 +367,7 @@ kernel/byterun/coq_jumptbl.h: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< jump > $@ -kernel/copcodes.ml: kernel/genOpcodeFiles.exe +kernel/vmopcodes.ml: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< copml > $@ @@ -709,10 +709,6 @@ plugins/micromega/%.cmi: plugins/micromega/%.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -plugins/nsatz/%.cmi: plugins/nsatz/%.mli - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< - %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -721,10 +717,6 @@ plugins/micromega/%.cmo: plugins/micromega/%.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -plugins/nsatz/%.cmo: plugins/nsatz/%.ml - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< - %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -762,10 +754,6 @@ plugins/micromega/%.cmx: plugins/micromega/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix,num -c $< -plugins/nsatz/%.cmx: plugins/nsatz/%.ml - $(SHOW)'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix,num -c $< - plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< diff --git a/Makefile.doc b/Makefile.doc index cc6277ca79..473a70fb72 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -223,7 +223,7 @@ install-doc-stdlib-html: $(MKDIR) $(FULLDOCDIR)/html/stdlib $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib -install-doc-printable: +install-doc-printable: $(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/stdlib/Library.ps $(FULLDOCDIR)/ps @@ -250,7 +250,8 @@ $(DOC_GRAM): $(DOC_GRAMCMO) coqpp/coqpp_parser.mli coqpp/coqpp_parser.ml doc/too PLUGIN_MLGS := $(wildcard plugins/*/*.mlg) OMITTED_PLUGIN_MLGS := plugins/ssr/ssrparser.mlg plugins/ssr/ssrvernac.mlg plugins/ssrmatching/g_ssrmatching.mlg \ plugins/ssrsearch/g_search.mlg -DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) +DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) \ + user-contrib/Ltac2/g_ltac2.mlg DOC_EDIT_MLGS := $(wildcard doc/tools/docgram/*.edit_mlg) DOC_RSTS := $(wildcard doc/sphinx/*/*.rst) $(wildcard doc/sphinx/*/*/*.rst) diff --git a/Makefile.make b/Makefile.make index 7191738612..51d6d1c3c1 100644 --- a/Makefile.make +++ b/Makefile.make @@ -107,7 +107,7 @@ GRAMMLIFILES := $(addsuffix .mli, $(GRAMFILES)) GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml not in GRAMMLFILES? GENMLGFILES:= $(MLGFILES:.mlg=.ml) -GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/vmopcodes.ml kernel/uint63.ml GENMLIFILES:=$(GRAMMLIFILES) GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe diff --git a/azure-pipelines.yml b/azure-pipelines.yml index b27d1df39d..5830095861 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -22,7 +22,7 @@ jobs: powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" SET CYGROOT=C:\cygwin64 SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python3 + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib,mingw64-x86_64-gmp -P python3 SET TARGET_ARCH=x86_64-w64-mingw32 SET CD_MFMT=%cd:\=/% @@ -64,7 +64,7 @@ jobs: set -e brew update (cd $(brew --repository)/Library/Taps/homebrew/homebrew-core/ && git fetch --shallow-since=${HBCORE_DATE} && git checkout ${HBCORE_REF}) - brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme || true + brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme gmp || true # || true: workaround #12657, see also #12672 and commit message for this line pip3 install macpack displayName: 'Install system dependencies' @@ -80,7 +80,7 @@ jobs: opam switch set ocaml-base-compiler.$COMPILER eval $(opam env) opam update - opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 + opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.9.1 opam list displayName: 'Install OCaml dependencies' env: diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 999f44bf1d..a881b7804f 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -100,26 +100,27 @@ let mk_mtb mp sign delta = mod_delta = delta; mod_retroknowledge = ModTypeRK; } -let collect_constants_without_body sign mp = +let rec collect_constants_without_body sign mp accu = let collect_sf s lab = function | SFBconst cb -> let c = Constant.make2 mp lab in if Declareops.constant_has_body cb then s else Cset.add c s - | SFBmind _ | SFBmodule _ | SFBmodtype _ -> s in + | SFBmodule msb -> collect_constants_without_body msb.mod_type (MPdot(mp,lab)) s + | SFBmind _ | SFBmodtype _ -> s in match sign with | MoreFunctor _ -> Cset.empty (* currently ignored *) | NoFunctor struc -> - List.fold_left (fun s (lab,mb) -> collect_sf s lab mb) Cset.empty struc + List.fold_left (fun s (lab,mb) -> collect_sf s lab mb) accu struc -let rec check_module env opac mp mb = +let rec check_module env opac mp mb opacify = Flags.if_verbose Feedback.msg_notice (str " checking module: " ++ str (ModPath.to_string mp)); let env = Modops.add_retroknowledge mb.mod_retroknowledge env in let sign, opac = - check_signature env opac mb.mod_type mb.mod_mp mb.mod_delta Cset.empty + check_signature env opac mb.mod_type mb.mod_mp mb.mod_delta opacify in let optsign, opac = match mb.mod_expr with |Struct sign_struct -> - let opacify = collect_constants_without_body sign mb.mod_mp in + let opacify = collect_constants_without_body sign mb.mod_mp opacify in let sign, opac = check_signature env opac sign_struct mb.mod_mp mb.mod_delta opacify in Some (sign, mb.mod_delta), opac |Algebraic me -> Some (check_mexpression env opac me mb.mod_mp mb.mod_delta), opac @@ -152,7 +153,7 @@ and check_structure_field env opac mp lab res opacify = function let kn = Mod_subst.mind_of_delta_kn res kn in CheckInductive.check_inductive env kn mib, opac | SFBmodule msb -> - let opac = check_module env opac (MPdot(mp,lab)) msb in + let opac = check_module env opac (MPdot(mp,lab)) msb opacify in Modops.add_module msb env, opac | SFBmodtype mty -> check_module_type env mty; @@ -194,3 +195,5 @@ and check_signature env opac sign mp_mse res opacify = match sign with check_structure_field env opac mp_mse lab res opacify mb) (env, opac) struc in NoFunctor struc, opac + +let check_module env opac mp mb = check_module env opac mp mb Cset.empty diff --git a/clib/bigint.ml b/clib/bigint.ml deleted file mode 100644 index 735ff3261e..0000000000 --- a/clib/bigint.ml +++ /dev/null @@ -1,526 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(***************************************************) -(* Basic operations on (unbounded) integer numbers *) -(***************************************************) - -(* An integer is canonically represented as an array of k-digits blocs, - i.e. in base 10^k. - - 0 is represented by the empty array and -1 by the singleton [|-1|]. - The first bloc is in the range ]0;base[ for positive numbers. - The first bloc is in the range [-base;-1[ for numbers < -1. - All other blocs are numbers in the range [0;base[. - - Negative numbers are represented using 2's complementation : - one unit is "borrowed" from the top block for complementing - the other blocs. For instance, with 4-digits blocs, - [|-5;6789|] denotes -43211 - since -5.10^4+6789=-((4.10^4)+(10000-6789)) = -43211 - - The base is a power of 10 in order to facilitate the parsing and printing - of numbers in digital notation. - - All functions, to the exception of to_string and of_string should work - with an arbitrary base, even if not a power of 10. - - In practice, we set k=4 on 32-bits machines, so that no overflow in ocaml - machine words (i.e. the interval [-2^30;2^30-1]) occur when multiplying two - numbers less than (10^k). On 64-bits machines, k=9. -*) - -(* The main parameters *) - -let size = - let rec log10 n = if n < 10 then 0 else 1 + log10 (n / 10) in - (log10 max_int) / 2 - -let format_size = - (* How to parametrize a printf format *) - if Int.equal size 4 then Printf.sprintf "%04d" - else if Int.equal size 9 then Printf.sprintf "%09d" - else fun n -> - let rec aux j l n = - if Int.equal j size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10) - in String.concat "" (aux 0 [] n) - -(* The base is 10^size *) -let base = - let rec exp10 = function 0 -> 1 | n -> 10 * exp10 (n-1) in exp10 size - -(******************************************************************) -(* First, we represent all numbers by int arrays. - Later, we will optimize the particular case of small integers *) -(******************************************************************) - -module ArrayInt = struct - -(* Basic numbers *) -let zero = [||] - -let is_zero = function -| [||] -> true -| _ -> false - -(* An array is canonical when - - it is empty - - it is [|-1|] - - its first bloc is in [-base;-1[U]0;base[ - and the other blocs are in [0;base[. *) -(* -let canonical n = - let ok x = (0 <= x && x < base) in - let rec ok_tail k = (Int.equal k 0) || (ok n.(k) && ok_tail (k-1)) in - let ok_init x = (-base <= x && x < base && not (Int.equal x (-1)) && not (Int.equal x 0)) - in - (is_zero n) || (match n with [|-1|] -> true | _ -> false) || - (ok_init n.(0) && ok_tail (Array.length n - 1)) -*) - -(* [normalize_pos] : removing initial blocks of 0 *) - -let normalize_pos n = - let k = ref 0 in - while !k < Array.length n && Int.equal n.(!k) 0 do incr k done; - Array.sub n !k (Array.length n - !k) - -(* [normalize_neg] : avoid (-1) as first bloc. - input: an array with -1 as first bloc and other blocs in [0;base[ - output: a canonical array *) - -let normalize_neg n = - let k = ref 1 in - while !k < Array.length n && Int.equal n.(!k) (base - 1) do incr k done; - let n' = Array.sub n !k (Array.length n - !k) in - if Int.equal (Array.length n') 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n') - -(* [normalize] : avoid 0 and (-1) as first bloc. - input: an array with first bloc in [-base;base[ and others in [0;base[ - output: a canonical array *) - -let normalize n = - if Int.equal (Array.length n) 0 then n - else if Int.equal n.(0) (-1) then normalize_neg n - else if Int.equal n.(0) 0 then normalize_pos n - else n - -(* Opposite (expects and returns canonical arrays) *) - -let neg m = - if is_zero m then zero else - let n = Array.copy m in - let i = ref (Array.length m - 1) in - while !i > 0 && Int.equal n.(!i) 0 do decr i done; - if Int.equal !i 0 then begin - n.(0) <- - n.(0); - (* n.(0) cannot be 0 since m is canonical *) - if Int.equal n.(0) (-1) then normalize_neg n - else if Int.equal n.(0) base then (n.(0) <- 0; Array.append [| 1 |] n) - else n - end else begin - (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *) - n.(!i) <- base - n.(!i); decr i; - while !i > 0 do n.(!i) <- base - 1 - n.(!i); decr i done; - (* since -base <= n.(0) <= base-1, hence -base <= -n.(0)-1 <= base-1 *) - n.(0) <- - n.(0) - 1; - (* since m is canonical, m.(0)<>0 hence n.(0)<>-1, - and m=-1 is already handled above, so here m.(0)<>-1 hence n.(0)<>0 *) - n - end - -let push_carry r j = - let j = ref j in - while !j > 0 && r.(!j) < 0 do - r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1 - done; - while !j > 0 && r.(!j) >= base do - r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1 - done; - (* here r.(0) could be in [-2*base;2*base-1] *) - if r.(0) >= base then (r.(0) <- r.(0) - base; Array.append [| 1 |] r) - else if r.(0) < -base then (r.(0) <- r.(0) + 2*base; Array.append [| -2 |] r) - else normalize r (* in case r.(0) is 0 or -1 *) - -let add_to r a j = - if is_zero a then r else begin - for i = Array.length r - 1 downto j+1 do - r.(i) <- r.(i) + a.(i-j); - if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1) - done; - r.(j) <- r.(j) + a.(0); - push_carry r j - end - -let add n m = - let d = Array.length n - Array.length m in - if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d) - -let sub_to r a j = - if is_zero a then r else begin - for i = Array.length r - 1 downto j+1 do - r.(i) <- r.(i) - a.(i-j); - if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1) - done; - r.(j) <- r.(j) - a.(0); - push_carry r j - end - -let sub n m = - let d = Array.length n - Array.length m in - if d >= 0 then sub_to (Array.copy n) m d - else let r = neg m in add_to r n (Array.length r - Array.length n) - -let mult m n = - if is_zero m || is_zero n then zero else - let l = Array.length m + Array.length n in - let r = Array.make l 0 in - for i = Array.length m - 1 downto 0 do - for j = Array.length n - 1 downto 0 do - let p = m.(i) * n.(j) + r.(i+j+1) in - let (q,s) = - if p < 0 - then (p + 1) / base - 1, (p + 1) mod base + base - 1 - else p / base, p mod base in - r.(i+j+1) <- s; - if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q; - done - done; - normalize r - -(* Comparisons *) - -let is_strictly_neg n = not (is_zero n) && n.(0) < 0 -let is_strictly_pos n = not (is_zero n) && n.(0) > 0 -let is_neg_or_zero n = is_zero n || n.(0) < 0 -let is_pos_or_zero n = is_zero n || n.(0) > 0 - -(* Is m without its i first blocs less then n without its j first blocs ? - Invariant : |m|-i = |n|-j *) - -let rec less_than_same_size m n i j = - i < Array.length m && - (m.(i) < n.(j) || (Int.equal m.(i) n.(j) && less_than_same_size m n (i+1) (j+1))) - -let less_than m n = - if is_strictly_neg m then - is_pos_or_zero n || Array.length m > Array.length n - || (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0) - else - is_strictly_pos n && (Array.length m < Array.length n || - (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0)) - -(* For this equality test it is critical that n and m are canonical *) - -let rec array_eq len v1 v2 i = - if Int.equal len i then true - else - Int.equal v1.(i) v2.(i) && array_eq len v1 v2 (succ i) - -let equal m n = - let lenm = Array.length m in - let lenn = Array.length n in - (Int.equal lenm lenn) && (array_eq lenm m n 0) - -(* Is m without its k top blocs less than n ? *) - -let less_than_shift_pos k m n = - (Array.length m - k < Array.length n) - || (Int.equal (Array.length m - k) (Array.length n) && less_than_same_size m n k 0) - -let rec can_divide k m d i = - (Int.equal i (Array.length d)) || - (m.(k+i) > d.(i)) || - (Int.equal m.(k+i) d.(i) && can_divide k m d (i+1)) - -(* For two big nums m and d and a small number q, - computes m - d * q * base^(|m|-|d|-k) in-place (in m). - Both m d and q are positive. *) - -let sub_mult m d q k = - if not (Int.equal q 0) then - for i = Array.length d - 1 downto 0 do - let v = d.(i) * q in - m.(k+i) <- m.(k+i) - v mod base; - if m.(k+i) < 0 then (m.(k+i) <- m.(k+i) + base; m.(k+i-1) <- m.(k+i-1) -1); - if v >= base then begin - m.(k+i-1) <- m.(k+i-1) - v / base; - let j = ref (i-1) in - while m.(k + !j) < 0 do (* result is positive, hence !j remains >= 0 *) - m.(k + !j) <- m.(k + !j) + base; decr j; m.(k + !j) <- m.(k + !j) -1 - done - end - done - -(** Euclid division m/d = (q,r), with m = q*d+r and |r|<|q|. - This is the "Trunc" variant (a.k.a "Truncated-Toward-Zero"), - as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). - We have sign r = sign m *) - -let euclid m d = - let isnegm, m = - if is_strictly_neg m then (-1),neg m else 1,Array.copy m in - let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in - if is_zero d then raise Division_by_zero; - let q,r = - if less_than m d then (zero,m) else - let ql = Array.length m - Array.length d in - let q = Array.make (ql+1) 0 in - let i = ref 0 in - while not (less_than_shift_pos !i m d) do - if Int.equal m.(!i) 0 then incr i else - if can_divide !i m d 0 then begin - let v = - if Array.length d > 1 && not (Int.equal d.(0) m.(!i)) then - (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1) - else - m.(!i) / d.(0) in - q.(!i) <- q.(!i) + v; - sub_mult m d v !i - end else begin - let v = (m.(!i) * base + m.(!i+1)) / (d.(0) + 1) in - q.(!i) <- q.(!i) + v / base; - sub_mult m d (v / base) !i; - q.(!i+1) <- q.(!i+1) + v mod base; - if q.(!i+1) >= base then - (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1); - sub_mult m d (v mod base) (!i+1) - end - done; - (normalize q, normalize m) in - (if Int.equal (isnegd * isnegm) (-1) then neg q else q), - (if Int.equal isnegm (-1) then neg r else r) - -(* Parsing/printing ordinary 10-based numbers *) - -let of_string s = - let len = String.length s in - let isneg = len > 1 && s.[0] == '-' in - let d = ref (if isneg then 1 else 0) in - while !d < len && s.[!d] == '0' do incr d done; - if Int.equal !d len then zero else - let r = (len - !d) mod size in - let h = String.sub s (!d) r in - let e = match h with "" -> 0 | _ -> 1 in - let l = (len - !d) / size in - let a = Array.make (l + e) 0 in - if Int.equal e 1 then a.(0) <- int_of_string h; - for i = 1 to l do - a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size) - done; - if isneg then neg a else a - -let to_string_pos sgn n = - if Int.equal (Array.length n) 0 then "0" else - sgn ^ - String.concat "" - (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n))) - -let to_string n = - if is_strictly_neg n then to_string_pos "-" (neg n) - else to_string_pos "" n - -end - -(******************************************************************) -(* Optimized operations on (unbounded) integer numbers *) -(* integers smaller than base are represented as machine integers *) -(******************************************************************) - -open ArrayInt - -type bigint = Obj.t - -(* Since base is the largest power of 10 such that base*base <= max_int, - we have max_int < 100*base*base : any int can be represented - by at most three blocs *) - -let small n = (-base <= n) && (n < base) - -let mkarray n = - (* n isn't small, this case is handled separately below *) - let lo = n mod base - and hi = n / base in - let t = if small hi then [|hi;lo|] else [|hi/base;hi mod base;lo|] - in - for i = Array.length t -1 downto 1 do - if t.(i) < 0 then (t.(i) <- t.(i) + base; t.(i-1) <- t.(i-1) -1) - done; - t - -let ints_of_int n = - if Int.equal n 0 then [| |] - else if small n then [| n |] - else mkarray n - -let of_int n = - if small n then Obj.repr n else Obj.repr (mkarray n) - -let of_ints n = - let n = normalize n in (* TODO: using normalize here seems redundant now *) - if is_zero n then Obj.repr 0 else - if Int.equal (Array.length n) 1 then Obj.repr n.(0) else - Obj.repr n - -let coerce_to_int = (Obj.magic : Obj.t -> int) -let coerce_to_ints = (Obj.magic : Obj.t -> int array) - -let to_ints n = - if Obj.is_int n then ints_of_int (coerce_to_int n) - else coerce_to_ints n - -let int_of_ints = - let maxi = mkarray max_int and mini = mkarray min_int in - fun t -> - let l = Array.length t in - if (l > 3) || (Int.equal l 3 && (less_than maxi t || less_than t mini)) - then failwith "Bigint.to_int: too large"; - let sum = ref 0 in - let pow = ref 1 in - for i = l-1 downto 0 do - sum := !sum + t.(i) * !pow; - pow := !pow*base; - done; - !sum - -let to_int n = - if Obj.is_int n then coerce_to_int n - else int_of_ints (coerce_to_ints n) - -let app_pair f (m, n) = - (f m, f n) - -let add m n = - if Obj.is_int m && Obj.is_int n - then of_int (coerce_to_int m + coerce_to_int n) - else of_ints (add (to_ints m) (to_ints n)) - -let sub m n = - if Obj.is_int m && Obj.is_int n - then of_int (coerce_to_int m - coerce_to_int n) - else of_ints (sub (to_ints m) (to_ints n)) - -let mult m n = - if Obj.is_int m && Obj.is_int n - then of_int (coerce_to_int m * coerce_to_int n) - else of_ints (mult (to_ints m) (to_ints n)) - -let euclid m n = - if Obj.is_int m && Obj.is_int n - then app_pair of_int - (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n) - else app_pair of_ints (euclid (to_ints m) (to_ints n)) - -let less_than m n = - if Obj.is_int m && Obj.is_int n - then coerce_to_int m < coerce_to_int n - else less_than (to_ints m) (to_ints n) - -let neg n = - if Obj.is_int n then of_int (- (coerce_to_int n)) - else of_ints (neg (to_ints n)) - -let of_string m = of_ints (of_string m) -let to_string m = to_string (to_ints m) - -let zero = of_int 0 -let one = of_int 1 -let two = of_int 2 -let sub_1 n = sub n one -let add_1 n = add n one -let mult_2 n = add n n - -let div2_with_rest n = - let (q,b) = euclid n two in - (q, b == one) - -let is_strictly_neg n = is_strictly_neg (to_ints n) -let is_strictly_pos n = is_strictly_pos (to_ints n) -let is_neg_or_zero n = is_neg_or_zero (to_ints n) -let is_pos_or_zero n = is_pos_or_zero (to_ints n) - -let equal m n = - if Obj.is_block m && Obj.is_block n then - ArrayInt.equal (Obj.obj m) (Obj.obj n) - else m == n - -(* spiwack: computes n^m *) -(* The basic idea of the algorithm is that n^(2m) = (n^2)^m *) -(* In practice the algorithm performs : - k*n^0 = k - k*n^(2m) = k*(n*n)^m - k*n^(2m+1) = (n*k)*(n*n)^m *) -let pow = - let rec pow_aux odd_rest n m = (* odd_rest is the k from above *) - if m<=0 then - odd_rest - else - let quo = m lsr 1 (* i.e. m/2 *) - and odd = not (Int.equal (m land 1) 0) in - pow_aux - (if odd then mult n odd_rest else odd_rest) - (mult n n) - quo - in - pow_aux one - -(** Testing suite w.r.t. OCaml's Big_int *) - -(* -module B = struct - open Big_int - let zero = zero_big_int - let to_string = string_of_big_int - let of_string = big_int_of_string - let add = add_big_int - let opp = minus_big_int - let sub = sub_big_int - let mul = mult_big_int - let abs = abs_big_int - let sign = sign_big_int - let euclid n m = - let n' = abs n and m' = abs m in - let q',r' = quomod_big_int n' m' in - (if sign (mul n m) < 0 && sign q' <> 0 then opp q' else q'), - (if sign n < 0 then opp r' else r') -end - -let check () = - let roots = [ 1; 100; base; 100*base; base*base ] in - let rands = [ 1234; 5678; 12345678; 987654321 ] in - let nums = (List.flatten (List.map (fun x -> [x-1;x;x+1]) roots)) @ rands in - let numbers = - List.map string_of_int nums @ - List.map (fun n -> string_of_int (-n)) nums - in - let i = ref 0 in - let compare op x y n n' = - incr i; - let s = Printf.sprintf "%30s" (to_string n) in - let s' = Printf.sprintf "%30s" (B.to_string n') in - if s <> s' then Printf.printf "%s%s%s: %s <> %s\n" x op y s s' in - let test x y = - let n = of_string x and m = of_string y in - let n' = B.of_string x and m' = B.of_string y in - let a = add n m and a' = B.add n' m' in - let s = sub n m and s' = B.sub n' m' in - let p = mult n m and p' = B.mul n' m' in - let q,r = try euclid n m with Division_by_zero -> zero,zero - and q',r' = try B.euclid n' m' with Division_by_zero -> B.zero, B.zero - in - compare "+" x y a a'; - compare "-" x y s s'; - compare "*" x y p p'; - compare "/" x y q q'; - compare "%" x y r r' - in - List.iter (fun a -> List.iter (test a) numbers) numbers; - Printf.printf "%i tests done\n" !i -*) diff --git a/clib/bigint.mli b/clib/bigint.mli deleted file mode 100644 index 9677c93873..0000000000 --- a/clib/bigint.mli +++ /dev/null @@ -1,53 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Arbitrary large integer numbers *) - -type bigint - -val of_string : string -> bigint -(** May raise a Failure just as [int_of_string] on non-numerical strings *) - -val to_string : bigint -> string - -val of_int : int -> bigint -val to_int : bigint -> int (** May raise a Failure on oversized numbers *) - -val zero : bigint -val one : bigint -val two : bigint - -val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *) - -val add_1 : bigint -> bigint -val sub_1 : bigint -> bigint -val mult_2 : bigint -> bigint - -val add : bigint -> bigint -> bigint -val sub : bigint -> bigint -> bigint -val mult : bigint -> bigint -> bigint - -(** Euclid division m/d = (q,r), with m = q*d+r and |r|<|q|. - This is the "Trunc" variant (a.k.a "Truncated-Toward-Zero"), - as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). - We have sign r = sign m *) - -val euclid : bigint -> bigint -> bigint * bigint - -val less_than : bigint -> bigint -> bool -val equal : bigint -> bigint -> bool - -val is_strictly_pos : bigint -> bool -val is_strictly_neg : bigint -> bool -val is_pos_or_zero : bigint -> bool -val is_neg_or_zero : bigint -> bool -val neg : bigint -> bigint - -val pow : bigint -> int -> bigint diff --git a/clib/dyn.ml b/clib/dyn.ml index 1ddbe5a7c2..8ef90a366e 100644 --- a/clib/dyn.ml +++ b/clib/dyn.ml @@ -49,6 +49,13 @@ sig module Map(Value : ValueS) : MapS with type 'a key = 'a tag and type 'a value = 'a Value.t + + module HMap (V1 : ValueS)(V2 : ValueS) : + sig + type map = { map : 'a. 'a tag -> 'a V1.t -> 'a V2.t } + val map : map -> Map(V1).t -> Map(V2).t + end + end module type S = @@ -132,6 +139,16 @@ module Self : PreS = struct let iter f m = Int.Map.iter (fun k v -> f (Any (k, v))) m let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu end + + module HMap (V1 : ValueS) (V2 : ValueS) = + struct + type map = { map : 'a. 'a tag -> 'a V1.t -> 'a V2.t } + + let map (f : map) (m : Map(V1).t) : Map(V2).t = + Int.Map.mapi f.map m + + end + end include Self diff --git a/clib/dyn.mli b/clib/dyn.mli index 926d0f3135..4fd33b5242 100644 --- a/clib/dyn.mli +++ b/clib/dyn.mli @@ -75,6 +75,12 @@ sig MapS with type 'a key = 'a tag and type 'a value = 'a Value.t (** Map from type tags to values parameterized by the tag type *) + module HMap (V1 : ValueS)(V2 : ValueS) : + sig + type map = { map : 'a. 'a tag -> 'a V1.t -> 'a V2.t } + val map : map -> Map(V1).t -> Map(V2).t + end + module Easy : sig (* To create a dynamic type on the fly *) val make_dyn_tag : string -> ('a -> t) * (t -> 'a) * 'a tag diff --git a/clib/option.ml b/clib/option.ml index c335e836c2..d1775ae3ae 100644 --- a/clib/option.ml +++ b/clib/option.ml @@ -55,6 +55,8 @@ let make x = Some x (** [bind x f] is [f y] if [x] is [Some y] and [None] otherwise *) let bind x f = match x with Some y -> f y | None -> None +let filter f x = bind x (fun v -> if f v then x else None) + (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) let init b x = if b then diff --git a/clib/option.mli b/clib/option.mli index 4c5df30179..4672780cab 100644 --- a/clib/option.mli +++ b/clib/option.mli @@ -46,6 +46,9 @@ val make : 'a -> 'a option (** [bind x f] is [f y] if [x] is [Some y] and [None] otherwise *) val bind : 'a option -> ('a -> 'b option) -> 'b option +(** [filter f x] is [x] if [x] [Some y] and [f y] is true, [None] otherwise *) +val filter : ('a -> bool) -> 'a option -> 'a option + (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) val init : bool -> 'a -> 'a option diff --git a/config/dune b/config/dune index bf1aa4f471..a30fdce9aa 100644 --- a/config/dune +++ b/config/dune @@ -2,8 +2,14 @@ (name config) (synopsis "Coq Configuration Variables") (public_name coq.config) + (modules :standard \ list_plugins) (wrapped false)) +(executable (name list_plugins) (modules list_plugins)) +(rule (targets plugin_list) + (deps (source_tree %{project_root}/plugins)) + (action (with-stdout-to %{targets} (chdir %{project_root} (run config/list_plugins.exe))))) + ; Dune doesn't use configure's output, but it is still necessary for ; some Coq files to work; will be fixed in the future. (rule @@ -13,7 +19,7 @@ %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run %{project_root}/dev/header.c - ; Needed to generate include lists for coq_makefile - (source_tree %{project_root}/plugins) + ; Needed to generate include lists for coq_makefile + plugin_list (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/config/list_plugins.ml b/config/list_plugins.ml new file mode 100644 index 0000000000..5e2827bfe0 --- /dev/null +++ b/config/list_plugins.ml @@ -0,0 +1,10 @@ +let plugins = + try Sys.readdir "plugins" + with _ -> [||] + +let () = Array.sort compare plugins + +let () =Array.iter (fun f -> + let f' = "plugins/"^f in + if Sys.is_directory f' && f.[0] <> '.' then print_endline f) + plugins diff --git a/configure.ml b/configure.ml index c05844198b..2d6018491e 100644 --- a/configure.ml +++ b/configure.ml @@ -64,8 +64,7 @@ let rec waitpid_non_intr pid = (** Below, we'd better read all lines on a channel before closing it, otherwise a SIGPIPE could be encountered by the sub-process *) -let read_lines_and_close fd = - let cin = Unix.in_channel_of_descr fd in +let read_lines_and_close cin = let lines = ref [] in begin try @@ -78,6 +77,9 @@ let read_lines_and_close fd = let lines = List.rev !lines in try List.hd lines, lines with Failure _ -> "", [] +let read_lines_and_close_fd fd = + read_lines_and_close (Unix.in_channel_of_descr fd) + (** Run some unix command and read the first line of its output. We avoid Unix.open_process and its non-fully-portable /bin/sh, especially when it comes to quoting the filenames. @@ -109,8 +111,8 @@ let run ?(fatal=true) ?(err=StdErr) prog args = let pid = Unix.create_process prog argv Unix.stdin out_w fd_err in let () = Unix.close out_w in let () = Unix.close nul_w in - let line, all = read_lines_and_close out_r in - let _ = read_lines_and_close nul_r in + let line, all = read_lines_and_close_fd out_r in + let _ = read_lines_and_close_fd nul_r in let () = check_exit_code (waitpid_non_intr pid) in line, all with @@ -686,19 +688,20 @@ let operating_system = else (try Sys.getenv "OS" with Not_found -> "") -(** Num library *) - -(* since 4.06, the Num library is no longer distributed with OCaml (replaced - by Zarith) -*) +(** Zarith and num libraries *) let check_for_numlib () = if caml_version_nums >= [4;6;0] then let numlib,_ = tryrun camlexec.find ["query";"num"] in match numlib with | "" -> - die "Num library not installed, required for OCaml 4.06 or later" - | _ -> cprintf "You have the Num library installed. Good!" + die "Num library not installed, required for OCaml 4.06 or later" + | _ -> cprintf "You have the Num library installed. Good!"; + let zarith,_ = tryrun camlexec.find ["query";"zarith"] in + match zarith with + | "" -> + die "Zarith library not installed, required" + | _ -> cprintf "You have the Zarith library installed. Good!" let numlib = check_for_numlib () @@ -1108,11 +1111,16 @@ let write_configml f = pr "\nlet core_src_dirs = [\n%s]\n" core_src_dirs; pr "\nlet plugins_dirs = [\n"; - let plugins = - try Sys.readdir "plugins" - with _ -> [||] + let plugins = match open_in "config/plugin_list" with + | exception Sys_error _ -> + let plugins = + try Sys.readdir "plugins" + with _ -> [||] + in + Array.sort compare plugins; + plugins + | ch -> Array.of_list (snd (read_lines_and_close ch)) in - Array.sort compare plugins; Array.iter (fun f -> let f' = "plugins/"^f in @@ -25,6 +25,7 @@ depends: [ "dune" { >= "2.5.0" } "ocamlfind" { build } "num" + "zarith" { >= "1.9.1" } ] build: [ diff --git a/coq.opam.docker b/coq.opam.docker index 229a47a87b..ac1869f344 100644 --- a/coq.opam.docker +++ b/coq.opam.docker @@ -24,6 +24,7 @@ depends: [ "ocaml" { >= "4.05.0" } "ocamlfind" { build } "num" + "zarith" { >= "1.9.1" } "conf-findutils" {build} ] diff --git a/default.nix b/default.nix index df1c43101b..ef969acd31 100644 --- a/default.nix +++ b/default.nix @@ -43,7 +43,7 @@ stdenv.mkDerivation rec { hostname python3 time # coq-makefile timing tools ] - ++ (with ocamlPackages; [ ocaml findlib ]) + ++ (with ocamlPackages; [ ocaml findlib num zarith ]) ++ optionals buildIde [ ocamlPackages.lablgtk3-sourceview3 glib gnome3.defaultIconTheme wrapGAppsHook diff --git a/dev/base_include b/dev/base_include index 1f14fc2941..daee2d97c5 100644 --- a/dev/base_include +++ b/dev/base_include @@ -29,7 +29,6 @@ #install_printer ppatom;; #install_printer ppwhd;; #install_printer ppvblock;; -#install_printer (* bigint *) ppbigint;; #install_printer (* loc *) pploc;; #install_printer (* substitution *) ppsubst;; diff --git a/dev/bench/gitlab-bench.yml b/dev/bench/gitlab-bench.yml new file mode 100644 index 0000000000..a2207081f4 --- /dev/null +++ b/dev/bench/gitlab-bench.yml @@ -0,0 +1,32 @@ + +bench: + stage: stage-1 + when: manual + before_script: + - printenv -0 | sort -z | tr '\0' '\n' + script: + - . ~/.opam/opam-init/init.sh + - ./dev/bench/gitlab.sh + tags: + - timing + variables: + GIT_DEPTH: "" + coq_pr_number: "" + coq_pr_comment_id: "" + new_ocaml_switch: "ocaml-base-compiler.4.07.1" + old_ocaml_switch: "ocaml-base-compiler.4.07.1" + new_coq_repository: "https://gitlab.com/coq/coq.git" + old_coq_repository: "https://gitlab.com/coq/coq.git" + new_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" + old_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" + 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" + artifacts: + name: "$CI_JOB_NAME" + paths: + - _bench/html/**/*.v.html + - _bench/logs + when: always + expire_in: 1 year diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh index 15f5c01ac6..38b4e25bde 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -52,15 +52,6 @@ check_variable "coq_opam_packages" new_coq_commit=$(git rev-parse HEAD^2) old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) -if which jq > /dev/null; then - : -else - echo > /dev/stderr - echo "ERROR: \"jq\" program is not available." > /dev/stderr - echo > /dev/stderr - exit 1 -fi - if echo "$num_of_iterations" | grep '^[1-9][0-9]*$' 2> /dev/null > /dev/null; then : else @@ -76,39 +67,6 @@ working_dir="$PWD/_bench" log_dir=$working_dir/logs mkdir "$log_dir" -if [ ! -z "${coq_pr_number}" ]; then - github_response="$(curl "https://api.github.com/repos/coq/coq/pulls/${coq_pr_number}")" - new_coq_repository="$(echo "${github_response}" | jq -r '.head.repo.clone_url')" - new_coq_commit="$(echo "${github_response}" | jq -r '.head.sha')" - old_coq_repository="$(echo "${github_response}" | jq -r '.base.repo.clone_url')" - old_coq_commit="$(echo "${github_response}" | jq -r '.base.sha')" - coq_pr_title="$(echo "${github_response}" | jq -r '.title')" - # for coqbot parsing purposes, coq_pr_number and coq_pr_comment_id must not have newlines - coq_pr_number="$(echo "${coq_pr_number}" | tr -d '\n' | tr -d '\r')" - coq_pr_comment_id="$(echo "${coq_pr_comment_id}" | tr -d '\n' | tr -d '\r')" - - for val in "${new_coq_repository}" "${new_coq_commit}" "${old_coq_repository}" "${old_coq_commit}" "${coq_pr_title}"; do - if [ -z "$val" ] || [ "val" == "null" ]; then - echo 'ERROR: Invalid Response:' > /dev/stderr - echo "${github_response}" > /dev/stderr - echo "Info:" > /dev/stderr - curl -i "https://api.github.com/repos/coq/coq/pulls/${coq_pr_number}" > /dev/stderr - exit 1 - fi - done - - if [ -z "$BENCH_DEBUG" ]; then # if it's non-empty, this'll get - # printed later anyway. But we - # want to see it always if we're - # automatically computing values - echo "DEBUG: new_coq_repository = $new_coq_repository" - echo "DEBUG: new_coq_commit = $new_coq_commit" - echo "DEBUG: old_coq_repository = $old_coq_repository" - echo "DEBUG: old_coq_commit = $old_coq_commit" - fi - -fi - if [ ! -z "$BENCH_DEBUG" ] then echo "DEBUG: ocaml -version = `ocaml -version`" diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index fd6ea9bb09..8eff2cf577 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -389,6 +389,7 @@ IF "%RUNSETUP%"=="Y" ( -P libfontconfig1 ^
-P gtk-update-icon-cache ^
-P libtool,automake ^
+ -P libgmp-devel ^
-P intltool ^
-P bison,flex ^
%EXTRAPACKAGES% ^
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index cc9fd13fdc..cde1d798a0 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1006,6 +1006,7 @@ function make_ocaml_tools { function make_ocaml_libs { make_num + make_zarith make_findlib make_lablgtk } @@ -1023,6 +1024,16 @@ function make_num { fi } +function make_zarith { + make_ocaml + if build_prep https://github.com/ocaml/Zarith/archive release-1.9.1 tar.gz 1 zarith-1.9.1; then + logn configure ./configure + log1 make + log2 make install + build_post + fi +} + ##### OCAMLBUILD ##### function make_ocamlbuild { diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 64936cd236..17d71ac52a 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -10,4 +10,4 @@ bash opam64/install.sh opam init default -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $OPAM_VARIANT --disable-sandboxing eval "$(opam env)" -opam install -y num ocamlfind dune ounit +opam install -y num ocamlfind dune ounit zarith diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 67a8415891..78c8673299 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-08-18-V29" +# CACHEKEY: "bionic_coq-V2020-08-28-V92" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -6,9 +6,14 @@ LABEL maintainer="e@x80.org" ENV DEBIAN_FRONTEND="noninteractive" +# We need libgmp-dev:i386 for zarith; maybe we could also install GTK +RUN dpkg --add-architecture i386 + RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip jq \ + # Dependencies of ZArith + perl libgmp-dev libgmp-dev:i386 \ # Dependencies of lablgtk (for CoqIDE) libgtksourceview-3.0-dev \ # Dependencies of stdlib and sphinx doc @@ -35,10 +40,10 @@ ENV NJOBS="2" \ # Base opam is the set of base packages required by Coq ENV COMPILER="4.05.0" -# Common OPAM packages. -# `num` does not have a version number as the right version to install varies -# with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.0" \ +# Common OPAM packages, num to be removed once the migration to +# micromega is complete, `num` also does not have a version number as +# the right version to install varies with the compiler version. +ENV BASE_OPAM="num zarith.1.9.1 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.0" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ BASE_ONLY_OPAM="elpi.1.11.0" @@ -52,9 +57,10 @@ ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ opam install $BASE_OPAM $COQIDE_OPAM $CI_OPAM $BASE_ONLY_OPAM -# base+32bit switch +# base+32bit switch, note the zarith hack RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ - opam install $BASE_OPAM + i386 env CC='gcc -m32' opam install zarith.1.9.1 && \ + opam install $BASE_OPAM # EDGE switch ENV COMPILER_EDGE="4.10.0" \ diff --git a/dev/ci/user-overlays/08743-ejgallego-zarith.sh b/dev/ci/user-overlays/08743-ejgallego-zarith.sh new file mode 100644 index 0000000000..da1d30c1e9 --- /dev/null +++ b/dev/ci/user-overlays/08743-ejgallego-zarith.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11742" ] || [ "$CI_BRANCH" = "zarith+core" ]; then + + bignums_CI_REF=zarith + bignums_CI_GITURL=https://github.com/ejgallego/bignums + +fi diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index 63071bba72..60618f6491 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -23,7 +23,6 @@ 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.ppbigint 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 ea90e83a83..773170207e 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -80,7 +80,6 @@ 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 ppbigint n = pp (str (Bigint.to_string n));; let ppnumtokunsigned n = pp (NumTok.Unsigned.print n) let ppnumtokunsignednat n = pp (NumTok.UnsignedNat.print n) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 65eab8daa3..b1bb5e4702 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -53,7 +53,6 @@ val ppglob_constr : 'a Glob_term.glob_constr_g -> unit val pppattern : Pattern.constr_pattern -> unit val ppfconstr : CClosure.fconstr -> unit -val ppbigint : Bigint.bigint -> unit val ppnumtokunsigned : NumTok.Unsigned.t -> unit val ppnumtokunsignednat : NumTok.UnsignedNat.t -> unit diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index ac4972ed0d..1eacfa0fd6 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -1,7 +1,7 @@ open Format open Term open Names -open Cemitcodes +open Vmemitcodes open Vmvalues let ppripos (ri,pos) = diff --git a/doc/changelog/08-tools/12862-more-mod-checking.rst b/doc/changelog/08-tools/12862-more-mod-checking.rst new file mode 100644 index 0000000000..bb1bf9e789 --- /dev/null +++ b/doc/changelog/08-tools/12862-more-mod-checking.rst @@ -0,0 +1,4 @@ +- **Fixed:** + ``coqchk`` no longer reports names from inner modules of opaque modules as + axioms (`#12862 <https://github.com/coq/coq/pull/12862>`_, fixes `#12845 + <https://github.com/coq/coq/issues/12845>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst b/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst new file mode 100644 index 0000000000..41359098e3 --- /dev/null +++ b/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst @@ -0,0 +1,7 @@ +- **Changed:** + ``Require Import Coq.nsatz.NsatzTactic`` now allows using :tacn:`nsatz` + with `Z` and `Q` without having to supply instances or using ``Require Import Coq.nsatz.Nsatz``, which + transitively requires unneeded files declaring axioms used in the reals + (`#12861 <https://github.com/coq/coq/pull/12861>`_, + fixes `#12860 <https://github.com/coq/coq/issues/12860>`_, + by Jason Gross). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst b/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst new file mode 100644 index 0000000000..3b34e11ff8 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst @@ -0,0 +1,8 @@ +- **Changed:** + Coq's core system now uses the `zarith <https://github.com/ocaml/Zarith>`_ + library, based on GNU's gmp instead of ``num`` which is + deprecated upstream. The custom ``bigint`` module is + not longer provided; note that the ``micromega`` still uses + ``num`` + (`#11742 <https://github.com/coq/coq/pull/11742>`_, + by Emilio Jesus Gallego Arias and Vicent Laporte). diff --git a/doc/sphinx/_static/coqnotations.sty b/doc/sphinx/_static/coqnotations.sty index 3dfe4db439..2b1678e7ef 100644 --- a/doc/sphinx/_static/coqnotations.sty +++ b/doc/sphinx/_static/coqnotations.sty @@ -79,7 +79,7 @@ \newcssclass{prodn-table}{% \begin{savenotes} \sphinxattablestart - \begin{tabulary}{\linewidth}[t]{lLL} + \begin{tabulary}{\linewidth}[t]{lLLL} #1 \end{tabulary} \par @@ -89,4 +89,5 @@ \newcssclass{prodn-target}{\raisebox{\dimexpr \nscriptsize \relax}{#1}} \newcssclass{prodn-cell-nonterminal}{#1 &} \newcssclass{prodn-cell-op}{#1 &} -\newcssclass{prodn-cell-production}{#1\\} +\newcssclass{prodn-cell-production}{#1 &} +\newcssclass{prodn-cell-tag}{#1\\} diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 9546f7107e..8c3f7ac3c1 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -192,7 +192,8 @@ .prodn-cell-nonterminal, .prodn-cell-op, -.prodn-cell-production +.prodn-cell-production, +.prodn-cell-tag { display: table-cell; } @@ -206,6 +207,17 @@ font-weight: normal; } +.prodn-cell-production { + width: 99%; +} + +.prodn-cell-tag { + text-align: right; + font-weight: normal; + font-size: 75%; + font-family: "Lato","proxima-nova","Helvetica Neue",Arial,sans-serif; +} + .prodn-table .notation > .repeat-wrapper { margin-top: 0.28em; } diff --git a/doc/sphinx/addendum/nsatz.rst b/doc/sphinx/addendum/nsatz.rst index ed2e1ea58c..ed93145622 100644 --- a/doc/sphinx/addendum/nsatz.rst +++ b/doc/sphinx/addendum/nsatz.rst @@ -34,6 +34,12 @@ Nsatz: tactics for proving equalities in integral domains You can load the ``Nsatz`` module with the command ``Require Import Nsatz``. + Alternatively, if you prefer not to transitively depend on the + files declaring the axioms used to define the real numbers, you can + ``Require Import NsatzTactic`` instead; this will still allow + :tacn:`nsatz` to solve goals defined about :math:`\mathbb{Z}`, + :math:`\mathbb{Q}` and any user-registered rings. + More about `nsatz` --------------------- @@ -85,4 +91,4 @@ performed using :ref:`typeclasses`. then `lvar` is replaced by all the variables which are not in `parameters`. -See the file `Nsatz.v` for many examples, especially in geometry. +See the test-suite file `Nsatz.v <https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v>`_ for many examples, especially in geometry. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 0f501382e7..191eae6430 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -484,7 +484,7 @@ Tactic language (`#11882 <https://github.com/coq/coq/pull/11882>`_, by Hugo Herbelin). - **Added:** - Ltac2 notations for reductions in terms: :n:`eval @red_expr in @ltac2_term` + Ltac2 notations for reductions in terms: :n:`eval @red_expr in @term` (`#11981 <https://github.com/coq/coq/pull/11981>`_, by Michael Soegtrop). - **Fixed:** diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 99762c7a0e..ee8784fc02 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -187,6 +187,16 @@ nitpick_ignore = [ ('token', token) for token in [ 'collection', 'modpath', 'tactic', + 'destruction_arg', + 'bindings', + 'induction_clause', + 'conversion', + 'where', + 'oriented_rewriter', + 'hintbases', + 'bindings_with_parameters', + 'destruction_arg', + 'clause_dft_concl' ]] # -- Options for HTML output ---------------------------------------------- diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 64b29c1c0b..1f0d696d99 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -227,6 +227,7 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types | @term_match | @term_record | @term_generalizing + | [| {*; @term } %| @term {? : @type } |] {? @univ_annot } | @term_ltac | ( @term ) qualid_annotated ::= @qualid {? @univ_annot } diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 0f27b65107..6b031cfea3 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -5,8 +5,14 @@ Conversion rules In |Cic|, there is an internal reduction mechanism. In particular, it can decide if two programs are *intentionally* equal (one says -*convertible*). Convertibility is described in this section. +:term:`convertible`). Convertibility is described in this section. +α-conversion +~~~~~~~~~~~~ + +Two terms are :gdef:`α-convertible <alpha-convertible>` if they are syntactically +equal ignoring differences in the names of variables bound within the expression. +For example `forall x, x + 0 = x` is α-convertible with `forall y, y + 0 = y`. .. _beta-reduction: @@ -153,7 +159,7 @@ 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 *convertible*, or *equivalent*, in the +*βδιζη-convertible*, or simply :gdef:`convertible`, or *equivalent*, 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/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index d6a828521f..34752a4c4d 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -90,6 +90,10 @@ constructions. There are two variants of them. First destructuring let syntax ++++++++++++++++++++++++++++++ +.. todo explain that this applies to all of the "let" constructs (Gallina, Ltac1 and Ltac2) + also add "irrefutable pattern" to the glossary + note that in Ltac2 an upper case ident is a constructor, lower case is a variable + The expression :n:`let ( {*, @ident__i } ) := @term__0 in @term__1` performs case analysis on :n:`@term__0` whose type must be an inductive type with exactly one constructor. The number of variables diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index d9992029ba..daae46ad11 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -89,10 +89,11 @@ invoking ``coq_makefile`` is the following one: Such command generates the following files: CoqMakefile - is a generic makefile for ``GNU Make`` that provides - targets to build the project (both ``.v`` and ``.ml*`` files), to install it - system-wide in the ``coq-contrib`` directory (i.e. where |Coq| is installed) - as well as to invoke coqdoc to generate HTML documentation. + is a makefile for ``GNU Make`` with targets to build the project + (e.g. generate .vo or .html files from .v or compile .ml* files) + and install it in the ``user-contrib`` directory where the |Coq| + library is installed. Run ``make`` with the ``-f CoqMakefile`` + option to use ``CoqMakefile``. CoqMakefile.conf contains make variables assignments that reflect diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b0b0367d6d..e7ba82fb31 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1122,12 +1122,14 @@ Pattern matching on terms: match then the :token:`ltac_expr` can't use `S` to refer to the constructor of `nat` without qualifying the constructor as `Datatypes.S`. - .. todo below: is matching non-linear unification? is it the same or different - from unification elsewhere in Coq? + .. todo how does this differ from the 1-2 other unification routines elsewhere in Coq? + Does it use constr_eq or eq_constr_nounivs? Matching is non-linear: if a metavariable occurs more than once, each occurrence must match the same - expression. Matching is first-order except on variables of the form :n:`@?@ident` + expression. Expressions match if they are syntactically equal or are + :term:`α-convertible <alpha-convertible>`. + Matching is first-order except on variables of the form :n:`@?@ident` that occur in the head position of an application. For these variables, matching is second-order and returns a functional term. @@ -1305,20 +1307,20 @@ Pattern matching on terms: match .. example:: Multiple matches for a "context" pattern. - Internally "x <> y" is represented as "(not x y)", which produces the + Internally "x <> y" is represented as "(~ (x = y))", which produces the first match. .. coqtop:: in reset Ltac f t := match t with - | context [ (not ?t) ] => idtac "?t = " t; fail + | context [ (~ ?t) ] => idtac "?t = " t; fail | _ => idtac end. Goal True. .. coqtop:: all - f ((not True) <> (not False)). + f ((~ True) <> (~ False)). .. _ltac-match-goal: @@ -1345,6 +1347,13 @@ Pattern matching on goals and hypotheses: match goal 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. + Matching is non-linear: if a + metavariable occurs more than once, each occurrence must match the same + expression. Within a single term, expressions match if they are syntactically equal or + :term:`α-convertible <alpha-convertible>`. When a metavariable is used across + multiple hypotheses or across a hypothesis and the current goal, the expressions match if + they are :term:`convertible`. + :n:`{*, @match_hyp }` Patterns to match with hypotheses. Each pattern must match a distinct hypothesis in order for the branch to match. @@ -1381,7 +1390,7 @@ Pattern matching on goals and hypotheses: match goal :cmd:`Import` `ListNotations`) must be parenthesized or, for the fourth form, use double brackets: `[ [ ?l ] ]`. - :n:`@term__binder`\s in the form `[?x ; ?y]` for a list is not parsed correctly. The workaround is + :n:`@term__binder`\s in the form `[?x ; ?y]` for a list are not parsed correctly. The workaround is to add parentheses or to use the underlying term instead of the notation, i.e. `(cons ?x ?y)`. If there are multiple :token:`match_hyp`\s in a branch, there may be multiple ways to match them to hypotheses. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 1e35160205..b217448711 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -27,6 +27,50 @@ especially wherever an advanced tactic language is needed. The previous implementation of Ltac, described in the previous chapter, will be referred to as Ltac1. +Current limitations include: + +- There are a number of tactics that are not yet supported in Ltac2 because + the interface OCaml and/or Ltac2 notations haven't been written. See + :ref:`defining_tactics`. + +- Missing usability features such as: + + - Printing functions are limited and awkward to use. Only a few data types are + printable. + - Deep pattern matching and matching on tuples don't work. + - If statements on Ltac2 boolean values + - A convenient way to build terms with casts through the low-level API. Because the + cast type is opaque, building terms with casts currently requires an awkward construction like the + following, which also incurs extra overhead to repeat typechecking for each + call to `get_vm_cast`: + + .. coqdoc:: + + Constr.Unsafe.make (Constr.Unsafe.Cast 'I (get_vm_cast ()) 'True) + + with: + + .. coqtop:: none + + From Ltac2 Require Import Ltac2. + + .. coqtop:: in + + Ltac2 get_vm_cast () := + match Constr.Unsafe.kind '(I <: True) with + | Constr.Unsafe.Cast _ cst _ => cst + | _ => Control.throw Not_found + end. + +- Missing low-level primitives that are convenient for writing automation, such as: + + - An easy way to get the number of constructors of an inductive type. + Currently only way to do this is to destruct a variable of the inductive type + and count the number of goals that result. +- The :attr:`deprecated` attribute is not supported for Ltac2 definitions. + +- Error messages may be cryptic. + .. _ltac2_design: General design @@ -49,7 +93,7 @@ In particular, Ltac2 is: Coq-side terms - a language featuring notation facilities to help write palatable scripts -We describe more in details each point in the remainder of this document. +We describe these in more detail in the remainder of this document. ML component ------------ @@ -84,7 +128,7 @@ which allows to ensure that Ltac2 satisfies the same equations as a generic ML with unspecified effects would do, e.g. function reduction is substitution by a value. -To import Ltac2, use the following command: +Use the following command to import Ltac2: .. coqtop:: in @@ -96,17 +140,20 @@ Type Syntax At the level of terms, we simply elaborate on Ltac1 syntax, which is quite close to OCaml. Types follow the simply-typed syntax of OCaml. -The non-terminal :production:`lident` designates identifiers starting with a -lowercase. +.. insertprodn ltac2_type ltac2_typevar -.. productionlist:: coq - ltac2_type : ( `ltac2_type`, ... , `ltac2_type` ) `ltac2_typeconst` - : ( `ltac2_type` * ... * `ltac2_type` ) - : `ltac2_type` -> `ltac2_type` - : `ltac2_typevar` - ltac2_typeconst : ( `modpath` . )* `lident` - ltac2_typevar : '`lident` - ltac2_typeparams : ( `ltac2_typevar`, ... , `ltac2_typevar` ) +.. prodn:: + ltac2_type ::= @ltac2_type2 -> @ltac2_type + | @ltac2_type2 + ltac2_type2 ::= @ltac2_type1 * {+* @ltac2_type1 } + | @ltac2_type1 + ltac2_type1 ::= @ltac2_type0 @qualid + | @ltac2_type0 + ltac2_type0 ::= ( {+, @ltac2_type } ) {? @qualid } + | @ltac2_typevar + | _ + | @qualid + ltac2_typevar ::= ' @ident The set of base types can be extended thanks to the usual ML type declarations such as algebraic datatypes and records. @@ -126,114 +173,156 @@ Type declarations One can define new types with the following commands. -.. cmd:: Ltac2 Type {? @ltac2_typeparams } @lident +.. cmd:: Ltac2 Type {? rec } @tac2typ_def {* with @tac2typ_def } :name: Ltac2 Type - This command defines an abstract type. It has no use for the end user and - is dedicated to types representing data coming from the OCaml world. + .. insertprodn tac2typ_def tac2rec_field -.. cmdv:: Ltac2 Type {? rec} {? @ltac2_typeparams } @lident := @ltac2_typedef + .. prodn:: + tac2typ_def ::= {? @tac2typ_prm } @qualid {? {| := | ::= } @tac2typ_knd } + tac2typ_prm ::= @ltac2_typevar + | ( {+, @ltac2_typevar } ) + tac2typ_knd ::= @ltac2_type + | [ {? {? %| } {+| @tac2alg_constructor } } ] + | [ .. ] + | %{ {? {+; @tac2rec_field } {? ; } } %} + tac2alg_constructor ::= @ident + | @ident ( {*, @ltac2_type } ) + tac2rec_field ::= {? mutable } @ident : @ltac2_type - This command defines a type with a manifest. There are four possible - kinds of such definitions: alias, variant, record and open variant types. + :n:`:=` + Defines a type with with an explicit set of constructors - .. productionlist:: coq - ltac2_typedef : `ltac2_type` - : [ `ltac2_constructordef` | ... | `ltac2_constructordef` ] - : { `ltac2_fielddef` ; ... ; `ltac2_fielddef` } - : [ .. ] - ltac2_constructordef : `uident` [ ( `ltac2_type` , ... , `ltac2_type` ) ] - ltac2_fielddef : [ mutable ] `ident` : `ltac2_type` + :n:`::=` + Extends an existing open variant type, a special kind of variant type whose constructors are not + statically defined, but can instead be extended dynamically. A typical example + is the standard `exn` type for exceptions. Pattern matching on open variants must always + include a catch-all clause. They can be extended with this form, in which case + :token:`tac2typ_knd` should be in the form :n:`[ {? {? %| } {+| @tac2alg_constructor } } ]`. - Aliases are just a name for a given type expression and are transparently - unfoldable to it. They cannot be recursive. The non-terminal - :production:`uident` designates identifiers starting with an uppercase. + Without :n:`{| := | ::= }` + Defines an abstract type for use representing data from OCaml. Not for + end users. + + :n:`with @tac2typ_def` + Permits definition of mutually recursive type definitions. + + Each production of :token:`tac2typ_knd` defines one of four possible kinds + of definitions, respectively: alias, variant, open variant and record types. + + Aliases are names for a given type expression and are transparently + unfoldable to that expression. They cannot be recursive. + + .. The non-terminal :token:`uident` designates identifiers starting with an uppercase. Variants are sum types defined by constructors and eliminated by pattern-matching. They can be recursive, but the `rec` flag must be explicitly set. Pattern matching must be exhaustive. + Open variants can be extended with additional constructors using the `::=` form. + Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `rec` flag is set. - .. cmdv:: Ltac2 Type {? @ltac2_typeparams } @ltac2_qualid ::= [ @ltac2_constructordef ] +.. cmd:: Ltac2 @ external @ident : @ltac2_type := @string @string + :name: Ltac2 external + + Declares abstract terms. Frequently, these declare OCaml functions + defined in |Coq| and give their type information. They can also declare + data structures from OCaml. This command has no use for the end user. + +APIs +~~~~ + +Ltac2 provides over 150 API functions that provide various capabilities. These +are declared with :cmd:`Ltac2 external` in :n:`lib/coq/user-contrib/Ltac2/*.v`. +For example, `Message.print` defined in `Message.v` is used to print messages: - Open variants are a special kind of variant types whose constructors are not - statically defined, but can instead be extended dynamically. A typical example - is the standard `exn` type. Pattern matching on open variants must always include a catch-all - clause. They can be extended with this command. +.. coqtop:: none + + Goal True. + +.. coqtop:: all abort + + Message.print (Message.of_string "fully qualified calls"). + From Ltac2 Require Import Message. + print (of_string "unqualified calls"). Term Syntax ~~~~~~~~~~~ -The syntax of the functional fragment is very close to the one of Ltac1, except +The syntax of the functional fragment is very close to that of Ltac1, except that it adds a true pattern-matching feature, as well as a few standard constructs from ML. -.. productionlist:: coq - ltac2_var : `lident` - ltac2_qualid : ( `modpath` . )* `lident` - ltac2_constructor: `uident` - ltac2_term : `ltac2_qualid` - : `ltac2_constructor` - : `ltac2_term` `ltac2_term` ... `ltac2_term` - : fun `ltac2_var` => `ltac2_term` - : let `ltac2_var` := `ltac2_term` in `ltac2_term` - : let rec `ltac2_var` := `ltac2_term` in `ltac2_term` - : match `ltac2_term` with `ltac2_branch` ... `ltac2_branch` end - : `int` - : `string` - : `ltac2_term` ; `ltac2_term` - : [| `ltac2_term` ; ... ; `ltac2_term` |] - : ( `ltac2_term` , ... , `ltac2_term` ) - : { `ltac2_field` `ltac2_field` ... `ltac2_field` } - : `ltac2_term` . ( `ltac2_qualid` ) - : `ltac2_term` . ( `ltac2_qualid` ) := `ltac2_term` - : [; `ltac2_term` ; ... ; `ltac2_term` ] - : `ltac2_term` :: `ltac2_term` - : ... - ltac2_branch : `ltac2_pattern` => `ltac2_term` - ltac2_pattern : `ltac2_var` - : _ - : ( `ltac2_pattern` , ... , `ltac2_pattern` ) - : `ltac2_constructor` `ltac2_pattern` ... `ltac2_pattern` - : [ ] - : `ltac2_pattern` :: `ltac2_pattern` - ltac2_field : `ltac2_qualid` := `ltac2_term` - -In practice, there is some additional syntactic sugar that allows e.g. to -bind a variable and match on it at the same time, in the usual ML style. +In practice, there is some additional syntactic sugar that allows the +user to bind a variable and match on it at the same time, in the usual ML style. There is dedicated syntax for list and array literals. -.. note:: +.. insertprodn ltac2_expr ltac2_tactic_atom + +.. prodn:: + ltac2_expr ::= @ltac2_expr5 ; @ltac2_expr + | @ltac2_expr5 + ltac2_expr5 ::= fun {+ @tac2pat0 } => @ltac2_expr + | let {? rec } @ltac2_let_clause {* with @ltac2_let_clause } in @ltac2_expr + | @ltac2_expr3 + ltac2_let_clause ::= {+ @tac2pat0 } := @ltac2_expr + ltac2_expr3 ::= {+, @ltac2_expr2 } + ltac2_expr2 ::= @ltac2_expr1 :: @ltac2_expr2 + | @ltac2_expr1 + ltac2_expr1 ::= @ltac2_expr0 {+ @ltac2_expr0 } + | @ltac2_expr0 .( @qualid ) + | @ltac2_expr0 .( @qualid ) := @ltac2_expr5 + | @ltac2_expr0 + tac2rec_fieldexpr ::= @qualid := @ltac2_expr1 + ltac2_expr0 ::= ( @ltac2_expr ) + | ( @ltac2_expr : @ltac2_type ) + | () + | [ {*; @ltac2_expr5 } ] + | %{ {? {+ @tac2rec_fieldexpr } {? ; } } %} + | @ltac2_tactic_atom + ltac2_tactic_atom ::= @int + | @string + | @qualid + | @ @ident + | & @lident + | ' @term + | @ltac2_quotations + +The non-terminal :production:`lident` designates identifiers starting with a +lowercase letter. + +:n:`'@term` is equivalent to :n:`open_constr:(@term)`. - For now, deep pattern matching is not implemented. -Ltac Definitions -~~~~~~~~~~~~~~~~ -.. cmd:: Ltac2 {? mutable} {? rec} @lident := @ltac2_value +Ltac2 Definitions +~~~~~~~~~~~~~~~~~ + +.. cmd:: Ltac2 {? mutable } {? rec } @tac2def_body {* with @tac2def_body } :name: Ltac2 - This command defines a new global Ltac2 value. + .. insertprodn tac2def_body tac2def_body + + .. prodn:: + tac2def_body ::= {| _ | @ident } {* @tac2pat0 } := @ltac2_expr + + This command defines a new global Ltac2 value. If one or more :token:`tac2pat0` + are specified, the new value is a function. This is a shortcut for one of the + :token:`ltac2_expr5` productions. For example: :n:`Ltac2 foo a b := …` is equivalent + to :n:`Ltac2 foo := fun a b => …`. The body of an Ltac2 definition is required to be a syntactical value that is, a function, a constant, a pure constructor recursively applied to values or a (non-recursive) let binding of a value in a value. - .. productionlist:: coq - ltac2_value: fun `ltac2_var` => `ltac2_term` - : `ltac2_qualid` - : `ltac2_constructor` `ltac2_value` ... `ltac2_value` - : `ltac2_var` - : let `ltac2_var` := `ltac2_value` in `ltac2_value` - If ``rec`` is set, the tactic is expanded into a recursive binding. If ``mutable`` is set, the definition can be redefined at a later stage (see below). -.. cmd:: Ltac2 Set @qualid {? as @lident} := @ltac2_term +.. cmd:: Ltac2 Set @qualid {? as @ident } := @ltac2_expr :name: Ltac2 Set This command redefines a previous ``mutable`` definition. @@ -254,7 +343,6 @@ Ltac Definitions .. example:: Interaction with recursive calls - .. coqtop:: all Ltac2 mutable rec f b := match b with true => 0 | _ => f true end. @@ -334,7 +422,7 @@ Intuitively a thunk of type :n:`unit -> 'a` can do the following: i.e. thunks can produce a lazy list of results where each tail is waiting for a continuation exception. - It can access a backtracking proof state, consisting among other things of - the current evar assignation and the list of goals under focus. + the current evar assignment and the list of goals under focus. We now describe more thoroughly the various effects in Ltac2. @@ -348,8 +436,8 @@ Mutable fields of records can be modified using the set syntax. Likewise, built-in types like `string` and `array` feature imperative assignment. See modules `String` and `Array` respectively. -A few printing primitives are provided in the `Message` module, allowing to -display information to the user. +A few printing primitives are provided in the `Message` module for +displaying information to the user. Fatal errors ++++++++++++ @@ -458,20 +546,27 @@ Ltac2 makes these explicit using quoting and unquoting notation, although there are notations to do it in a short and elegant way so as not to be too cumbersome to the user. -Generic Syntax for Quotations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In general, quotations can be introduced in terms using the following syntax, where -:production:`quotentry` is some parsing entry. - -.. prodn:: - ltac2_term += @ident : ( @quotentry ) +Quotations +~~~~~~~~~~ .. _ltac2_built-in-quotations: Built-in quotations +++++++++++++++++++ +.. insertprodn ltac2_quotations ltac1_expr_in_env + +.. prodn:: + ltac2_quotations ::= ident : ( @lident ) + | constr : ( @term ) + | open_constr : ( @term ) + | pattern : ( @cpattern ) + | reference : ( {| & @ident | @qualid } ) + | ltac1 : ( @ltac1_expr_in_env ) + | ltac1val : ( @ltac1_expr_in_env ) + ltac1_expr_in_env ::= @ltac_expr + | {* @ident } |- @ltac_expr + The current implementation recognizes the following built-in quotations: - ``ident``, which parses identifiers (type ``Init.ident``). @@ -481,16 +576,17 @@ The current implementation recognizes the following built-in quotations: holes at runtime (type ``Init.constr`` as well). - ``pattern``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). -- ``reference``, which parses either a :n:`@qualid` or :n:`&@ident`. Qualified names +- ``reference`` Qualified names are globalized at internalization into the corresponding global reference, while ``&id`` is turned into ``Std.VarRef id``. This produces at runtime a - ``Std.reference``. There shall be no white space between the ampersand - symbol (``&``) and the identifier (:n:`@ident`). + ``Std.reference``. +- ``ltac1``, for calling Ltac1 code, described in :ref:`simple_api`. +- ``ltac1val``, for manipulating Ltac1 values, described in :ref:`low_level_api`. -The following syntactic sugar is provided for two common cases. +The following syntactic sugar is provided for two common cases: - ``@id`` is the same as ``ident:(id)`` -- ``'t`` is the same as ``open_constr:(t)`` +- :n:`'@term` is the same as :n:`open_constr:(@term)` Strict vs. non-strict mode ++++++++++++++++++++++++++ @@ -521,11 +617,11 @@ Term Antiquotations Syntax ++++++ -One can also insert Ltac2 code into Coq terms, similarly to what is possible in +One can also insert Ltac2 code into Coq terms, similar to what is possible in Ltac1. .. prodn:: - term += ltac2:( @ltac2_term ) + term += ltac2:( @ltac2_expr ) Antiquoted terms are expected to have type ``unit``, as they are only evaluated for their side-effects. @@ -659,168 +755,473 @@ insert in a concise way an Ltac2 variable of type :n:`constr` into a Coq term. Match over terms ~~~~~~~~~~~~~~~~ -Ltac2 features a construction similar to Ltac1 :n:`match` over terms, although +Ltac2 features a construction similar to Ltac1 :tacn:`match` over terms, although in a less hard-wired way. -.. productionlist:: coq - ltac2_term : match! `ltac2_term` with `constrmatching` .. `constrmatching` end - : lazy_match! `ltac2_term` with `constrmatching` .. `constrmatching` end - : multi_match! `ltac2_term` with `constrmatching` .. `constrmatching` end - constrmatching : | `constrpattern` => `ltac2_term` - constrpattern : `term` - : context [ `term` ] - : context `lident` [ `term` ] - -This construction is not primitive and is desugared at parsing time into -calls to term matching functions from the `Pattern` module. Internally, it is -implemented thanks to a specific scope accepting the :n:`@constrmatching` syntax. - -Variables from the :n:`@constrpattern` are statically bound in the body of the branch, to -values of type `constr` for the variables from the :n:`@term` pattern and to a -value of type `Pattern.context` for the variable :n:`@lident`. - -Note that unlike Ltac, only lowercase identifiers are valid as Ltac2 -bindings, so that there will be a syntax error if one of the bound variables +.. tacn:: @ltac2_match_key @ltac2_expr__term with @ltac2_match_list end + :name: lazy_match!; match!; multi_match! + + .. insertprodn ltac2_match_key ltac2_match_pattern + + .. prodn:: + ltac2_match_key ::= lazy_match! + | match! + | multi_match! + ltac2_match_list ::= {? %| } {+| @ltac2_match_rule } + ltac2_match_rule ::= @ltac2_match_pattern => @ltac2_expr + ltac2_match_pattern ::= @cpattern + | context {? @ident } [ @cpattern ] + + Evaluates :n:`@ltac2_expr__term`, which must yield a term, and matches it + sequentially with the :token:`ltac2_match_pattern`\s, which may contain + metavariables. When a match is found, metavariable values are substituted + into :n:`@ltac2_expr`, which is then applied. + + Matching may continue depending on whether `lazy_match!`, `match!` or `multi_match!` + is specified. + + In the :token:`ltac2_match_pattern`\s, metavariables have the form :n:`?@ident`, whereas + in the :n:`@ltac2_expr`\s, the question mark is omitted. + + .. todo how does this differ from the 1-2 other unification routines elsewhere in Coq? + + Matching is non-linear: if a + metavariable occurs more than once, each occurrence must match the same + expression. Expressions match if they are syntactically equal or are + :term:`α-convertible <alpha-convertible>`. + Matching is first-order except on variables of the form :n:`@?@ident` + that occur in the head position of an application. For these variables, + matching is second-order and returns a functional term. + + .. todo the `@?ident` form is in dangling_pattern_extension_rule, not included in the doc yet + maybe belongs with "Applications" + + `lazy_match!` + Causes the match to commit to the first matching branch + rather than trying a new match if :n:`@ltac2_expr` fails. + :ref:`Example<ltac2_match_vs_lazymatch_ex>`. + + `match!` + If :n:`@ltac2_expr` fails, continue matching with the next branch. + Failures in subsequent tactics (after the `match!`) will not cause selection + of a new branch. Examples :ref:`here<ltac2_match_vs_lazymatch_ex>` and + :ref:`here<ltac2_match_vs_multimatch_ex>`. + + `multi_match!` + If :n:`@ltac2_expr` fails, continue matching with the next branch. + When a :n:`@ltac2_expr` succeeds for a branch, subsequent failures + (after the `multi_match!`) causing consumption of all the successes + of :n:`@ltac2_expr` trigger selection of a new matching branch. + :ref:`Example<ltac2_match_vs_multimatch_ex>`. + + :n:`@cpattern` + The syntax of :token:`cpattern` is + the same as that of :token:`term`\s, but it can contain pattern matching + metavariables in the form :n:`?@ident` and :n:`@?@ident`. :g:`_` can be used to match + irrelevant terms. + + .. todo more on @?@ident here: https://github.com/coq/coq/pull/12085#discussion_r467504046 + .. todo Example is broken :ref:`Example<ltac2_match_with_holes_ex>`. + + .. todo Didn't understand the following 2 paragraphs well enough to revise + see https://github.com/coq/coq/pull/12103#discussion_r436297754 for a + possible example + + Unlike Ltac1, Ltac2 :n:`?id` metavariables only match closed terms. + + There is also a special notation for second-order pattern matching: in an + applicative pattern of the form :n:`@?@ident @ident__1 … @ident__n`, + the variable :token:`ident` matches any complex expression with (possible) + dependencies in the variables :n:`@ident__i` and returns a functional term + of the form :n:`fun @ident__1 … @ident__n => @term`. + + .. _match_term_context: + + :n:`context {? @ident } [ @cpattern ]` + Matches any term with a subterm matching :token:`cpattern`. If there is a match + and :n:`@ident` is present, it is assigned the "matched + context", i.e. the initial term where the matched subterm is replaced by a + hole. This hole in the matched context can be filled with the expression + :n:`Pattern.instantiate @ident @cpattern`. + + For :tacn:`match!` and :tacn:`multi_match!`, if the evaluation of the :token:`ltac2_expr` + fails, the next matching subterm is tried. If no further subterm matches, the next branch + is tried. Matching subterms are considered from top to bottom and from left to + right (with respect to the raw printing obtained by setting the + :flag:`Printing All` flag). :ref:`Example<ltac2_match_term_context_ex>`. + + .. todo There's a more realistic example from @JasonGross here: + https://github.com/coq/coq/pull/12103#discussion_r432996954 + + :n:`@ltac2_expr` + The tactic to apply if the construct matches. Metavariable values from the pattern + match are statically bound as Ltac2 variables in :n:`@ltac2_expr` before + it is applied. + + If :n:`@ltac2_expr` is a tactic with backtracking points, then subsequent + failures after a :tacn:`lazy_match!` or :tacn:`multi_match!` (but not :tacn:`match!`) can cause + backtracking into :n:`@ltac2_expr` to select its next success. + + Variables from the :n:`@tac2pat1` are statically bound in the body of the branch. + Variables from the :n:`@term` pattern have values of type `constr`. + Variables from the :n:`@ident` in the `context` construct have values of type + `Pattern.context` (defined in `Pattern.v`). + +Note that unlike Ltac1, only lowercase identifiers are valid as Ltac2 +bindings. Ltac2 will report an error if one of the bound variables starts with an uppercase character. -The semantics of this construction is otherwise the same as the corresponding +The semantics of this construction are otherwise the same as the corresponding one from Ltac1, except that it requires the goal to be focused. +.. _ltac2_match_vs_lazymatch_ex: + +.. example:: Ltac2 Comparison of lazy_match! and match! + + (Equivalent to this :ref:`Ltac1 example<match_vs_lazymatch_ex>`.) + + These lines define a `msg` tactic that's used in several examples as a more-succinct + alternative to `print (to_string "...")`: + + .. coqtop:: in + + From Ltac2 Require Import Message. + Ltac2 msg x := print (of_string x). + + .. coqtop:: none + + Goal True. + + In :tacn:`lazy_match!`, if :token:`ltac2_expr` fails, the :tacn:`lazy_match!` fails; + it doesn't look for further matches. In :tacn:`match!`, if :token:`ltac2_expr` fails + in a matching branch, it will try to match on subsequent branches. Note that + :n:`'@term` below is equivalent to :n:`open_constr:(@term)`. + + .. coqtop:: all + + Fail lazy_match! 'True with + | True => msg "branch 1"; fail + | _ => msg "branch 2" + end. + + match! 'True with + | True => msg "branch 1"; fail + | _ => msg "branch 2" + end. + +.. _ltac2_match_vs_multimatch_ex: + +.. example:: Ltac2 Comparison of match! and multi_match! + + (Equivalent to this :ref:`Ltac1 example<match_vs_multimatch_ex>`.) + + :tacn:`match!` tactics are only evaluated once, whereas :tacn:`multi_match!` + tactics may be evaluated more than once if the following constructs trigger backtracking: + + .. coqtop:: all + + Fail match! 'True with + | True => msg "branch 1" + | _ => msg "branch 2" + end ; + msg "branch A"; fail. + + .. coqtop:: all + + Fail multi_match! 'True with + | True => msg "branch 1" + | _ => msg "branch 2" + end ; + msg "branch A"; fail. + +.. _ltac2_match_with_holes_ex: + +.. todo EXAMPLE DOESN'T WORK: Ltac2 does not (yet?) handle pattern variables matching open terms. + Matching a pattern with holes + + (Equivalent to this :ref:`Ltac1 example<match_with_holes_ex>`.) + + Notice the :tacn:`idtac` prints ``(z + 1)`` while the :tacn:`pose` substitutes + ``(x + 1)``. + + .. coqtop:: all + + match! constr:(fun x => (x + 1) * 3) with + | fun z => ?y * 3 => print (of_constr y); pose (fun z: nat => $y * 5) + end. + +.. _ltac2_match_term_context_ex: + +.. example:: Ltac2 Multiple matches for a "context" pattern. + + (Equivalent to this :ref:`Ltac1 example<match_term_context_ex>`.) + + Internally "x <> y" is represented as "(~ (x = y))", which produces the + first match. + + .. coqtop:: in + + Ltac2 f2 t := match! t with + | context [ (~ ?t) ] => print (of_constr t); fail + | _ => () + end. + + .. coqtop:: all abort + + f2 constr:((~ True) <> (~ False)). + Match over goals ~~~~~~~~~~~~~~~~ -Similarly, there is a way to match over goals in an elegant way, which is -just a notation desugared at parsing time. +.. tacn:: @ltac2_match_key {? reverse } goal with @goal_match_list end + :name: lazy_match! goal; match! goal; multi_match! goal -.. productionlist:: coq - ltac2_term : match! [ reverse ] goal with `goalmatching` ... `goalmatching` end - : lazy_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end - : multi_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end - goalmatching : | [ `hypmatching` ... `hypmatching` |- `constrpattern` ] => `ltac2_term` - hypmatching : `lident` : `constrpattern` - : _ : `constrpattern` + .. insertprodn goal_match_list gmatch_hyp_pattern -Variables from :n:`@hypmatching` and :n:`@constrpattern` are bound in the body of the -branch. Their types are: + .. prodn:: + goal_match_list ::= {? %| } {+| @gmatch_rule } + gmatch_rule ::= @gmatch_pattern => @ltac2_expr + gmatch_pattern ::= [ {*, @gmatch_hyp_pattern } |- @ltac2_match_pattern ] + gmatch_hyp_pattern ::= @name : @ltac2_match_pattern -- ``constr`` for pattern variables appearing in a :n:`@term` -- ``Pattern.context`` for variables binding a context -- ``ident`` for variables binding a hypothesis name. + 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 + 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. -The same identifier caveat as in the case of matching over constr applies, and -this features has the same semantics as in Ltac1. In particular, a ``reverse`` -flag can be specified to match hypotheses from the more recently introduced to -the least recently introduced one. + Matching is non-linear: if a + metavariable occurs more than once, each occurrence must match the same + expression. Within a single term, expressions match if they are syntactically equal or + :term:`α-convertible <alpha-convertible>`. When a metavariable is used across + multiple hypotheses or across a hypothesis and the current goal, the expressions match if + they are :term:`convertible`. -.. _ltac2_notations: + .. more detail here: https://github.com/coq/coq/pull/12085#discussion_r470406466 -Notations ---------- + :n:`{*, @gmatch_pattern }` + Patterns to match with hypotheses. Each pattern must match a distinct hypothesis in order + for the branch to match. -Notations are the crux of the usability of Ltac1. We should be able to recover -a feeling similar to the old implementation by using and abusing notations. + Hypotheses have the form :n:`@name {? := @term__binder } : @type`. Currently Ltac2 doesn't + allow matching on or capturing the value of :n:`@term__binder`. It only supports matching on + the :token:`name` and the :token:`type`, for example `n : ?t`. -Scopes -~~~~~~ + .. currently only supports the first row + :list-table:: + :widths: 2 1 + :header-rows: 1 -A scope is a name given to a grammar entry used to produce some Ltac2 expression -at parsing time. Scopes are described using a form of S-expression. + * - Pattern syntax + - Example pattern -.. prodn:: - ltac2_scope ::= {| @string | @int | @lident ({+, @ltac2_scope}) } + * - :n:`@name : @ltac2_match_pattern` + - `n : ?t` -A few scopes contain antiquotation features. For the sake of uniformity, all -antiquotations are introduced by the syntax :n:`$@lident`. + * - :n:`@name := @match_pattern__binder` + - `n := ?b` -The following scopes are built-in. + * - :n:`@name := @term__binder : @type` + - `n := ?b : ?t` -- :n:`constr`: + * - :n:`@name := [ @match_pattern__binder ] : @ltac2_match_pattern` + - `n := [ ?b ] : ?t` - + parses :n:`c = @term` and produces :n:`constr:(c)` + :token:`name` can't have a `?`. Note that the last two forms are equivalent except that: - This scope can be parameterized by a list of delimiting keys of notation - scopes (as described in :ref:`LocalInterpretationRulesForNotations`), - describing how to interpret the parsed term. For instance, :n:`constr(A, B)` - parses :n:`c = @term` and produces :n:`constr:(c%A%B)`. + - if the `:` in the third form has been bound to something else in a notation, you must use the fourth form. + Note that cmd:`Require Import` `ssreflect` loads a notation that does this. + - a :n:`@term__binder` such as `[ ?l ]` (e.g., denoting a singleton list after + :cmd:`Import` `ListNotations`) must be parenthesized or, for the fourth form, + use double brackets: `[ [ ?l ] ]`. -- :n:`ident`: + If there are multiple :token:`gmatch_hyp_pattern`\s in a branch, there may be multiple ways to match them to hypotheses. + For :tacn:`match! goal` and :tacn:`multi_match! goal`, if the evaluation of the :token:`ltac2_expr` fails, + matching will continue with the next hypothesis combination. When those are exhausted, + the next alternative from any `context` construct in the :token:`ltac2_match_pattern`\s is tried and then, + when the context alternatives are exhausted, the next branch is tried. + :ref:`Example<ltac2_match_goal_multiple_hyps_ex>`. - + parses :n:`id = @ident` and produces :n:`ident:(id)` - + parses :n:`$(x = @ident)` and produces the variable :n:`x` + `reverse` + Hypothesis matching for :token:`gmatch_hyp_pattern`\s normally begins by matching them from left to right, + to hypotheses, last to first. Specifying `reverse` begins matching in the reverse order, from + first to last. :ref:`Normal<ltac2_match_goal_hyps_ex>` and :ref:`reverse<ltac2_match_goal_hyps_rev_ex>` examples. -- :n:`list0(@ltac2_scope)`: + :n:`|- @ltac2_match_pattern` + A pattern to match with the current goal - + if :n:`@ltac2_scope` parses :n:`@quotentry`, - then it parses :n:`(@quotentry__0, ..., @quotentry__n)` and produces - :n:`[@quotentry__0; ...; @quotentry__n]`. + Note that unlike Ltac1, only lowercase identifiers are valid as Ltac2 + bindings. Ltac2 will report an error if you try to use a bound variable + that starts with an uppercase character. -- :n:`list0(@ltac2_scope, sep = @string__sep)`: + Variables from :n:`@gmatch_hyp_pattern` and :n:`@ltac2_match_pattern` are + bound in the body of the branch. Their types are: - + if :n:`@ltac2_scope` parses :n:`@quotentry`, - then it parses :n:`(@quotentry__0 @string__sep ... @string__sep @quotentry__n)` - and produce :n:`[@quotentry__0; ...; @quotentry__n]`. + - ``constr`` for pattern variables appearing in a :n:`@term` + - ``Pattern.context`` for variables binding a context + - ``ident`` for variables binding a hypothesis name. -- :n:`list1`: same as :n:`list0` (with or without separator) but parses :n:`{+ @quotentry}` instead - of :n:`{* @quotentry}`. + The same identifier caveat as in the case of matching over constr applies, and + this feature has the same semantics as in Ltac1. -- :n:`opt(@ltac2_scope)` +.. _ltac2_match_goal_hyps_ex: - + if :n:`@ltac2_scope` parses :n:`@quotentry`, parses :n:`{? @quotentry}` and produces either :n:`None` or - :n:`Some x` where :n:`x` is the parsed expression. +.. example:: Ltac2 Matching hypotheses -- :n:`self`: + (Equivalent to this :ref:`Ltac1 example<match_goal_hyps_ex>`.) - + parses a Ltac2 expression at the current level and returns it as is. + Hypotheses are matched from the last hypothesis (which is by default the newest + hypothesis) to the first until the :tacn:`apply` succeeds. -- :n:`next`: + .. coqtop:: all abort - + parses a Ltac2 expression at the next level and returns it as is. + Goal forall A B : Prop, A -> B -> (A->B). + intros. + match! goal with + | [ h : _ |- _ ] => let h := Control.hyp h in print (of_constr h); apply $h + end. -- :n:`tactic(n = @int)`: +.. _ltac2_match_goal_hyps_rev_ex: - + parses a Ltac2 expression at the provided level :n:`n` and returns it as is. +.. example:: Matching hypotheses with reverse -- :n:`thunk(@ltac2_scope)`: + (Equivalent to this :ref:`Ltac1 example<match_goal_hyps_rev_ex>`.) - + parses the same as :n:`scope`, and if :n:`e` is the parsed expression, returns - :n:`fun () => e`. + Hypotheses are matched from the first hypothesis to the last until the :tacn:`apply` succeeds. -- :n:`STRING`: + .. coqtop:: all abort - + parses the corresponding string as an identifier and returns :n:`()`. + Goal forall A B : Prop, A -> B -> (A->B). + intros. + match! reverse goal with + | [ h : _ |- _ ] => let h := Control.hyp h in print (of_constr h); apply $h + end. -- :n:`keyword(s = @string)`: +.. _ltac2_match_goal_multiple_hyps_ex: - + parses the string :n:`s` as a keyword and returns `()`. +.. example:: Multiple ways to match a hypotheses -- :n:`terminal(s = @string)`: + (Equivalent to this :ref:`Ltac1 example<match_goal_multiple_hyps_ex>`.) - + parses the string :n:`s` as a keyword, if it is already a - keyword, otherwise as an :n:`@ident`. Returns `()`. + Every possible match for the hypotheses is evaluated until the right-hand + side succeeds. Note that `h1` and `h2` are never matched to the same hypothesis. + Observe that the number of permutations can grow as the factorial + of the number of hypotheses and hypothesis patterns. -- :n:`seq(@ltac2_scope__1, ..., @ltac2_scope__2)`: + .. coqtop:: all abort - + parses :n:`scope__1`, ..., :n:`scope__n` in this order, and produces a tuple made - out of the parsed values in the same order. As an optimization, all - subscopes of the form :n:`STRING` are left out of the returned tuple, instead - of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using :n:`self` or :n:`next`. + Goal forall A B : Prop, A -> B -> (A->B). + intros A B H. + match! goal with + | [ h1 : _, h2 : _ |- _ ] => + print (concat (of_string "match ") + (concat (of_constr (Control.hyp h1)) + (concat (of_string " ") + (of_constr (Control.hyp h2))))); + fail + | [ |- _ ] => () + end. -A few other specific scopes exist to handle Ltac1-like syntax, but their use is -discouraged and they are thus not documented. -For now there is no way to declare new scopes from Ltac2 side, but this is -planned. +Match on values +~~~~~~~~~~~~~~~ -Notations -~~~~~~~~~ +.. tacn:: match @ltac2_expr5 with {? @ltac2_branches } end + :name: match (Ltac2) + + Matches a value, akin to the OCaml `match` construct. By itself, it doesn't cause backtracking + as do the `*match*!` and `*match*! goal` constructs. + + .. insertprodn ltac2_branches atomic_tac2pat -The Ltac2 parser can be extended with syntactic notations. + .. prodn:: + ltac2_branches ::= {? %| } {+| @tac2pat1 => @ltac2_expr } + tac2pat1 ::= @qualid {+ @tac2pat0 } + | @qualid + | [ ] + | @tac2pat0 :: @tac2pat0 + | @tac2pat0 + tac2pat0 ::= _ + | () + | @qualid + | ( {? @atomic_tac2pat } ) + atomic_tac2pat ::= @tac2pat1 : @ltac2_type + | @tac2pat1 , {*, @tac2pat1 } + | @tac2pat1 -.. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @int} := @ltac2_term +.. note:: + + For now, deep pattern matching is not implemented. + + +.. _ltac2_notations: + +Notations +--------- + +.. cmd:: Ltac2 Notation {+ @ltac2_scope } {? : @int } := @ltac2_expr :name: Ltac2 Notation - A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded + .. todo seems like name maybe should use lident rather than ident, considering: + + Ltac2 Notation "ex1" X(constr) := print (of_constr X). + ex1 1. + + Unbound constructor X + + This works fine with lower-case "x" in place of "X" + + .. todo Ltac2 Notation := permits redefining same symbol (no warning) + Also allows defining a symbol beginning with uppercase, which is prohibited + in similar constructs. + + :cmd:`Ltac2 Notation` provides a way to extend the syntax of Ltac2 tactics. The left-hand + side (before the `:=`) defines the syntax to recognize and gives formal parameter + names for the syntactic values. :n:`@int` is the level of the notation. + When the notation is used, the values are substituted + into the right-hand side. The right-hand side is typechecked when the notation is used, + not when it is defined. In the following example, `x` is the formal parameter name and + `constr` is its :ref:`syntactic class<syntactic_classes>`. `print` and `of_constr` are + functions provided by |Coq| through `Message.v`. + + .. todo "print" doesn't seem to pay attention to "Set Printing All" + + .. example:: Printing a :n:`@term` + + .. coqtop:: none + + Goal True. + + .. coqtop:: all + + From Ltac2 Require Import Message. + Ltac2 Notation "ex1" x(constr) := print (of_constr x). + ex1 (1 + 2). + + You can also print terms with a regular Ltac2 definition, but then the :n:`@term` must be in + the quotation `constr:( … )`: + + .. coqtop:: all + + Ltac2 ex2 x := print (of_constr x). + ex2 constr:(1+2). + + There are also metasyntactic classes described :ref:`here<syntactic_classes>` + that combine other items. For example, `list1(constr, ",")` + recognizes a comma-separated list of one or more :token:`term`\s. + + .. example:: Parsing a list of :n:`@term`\s + + .. coqtop:: abort all + + Ltac2 rec print_list x := match x with + | a :: t => print (of_constr a); print_list t + | [] => () + end. + Ltac2 Notation "ex2" x(list1(constr, ",")) := print_list x. + ex2 1, 2, 3. + + An Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded to the provided body where every token from the notation is let-bound to the corresponding generated expression. @@ -848,37 +1249,432 @@ The Ltac2 parser can be extended with syntactic notations. Abbreviations ~~~~~~~~~~~~~ -.. cmdv:: Ltac2 Notation @lident := @ltac2_term +.. cmd:: Ltac2 Notation {| @string | @lident } := @ltac2_expr + :name: Ltac2 Notation (abbreviation) - This command introduces a special kind of notation, called an abbreviation, - that is designed so that it does not add any parsing rules. It is similar in - spirit to Coq abbreviations, insofar as its main purpose is to give an - absolute name to a piece of pure syntax, which can be transparently referred to - by this name as if it were a proper definition. + Introduces a special kind of notation, called an abbreviation, + that does not add any parsing rules. It is similar in + spirit to Coq abbreviations (see :cmd:`Notation (abbreviation)`, + insofar as its main purpose is to give an + absolute name to a piece of pure syntax, which can be transparently referred to + by this name as if it were a proper definition. - The abbreviation can then be manipulated just as a normal Ltac2 definition, - except that it is expanded at internalization time into the given expression. - Furthermore, in order to make this kind of construction useful in practice in - an effectful language such as Ltac2, any syntactic argument to an abbreviation - is thunked on-the-fly during its expansion. + The abbreviation can then be manipulated just like a normal Ltac2 definition, + except that it is expanded at internalization time into the given expression. + Furthermore, in order to make this kind of construction useful in practice in + an effectful language such as Ltac2, any syntactic argument to an abbreviation + is thunked on-the-fly during its expansion. -For instance, suppose that we define the following. + For instance, suppose that we define the following. -:n:`Ltac2 Notation foo := fun x => x ().` + :n:`Ltac2 Notation foo := fun x => x ().` -Then we have the following expansion at internalization time. + Then we have the following expansion at internalization time. -:n:`foo 0 ↦ (fun x => x ()) (fun _ => 0)` + :n:`foo 0 ↦ (fun x => x ()) (fun _ => 0)` -Note that abbreviations are not typechecked at all, and may result in typing -errors after expansion. + Note that abbreviations are not type checked at all, and may result in typing + errors after expansion. + +.. _defining_tactics: + +Defining tactics +~~~~~~~~~~~~~~~~ + +Built-in tactics (those defined in OCaml code in the |Coq| executable) and Ltac1 tactics, +which are defined in `.v` files, must be defined through notations. (Ltac2 tactics can be +defined with :cmd:`Ltac2`. + +Notations for many but not all built-in tactics are defined in `Notations.v`, which is automatically +loaded with Ltac2. The Ltac2 syntax for these tactics is often identical or very similar to the +tactic syntax described in other chapters of this documentation. These notations rely on tactic functions +declared in `Std.v`. Functions corresponding to some built-in tactics may not yet be defined in the +|Coq| executable or declared in `Std.v`. Adding them may require code changes to |Coq| or defining +workarounds through Ltac1 (described below). + +Two examples of syntax differences: + +- There is no notation defined that's equivalent to :n:`intros until {| @ident | @num }`. There is, + however, already an ``intros_until`` tactic function defined ``Std.v``, so it may be possible for a user + to add the necessary notation. +- The built-in `simpl` tactic in Ltac1 supports the use of scope keys in delta flags, e.g. :n:`simpl ["+"%nat]` + which is not accepted by Ltac2. This is because Ltac2 uses a different + definition for :token:`delta_flag`; compare it to :token:`ltac2_delta_flag`. This also affects + :tacn:`compute`. + +Ltac1 tactics are not automatically available in Ltac2. (Note that some of the tactics described +in the documentation are defined with Ltac1.) +You can make them accessible in Ltac2 with commands similar to the following: + +.. coqtop:: in + + From Coq Require Import Lia. + Local Ltac2 lia_ltac1 () := ltac1:(lia). + Ltac2 Notation "lia" := lia_ltac1 (). + +A similar approach can be used to access missing built-in tactics. See :ref:`simple_api` for an +example that passes two parameters to a missing build-in tactic. + +.. _syntactic_classes: + +Syntactic classes +~~~~~~~~~~~~~~~~~ + +The simplest syntactic classes in Ltac2 notations represent individual nonterminals +from the |Coq| grammar. Only a few selected nonterminals are available as syntactic classes. +In addition, there are metasyntactic operations for describing +more complex syntax, such as making an item optional or representing a list of items. +When parsing, each syntactic class expression returns a value that's bound to a name in the +notation definition. + +Syntactic classes are described with a form of S-expression: + + .. insertprodn ltac2_scope ltac2_scope + + .. prodn:: + ltac2_scope ::= @string + | @int + | @name + | @name ( {+, @ltac2_scope } ) + +.. todo no syn class for ints or strings? + parm names are not reserved (e.g the var can be named "list1") + +Metasyntactic operations that can be applied to other syntactic classes are: + + :n:`opt(@ltac2_scope)` + Parses an optional :token:`ltac2_scope`. The associated value is either :n:`None` or + enclosed in :n:`Some` + + :n:`list1(@ltac2_scope {? , @string })` + Parses a list of one or more :token:`ltac2_scope`\s. If :token:`string` is specified, + items must be separated by :token:`string`. + + :n:`list0(@ltac2_scope {? , @string })` + Parses a list of zero or more :token:`ltac2_scope`\s. If :token:`string` is specified, + items must be separated by :token:`string`. For zero items, the associated value + is an empty list. + + :n:`seq({+, @ltac2_scope })` + Parses the :token:`ltac2_scope`\s in order. The associated value is a tuple, + omitting :token:`ltac2_scope`\s that are :token:`string`\s. + `self` and `next` are not permitted within `seq`. + +The following classes represent nonterminals with some special handling. The +table further down lists the classes that that are handled plainly. + + :n:`constr {? ( {+, @scope_key } ) }` + Parses a :token:`term`. If specified, the :token:`scope_key`\s are used to interpret + the term (as described in :ref:`LocalInterpretationRulesForNotations`). The last + :token:`scope_key` is the top of the scope stack that's applied to the :token:`term`. + + :n:`open_constr` + Parses an open :token:`term`. + + :n:`ident` + Parses :token:`ident` or :n:`$@ident`. The first form returns :n:`ident:(@ident)`, + while the latter form returns the variable :n:`@ident`. + + :n:`@string` + Accepts the specified string that is not a keyword, returning a value of `()`. + + :n:`keyword(@string)` + Accepts the specified string that is a keyword, returning a value of `()`. + + :n:`terminal(@string)` + Accepts the specified string whether it's a keyword or not, returning a value of `()`. + + :n:`tactic {? (@int) }` + Parses an :token:`ltac2_expr`. If :token:`int` is specified, the construct + parses a :n:`ltac2_expr@int`, for example `tactic(5)` parses :token:`ltac2_expr5`. + `tactic(6)` parses :token:`ltac2_expr`. + :token:`int` must be in the range `0 .. 6`. + + You can also use `tactic` to accept an :token:`int` or a :token:`string`, but there's + no syntactic class that accepts *only* an :token:`int` or a :token:`string`. + + .. todo this doesn't work as expected: "::" is in ltac2_expr1 + Ltac2 Notation "ex4" x(tactic(0)) := x. + ex4 auto :: [auto]. + + .. not sure "self" and "next" do anything special. I get the same error + message for both from constructs like + + Ltac2 Notation "ex5" x(self) := auto. + ex5 match. + + Syntax error: [tactic:tac2expr level 5] expected after 'match' (in [tactic:tac2expr]). + + :n:`self` + parses an Ltac2 expression at the current level and returns it as is. + + :n:`next` + parses an Ltac2 expression at the next level and returns it as is. + + :n:`thunk(@ltac2_scope)` + Used for semantic effect only, parses the same as :token:`ltac2_scope`. + If :n:`e` is the parsed expression for :token:`ltac2_scope`, `thunk` + returns :n:`fun () => e`. + + :n:`pattern` + parses a :token:`cpattern` + +A few syntactic classes contain antiquotation features. For the sake of uniformity, all +antiquotations are introduced by the syntax :n:`$@lident`. + +A few other specific syntactic classes exist to handle Ltac1-like syntax, but their use is +discouraged and they are thus not documented. + +For now there is no way to declare new syntactic classes from the Ltac2 side, but this is +planned. + +Other nonterminals that have syntactic classes are listed here. + + .. list-table:: + :header-rows: 1 + + * - Syntactic class name + - Nonterminal + - Similar non-Ltac2 syntax + + * - :n:`intropatterns` + - :token:`ltac2_intropatterns` + - :token:`intropattern_list` + + * - :n:`intropattern` + - :token:`ltac2_simple_intropattern` + - :token:`simple_intropattern` + + * - :n:`ident` + - :token:`ident_or_anti` + - :token:`ident` + + * - :n:`destruction_arg` + - :token:`ltac2_destruction_arg` + - :token:`destruction_arg` + + * - :n:`with_bindings` + - :token:`q_with_bindings` + - :n:`{? with @bindings }` + + * - :n:`bindings` + - :token:`ltac2_bindings` + - :token:`bindings` + + * - :n:`strategy` + - :token:`ltac2_strategy_flag` + - :token:`strategy_flag` + + * - :n:`reference` + - :token:`refglobal` + - :token:`reference` + + * - :n:`clause` + - :token:`ltac2_clause` + - :token:`clause_dft_concl` + + * - :n:`occurrences` + - :token:`q_occurrences` + - :n:`{? at @occs_nums }` + + * - :n:`induction_clause` + - :token:`ltac2_induction_clause` + - :token:`induction_clause` + + * - :n:`conversion` + - :token:`ltac2_conversion` + - :token:`conversion` + + * - :n:`rewriting` + - :token:`ltac2_oriented_rewriter` + - :token:`oriented_rewriter` + + * - :n:`dispatch` + - :token:`ltac2_for_each_goal` + - :token:`for_each_goal` + + * - :n:`hintdb` + - :token:`hintdb` + - :token:`hintbases` + + * - :n:`move_location` + - :token:`move_location` + - :token:`where` + + * - :n:`pose` + - :token:`pose` + - :token:`bindings_with_parameters` + + * - :n:`assert` + - :token:`assertion` + - :n:`( @ident := @term )` + + * - :n:`constr_matching` + - :token:`ltac2_match_list` + - See :tacn:`match` + + * - :n:`goal_matching` + - :token:`goal_match_list` + - See :tacn:`match goal` + +Here is the syntax for the :n:`q_*` nonterminals: + +.. insertprodn ltac2_intropatterns nonsimple_intropattern + +.. prodn:: + ltac2_intropatterns ::= {* @nonsimple_intropattern } + nonsimple_intropattern ::= * + | ** + | @ltac2_simple_intropattern + +.. insertprodn ltac2_simple_intropattern ltac2_naming_intropattern + +.. prodn:: + ltac2_simple_intropattern ::= @ltac2_naming_intropattern + | _ + | @ltac2_or_and_intropattern + | @ltac2_equality_intropattern + ltac2_or_and_intropattern ::= [ {+| @ltac2_intropatterns } ] + | () + | ( {+, @ltac2_simple_intropattern } ) + | ( {+& @ltac2_simple_intropattern } ) + ltac2_equality_intropattern ::= -> + | <- + | [= @ltac2_intropatterns ] + ltac2_naming_intropattern ::= ? @lident + | ?$ @lident + | ? + | @ident_or_anti + +.. insertprodn ident_or_anti ident_or_anti + +.. prodn:: + ident_or_anti ::= @lident + | $ @ident + +.. insertprodn ltac2_destruction_arg ltac2_constr_with_bindings + +.. prodn:: + ltac2_destruction_arg ::= @num + | @lident + | @ltac2_constr_with_bindings + ltac2_constr_with_bindings ::= @term {? with @ltac2_bindings } + +.. insertprodn q_with_bindings qhyp + +.. prodn:: + q_with_bindings ::= {? with @ltac2_bindings } + ltac2_bindings ::= {+ @ltac2_simple_binding } + | {+ @term } + ltac2_simple_binding ::= ( @qhyp := @term ) + qhyp ::= $ @ident + | @num + | @lident + +.. insertprodn ltac2_strategy_flag ltac2_delta_flag + +.. prodn:: + ltac2_strategy_flag ::= {+ @ltac2_red_flag } + | {? @ltac2_delta_flag } + ltac2_red_flag ::= beta + | iota + | match + | fix + | cofix + | zeta + | delta {? @ltac2_delta_flag } + ltac2_delta_flag ::= {? - } [ {+ @refglobal } ] + +.. insertprodn refglobal refglobal + +.. prodn:: + refglobal ::= & @ident + | @qualid + | $ @ident + +.. insertprodn ltac2_clause ltac2_in_clause + +.. prodn:: + ltac2_clause ::= in @ltac2_in_clause + | at @ltac2_occs_nums + ltac2_in_clause ::= * {? @ltac2_occs } + | * |- {? @ltac2_concl_occ } + | {*, @ltac2_hypident_occ } {? |- {? @ltac2_concl_occ } } + +.. insertprodn q_occurrences ltac2_hypident + +.. prodn:: + q_occurrences ::= {? @ltac2_occs } + ltac2_occs ::= at @ltac2_occs_nums + ltac2_occs_nums ::= {? - } {+ {| @num | $ @ident } } + ltac2_concl_occ ::= * {? @ltac2_occs } + ltac2_hypident_occ ::= @ltac2_hypident {? @ltac2_occs } + ltac2_hypident ::= @ident_or_anti + | ( type of @ident_or_anti ) + | ( value of @ident_or_anti ) + +.. insertprodn ltac2_induction_clause ltac2_eqn_ipat + +.. prodn:: + ltac2_induction_clause ::= @ltac2_destruction_arg {? @ltac2_as_or_and_ipat } {? @ltac2_eqn_ipat } {? @ltac2_clause } + ltac2_as_or_and_ipat ::= as @ltac2_or_and_intropattern + ltac2_eqn_ipat ::= eqn : @ltac2_naming_intropattern + +.. insertprodn ltac2_conversion ltac2_conversion + +.. prodn:: + ltac2_conversion ::= @term + | @term with @term + +.. insertprodn ltac2_oriented_rewriter ltac2_rewriter + +.. prodn:: + ltac2_oriented_rewriter ::= {| -> | <- } @ltac2_rewriter + ltac2_rewriter ::= {? @num } {? {| ? | ! } } @ltac2_constr_with_bindings + +.. insertprodn ltac2_for_each_goal ltac2_goal_tactics + +.. prodn:: + ltac2_for_each_goal ::= @ltac2_goal_tactics + | {? @ltac2_goal_tactics %| } {? @ltac2_expr } .. {? %| @ltac2_goal_tactics } + ltac2_goal_tactics ::= {*| {? @ltac2_expr } } + +.. insertprodn hintdb hintdb + +.. prodn:: + hintdb ::= * + | {+ @ident_or_anti } + +.. insertprodn move_location move_location + +.. prodn:: + move_location ::= at top + | at bottom + | after @ident_or_anti + | before @ident_or_anti + +.. insertprodn pose ltac2_as_name + +.. prodn:: + pose ::= ( @ident_or_anti := @term ) + | @term {? @ltac2_as_name } + ltac2_as_name ::= as @ident_or_anti + +.. insertprodn assertion ltac2_by_tactic + +.. prodn:: + assertion ::= ( @ident_or_anti := @term ) + | ( @ident_or_anti : @term ) {? @ltac2_by_tactic } + | @term {? @ltac2_as_ipat } {? @ltac2_by_tactic } + ltac2_as_ipat ::= as @ltac2_simple_intropattern + ltac2_by_tactic ::= by @ltac2_expr Evaluation ---------- Ltac2 features a toplevel loop that can be used to evaluate expressions. -.. cmd:: Ltac2 Eval @ltac2_term +.. cmd:: Ltac2 Eval @ltac2_expr :name: Ltac2 Eval This command evaluates the term in the current proof if there is one, or in the @@ -899,22 +1695,26 @@ Compatibility layer with Ltac1 Ltac1 from Ltac2 ~~~~~~~~~~~~~~~~ +.. _simple_api: + Simple API ++++++++++ -One can call Ltac1 code from Ltac2 by using the :n:`ltac1` quotation. It parses +One can call Ltac1 code from Ltac2 by using the :n:`ltac1:(@ltac1_expr_in_env)` quotation. +See :ref:`ltac2_built-in-quotations`. It parses a Ltac1 expression, and semantics of this quotation is the evaluation of the corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. -.. productionlist:: coq - ltac2_term : ltac1 : ( `ltac_expr` ) - Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can -be done with an explicit annotation on the :n:`ltac1` quotation. +be done with an explicit annotation on the :n:`ltac1:({* @ident } |- @ltac_expr)` +quotation. See :ref:`ltac2_built-in-quotations`. For example: -.. productionlist:: coq - ltac2_term : ltac1 : ( `ident` ... `ident` |- `ltac_expr` ) +.. coqtop:: in + + Local Ltac2 replace_with (lhs: constr) (rhs: constr) := + ltac1:(lhs rhs |- replace lhs with rhs) (Ltac1.of_constr lhs) (Ltac1.of_constr rhs). + Ltac2 Notation "replace" lhs(constr) "with" rhs(constr) := replace_with lhs rhs. The return type of this expression is a function of the same arity as the number of identifiers, with arguments of type `Ltac2.Ltac1.t` (see below). This syntax @@ -922,6 +1722,8 @@ will bind the variables in the quoted Ltac1 code as if they had been bound from Ltac1 itself. Similarly, the arguments applied to the quotation will be passed at runtime to the Ltac1 code. +.. _low_level_api: + Low-level API +++++++++++++ @@ -948,8 +1750,8 @@ Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation instead. .. prodn:: - ltac_expr += ltac2 : ( `ltac2_term` ) - | ltac2 : ( `ident` ... `ident` |- `ltac2_term` ) + ltac_expr += ltac2 : ( @ltac2_expr ) + | ltac2 : ( {+ @ident } |- @ltac2_expr ) The typing rules are dual, that is, the optional identifiers are bound with type `Ltac2.Ltac1.t` in the Ltac2 expression, which is expected to have @@ -992,7 +1794,7 @@ Transition from Ltac1 Owing to the use of a lot of notations, the transition should not be too difficult. In particular, it should be possible to do it incrementally. That -said, we do *not* guarantee you it is going to be a blissful walk either. +said, we do *not* guarantee it will be a blissful walk either. Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq will help you. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 4eaca8634f..7f270e8076 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -5596,11 +5596,11 @@ context pattern see :ref:`contextual_patterns_ssr` discharge item see :ref:`discharge_ssr` -.. prodn:: gen_item ::= {| {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } +.. prodn:: gen_item ::= {| {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } generalization item see :ref:`structure_ssr` -.. prodn:: i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } +.. prodn:: i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } intro pattern :ref:`introduction_ssr` @@ -5614,7 +5614,7 @@ view :ref:`introduction_ssr` intro block :ref:`introduction_ssr` .. prodn:: - i_block ::= {| [^ @ident ] | [^~ {| @ident | @num } ] } + i_block ::= {| [^ @ident ] | [^~ {| @ident | @num } ] } intro item see :ref:`introduction_ssr` diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 8635add0e1..f3dc9a6cb1 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -2988,9 +2988,9 @@ Performing computations | pattern {+, @pattern_occ } | @ident delta_flag ::= {? - } [ {+ @reference } ] - strategy_flag ::= {+ @red_flags } + strategy_flag ::= {+ @red_flag } | @delta_flag - red_flags ::= beta + red_flag ::= beta | iota | match | fix diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index ad0aab19b5..36ad4af837 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1265,9 +1265,9 @@ Inlining hints for the fast reduction machines Registering primitive operations ```````````````````````````````` -.. cmd:: Primitive @ident {? : @term } := #@ident__prim +.. cmd:: Primitive @ident_decl {? : @term } := #@ident - Makes the primitive type or primitive operator :n:`#@ident__prim` defined in OCaml + Makes the primitive type or primitive operator :n:`#@ident` defined in OCaml accessible in |Coq| commands and tactics. For internal use by implementors of |Coq|'s standard library or standard library replacements. No space is allowed after the `#`. Invalid values give a syntax diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 284c5d585a..d8caf4efe2 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -494,7 +494,11 @@ class ProductionObject(CoqObject): loc = os.path.basename(get_node_location(signode)) raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) - self.signatures.append((lhs, op, rhs)) + parts = rhs.split(" ", maxsplit=1) + rhs = parts[0].strip() + tag = parts[1].strip() if len(parts) == 2 else "" + + self.signatures.append((lhs, op, rhs, tag)) return [('token', lhs)] if op == '::=' else None def _add_index_entry(self, name, target): @@ -513,21 +517,21 @@ class ProductionObject(CoqObject): self.signatures = [] indexnode = super().run()[0] # makes calls to handle_signature - table = nodes.inline(classes=['prodn-table']) - tgroup = nodes.inline(classes=['prodn-column-group']) - for _ in range(3): - tgroup += nodes.inline(classes=['prodn-column']) + table = nodes.container(classes=['prodn-table']) + tgroup = nodes.container(classes=['prodn-column-group']) + for _ in range(4): + tgroup += nodes.container(classes=['prodn-column']) table += tgroup - tbody = nodes.inline(classes=['prodn-row-group']) + tbody = nodes.container(classes=['prodn-row-group']) table += tbody # create rows for signature in self.signatures: - lhs, op, rhs = signature + lhs, op, rhs, tag = signature position = self.state_machine.get_source_and_line(self.lineno) - row = nodes.inline(classes=['prodn-row']) - entry = nodes.inline(classes=['prodn-cell-nonterminal']) + row = nodes.container(classes=['prodn-row']) + entry = nodes.container(classes=['prodn-cell-nonterminal']) if lhs != "": target_name = 'grammar-token-' + nodes.make_id(lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) @@ -537,17 +541,21 @@ class ProductionObject(CoqObject): entry += inline entry += notation_to_sphinx('@'+lhs, *position) else: - entry += nodes.literal('', '') + entry += nodes.Text('') row += entry - entry = nodes.inline(classes=['prodn-cell-op']) - entry += nodes.literal(op, op) + entry = nodes.container(classes=['prodn-cell-op']) + entry += nodes.Text(op) row += entry - entry = nodes.inline(classes=['prodn-cell-production']) + entry = nodes.container(classes=['prodn-cell-production']) entry += notation_to_sphinx(rhs, *position) row += entry + entry = nodes.container(classes=['prodn-cell-tag']) + entry += nodes.Text(tag) + row += entry + tbody += row return [indexnode, table] # only this node goes into the doc diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 2d29743d78..14f87e5885 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -37,13 +37,16 @@ for documentation purposes: 1. The tool reads all the `mlg` files and generates `fullGrammar`, which includes all the grammar without the actions for each production or the OCaml code. This file is provided as a convenience to make it easier to examine the (mostly) - unprocessed grammar of the mlg files with less clutter. Nonterminals that use - levels (`"5" RIGHTA` below) are modified, for example: + unprocessed grammar of the mlg files with less clutter. This step includes two + transformations that rename some nonterminal symbols: + + First, nonterminals that use levels (`"5" RIGHTA` below) are modified, for example: ``` tactic_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] + [ "4" ... ``` becomes @@ -55,6 +58,17 @@ for documentation purposes: ] ``` + Second, nonterminals that are local to an .mlg will be renamed, if necessary, to + make them unique. For example, `strategy_level` is defined as a local nonterminal + in both `g_prim.mlg` and in `extraargs.mlg`. The nonterminal defined in the former + remains `strategy_level` because it happens to be processed before the latter, + in which the nonterminal is renamed to `EXTRAARGS_strategy_level` to make the local + symbol unique. + + Nonterminals listed after `GLOBAL:` are global; otherwise they are local. + + References to renamed symbols are updated with the modified names. + 2. The tool applies grammar editing operations specified by `common.edit_mlg` to generate `editedGrammar`. @@ -227,9 +241,22 @@ to the grammar. The end of the existing `prodn` is recognized by a blank line. -### Other details +### Tagging productions + +`doc_grammar` tags the origin of productions from plugins that aren't automatically +loaded. In grammar files, they appear as `(* XXX plugin *)`. In rsts, productions +generated by `.. insertprodn` will include where relevant three spaces as (a delimiter) +and a tag name after each production, which Sphinx will show on the far right-hand side +of the production. + +The origin of a production can be specified explicitly in `common.edit_mlg` with the +`TAG name` appearing at the end of a production. `name` must be in quotes if it +contains whitespace characters. Some edit operations preserve the +tags, but others, such as `REPLACE ... WITH ...` do not. + +A mapping from filenames to tags (e.g. "g_ltac2.mlg" is "Ltac2") is hard-coded as is +filtering to avoid showing tags for, say, Ltac2 productions from appearing on every +production in that chapter. -The output identifies productions from plugins that aren't automatically loaded with -`(* XXX plugin *)` in grammar files and with `(XXX plugin)` in productionlists. If desired, this mechanism could be extended to tag certain productions as deprecated, perhaps in conjunction with a coqpp change. diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 80f825358f..6625e07d05 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -12,19 +12,98 @@ DOC_GRAMMAR +(* first, fixup symbols duplicated across files *) +lglob: [ +| lconstr +| DELETE EXTRAARGS_lconstr +] + +hint: [ +| "Extern" natural OPT constr_pattern "=>" tactic +] + +(* todo: does ARGUMENT EXTEND make the symbol global? It is in both extraargs and extratactics *) +strategy_level_or_var: [ +| DELETE EXTRAARGS_strategy_level +| strategy_level +] + +operconstr0: [ +| "ltac" ":" "(" tactic_expr5 ")" +] + +EXTRAARGS_natural: [ | DELETENT ] +EXTRAARGS_lconstr: [ | DELETENT ] +EXTRAARGS_strategy_level: [ | DELETENT ] +G_LTAC_hint: [ | DELETENT ] +G_LTAC_operconstr0: [ | DELETENT ] + +G_REWRITE_binders: [ +| DELETE Pcoq.Constr.binders +| binders +] + +G_TACTIC_in_clause: [ +| in_clause +| MOVEALLBUT in_clause +| in_clause +] + +SPLICE: [ +| G_REWRITE_binders +| G_TACTIC_in_clause +] + +RENAME: [ +| G_LTAC2_delta_flag ltac2_delta_flag +| G_LTAC2_strategy_flag ltac2_strategy_flag +| G_LTAC2_binder ltac2_binder +| G_LTAC2_branches ltac2_branches +| G_LTAC2_let_clause ltac2_let_clause +| G_LTAC2_tactic_atom ltac2_tactic_atom +| G_LTAC2_rewriter ltac2_rewriter +| G_LTAC2_constr_with_bindings ltac2_constr_with_bindings +| G_LTAC2_match_rule ltac2_match_rule +| G_LTAC2_match_pattern ltac2_match_pattern +| G_LTAC2_intropatterns ltac2_intropatterns +| G_LTAC2_simple_intropattern ltac2_simple_intropattern +| G_LTAC2_simple_intropattern_closed ltac2_simple_intropattern_closed +| G_LTAC2_or_and_intropattern ltac2_or_and_intropattern +| G_LTAC2_equality_intropattern ltac2_equality_intropattern +| G_LTAC2_naming_intropattern ltac2_naming_intropattern +| G_LTAC2_destruction_arg ltac2_destruction_arg +| G_LTAC2_with_bindings ltac2_with_bindings +| G_LTAC2_bindings ltac2_bindings +| G_LTAC2_simple_binding ltac2_simple_binding +| G_LTAC2_in_clause ltac2_in_clause +| G_LTAC2_occs ltac2_occs +| G_LTAC2_occs_nums ltac2_occs_nums +| G_LTAC2_concl_occ ltac2_concl_occ +| G_LTAC2_hypident_occ ltac2_hypident_occ +| G_LTAC2_hypident ltac2_hypident +| G_LTAC2_induction_clause ltac2_induction_clause +| G_LTAC2_as_or_and_ipat ltac2_as_or_and_ipat +| G_LTAC2_eqn_ipat ltac2_eqn_ipat +| G_LTAC2_conversion ltac2_conversion +| G_LTAC2_oriented_rewriter ltac2_oriented_rewriter +| G_LTAC2_tactic_then_gen ltac2_tactic_then_gen +| G_LTAC2_tactic_then_last ltac2_tactic_then_last +| G_LTAC2_as_name ltac2_as_name +| G_LTAC2_as_ipat ltac2_as_ipat +| G_LTAC2_by_tactic ltac2_by_tactic +| G_LTAC2_match_list ltac2_match_list +] + (* renames to eliminate qualified names put other renames at the end *) RENAME: [ (* map missing names for rhs *) | Constr.constr term -| Constr.constr_pattern constr_pattern | Constr.global global | Constr.lconstr lconstr | Constr.lconstr_pattern cpattern | G_vernac.query_command query_command | G_vernac.section_subset_expr section_subset_expr -| Pltac.tactic tactic -| Pltac.tactic_expr tactic_expr5 | Prim.ident ident | Prim.reference reference | Pvernac.Vernac_.main_entry vernac_control @@ -69,6 +148,8 @@ DELETE: [ | test_name_colon | test_pipe_closedcurly | ensure_fixannot +| test_array_opening +| test_array_closing (* SSR *) (* | ssr_null_entry *) @@ -125,6 +206,26 @@ tactic_then_last: [ | OPTINREF ] +ltac2_tactic_then_last: [ +| REPLACE "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) +| WITH LIST0 ( "|" OPT tac2expr6 ) TAG Ltac2 +] + +ltac2_goal_tactics: [ +| LIST0 ( OPT tac2expr6 ) SEP "|" TAG Ltac2 +] + +ltac2_tactic_then_gen: [ | DELETENT ] + +ltac2_tactic_then_gen: [ +| ltac2_goal_tactics TAG Ltac2 +| OPT ( ltac2_goal_tactics "|" ) OPT tac2expr6 ".." OPT ( "|" ltac2_goal_tactics ) TAG Ltac2 +] + +ltac2_tactic_then_last: [ +| OPTINREF +] + reference: [ | DELETENT ] reference: [ @@ -155,15 +256,6 @@ dirpath: [ | WITH LIST0 ( ident "." ) ident ] -binders: [ -| DELETE Pcoq.Constr.binders (* todo: not sure why there are 2 "binders:" *) -] - -lconstr: [ -| DELETE l_constr -] - - let_type_cstr: [ | DELETE OPT [ ":" lconstr ] | type_cstr @@ -309,6 +401,8 @@ operconstr0: [ | MOVETO term_generalizing "`{" operconstr200 "}" | MOVETO term_generalizing "`(" operconstr200 ")" | MOVETO term_ltac "ltac" ":" "(" tactic_expr5 ")" +| REPLACE "[" "|" array_elems "|" lconstr type_cstr "|" "]" univ_instance +| WITH "[|" array_elems "|" lconstr type_cstr "|]" univ_instance ] fix_decls: [ @@ -551,9 +645,28 @@ delta_flag: [ | OPTINREF ] +ltac2_delta_flag: [ +| EDIT ADD_OPT "-" "[" refglobals "]" (* Ltac2 plugin *) +] + +ltac2_branches: [ +| EDIT ADD_OPT "|" LIST1 branch SEP "|" (* Ltac2 plugin *) +| OPTINREF +] + +RENAME: [ +| red_flag ltac2_red_flag +| red_flags red_flag +] + +RENAME: [ +] + strategy_flag: [ | REPLACE OPT delta_flag | WITH delta_flag +(*| REPLACE LIST1 red_flags +| WITH LIST1 red_flag*) | (* empty *) | OPTINREF ] @@ -841,7 +954,7 @@ simple_tactic: [ | DELETE "autorewrite" "with" LIST1 preident clause "using" tactic | DELETE "autorewrite" "*" "with" LIST1 preident clause | REPLACE "autorewrite" "*" "with" LIST1 preident clause "using" tactic -| WITH "autorewrite" OPT "*" "with" LIST1 preident clause_dft_concl OPT ( "using" tactic ) +| WITH "autorewrite" OPT "*" "with" LIST1 preident clause OPT ( "using" tactic ) | DELETE "cofix" ident | REPLACE "cofix" ident "with" LIST1 cofixdecl | WITH "cofix" ident OPT ( "with" LIST1 cofixdecl ) @@ -900,7 +1013,7 @@ simple_tactic: [ | DELETE "replace" "->" uconstr clause | DELETE "replace" "<-" uconstr clause | DELETE "replace" uconstr clause -| "replace" orient uconstr clause_dft_concl (* todo: fix '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 ) | DELETE "rewrite" "*" orient uconstr "in" hyp by_arg_tac @@ -1163,6 +1276,7 @@ command: [ | REPLACE "String" "Notation" reference reference reference ":" ident | WITH "String" "Notation" reference reference reference ":" scope_name +| DELETE "Ltac2" ltac2_entry (* was split up *) ] option_setting: [ @@ -1180,14 +1294,10 @@ syntax: [ | WITH "Undelimit" "Scope" scope_name | REPLACE "Bind" "Scope" IDENT; "with" LIST1 class_rawexpr | WITH "Bind" "Scope" scope_name; "with" LIST1 class_rawexpr -| REPLACE "Infix" ne_lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] -| WITH "Infix" ne_lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] -| REPLACE "Notation" lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] -| WITH "Notation" lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] -| REPLACE "Reserved" "Infix" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] -| WITH "Reserved" "Infix" ne_lstring OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] -| REPLACE "Reserved" "Notation" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] -| WITH "Reserved" "Notation" ne_lstring OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] +| REPLACE "Infix" ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] +| WITH "Infix" ne_lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] +| REPLACE "Notation" lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] +| WITH "Notation" lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] ] syntax_modifier: [ @@ -1458,8 +1568,33 @@ by_tactic: [ ] rewriter: [ -| REPLACE [ "?" | LEFTQMARK ] constr_with_bindings_arg -| WITH "?" constr_with_bindings_arg +| DELETE "!" constr_with_bindings_arg +| DELETE [ "?" | LEFTQMARK ] constr_with_bindings_arg +| DELETE natural "!" constr_with_bindings_arg +| DELETE natural [ "?" | LEFTQMARK ] constr_with_bindings_arg +| DELETE natural constr_with_bindings_arg +| DELETE constr_with_bindings_arg +| OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg +] + +ltac2_rewriter: [ +| DELETE "!" ltac2_constr_with_bindings (* Ltac2 plugin *) +| DELETE [ "?" | LEFTQMARK ] ltac2_constr_with_bindings +| DELETE lnatural "!" ltac2_constr_with_bindings (* Ltac2 plugin *) +| DELETE lnatural [ "?" | LEFTQMARK ] ltac2_constr_with_bindings +| DELETE lnatural ltac2_constr_with_bindings (* Ltac2 plugin *) +| DELETE ltac2_constr_with_bindings (* Ltac2 plugin *) +| OPT natural OPT [ "?" | "!" ] ltac2_constr_with_bindings +] + +tac2expr0: [ +| DELETE "(" ")" +] + +tac2type_body: [ +| REPLACE ":=" tac2typ_knd (* Ltac2 plugin *) +| WITH [ ":=" | "::=" ] tac2typ_knd TAG Ltac2 +| DELETE "::=" tac2typ_knd (* Ltac2 plugin *) ] intropattern_or_list_or: [ @@ -1525,6 +1660,12 @@ in_clause: [ | DELETE LIST0 hypident_occ SEP "," ] +ltac2_in_clause: [ +| REPLACE LIST0 ltac2_hypident_occ SEP "," "|-" ltac2_concl_occ (* Ltac2 plugin *) +| WITH LIST0 ltac2_hypident_occ SEP "," OPT ( "|-" ltac2_concl_occ ) TAG Ltac2 +| DELETE LIST0 ltac2_hypident_occ SEP "," (* Ltac2 plugin *) +] + concl_occ: [ | OPTINREF ] @@ -1597,8 +1738,12 @@ by_notation: [ ] decl_notation: [ -| REPLACE ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] -| WITH ne_lstring ":=" constr only_parsing OPT [ ":" scope_name ] +| REPLACE ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] +| WITH ne_lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] +] + +syntax_modifiers: [ +| OPTINREF ] @@ -1636,6 +1781,15 @@ tactic_mode: [ | DELETE command ] +sexpr: [ +| REPLACE syn_node (* Ltac2 plugin *) +| WITH name TAG Ltac2 +| REPLACE syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) +| WITH name "(" LIST1 sexpr SEP "," ")" TAG Ltac2 +] + +syn_node: [ | DELETENT ] + RENAME: [ | toplevel_selector toplevel_selector_temp ] @@ -1754,9 +1908,24 @@ tactic_value: [ | [ value_tactic | syn_value ] ] + +(* defined in Ltac2/Notations.v *) + +ltac2_match_key: [ +| "lazy_match!" +| "match!" +| "multi_match!" +] + +ltac2_constructs: [ +| ltac2_match_key tac2expr6 "with" ltac2_match_list "end" +| ltac2_match_key OPT "reverse" "goal" "with" gmatch_list "end" +] + simple_tactic: [ | ltac_builtins | ltac_constructs +| ltac2_constructs | ltac_defined_tactics | tactic_notation_tactics ] @@ -1767,6 +1936,24 @@ tacdef_body: [ | DELETE global ltac_def_kind tactic_expr5 ] +tac2def_typ: [ +| REPLACE "Type" rec_flag LIST1 tac2typ_def SEP "with" (* Ltac2 plugin *) +| WITH "Type" rec_flag tac2typ_def LIST0 ( "with" tac2typ_def ) TAG Ltac2 +] + +tac2def_val: [ +| REPLACE mut_flag rec_flag LIST1 tac2def_body SEP "with" (* Ltac2 plugin *) +| WITH mut_flag rec_flag tac2def_body LIST0 ( "with" tac2def_body ) TAG Ltac1 +] + +tac2alg_constructors: [ +| REPLACE "|" LIST1 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +| WITH OPT "|" LIST1 tac2alg_constructor SEP "|" TAG Ltac2 +| DELETE LIST0 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +| (* empty *) +| OPTINREF +] + SPLICE: [ | def_token | extended_def_token @@ -1792,7 +1979,233 @@ logical_kind: [ | [ "Field" | "Method" ] ] +(* ltac2 *) + +DELETE: [ +| test_ltac1_env +] + +mut_flag: [ +| OPTINREF +] + +rec_flag: [ +| OPTINREF +] + +ltac2_orient: [ | DELETENT ] + +ltac2_orient: [ +| orient +] + SPLICE: [ +| ltac2_orient +] + +tac2typ_prm: [ +| OPTINREF +] + +tac2type_body: [ +| OPTINREF +] + +atomic_tac2pat: [ +| OPTINREF +] + +tac2expr0: [ +(* +| DELETE "(" ")" (* covered by "()" prodn *) +| REPLACE "{" [ | LIST1 tac2rec_fieldexpr OPT ";" ] "}" +| WITH "{" OPT ( LIST1 tac2rec_fieldexpr OPT ";" ) "}" +*) +] + +(* todo: should +| tac2pat1 "," LIST0 tac2pat1 SEP "," +use LIST1? *) + +SPLICE: [ +| tac2expr4 +] + +tac2expr3: [ +| REPLACE tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) +| WITH LIST1 tac2expr2 SEP "," TAG Ltac2 +| DELETE tac2expr2 (* Ltac2 plugin *) +] + +tac2rec_fieldexprs: [ +| DELETE tac2rec_fieldexpr ";" tac2rec_fieldexprs +| DELETE tac2rec_fieldexpr ";" +| DELETE tac2rec_fieldexpr +| LIST1 tac2rec_fieldexpr OPT ";" +| OPTINREF +] + +tac2rec_fields: [ +| DELETE tac2rec_field ";" tac2rec_fields +| DELETE tac2rec_field ";" +| DELETE tac2rec_field +| LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 +| OPTINREF +] + +(* todo: weird productions, ints only after an initial "-"??: + occs_nums: [ + | LIST1 [ num | ident ] + | "-" [ num | ident ] LIST0 int_or_var +*) +ltac2_occs_nums: [ +| DELETE LIST1 nat_or_anti (* Ltac2 plugin *) +| REPLACE "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) +| WITH OPT "-" LIST1 nat_or_anti TAG Ltac2 +] + +syn_level: [ +| OPTINREF +] + +ltac2_delta_flag: [ +| OPTINREF +] + +ltac2_occs: [ +| OPTINREF +] + +ltac2_concl_occ: [ +| OPTINREF +] + +ltac2_with_bindings: [ +| OPTINREF +] + +ltac2_as_or_and_ipat: [ +| OPTINREF +] + +ltac2_eqn_ipat: [ +| OPTINREF +] + +ltac2_as_name: [ +| OPTINREF +] + +ltac2_as_ipat: [ +| OPTINREF +] + +ltac2_by_tactic: [ +| OPTINREF +] + +ltac2_entry: [ +| REPLACE tac2def_typ (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_typ +| REPLACE tac2def_syn (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_syn +| REPLACE tac2def_mut (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_mut +| REPLACE tac2def_val (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_val +| REPLACE tac2def_ext (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_ext +| "Ltac2" "Notation" [ string | lident ] ":=" tac2expr6 TAG Ltac2 (* variant *) +| MOVEALLBUT command +(* todo: MOVEALLBUT should ignore tag on "but" prodns *) +] + +ltac2_match_list: [ +| EDIT ADD_OPT "|" LIST1 ltac2_match_rule SEP "|" (* Ltac2 plugin *) +] + +ltac2_or_and_intropattern: [ +| DELETE "(" ltac2_simple_intropattern ")" (* Ltac2 plugin *) +| REPLACE "(" ltac2_simple_intropattern "," LIST1 ltac2_simple_intropattern SEP "," ")" (* Ltac2 plugin *) +| WITH "(" LIST1 ltac2_simple_intropattern SEP "," ")" TAG Ltac2 +| REPLACE "(" ltac2_simple_intropattern "&" LIST1 ltac2_simple_intropattern SEP "&" ")" (* Ltac2 plugin *) +| WITH "(" LIST1 ltac2_simple_intropattern SEP "&" ")" TAG Ltac2 +] + +SPLICE: [ +| tac2def_val +| tac2def_typ +| tac2def_ext +| tac2def_syn +| tac2def_mut +| mut_flag +| rec_flag +| locident +| syn_level +| tac2rec_fieldexprs +| tac2type_body +| tac2alg_constructors +| tac2rec_fields +| ltac2_binder +| branch +| anti +] + +tac2expr5: [ +| REPLACE "let" OPT "rec" LIST1 ltac2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) +| WITH "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" tac2expr6 TAG Ltac2 +| MOVETO simple_tactic "match" tac2expr5 "with" OPT ltac2_branches "end" (* Ltac2 plugin *) +| DELETE simple_tactic +] + +RENAME: [ +| Prim.string string +| Prim.integer int +| Prim.qualid qualid +| Prim.natural num +] + +gmatch_list: [ +| EDIT ADD_OPT "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) +] + +ltac2_quotations: [ + +] + +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 "reference" ":" "(" globref ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +] + +(* non-Ltac2 "clause" is really clause_dft_concl + there is an ltac2 "clause" *) +ltac2_clause: [ ] + +clause: [ +| MOVEALLBUT ltac2_clause +] + +clause: [ +| clause_dft_concl +] + +q_clause: [ +| REPLACE clause +| WITH ltac2_clause TAG Ltac2 +] + +ltac2_induction_clause: [ +| REPLACE ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT clause (* Ltac2 plugin *) +| WITH ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT ltac2_clause TAG Ltac2 +] + +SPLICE: [ +| clause | noedit_mode | bigint | match_list @@ -1808,6 +2221,7 @@ SPLICE: [ | pattern_ident | constr_eval (* splices as multiple prods *) | tactic_then_last (* todo: dependency on c.edit_mlg edit?? really useful? *) +| ltac2_tactic_then_last | Prim.name | ltac_selector | Constr.ident @@ -1962,7 +2376,6 @@ SPLICE: [ | search_where | message_token | input_fun -| tactic_then_last | ltac_use_default | toplevel_selector_temp | comment @@ -1970,14 +2383,24 @@ SPLICE: [ | match_context_rule | match_rule | by_notation +| lnatural +| nat_or_anti +| globref +| let_binder +| refglobals (* Ltac2 *) +| syntax_modifiers +| array_elems +| ltac2_expr +| G_LTAC2_input_fun +| ltac2_simple_intropattern_closed +| ltac2_with_bindings ] (* end SPLICE *) RENAME: [ -| clause clause_dft_concl - | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) | tactic0 ltac_expr0 (* todo: can't figure out how this gets mapped by coqpp *) +| ltac1_expr ltac_expr | tactic_expr5 ltac_expr | tactic_expr4 ltac_expr4 | tactic_expr3 ltac_expr3 @@ -1998,6 +2421,7 @@ RENAME: [ | ssexpr35 ssexpr (* strange in mlg, ssexpr50 is after this *) | tactic_then_gen for_each_goal +| ltac2_tactic_then_gen ltac2_for_each_goal | selector_body selector | match_hyps match_hyp @@ -2029,6 +2453,20 @@ RENAME: [ | numnotoption numeral_modifier | tactic_arg_compat tactic_arg | lconstr_pattern cpattern +| Pltac.tactic ltac_expr +| sexpr ltac2_scope +| tac2type5 ltac2_type +| tac2type2 ltac2_type2 +| tac2type1 ltac2_type1 +| tac2type0 ltac2_type0 +| typ_param ltac2_typevar +| tac2expr6 ltac2_expr +| tac2expr5 ltac2_expr5 +| tac2expr3 ltac2_expr3 +| tac2expr2 ltac2_expr2 +| tac2expr1 ltac2_expr1 +| tac2expr0 ltac2_expr0 +| gmatch_list goal_match_list ] simple_tactic: [ @@ -2050,6 +2488,7 @@ SPLICE: [ | command_entry | ltac_builtins | ltac_constructs +| ltac2_constructs | ltac_defined_tactics | tactic_notation_tactics ] @@ -2064,12 +2503,47 @@ NOTINRSTS: [ | simple_tactic | REACHABLE | NOTINRSTS +| l1_tactic +| l2_tactic +| l3_tactic +| binder_tactic +| value_tactic +| ltac2_entry +(* ltac2 syntactic classes *) +| q_intropatterns +| q_intropattern +| q_ident +| q_destruction_arg +| q_with_bindings +| q_bindings +| q_strategy_flag +| q_reference +| q_clause +| q_occurrences +| q_induction_clause +| q_conversion +| q_rewriting +| q_dispatch +| q_hintdb +| q_move_location +| q_pose +| q_assert +| q_constr_matching +| q_goal_matching + +(* todo: figure these out +(*Warning: editedGrammar: Undefined symbol 'ltac1_expr' *) +| dangling_pattern_extension_rule +| vernac_aux +| subprf +| tactic_mode +| tac2expr_in_env (* no refs *) +| tac2mode (* no refs *) +| ltac_use_default (* from tac2mode *) +| tacticals +*) ] REACHABLE: [ | NOTINRSTS ] - -strategy_level: [ -| DELETE strategy_level0 -] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 33c4bd3e01..0ac652c0db 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -82,6 +82,138 @@ type gram = { order: string list; } + +(*** Print routines ***) + +let sprintf = Printf.sprintf + +let map_and_concat f ?(delim="") l = + String.concat delim (List.map f l) + +let rec db_output_prodn = function + | Sterm s -> sprintf "(Sterm %s) " s + | Snterm s -> sprintf "(Snterm %s) " s + | Slist1 sym -> sprintf "(Slist1 %s) " (db_output_prodn sym) + | Slist1sep (sym, sep) -> sprintf "(Slist1sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) + | Slist0 sym -> sprintf "(Slist0 %s) " (db_output_prodn sym) + | Slist0sep (sym, sep) -> sprintf "(Slist0sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) + | Sopt sym -> sprintf "(Sopt %s) " (db_output_prodn sym) + | Sparen prod -> sprintf "(Sparen %s) " (db_out_list prod) + | Sprod prods -> sprintf "(Sprod %s) " (db_out_prods prods) + | Sedit s -> sprintf "(Sedit %s) " s + | Sedit2 (s, s2) -> sprintf "(Sedit2 %s %s) " s s2 +and db_out_list prod = sprintf "(%s)" (map_and_concat db_output_prodn prod) +and db_out_prods prods = sprintf "( %s )" (map_and_concat ~delim:" | " db_out_list prods) + +(* identify special chars that don't get a trailing space in output *) +let omit_space s = List.mem s ["?"; "."; "#"] + +let rec output_prod plist need_semi = function + | Sterm s -> if plist then sprintf "%s" s else sprintf "\"%s\"" s + | Snterm s -> + if plist then sprintf "`%s`" s else + sprintf "%s%s" s (if s = "IDENT" && need_semi then ";" else "") + | Slist1 sym -> sprintf "LIST1 %s" (prod_to_str ~plist [sym]) + | Slist1sep (sym, sep) -> sprintf "LIST1 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) + | Slist0 sym -> sprintf "LIST0 %s" (prod_to_str ~plist [sym]) + | Slist0sep (sym, sep) -> sprintf "LIST0 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) + | Sopt sym -> sprintf "OPT %s" (prod_to_str ~plist [sym]) + | Sparen sym_list -> sprintf "( %s )" (prod_to_str sym_list) + | Sprod sym_list_list -> + sprintf "[ %s ]" (String.concat " " (List.mapi (fun i r -> + let prod = (prod_to_str r) in + let sep = if i = 0 then "" else + if prod <> "" then "| " else "|" in + sprintf "%s%s" sep prod) + sym_list_list)) + | Sedit s -> sprintf "%s" s + (* todo: make TAG info output conditional on the set of prods? *) + | Sedit2 ("TAG", plugin) -> + if plist then + sprintf " (%s plugin)" plugin + else + sprintf " (* %s plugin *)" plugin + | Sedit2 ("FILE", file) -> + let file_suffix_regex = Str.regexp ".*/\\([a-zA-Z0-9_\\.]+\\)" in + let suffix = if Str.string_match file_suffix_regex file 0 then Str.matched_group 1 file else file in + if plist then + sprintf " (%s)" suffix + else + sprintf " (* %s *)" suffix + | Sedit2 (s, s2) -> sprintf "%s \"%s\"" s s2 + +and prod_to_str_r plist prod = + match prod with + | Sterm s :: Snterm "ident" :: tl when omit_space s && plist -> + (sprintf "%s`ident`" s) :: (prod_to_str_r plist tl) + | p :: tl -> + let need_semi = + match prod with + | Snterm "IDENT" :: Sterm _ :: _ + | Snterm "IDENT" :: Sprod _ :: _ -> true + | _ -> false in + (output_prod plist need_semi p) :: (prod_to_str_r plist tl) + | [] -> [] + +and prod_to_str ?(plist=false) prod = + String.concat " " (prod_to_str_r plist prod) + +(* Determine if 2 productions are equal ignoring Sedit and Sedit2 *) +let ematch prod edit = + let rec ematchr prod edit = + (*Printf.printf "%s and\n %s\n\n" (prod_to_str prod) (prod_to_str edit);*) + match (prod, edit) with + | (_, Sedit _ :: tl) + | (_, Sedit2 _ :: tl) + -> ematchr prod tl + | (Sedit _ :: tl, _) + | (Sedit2 _ :: tl, _) + -> ematchr tl edit + | (phd :: ptl, hd :: tl) -> + let m = match (phd, hd) with + | (Slist1 psym, Slist1 sym) + | (Slist0 psym, Slist0 sym) + | (Sopt psym, Sopt sym) + -> ematchr [psym] [sym] + | (Slist1sep (psym, psep), Slist1sep (sym, sep)) + | (Slist0sep (psym, psep), Slist0sep (sym, sep)) + -> ematchr [psym] [sym] && ematchr [psep] [sep] + | (Sparen psyml, Sparen syml) + -> ematchr psyml syml + | (Sprod psymll, Sprod symll) -> + if List.compare_lengths psymll symll != 0 then false + else + List.fold_left (&&) true (List.map2 ematchr psymll symll) + | _, _ -> phd = hd + in + m && ematchr ptl tl + | ([], hd :: tl) -> false + | (phd :: ptl, []) -> false + | ([], []) -> true +in + (*Printf.printf "\n";*) + let rv = ematchr prod edit in + (*Printf.printf "%b\n" rv;*) + rv + +let get_first m_prod prods = + let rec find_first_r prods i = + match prods with + | [] -> + raise Not_found + | prod :: tl -> + if ematch prod m_prod then i + else find_first_r tl (i+1) + in + find_first_r prods 0 + +let find_first edit prods nt = + try + get_first edit prods + with Not_found -> + error "Can't find '%s' in edit for '%s'\n" (prod_to_str edit) nt; + raise Not_found + module DocGram = struct (* these guarantee that order and map have a 1-1 relationship on the nt name. They don't guarantee that nts on rhs of a production @@ -90,6 +222,8 @@ module DocGram = struct exception Duplicate exception Invalid + let g_empty () = ref { map = NTMap.empty; order = [] } + (* add an nt at the end (if not already present) then set its prods *) let g_maybe_add g nt prods = if not (NTMap.mem nt !g.map) then @@ -167,81 +301,6 @@ module DocGram = struct end open DocGram -(*** Print routines ***) - -let sprintf = Printf.sprintf - -let map_and_concat f ?(delim="") l = - String.concat delim (List.map f l) - -let rec db_output_prodn = function - | Sterm s -> sprintf "(Sterm %s) " s - | Snterm s -> sprintf "(Snterm %s) " s - | Slist1 sym -> sprintf "(Slist1 %s) " (db_output_prodn sym) - | Slist1sep (sym, sep) -> sprintf "(Slist1sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) - | Slist0 sym -> sprintf "(Slist0 %s) " (db_output_prodn sym) - | Slist0sep (sym, sep) -> sprintf "(Slist0sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) - | Sopt sym -> sprintf "(Sopt %s) " (db_output_prodn sym) - | Sparen prod -> sprintf "(Sparen %s) " (db_out_list prod) - | Sprod prods -> sprintf "(Sprod %s) " (db_out_prods prods) - | Sedit s -> sprintf "(Sedit %s) " s - | Sedit2 (s, s2) -> sprintf "(Sedit2 %s %s) " s s2 -and db_out_list prod = sprintf "(%s)" (map_and_concat db_output_prodn prod) -and db_out_prods prods = sprintf "( %s )" (map_and_concat ~delim:" | " db_out_list prods) - -(* identify special chars that don't get a trailing space in output *) -let omit_space s = List.mem s ["?"; "."; "#"] - -let rec output_prod plist need_semi = function - | Sterm s -> if plist then sprintf "%s" s else sprintf "\"%s\"" s - | Snterm s -> - if plist then sprintf "`%s`" s else - sprintf "%s%s" s (if s = "IDENT" && need_semi then ";" else "") - | Slist1 sym -> sprintf "LIST1 %s" (prod_to_str ~plist [sym]) - | Slist1sep (sym, sep) -> sprintf "LIST1 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) - | Slist0 sym -> sprintf "LIST0 %s" (prod_to_str ~plist [sym]) - | Slist0sep (sym, sep) -> sprintf "LIST0 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) - | Sopt sym -> sprintf "OPT %s" (prod_to_str ~plist [sym]) - | Sparen sym_list -> sprintf "( %s )" (prod_to_str sym_list) - | Sprod sym_list_list -> - sprintf "[ %s ]" (String.concat " " (List.mapi (fun i r -> - let prod = (prod_to_str r) in - let sep = if i = 0 then "" else - if prod <> "" then "| " else "|" in - sprintf "%s%s" sep prod) - sym_list_list)) - | Sedit s -> sprintf "%s" s - (* todo: make PLUGIN info output conditional on the set of prods? *) - | Sedit2 ("PLUGIN", plugin) -> - if plist then - sprintf " (%s plugin)" plugin - else - sprintf " (* %s plugin *)" plugin - | Sedit2 ("FILE", file) -> - let file_suffix_regex = Str.regexp ".*/\\([a-zA-Z0-9_\\.]+\\)" in - let suffix = if Str.string_match file_suffix_regex file 0 then Str.matched_group 1 file else file in - if plist then - sprintf " (%s)" suffix - else - sprintf " (* %s *)" suffix - | Sedit2 (s, s2) -> sprintf "%s \"%s\"" s s2 - -and prod_to_str_r plist prod = - match prod with - | Sterm s :: Snterm "ident" :: tl when omit_space s && plist -> - (sprintf "%s`ident`" s) :: (prod_to_str_r plist tl) - | p :: tl -> - let need_semi = - match prod with - | Snterm "IDENT" :: Sterm _ :: _ - | Snterm "IDENT" :: Sprod _ :: _ -> true - | _ -> false in - (output_prod plist need_semi p) :: (prod_to_str_r plist tl) - | [] -> [] - -and prod_to_str ?(plist=false) prod = - String.concat " " (prod_to_str_r plist prod) - let rec output_prodn = function | Sterm s -> @@ -275,7 +334,7 @@ let rec output_prodn = function sym_list)) rcurly | Sedit s -> sprintf "%s" s - | Sedit2 ("PLUGIN", s2) -> "" + | Sedit2 ("TAG", s2) -> "" | Sedit2 (s, s2) -> sprintf "%s \"%s\"" s s2 and output_sep sep = @@ -292,6 +351,16 @@ and prod_to_prodn_r prod = and prod_to_prodn prod = String.concat " " (prod_to_prodn_r prod) +let get_tag file prod = + List.fold_left (fun rv sym -> + match sym with + (* todo: temporarily limited to Ltac2 tags in prodn when not in ltac2.rst *) + | Sedit2 ("TAG", s2) + when (s2 = "Ltac2" || s2 = "not Ltac2") && + file <> "doc/sphinx/proof-engine/ltac2.rst" -> " " ^ s2 + | _ -> rv + ) "" prod + let pr_prods nt prods = (* duplicative *) Printf.printf "%s: [\n" nt; List.iter (fun prod -> @@ -397,6 +466,10 @@ and cvt_gram_sym_list l = (Sedit2 ("NOTE", s2)) :: cvt_gram_sym_list tl | GSymbQualid ("USE_NT", _) :: GSymbQualid (s2, l) :: tl -> (Sedit2 ("USE_NT", s2)) :: cvt_gram_sym_list tl + | GSymbQualid ("TAG", _) :: GSymbQualid (s2, l) :: tl -> + (Sedit2 ("TAG", s2)) :: cvt_gram_sym_list tl + | GSymbQualid ("TAG", _) :: GSymbString (s2) :: tl -> + (Sedit2 ("TAG", s2)) :: cvt_gram_sym_list tl | GSymbString s :: tl -> (* todo: not seeing "(bfs)" here for some reason *) keywords := StringSet.add s !keywords; @@ -474,59 +547,36 @@ let autoloaded_mlgs = [ (* in the order they are loaded by Coq *) ] -let ematch prod edit = - let rec ematchr prod edit = - (*Printf.printf "%s and\n %s\n\n" (prod_to_str prod) (prod_to_str edit);*) - match (prod, edit) with - | (_, Sedit _ :: tl) - | (_, Sedit2 _ :: tl) - -> ematchr prod tl - | (Sedit _ :: tl, _) - | (Sedit2 _ :: tl, _) - -> ematchr tl edit - | (phd :: ptl, hd :: tl) -> - let m = match (phd, hd) with - | (Slist1 psym, Slist1 sym) - | (Slist0 psym, Slist0 sym) - | (Sopt psym, Sopt sym) - -> ematchr [psym] [sym] - | (Slist1sep (psym, psep), Slist1sep (sym, sep)) - | (Slist0sep (psym, psep), Slist0sep (sym, sep)) - -> ematchr [psym] [sym] && ematchr [psep] [sep] - | (Sparen psyml, Sparen syml) - -> ematchr psyml syml - | (Sprod psymll, Sprod symll) -> - if List.compare_lengths psymll symll != 0 then false - else - List.fold_left (&&) true (List.map2 ematchr psymll symll) - | _, _ -> phd = hd - in - m && ematchr ptl tl - | ([], hd :: tl) -> false - | (phd :: ptl, []) -> false - | ([], []) -> true -in - (*Printf.printf "\n";*) - let rv = ematchr prod edit in - (*Printf.printf "%b\n" rv;*) - rv - let has_match p prods = List.exists (fun p2 -> ematch p p2) prods let plugin_regex = Str.regexp "^plugins/\\([a-zA-Z0-9_]+\\)/" let level_regex = Str.regexp "[a-zA-Z0-9_]*$" -let read_mlg is_edit ast file level_renames symdef_map = +let get_plugin_name file = + if file = "user-contrib/Ltac2/g_ltac2.mlg" then + "Ltac2" + else if Str.string_match plugin_regex file 0 then + Str.matched_group 1 file + else + "" + +let read_mlg g is_edit ast file level_renames symdef_map = let res = ref [] in let locals = ref StringSet.empty in + let dup_renames = ref StringMap.empty in let add_prods nt prods = if not is_edit then + if NTMap.mem nt !g.map && nt <> "command" && nt <> "simple_tactic" then begin + let new_name = String.uppercase_ascii (Filename.remove_extension (Filename.basename file)) ^ "_" ^ nt in + dup_renames := StringMap.add nt new_name !dup_renames; + Printf.printf "** dup sym %s -> %s in %s\n" nt new_name file + end; add_symdef nt file symdef_map; + let plugin = get_plugin_name file in let prods = if not is_edit && not (List.mem file autoloaded_mlgs) && - Str.string_match plugin_regex file 0 then - let plugin = Str.matched_group 1 file in - List.map (fun p -> p @ [Sedit2 ("PLUGIN", plugin)]) prods + plugin <> "" then + List.map (fun p -> p @ [Sedit2 ("TAG", plugin)]) prods else prods in @@ -600,7 +650,7 @@ let read_mlg is_edit ast file level_renames symdef_map = in List.iter prod_loop ast; - List.rev !res, !locals + List.rev !res, !locals, !dup_renames let dir s = "doc/tools/docgram/" ^ s @@ -608,7 +658,7 @@ let read_mlg_edit file = let fdir = dir file in let level_renames = ref StringMap.empty in (* ignored *) let symdef_map = ref StringMap.empty in (* ignored *) - let prods, _ = read_mlg true (parse_file fdir) fdir level_renames symdef_map in + let prods, _, _ = read_mlg (g_empty ()) true (parse_file fdir) fdir level_renames symdef_map in prods let add_rule g nt prods file = @@ -623,17 +673,99 @@ let add_rule g nt prods file = prods) in g_maybe_add_begin g nt (ent @ nodups) + +let remove_Sedit2 p = + List.filter (fun sym -> match sym with | Sedit2 _ -> false | _ -> true) p + +(* edit a production: rename nonterminals, drop nonterminals, substitute nonterminals *) +let rec edit_prod g top edit_map prod = + let edit_nt edit_map sym0 nt = + try + let binding = StringMap.find nt edit_map in + match binding with + | "DELETE" -> [] + | "SPLICE" -> + begin + try let splice_prods = NTMap.find nt !g.map in + match splice_prods with + | [] -> error "Empty splice for '%s'\n" nt; [] + | [p] -> List.rev (remove_Sedit2 p) + | _ -> [Sprod (List.map remove_Sedit2 splice_prods)] (* todo? check if we create a dup *) + with Not_found -> error "Missing nt '%s' for splice\n" nt; [Snterm nt] + end + | _ -> [Snterm binding] + with Not_found -> [sym0] + in + let maybe_wrap syms = + match syms with + | s :: [] -> List.hd syms + | s -> Sparen (List.rev syms) + in + + let rec edit_symbol sym0 = + match sym0 with + | Sterm s -> [sym0] + | Snterm s -> edit_nt edit_map sym0 s + | Slist1 sym -> [Slist1 (maybe_wrap (edit_symbol sym))] + (* you'll get a run-time failure deleting a SEP symbol *) + | Slist1sep (sym, sep) -> [Slist1sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Slist0 sym -> [Slist0 (maybe_wrap (edit_symbol sym))] + | Slist0sep (sym, sep) -> [Slist0sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Sopt sym -> [Sopt (maybe_wrap (edit_symbol sym))] + | Sparen slist -> [Sparen (List.hd (edit_prod g false edit_map slist))] + | Sprod slistlist -> let (_, prods) = edit_rule g edit_map "" slistlist in + [Sprod prods] + | Sedit _ + | Sedit2 _ -> [sym0] (* these constructors not used here *) + in + let is_splice nt = + try + StringMap.find nt edit_map = "SPLICE" + with Not_found -> false + in + let get_splice_prods nt = + try NTMap.find nt !g.map + with Not_found -> (error "Missing nt '%s' for splice\n" nt; []) + in + + (* special case splice creating multiple new productions *) + let splice_prods = match prod with + | Snterm nt :: [] when is_splice nt -> + get_splice_prods nt + | Snterm nt :: Sedit2 ("TAG", _) :: [] when is_splice nt -> + get_splice_prods nt + | _ -> [] + in + if top && splice_prods <> [] then + splice_prods + else + [List.rev (List.concat (List.rev (List.map (fun sym -> edit_symbol sym) prod)))] + +and edit_rule g edit_map nt rule = + let nt = + try let new_name = StringMap.find nt edit_map in + match new_name with + | "SPLICE" -> nt + | "DELETE" -> "" + | _ -> new_name + with Not_found -> nt + in + (nt, (List.concat (List.map (edit_prod g true edit_map) rule))) + let read_mlg_files g args symdef_map = let level_renames = ref StringMap.empty in let last_autoloaded = List.hd (List.rev autoloaded_mlgs) in List.iter (fun file -> - (* does nt renaming, deletion and splicing *) - let rules, locals = read_mlg false (parse_file file) file level_renames symdef_map in + (* todo: ??? does nt renaming, deletion and splicing *) + let rules, locals, dup_renames = read_mlg g false (parse_file file) file level_renames symdef_map in let numprods = List.fold_left (fun num rule -> let nt, prods = rule in - if NTMap.mem nt !g.map && (StringSet.mem nt locals) && - StringSet.cardinal (StringSet.of_list (StringMap.find nt !symdef_map)) > 1 then - warn "%s: local nonterminal '%s' already defined\n" file nt; + (* rename local duplicates *) + let prods = List.map (fun prod -> List.hd (edit_prod g true dup_renames prod)) prods in + let nt = try StringMap.find nt dup_renames with Not_found -> nt in +(* if NTMap.mem nt !g.map && (StringSet.mem nt locals) &&*) +(* StringSet.cardinal (StringSet.of_list (StringMap.find nt !symdef_map)) > 1 then*) +(* warn "%s: local nonterminal '%s' already defined\n" file nt; (* todo: goes away *)*) add_rule g nt prods file; num + List.length prods) 0 rules @@ -701,7 +833,12 @@ let create_edit_map g op edits = | "RENAME" -> if not (StringSet.mem key all_nts_ref || (StringSet.mem key all_nts_def)) then error "Unused/undefined nt `%s` in RENAME\n" key; -(* todo: could not get the following codeto type check + | "MERGE" -> + if not (StringSet.mem key all_nts_ref || (StringSet.mem key all_nts_def)) then + error "Unused/undefined nt `%s` in MERGE\n" key; + if not (StringSet.mem binding all_nts_ref || (StringSet.mem binding all_nts_def)) then + error "Unused/undefined nt `%s` in MERGE\n" key; +(* todo: could not get the following code to type check (match binding with | _ :: Snterm new_nt :: _ -> if not (StringSet.mem new_nt all_nts_ref) then @@ -713,9 +850,6 @@ let create_edit_map g op edits = in aux edits StringMap.empty -let remove_Sedit2 p = - List.filter (fun sym -> match sym with | Sedit2 _ -> false | _ -> true) p - (* don't deal with Sedit, Sedit2 yet (ever?) *) let rec pmatch fullprod fullpat repl = let map_prod prod = List.concat (List.map (fun s -> pmatch [s] fullpat repl) prod) in @@ -768,88 +902,15 @@ let global_repl g pat repl = g_update_prods g nt (List.map (fun prod -> pmatch prod pat repl) (NTMap.find nt !g.map)) ) !g.order -(* edit a production: rename nonterminals, drop nonterminals, substitute nonterminals *) -let rec edit_prod g top edit_map prod = - let edit_nt edit_map sym0 nt = - try - let binding = StringMap.find nt edit_map in - match binding with - | "DELETE" -> [] - | "SPLICE" -> - begin - try let splice_prods = NTMap.find nt !g.map in - match splice_prods with - | [] -> error "Empty splice for '%s'\n" nt; [] - | [p] -> List.rev (remove_Sedit2 p) - | _ -> [Sprod (List.map remove_Sedit2 splice_prods)] - with Not_found -> error "Missing nt '%s' for splice\n" nt; [Snterm nt] - end - | _ -> [Snterm binding] - with Not_found -> [sym0] - in - let maybe_wrap syms = - match syms with - | s :: [] -> List.hd syms - | s -> Sparen (List.rev syms) - in - - let rec edit_symbol sym0 = - match sym0 with - | Sterm s -> [sym0] - | Snterm s -> edit_nt edit_map sym0 s - | Slist1 sym -> [Slist1 (maybe_wrap (edit_symbol sym))] - (* you'll get a run-time failure deleting a SEP symbol *) - | Slist1sep (sym, sep) -> [Slist1sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Slist0 sym -> [Slist0 (maybe_wrap (edit_symbol sym))] - | Slist0sep (sym, sep) -> [Slist0sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Sopt sym -> [Sopt (maybe_wrap (edit_symbol sym))] - | Sparen slist -> [Sparen (List.hd (edit_prod g false edit_map slist))] - | Sprod slistlist -> let (_, prods) = edit_rule g edit_map "" slistlist in - [Sprod prods] - | Sedit _ - | Sedit2 _ -> [sym0] (* these constructors not used here *) - in - let is_splice nt = - try - StringMap.find nt edit_map = "SPLICE" - with Not_found -> false - in - let get_splice_prods nt = - try NTMap.find nt !g.map - with Not_found -> (error "Missing nt '%s' for splice\n" nt; []) - in - - (* special case splice creating multiple new productions *) - let splice_prods = match prod with - | Snterm nt :: [] when is_splice nt -> - get_splice_prods nt - | _ -> [] - in - if top && splice_prods <> [] then - splice_prods - else - [List.rev (List.concat (List.rev (List.map (fun sym -> edit_symbol sym) prod)))] - -and edit_rule g edit_map nt rule = - let nt = - try let new_name = StringMap.find nt edit_map in - match new_name with - | "SPLICE" -> nt - | "DELETE" -> "" - | _ -> new_name - with Not_found -> nt - in - (nt, (List.concat (List.map (edit_prod g true edit_map) rule))) - (*** splice: replace a reference to a nonterminal with its definition ***) (* todo: create a better splice routine *) -let apply_splice g splice_map = +let apply_splice g edit_map = List.iter (fun b -> let (nt0, prods0) = b in let rec splice_loop nt prods cnt = let max_cnt = 10 in - let (nt', prods') = edit_rule g splice_map nt prods in + let (nt', prods') = edit_rule g edit_map nt prods in if cnt > max_cnt then error "Splice for '%s' not done after %d iterations\n" nt0 max_cnt; if nt' = nt && prods' = prods then @@ -867,19 +928,8 @@ let apply_splice g splice_map = | "SPLICE" -> g_remove g nt; | _ -> ()) - (StringMap.bindings splice_map) + (StringMap.bindings edit_map) -let find_first edit prods nt = - let rec find_first_r edit prods nt i = - match prods with - | [] -> - error "Can't find '%s' in edit for '%s'\n" (prod_to_str edit) nt; - raise Not_found - | prod :: tl -> - if ematch prod edit then i - else find_first_r edit tl nt (i+1) - in - find_first_r edit prods nt 0 let remove_prod edit prods nt = let res, got_first = List.fold_left (fun args prod -> @@ -1087,6 +1137,29 @@ let expand_lists g = with | Queue.Empty -> () +let apply_merge g edit_map = + List.iter (fun b -> + let (from_nt, to_nt) = b in + let from_prods = NTMap.find from_nt !g.map in + List.iter (fun prod -> + try + ignore( get_first prod (NTMap.find to_nt !g.map)); + with Not_found -> g_add_prod_after g None to_nt prod) + from_prods) + (NTMap.bindings edit_map) + +let apply_rename_delete g edit_map = + List.iter (fun b -> let (nt, _) = b in + let prods = try NTMap.find nt !g.map with Not_found -> [] in + let (nt', prods') = edit_rule g edit_map nt prods in + if nt' = "" then + g_remove g nt + else if nt <> nt' then + g_rename_merge g nt nt' prods' + else + g_update_prods g nt prods') + (NTMap.bindings !g.map) + let edit_all_prods g op eprods = let do_it op eprods num = let rec aux eprods res = @@ -1101,25 +1174,20 @@ let edit_all_prods g op eprods = op (prod_to_str eprod) num; aux tl res in - let map = create_edit_map g op (aux eprods []) in - if op = "SPLICE" then - apply_splice g map - else (* RENAME/DELETE *) - List.iter (fun b -> let (nt, _) = b in - let prods = try NTMap.find nt !g.map with Not_found -> [] in - let (nt', prods') = edit_rule g map nt prods in - if nt' = "" then - g_remove g nt - else if nt <> nt' then - g_rename_merge g nt nt' prods' - else - g_update_prods g nt prods') - (NTMap.bindings !g.map); + let edit_map = create_edit_map g op (aux eprods []) in + match op with + | "SPLICE" -> apply_splice g edit_map + | "MERGE" -> apply_merge g edit_map; apply_rename_delete g edit_map + | "RENAME" + | "DELETE" -> apply_rename_delete g edit_map + | _ -> () + in match op with | "RENAME" -> do_it op eprods 2; true | "DELETE" -> do_it op eprods 1; true | "SPLICE" -> do_it op eprods 1; true + | "MERGE" -> do_it op eprods 2; true | "EXPAND" -> if List.length eprods > 1 || List.length (List.hd eprods) <> 0 then error "'EXPAND:' expects a single empty production\n"; @@ -1559,7 +1627,7 @@ let rec dump prod = [@@@ocaml.warning "+32"] let reorder_grammar eg reordered_rules file = - let og = ref { map = NTMap.empty; order = [] } in + let og = g_empty () in List.iter (fun rule -> let nt, prods = rule in try @@ -1761,11 +1829,12 @@ let process_rst g file args seen tac_prods cmd_prods = let prods = NTMap.find nt !g.map in List.iteri (fun i prod -> let rhs = String.trim (prod_to_prodn prod) in + let tag = get_tag file prod in let sep = if i = 0 then " ::=" else "|" in if has_empty_prod prod then error "%s line %d: Empty (sub-)production for %s, edit to remove: '%s %s'\n" file !linenum nt sep rhs; - fprintf new_rst "%s %s%s %s\n" indent (if i = 0 then nt else "") sep rhs) + fprintf new_rst "%s %s%s %s%s\n" indent (if i = 0 then nt else "") sep rhs tag) prods; if nt <> end_ then copy_prods tl in @@ -1832,8 +1901,10 @@ let process_rst g file args seen tac_prods cmd_prods = "doc/sphinx/language/gallina-specification-language.rst"; "doc/sphinx/language/using/libraries/funind.rst"; "doc/sphinx/proof-engine/ltac.rst"; + "doc/sphinx/proof-engine/ltac2.rst"; "doc/sphinx/proof-engine/vernacular-commands.rst"; - "doc/sphinx/user-extensions/syntax-extensions.rst" + "doc/sphinx/user-extensions/syntax-extensions.rst"; + "doc/sphinx/proof-engine/vernacular-commands.rst" ] in @@ -1941,12 +2012,16 @@ let report_omitted_prods g seen label split = (if first = "" then nt else first), nt, n + 1, total + 1) ("", "", 0, 0) !g.order in maybe_warn first last n; +(* List.iter (fun nt -> + if not (NTMap.mem nt seen || (List.mem nt included)) then + warn "%s %s not included in .rst files\n" "Nonterminal" nt) + !g.order;*) if total <> 0 then Printf.eprintf "TOTAL %ss not included = %d\n" label total let process_grammar args = let symdef_map = ref StringMap.empty in - let g = ref { map = NTMap.empty; order = [] } in + let g = g_empty () in let level_renames = read_mlg_files g args symdef_map in if args.verbose then begin diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index c5edb538b7..7f4e92fc37 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -59,7 +59,6 @@ universe: [ lconstr: [ | operconstr200 -| l_constr ] constr: [ @@ -118,8 +117,12 @@ operconstr0: [ | "{|" record_declaration bar_cbrace | "{" binder_constr "}" | "`{" operconstr200 "}" +| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_instance | "`(" operconstr200 ")" -| "ltac" ":" "(" Pltac.tactic_expr ")" +] + +array_elems: [ +| LIST0 lconstr SEP ";" ] record_declaration: [ @@ -305,7 +308,6 @@ open_binders: [ binders: [ | LIST0 binder -| Pcoq.Constr.binders ] binder: [ @@ -435,7 +437,6 @@ integer: [ natural: [ | bignat -| _natural ] bigint: [ @@ -456,7 +457,6 @@ strategy_level: [ | "opaque" | integer | "transparent" -| strategy_level0 ] vernac_toplevel: [ @@ -635,26 +635,37 @@ command: [ | "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident | "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident | "Add" "Relation" constr constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "symmetry" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "transitivity" "proved" "by" constr "as" ident | "Add" "Setoid" constr constr constr "as" ident -| "Add" "Parametric" "Setoid" binders ":" constr constr constr "as" ident +| "Add" "Parametric" "Setoid" G_REWRITE_binders ":" constr constr constr "as" ident | "Add" "Morphism" constr ":" ident | "Declare" "Morphism" constr ":" ident | "Add" "Morphism" constr "with" "signature" lconstr "as" ident -| "Add" "Parametric" "Morphism" binders ":" constr "with" "signature" lconstr "as" ident +| "Add" "Parametric" "Morphism" G_REWRITE_binders ":" constr "with" "signature" lconstr "as" ident | "Print" "Rewrite" "HintDb" preident | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" | "Show" "Ltac" "Profile" "CutOff" int | "Show" "Ltac" "Profile" string | "Show" "Lia" "Profile" (* micromega plugin *) +| "Add" "Zify" "InjTyp" constr (* micromega plugin *) +| "Add" "Zify" "BinOp" constr (* micromega plugin *) +| "Add" "Zify" "UnOp" constr (* micromega plugin *) +| "Add" "Zify" "CstOp" constr (* micromega plugin *) +| "Add" "Zify" "BinRel" constr (* micromega plugin *) +| "Add" "Zify" "PropOp" constr (* micromega plugin *) +| "Add" "Zify" "PropBinOp" constr (* micromega plugin *) +| "Add" "Zify" "PropUOp" constr (* micromega plugin *) +| "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 *) @@ -663,7 +674,6 @@ command: [ | "Add" "PropOp" constr (* micromega plugin *) | "Add" "PropBinOp" constr (* micromega plugin *) | "Add" "PropUOp" constr (* micromega plugin *) -| "Add" "Spec" constr (* micromega plugin *) | "Add" "BinOpSpec" constr (* micromega plugin *) | "Add" "UnOpSpec" constr (* micromega plugin *) | "Add" "Saturate" constr (* micromega plugin *) @@ -672,6 +682,8 @@ command: [ | "Show" "Zify" "UnOp" (* micromega plugin *) | "Show" "Zify" "CstOp" (* micromega plugin *) | "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 (* setoid_ring plugin *) | "Print" "Rings" (* setoid_ring plugin *) @@ -679,6 +691,9 @@ command: [ | "Print" "Fields" (* setoid_ring plugin *) | "Numeral" "Notation" reference reference reference ":" ident numnotoption | "String" "Notation" reference reference reference ":" ident +| "Ltac2" ltac2_entry (* Ltac2 plugin *) +| "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) +| "Print" "Ltac2" reference (* Ltac2 plugin *) ] reference_or_constr: [ @@ -700,7 +715,6 @@ hint: [ | "Mode" global mode | "Unfold" LIST1 global | "Constructors" LIST1 global -| "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic ] constr_body: [ @@ -791,7 +805,7 @@ gallina: [ | "Combined" "Scheme" identref "from" LIST1 identref SEP "," | "Register" global "as" qualid | "Register" "Inline" global -| "Primitive" identref OPT [ ":" lconstr ] ":=" register_token +| "Primitive" ident_decl OPT [ ":" lconstr ] ":=" register_token | "Universe" LIST1 identref | "Universes" LIST1 identref | "Constraint" LIST1 univ_constraint SEP "," @@ -872,7 +886,7 @@ reduce: [ ] decl_notation: [ -| ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] +| ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] ] decl_sep: [ @@ -1353,12 +1367,12 @@ syntax: [ | "Delimit" "Scope" IDENT; "with" IDENT | "Undelimit" "Scope" IDENT | "Bind" "Scope" IDENT; "with" LIST1 class_rawexpr -| "Infix" ne_lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] +| "Infix" ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] | "Notation" identref LIST0 ident ":=" constr only_parsing -| "Notation" lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] +| "Notation" lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] | "Format" "Notation" STRING STRING STRING -| "Reserved" "Infix" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] -| "Reserved" "Notation" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] +| "Reserved" "Infix" ne_lstring syntax_modifiers +| "Reserved" "Notation" ne_lstring syntax_modifiers ] only_parsing: [ @@ -1387,6 +1401,11 @@ syntax_modifier: [ | IDENT syntax_extension_type ] +syntax_modifiers: [ +| "(" LIST1 syntax_modifier SEP "," ")" +| +] + syntax_extension_type: [ | "ident" | "global" @@ -1791,6 +1810,10 @@ orient: [ | ] +EXTRAARGS_natural: [ +| _natural +] + occurrences: [ | LIST1 integer | var @@ -1800,8 +1823,12 @@ glob: [ | constr ] +EXTRAARGS_lconstr: [ +| l_constr +] + lglob: [ -| lconstr +| EXTRAARGS_lconstr ] casted_constr: [ @@ -1829,18 +1856,18 @@ by_arg_tac: [ in_clause: [ | in_clause' -| "*" occs -| "*" "|-" concl_occ -| LIST0 hypident_occ SEP "," "|-" concl_occ -| LIST0 hypident_occ SEP "," ] test_lpar_id_colon: [ | local_test_lpar_id_colon ] +EXTRAARGS_strategy_level: [ +| strategy_level0 +] + strategy_level_or_var: [ -| strategy_level +| EXTRAARGS_strategy_level | identref ] @@ -1985,7 +2012,6 @@ failkw: [ binder_tactic: [ | "fun" LIST1 input_fun "=>" tactic_expr5 | "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" tactic_expr5 -| "info" tactic_expr5 ] tactic_arg_compat: [ @@ -2124,6 +2150,14 @@ tactic_mode: [ | "par" ":" OPT ltac_info tactic ltac_use_default ] +G_LTAC_hint: [ +| "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic +] + +G_LTAC_operconstr0: [ +| "ltac" ":" "(" Pltac.tactic_expr ")" +] + ltac_selector: [ | toplevel_selector ] @@ -2194,6 +2228,10 @@ rewstrategy: [ | "fold" constr ] +G_REWRITE_binders: [ +| Pcoq.Constr.binders +] + int_or_var: [ | integer | identref @@ -2372,19 +2410,26 @@ hypident_occ: [ | hypident occs ] +G_TACTIC_in_clause: [ +| "*" occs +| "*" "|-" concl_occ +| LIST0 hypident_occ SEP "," "|-" concl_occ +| LIST0 hypident_occ SEP "," +] + clause_dft_concl: [ -| "in" in_clause +| "in" G_TACTIC_in_clause | occs | ] clause_dft_all: [ -| "in" in_clause +| "in" G_TACTIC_in_clause | ] opt_clause: [ -| "in" in_clause +| "in" G_TACTIC_in_clause | "at" occs_nums | ] @@ -2521,3 +2566,642 @@ numnotoption: [ | "(" "abstract" "after" bignat ")" ] +tac2pat1: [ +| Prim.qualid LIST1 tac2pat0 (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "[" "]" (* Ltac2 plugin *) +| tac2pat0 "::" tac2pat0 (* Ltac2 plugin *) +| tac2pat0 (* Ltac2 plugin *) +] + +tac2pat0: [ +| "_" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "(" atomic_tac2pat ")" (* Ltac2 plugin *) +] + +atomic_tac2pat: [ +| (* Ltac2 plugin *) +| tac2pat1 ":" tac2type5 (* Ltac2 plugin *) +| tac2pat1 "," LIST0 tac2pat1 SEP "," (* Ltac2 plugin *) +| tac2pat1 (* Ltac2 plugin *) +] + +tac2expr6: [ +| tac2expr5 ";" tac2expr6 (* Ltac2 plugin *) +| tac2expr5 (* Ltac2 plugin *) +] + +tac2expr5: [ +| "fun" LIST1 G_LTAC2_input_fun "=>" tac2expr6 (* Ltac2 plugin *) +| "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) +| "match" tac2expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) +| tac2expr4 (* Ltac2 plugin *) +] + +tac2expr4: [ +| tac2expr3 (* Ltac2 plugin *) +] + +tac2expr3: [ +| tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) +| tac2expr2 (* Ltac2 plugin *) +] + +tac2expr2: [ +| tac2expr1 "::" tac2expr2 (* Ltac2 plugin *) +| tac2expr1 (* Ltac2 plugin *) +] + +tac2expr1: [ +| tac2expr0 LIST1 tac2expr0 (* Ltac2 plugin *) +| tac2expr0 ".(" Prim.qualid ")" (* Ltac2 plugin *) +| tac2expr0 ".(" Prim.qualid ")" ":=" tac2expr5 (* Ltac2 plugin *) +| tac2expr0 (* Ltac2 plugin *) +] + +tac2expr0: [ +| "(" tac2expr6 ")" (* Ltac2 plugin *) +| "(" tac2expr6 ":" tac2type5 ")" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "(" ")" (* Ltac2 plugin *) +| "[" LIST0 tac2expr5 SEP ";" "]" (* Ltac2 plugin *) +| "{" tac2rec_fieldexprs "}" (* Ltac2 plugin *) +| G_LTAC2_tactic_atom (* Ltac2 plugin *) +] + +G_LTAC2_branches: [ +| (* Ltac2 plugin *) +| "|" LIST1 branch SEP "|" (* Ltac2 plugin *) +| LIST1 branch SEP "|" (* Ltac2 plugin *) +] + +branch: [ +| tac2pat1 "=>" tac2expr6 (* Ltac2 plugin *) +] + +rec_flag: [ +| "rec" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +mut_flag: [ +| "mutable" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +typ_param: [ +| "'" Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_tactic_atom: [ +| Prim.integer (* Ltac2 plugin *) +| Prim.string (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "@" Prim.ident (* Ltac2 plugin *) +| "&" lident (* Ltac2 plugin *) +| "'" Constr.constr (* Ltac2 plugin *) +| "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) +| "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) +| "ident" ":" "(" lident ")" (* Ltac2 plugin *) +| "pattern" ":" "(" Constr.lconstr_pattern ")" (* Ltac2 plugin *) +| "reference" ":" "(" globref ")" (* Ltac2 plugin *) +| "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +| "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +] + +ltac1_expr_in_env: [ +| test_ltac1_env LIST0 locident "|-" ltac1_expr (* Ltac2 plugin *) +| ltac1_expr (* Ltac2 plugin *) +] + +tac2expr_in_env: [ +| test_ltac1_env LIST0 locident "|-" tac2expr6 (* Ltac2 plugin *) +| tac2expr6 (* Ltac2 plugin *) +] + +G_LTAC2_let_clause: [ +| let_binder ":=" tac2expr6 (* Ltac2 plugin *) +] + +let_binder: [ +| LIST1 G_LTAC2_input_fun (* Ltac2 plugin *) +] + +tac2type5: [ +| tac2type2 "->" tac2type5 (* Ltac2 plugin *) +| tac2type2 (* Ltac2 plugin *) +] + +tac2type2: [ +| tac2type1 "*" LIST1 tac2type1 SEP "*" (* Ltac2 plugin *) +| tac2type1 (* Ltac2 plugin *) +] + +tac2type1: [ +| tac2type0 Prim.qualid (* Ltac2 plugin *) +| tac2type0 (* Ltac2 plugin *) +] + +tac2type0: [ +| "(" LIST1 tac2type5 SEP "," ")" OPT Prim.qualid (* Ltac2 plugin *) +| typ_param (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +] + +locident: [ +| Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_binder: [ +| "_" (* Ltac2 plugin *) +| Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_input_fun: [ +| tac2pat0 (* Ltac2 plugin *) +] + +tac2def_body: [ +| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" tac2expr6 (* Ltac2 plugin *) +] + +tac2def_val: [ +| mut_flag rec_flag LIST1 tac2def_body SEP "with" (* Ltac2 plugin *) +] + +tac2def_mut: [ +| "Set" Prim.qualid OPT [ "as" locident ] ":=" tac2expr6 (* Ltac2 plugin *) +] + +tac2typ_knd: [ +| tac2type5 (* Ltac2 plugin *) +| "[" ".." "]" (* Ltac2 plugin *) +| "[" tac2alg_constructors "]" (* Ltac2 plugin *) +| "{" tac2rec_fields "}" (* Ltac2 plugin *) +] + +tac2alg_constructors: [ +| "|" LIST1 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +| LIST0 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +] + +tac2alg_constructor: [ +| Prim.ident (* Ltac2 plugin *) +| Prim.ident "(" LIST0 tac2type5 SEP "," ")" (* Ltac2 plugin *) +] + +tac2rec_fields: [ +| tac2rec_field ";" tac2rec_fields (* Ltac2 plugin *) +| tac2rec_field ";" (* Ltac2 plugin *) +| tac2rec_field (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +tac2rec_field: [ +| mut_flag Prim.ident ":" tac2type5 (* Ltac2 plugin *) +] + +tac2rec_fieldexprs: [ +| tac2rec_fieldexpr ";" tac2rec_fieldexprs (* Ltac2 plugin *) +| tac2rec_fieldexpr ";" (* Ltac2 plugin *) +| tac2rec_fieldexpr (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +tac2rec_fieldexpr: [ +| Prim.qualid ":=" tac2expr1 (* Ltac2 plugin *) +] + +tac2typ_prm: [ +| (* Ltac2 plugin *) +| typ_param (* Ltac2 plugin *) +| "(" LIST1 typ_param SEP "," ")" (* Ltac2 plugin *) +] + +tac2typ_def: [ +| tac2typ_prm Prim.qualid tac2type_body (* Ltac2 plugin *) +] + +tac2type_body: [ +| (* Ltac2 plugin *) +| ":=" tac2typ_knd (* Ltac2 plugin *) +| "::=" tac2typ_knd (* Ltac2 plugin *) +] + +tac2def_typ: [ +| "Type" rec_flag LIST1 tac2typ_def SEP "with" (* Ltac2 plugin *) +] + +tac2def_ext: [ +| "@" "external" locident ":" tac2type5 ":=" Prim.string Prim.string (* Ltac2 plugin *) +] + +syn_node: [ +| "_" (* Ltac2 plugin *) +| Prim.ident (* Ltac2 plugin *) +] + +sexpr: [ +| Prim.string (* Ltac2 plugin *) +| Prim.integer (* Ltac2 plugin *) +| syn_node (* Ltac2 plugin *) +| syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) +] + +syn_level: [ +| (* Ltac2 plugin *) +| ":" Prim.integer (* Ltac2 plugin *) +] + +tac2def_syn: [ +| "Notation" LIST1 sexpr syn_level ":=" tac2expr6 (* Ltac2 plugin *) +] + +lident: [ +| Prim.ident (* Ltac2 plugin *) +] + +globref: [ +| "&" Prim.ident (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +] + +anti: [ +| "$" Prim.ident (* Ltac2 plugin *) +] + +ident_or_anti: [ +| lident (* Ltac2 plugin *) +| "$" Prim.ident (* Ltac2 plugin *) +] + +lnatural: [ +| Prim.natural (* Ltac2 plugin *) +] + +q_ident: [ +| ident_or_anti (* Ltac2 plugin *) +] + +qhyp: [ +| anti (* Ltac2 plugin *) +| lnatural (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +] + +G_LTAC2_simple_binding: [ +| "(" qhyp ":=" Constr.lconstr ")" (* Ltac2 plugin *) +] + +G_LTAC2_bindings: [ +| test_lpar_idnum_coloneq LIST1 G_LTAC2_simple_binding (* Ltac2 plugin *) +| LIST1 Constr.constr (* Ltac2 plugin *) +] + +q_bindings: [ +| G_LTAC2_bindings (* Ltac2 plugin *) +] + +q_with_bindings: [ +| G_LTAC2_with_bindings (* Ltac2 plugin *) +] + +G_LTAC2_intropatterns: [ +| LIST0 nonsimple_intropattern (* Ltac2 plugin *) +] + +G_LTAC2_or_and_intropattern: [ +| "[" LIST1 G_LTAC2_intropatterns SEP "|" "]" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "(" G_LTAC2_simple_intropattern ")" (* Ltac2 plugin *) +| "(" G_LTAC2_simple_intropattern "," LIST1 G_LTAC2_simple_intropattern SEP "," ")" (* Ltac2 plugin *) +| "(" G_LTAC2_simple_intropattern "&" LIST1 G_LTAC2_simple_intropattern SEP "&" ")" (* Ltac2 plugin *) +] + +G_LTAC2_equality_intropattern: [ +| "->" (* Ltac2 plugin *) +| "<-" (* Ltac2 plugin *) +| "[=" G_LTAC2_intropatterns "]" (* Ltac2 plugin *) +] + +G_LTAC2_naming_intropattern: [ +| LEFTQMARK lident (* Ltac2 plugin *) +| "?$" lident (* Ltac2 plugin *) +| "?" (* Ltac2 plugin *) +| ident_or_anti (* Ltac2 plugin *) +] + +nonsimple_intropattern: [ +| G_LTAC2_simple_intropattern (* Ltac2 plugin *) +| "*" (* Ltac2 plugin *) +| "**" (* Ltac2 plugin *) +] + +G_LTAC2_simple_intropattern: [ +| G_LTAC2_simple_intropattern_closed (* Ltac2 plugin *) +] + +G_LTAC2_simple_intropattern_closed: [ +| G_LTAC2_or_and_intropattern (* Ltac2 plugin *) +| G_LTAC2_equality_intropattern (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| G_LTAC2_naming_intropattern (* Ltac2 plugin *) +] + +q_intropatterns: [ +| G_LTAC2_intropatterns (* Ltac2 plugin *) +] + +q_intropattern: [ +| G_LTAC2_simple_intropattern (* Ltac2 plugin *) +] + +nat_or_anti: [ +| lnatural (* Ltac2 plugin *) +| "$" Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_eqn_ipat: [ +| "eqn" ":" G_LTAC2_naming_intropattern (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_with_bindings: [ +| "with" G_LTAC2_bindings (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_constr_with_bindings: [ +| Constr.constr G_LTAC2_with_bindings (* Ltac2 plugin *) +] + +G_LTAC2_destruction_arg: [ +| lnatural (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +| G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +] + +q_destruction_arg: [ +| G_LTAC2_destruction_arg (* Ltac2 plugin *) +] + +G_LTAC2_as_or_and_ipat: [ +| "as" G_LTAC2_or_and_intropattern (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_occs_nums: [ +| LIST1 nat_or_anti (* Ltac2 plugin *) +| "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) +] + +G_LTAC2_occs: [ +| "at" G_LTAC2_occs_nums (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_hypident: [ +| ident_or_anti (* Ltac2 plugin *) +| "(" "type" "of" ident_or_anti ")" (* Ltac2 plugin *) +| "(" "value" "of" ident_or_anti ")" (* Ltac2 plugin *) +] + +G_LTAC2_hypident_occ: [ +| G_LTAC2_hypident G_LTAC2_occs (* Ltac2 plugin *) +] + +G_LTAC2_in_clause: [ +| "*" G_LTAC2_occs (* Ltac2 plugin *) +| "*" "|-" G_LTAC2_concl_occ (* Ltac2 plugin *) +| LIST0 G_LTAC2_hypident_occ SEP "," "|-" G_LTAC2_concl_occ (* Ltac2 plugin *) +| LIST0 G_LTAC2_hypident_occ SEP "," (* Ltac2 plugin *) +] + +clause: [ +| "in" G_LTAC2_in_clause (* Ltac2 plugin *) +| "at" G_LTAC2_occs_nums (* Ltac2 plugin *) +] + +q_clause: [ +| clause (* Ltac2 plugin *) +] + +G_LTAC2_concl_occ: [ +| "*" G_LTAC2_occs (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_induction_clause: [ +| G_LTAC2_destruction_arg G_LTAC2_as_or_and_ipat G_LTAC2_eqn_ipat OPT clause (* Ltac2 plugin *) +] + +q_induction_clause: [ +| G_LTAC2_induction_clause (* Ltac2 plugin *) +] + +G_LTAC2_conversion: [ +| Constr.constr (* Ltac2 plugin *) +| Constr.constr "with" Constr.constr (* Ltac2 plugin *) +] + +q_conversion: [ +| G_LTAC2_conversion (* Ltac2 plugin *) +] + +ltac2_orient: [ +| "->" (* Ltac2 plugin *) +| "<-" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_rewriter: [ +| "!" G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| [ "?" | LEFTQMARK ] G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| lnatural "!" G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| lnatural [ "?" | LEFTQMARK ] G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| lnatural G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +] + +G_LTAC2_oriented_rewriter: [ +| ltac2_orient G_LTAC2_rewriter (* Ltac2 plugin *) +] + +q_rewriting: [ +| G_LTAC2_oriented_rewriter (* Ltac2 plugin *) +] + +G_LTAC2_tactic_then_last: [ +| "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_tactic_then_gen: [ +| tac2expr6 "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| tac2expr6 ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) +| ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) +| tac2expr6 (* Ltac2 plugin *) +| "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +q_dispatch: [ +| G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +] + +q_occurrences: [ +| G_LTAC2_occs (* Ltac2 plugin *) +] + +red_flag: [ +| "beta" (* Ltac2 plugin *) +| "iota" (* Ltac2 plugin *) +| "match" (* Ltac2 plugin *) +| "fix" (* Ltac2 plugin *) +| "cofix" (* Ltac2 plugin *) +| "zeta" (* Ltac2 plugin *) +| "delta" G_LTAC2_delta_flag (* Ltac2 plugin *) +] + +refglobal: [ +| "&" Prim.ident (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "$" Prim.ident (* Ltac2 plugin *) +] + +q_reference: [ +| refglobal (* Ltac2 plugin *) +] + +refglobals: [ +| LIST1 refglobal (* Ltac2 plugin *) +] + +G_LTAC2_delta_flag: [ +| "-" "[" refglobals "]" (* Ltac2 plugin *) +| "[" refglobals "]" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_strategy_flag: [ +| LIST1 red_flag (* Ltac2 plugin *) +| G_LTAC2_delta_flag (* Ltac2 plugin *) +] + +q_strategy_flag: [ +| G_LTAC2_strategy_flag (* Ltac2 plugin *) +] + +hintdb: [ +| "*" (* Ltac2 plugin *) +| LIST1 ident_or_anti (* Ltac2 plugin *) +] + +q_hintdb: [ +| hintdb (* Ltac2 plugin *) +] + +G_LTAC2_match_pattern: [ +| "context" OPT Prim.ident "[" Constr.lconstr_pattern "]" (* Ltac2 plugin *) +| Constr.lconstr_pattern (* Ltac2 plugin *) +] + +G_LTAC2_match_rule: [ +| G_LTAC2_match_pattern "=>" tac2expr6 (* Ltac2 plugin *) +] + +G_LTAC2_match_list: [ +| LIST1 G_LTAC2_match_rule SEP "|" (* Ltac2 plugin *) +| "|" LIST1 G_LTAC2_match_rule SEP "|" (* Ltac2 plugin *) +] + +q_constr_matching: [ +| G_LTAC2_match_list (* Ltac2 plugin *) +] + +gmatch_hyp_pattern: [ +| Prim.name ":" G_LTAC2_match_pattern (* Ltac2 plugin *) +] + +gmatch_pattern: [ +| "[" LIST0 gmatch_hyp_pattern SEP "," "|-" G_LTAC2_match_pattern "]" (* Ltac2 plugin *) +] + +gmatch_rule: [ +| gmatch_pattern "=>" tac2expr6 (* Ltac2 plugin *) +] + +gmatch_list: [ +| LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) +| "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) +] + +q_goal_matching: [ +| gmatch_list (* Ltac2 plugin *) +] + +move_location: [ +| "at" "top" (* Ltac2 plugin *) +| "at" "bottom" (* Ltac2 plugin *) +| "after" ident_or_anti (* Ltac2 plugin *) +| "before" ident_or_anti (* Ltac2 plugin *) +] + +q_move_location: [ +| move_location (* Ltac2 plugin *) +] + +G_LTAC2_as_name: [ +| (* Ltac2 plugin *) +| "as" ident_or_anti (* Ltac2 plugin *) +] + +pose: [ +| test_lpar_id_coloneq "(" ident_or_anti ":=" Constr.lconstr ")" (* Ltac2 plugin *) +| Constr.constr G_LTAC2_as_name (* Ltac2 plugin *) +] + +q_pose: [ +| pose (* Ltac2 plugin *) +] + +G_LTAC2_as_ipat: [ +| "as" G_LTAC2_simple_intropattern (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_by_tactic: [ +| "by" tac2expr6 (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +assertion: [ +| test_lpar_id_coloneq "(" ident_or_anti ":=" Constr.lconstr ")" (* Ltac2 plugin *) +| test_lpar_id_colon "(" ident_or_anti ":" Constr.lconstr ")" G_LTAC2_by_tactic (* Ltac2 plugin *) +| Constr.constr G_LTAC2_as_ipat G_LTAC2_by_tactic (* Ltac2 plugin *) +] + +q_assert: [ +| assertion (* Ltac2 plugin *) +] + +ltac2_entry: [ +| tac2def_val (* Ltac2 plugin *) +| tac2def_typ (* Ltac2 plugin *) +| tac2def_ext (* Ltac2 plugin *) +| tac2def_syn (* Ltac2 plugin *) +| tac2def_mut (* Ltac2 plugin *) +] + +ltac2_expr: [ +| tac2expr6 (* Ltac2 plugin *) +] + +tac2mode: [ +| ltac2_expr ltac_use_default (* Ltac2 plugin *) +| G_vernac.query_command (* Ltac2 plugin *) +] + diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index f4bf51b6ba..84efc1e36c 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -45,6 +45,7 @@ term0: [ | term_match | term_record | term_generalizing +| "[|" LIST0 term SEP ";" "|" term OPT ( ":" type ) "|]" OPT univ_annot | term_ltac | "(" term ")" ] @@ -192,6 +193,32 @@ NOTINRSTS: [ | simple_tactic | REACHABLE | NOTINRSTS +| l1_tactic +| l3_tactic +| l2_tactic +| binder_tactic +| value_tactic +| ltac2_entry +| q_intropatterns +| q_intropattern +| q_ident +| q_destruction_arg +| q_with_bindings +| q_bindings +| q_strategy_flag +| q_reference +| q_clause +| q_occurrences +| q_induction_clause +| q_conversion +| q_rewriting +| q_dispatch +| q_hintdb +| q_move_location +| q_pose +| q_assert +| q_constr_matching +| q_goal_matching ] document: [ @@ -462,11 +489,11 @@ delta_flag: [ ] strategy_flag: [ -| LIST1 red_flags +| LIST1 red_flag | delta_flag ] -red_flags: [ +red_flag: [ | "beta" | "iota" | "match" @@ -751,6 +778,26 @@ command: [ | "Declare" "Reduction" ident ":=" red_expr | "Declare" "Custom" "Entry" ident | "Derive" ident "SuchThat" one_term "As" ident (* derive plugin *) +| "Extraction" qualid (* extraction plugin *) +| "Recursive" "Extraction" LIST1 qualid (* extraction plugin *) +| "Extraction" string LIST1 qualid (* extraction plugin *) +| "Extraction" "TestCompile" LIST1 qualid (* extraction plugin *) +| "Separate" "Extraction" LIST1 qualid (* extraction plugin *) +| "Extraction" "Library" ident (* extraction plugin *) +| "Recursive" "Extraction" "Library" ident (* extraction plugin *) +| "Extraction" "Language" language (* extraction plugin *) +| "Extraction" "Inline" LIST1 qualid (* extraction plugin *) +| "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) +| "Print" "Extraction" "Inline" (* extraction plugin *) +| "Reset" "Extraction" "Inline" (* extraction plugin *) +| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) +| "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) +| "Print" "Extraction" "Blacklist" (* extraction plugin *) +| "Reset" "Extraction" "Blacklist" (* extraction plugin *) +| "Extract" "Constant" qualid LIST0 string "=>" [ ident | string ] (* extraction plugin *) +| "Extract" "Inlined" "Constant" qualid "=>" [ ident | string ] (* extraction plugin *) +| "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) +| "Show" "Extraction" (* extraction plugin *) | "Proof" | "Proof" "Mode" string | "Proof" term @@ -807,6 +854,17 @@ command: [ | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" OPT [ "CutOff" int | string ] | "Show" "Lia" "Profile" (* micromega plugin *) +| "Add" "Zify" "InjTyp" one_term (* micromega plugin *) +| "Add" "Zify" "BinOp" one_term (* micromega plugin *) +| "Add" "Zify" "UnOp" one_term (* micromega plugin *) +| "Add" "Zify" "CstOp" one_term (* micromega plugin *) +| "Add" "Zify" "BinRel" one_term (* micromega plugin *) +| "Add" "Zify" "PropOp" one_term (* micromega plugin *) +| "Add" "Zify" "PropBinOp" one_term (* micromega plugin *) +| "Add" "Zify" "PropUOp" one_term (* micromega plugin *) +| "Add" "Zify" "BinOpSpec" one_term (* micromega plugin *) +| "Add" "Zify" "UnOpSpec" one_term (* micromega plugin *) +| "Add" "Zify" "Saturate" one_term (* micromega plugin *) | "Add" "InjTyp" one_term (* micromega plugin *) | "Add" "BinOp" one_term (* micromega plugin *) | "Add" "UnOp" one_term (* micromega plugin *) @@ -815,7 +873,6 @@ command: [ | "Add" "PropOp" one_term (* micromega plugin *) | "Add" "PropBinOp" one_term (* micromega plugin *) | "Add" "PropUOp" one_term (* micromega plugin *) -| "Add" "Spec" one_term (* micromega plugin *) | "Add" "BinOpSpec" one_term (* micromega plugin *) | "Add" "UnOpSpec" one_term (* micromega plugin *) | "Add" "Saturate" one_term (* micromega plugin *) @@ -824,8 +881,13 @@ command: [ | "Show" "Zify" "UnOp" (* micromega plugin *) | "Show" "Zify" "CstOp" (* micromega plugin *) | "Show" "Zify" "BinRel" (* micromega plugin *) +| "Show" "Zify" "UnOpSpec" (* micromega plugin *) +| "Show" "Zify" "BinOpSpec" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) +| "Print" "Rings" (* setoid_ring plugin *) +| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) +| "Print" "Fields" (* setoid_ring plugin *) | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST0 qualid | "Typeclasses" "Opaque" LIST0 qualid @@ -841,26 +903,6 @@ command: [ | "Print" "Firstorder" "Solver" | "Function" fix_definition LIST0 ( "with" fix_definition ) | "Functional" "Scheme" fun_scheme_arg LIST0 ( "with" fun_scheme_arg ) -| "Extraction" qualid (* extraction plugin *) -| "Recursive" "Extraction" LIST1 qualid (* extraction plugin *) -| "Extraction" string LIST1 qualid (* extraction plugin *) -| "Extraction" "TestCompile" LIST1 qualid (* extraction plugin *) -| "Separate" "Extraction" LIST1 qualid (* extraction plugin *) -| "Extraction" "Library" ident (* extraction plugin *) -| "Recursive" "Extraction" "Library" ident (* extraction plugin *) -| "Extraction" "Language" language (* extraction plugin *) -| "Extraction" "Inline" LIST1 qualid (* extraction plugin *) -| "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) -| "Print" "Extraction" "Inline" (* extraction plugin *) -| "Reset" "Extraction" "Inline" (* extraction plugin *) -| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) -| "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) -| "Print" "Extraction" "Blacklist" (* extraction plugin *) -| "Reset" "Extraction" "Blacklist" (* extraction plugin *) -| "Extract" "Constant" qualid LIST0 string "=>" [ ident | string ] (* extraction plugin *) -| "Extract" "Inlined" "Constant" qualid "=>" [ ident | string ] (* extraction plugin *) -| "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) -| "Show" "Extraction" (* extraction plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) | "Hint" "Rewrite" OPT [ "->" | "<-" ] LIST1 one_term OPT ( "using" ltac_expr ) OPT ( ":" LIST0 ident ) @@ -870,9 +912,6 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term -| "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) -| "Print" "Fields" (* setoid_ring plugin *) | "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier | "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body @@ -889,7 +928,7 @@ command: [ | "Combined" "Scheme" ident "from" LIST1 ident SEP "," | "Register" qualid "as" qualid | "Register" "Inline" qualid -| "Primitive" ident OPT [ ":" term ] ":=" "#" ident +| "Primitive" ident_decl OPT [ ":" term ] ":=" "#" ident | "Universe" LIST1 ident | "Universes" LIST1 ident | "Constraint" LIST1 univ_constraint SEP "," @@ -932,12 +971,12 @@ command: [ | "Delimit" "Scope" scope_name "with" scope_key | "Undelimit" "Scope" scope_name | "Bind" "Scope" scope_name "with" LIST1 class -| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] +| "Infix" string ":=" one_term OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) OPT [ ":" scope_name ] | "Notation" ident LIST0 ident ":=" one_term OPT ( "(" "only" "parsing" ")" ) -| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] +| "Notation" string ":=" one_term OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) OPT [ ":" scope_name ] | "Format" "Notation" string string string -| "Reserved" "Infix" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] -| "Reserved" "Notation" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] +| "Reserved" "Infix" string OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) +| "Reserved" "Notation" string OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) | "Eval" red_expr "in" term | "Compute" term | "Check" term @@ -946,6 +985,14 @@ command: [ | "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Ltac2" OPT "mutable" OPT "rec" tac2def_body LIST0 ( "with" tac2def_body ) +| "Ltac2" "Type" OPT "rec" tac2typ_def LIST0 ( "with" tac2typ_def ) +| "Ltac2" "@" "external" ident ":" ltac2_type ":=" string string +| "Ltac2" "Notation" LIST1 ltac2_scope OPT ( ":" int ) ":=" ltac2_expr +| "Ltac2" "Set" qualid OPT [ "as" ident ] ":=" ltac2_expr +| "Ltac2" "Notation" [ string | lident ] ":=" ltac2_expr (* Ltac2 plugin *) +| "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) +| "Print" "Ltac2" qualid (* Ltac2 plugin *) | "Time" sentence | "Redirect" string sentence | "Timeout" num sentence @@ -1044,8 +1091,170 @@ ltac_production_item: [ | ident OPT ( "(" ident OPT ( "," string ) ")" ) ] +tac2expr_in_env: [ +| LIST0 ident "|-" ltac2_expr (* Ltac2 plugin *) +| ltac2_expr (* Ltac2 plugin *) +] + +ltac2_type: [ +| ltac2_type2 "->" ltac2_type (* Ltac2 plugin *) +| ltac2_type2 (* Ltac2 plugin *) +] + +ltac2_type2: [ +| ltac2_type1 "*" LIST1 ltac2_type1 SEP "*" (* Ltac2 plugin *) +| ltac2_type1 (* Ltac2 plugin *) +] + +ltac2_type1: [ +| ltac2_type0 qualid (* Ltac2 plugin *) +| ltac2_type0 (* Ltac2 plugin *) +] + +ltac2_type0: [ +| "(" LIST1 ltac2_type SEP "," ")" OPT qualid (* Ltac2 plugin *) +| ltac2_typevar (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +] + +ltac2_typevar: [ +| "'" ident (* Ltac2 plugin *) +] + +lident: [ +| ident (* Ltac2 plugin *) +] + +destruction_arg: [ +| num +| constr_with_bindings +| constr_with_bindings_arg +] + +constr_with_bindings_arg: [ +| ">" constr_with_bindings +| constr_with_bindings +] + +clause_dft_concl: [ +| "in" in_clause +| OPT ( "at" occs_nums ) +] + +in_clause: [ +| "*" OPT ( "at" occs_nums ) +| "*" "|-" OPT concl_occ +| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) +] + +hypident_occ: [ +| hypident OPT ( "at" occs_nums ) +] + +hypident: [ +| ident +| "(" "type" "of" ident ")" +| "(" "value" "of" ident ")" +] + +concl_occ: [ +| "*" OPT ( "at" occs_nums ) +] + +q_intropatterns: [ +| ltac2_intropatterns (* Ltac2 plugin *) +] + +ltac2_intropatterns: [ +| LIST0 nonsimple_intropattern (* Ltac2 plugin *) +] + +nonsimple_intropattern: [ +| "*" (* Ltac2 plugin *) +| "**" (* Ltac2 plugin *) +| ltac2_simple_intropattern (* Ltac2 plugin *) +] + +q_intropattern: [ +| ltac2_simple_intropattern (* Ltac2 plugin *) +] + +ltac2_simple_intropattern: [ +| ltac2_naming_intropattern (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| ltac2_or_and_intropattern (* Ltac2 plugin *) +| ltac2_equality_intropattern (* Ltac2 plugin *) +] + +ltac2_or_and_intropattern: [ +| "[" LIST1 ltac2_intropatterns SEP "|" "]" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "(" LIST1 ltac2_simple_intropattern SEP "," ")" (* Ltac2 plugin *) +| "(" LIST1 ltac2_simple_intropattern SEP "&" ")" (* Ltac2 plugin *) +] + +ltac2_equality_intropattern: [ +| "->" (* Ltac2 plugin *) +| "<-" (* Ltac2 plugin *) +| "[=" ltac2_intropatterns "]" (* Ltac2 plugin *) +] + +ltac2_naming_intropattern: [ +| "?" lident (* Ltac2 plugin *) +| "?$" lident (* Ltac2 plugin *) +| "?" (* Ltac2 plugin *) +| ident_or_anti (* Ltac2 plugin *) +] + +q_ident: [ +| ident_or_anti (* Ltac2 plugin *) +] + +ident_or_anti: [ +| lident (* Ltac2 plugin *) +| "$" ident (* Ltac2 plugin *) +] + +q_destruction_arg: [ +| ltac2_destruction_arg (* Ltac2 plugin *) +] + +ltac2_destruction_arg: [ +| num (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +| ltac2_constr_with_bindings (* Ltac2 plugin *) +] + +ltac2_constr_with_bindings: [ +| term OPT ( "with" ltac2_bindings ) (* Ltac2 plugin *) +] + +q_bindings: [ +| ltac2_bindings (* Ltac2 plugin *) +] + +q_with_bindings: [ +| OPT ( "with" ltac2_bindings ) (* Ltac2 plugin *) +] + +ltac2_bindings: [ +| LIST1 ltac2_simple_binding (* Ltac2 plugin *) +| LIST1 term (* Ltac2 plugin *) +] + +ltac2_simple_binding: [ +| "(" qhyp ":=" term ")" (* Ltac2 plugin *) +] + +qhyp: [ +| "$" ident (* Ltac2 plugin *) +| num (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +] + int_or_id: [ -| ident (* extraction plugin *) +| ident | int (* extraction plugin *) ] @@ -1151,7 +1360,7 @@ decl_notations: [ ] decl_notation: [ -| string ":=" one_term OPT ( "(" "only" "parsing" ")" ) OPT [ ":" scope_name ] +| string ":=" one_term OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) OPT [ ":" scope_name ] ] simple_tactic: [ @@ -1210,6 +1419,7 @@ simple_tactic: [ | "solve" "[" LIST0 ltac_expr SEP "|" "]" | "idtac" LIST0 [ ident | string | int ] | [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | int ] +| "fun" LIST1 name "=>" ltac_expr | "eval" red_expr "in" term | "context" ident "[" term "]" | "type" "of" term @@ -1219,13 +1429,14 @@ simple_tactic: [ | "uconstr" ":" "(" term ")" | "fun" LIST1 name "=>" ltac_expr | "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" ltac_expr -| "info" ltac_expr | ltac_expr3 ";" [ ltac_expr3 | binder_tactic ] | ltac_expr3 ";" "[" for_each_goal "]" | ltac_expr1 "+" [ ltac_expr2 | binder_tactic ] | ltac_expr1 "||" [ ltac_expr2 | binder_tactic ] | "[>" for_each_goal "]" | toplevel_selector ":" ltac_expr +| ltac2_match_key ltac2_expr "with" ltac2_match_list "end" +| ltac2_match_key OPT "reverse" "goal" "with" goal_match_list "end" | "simplify_eq" OPT destruction_arg | "esimplify_eq" OPT destruction_arg | "discriminate" OPT destruction_arg @@ -1329,10 +1540,10 @@ simple_tactic: [ | "setoid_reflexivity" | "setoid_transitivity" one_term | "setoid_etransitivity" -| "decide" "equality" -| "compare" one_term one_term | "intros" LIST0 intropattern | "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 @@ -1453,6 +1664,7 @@ simple_tactic: [ | "psatz" term OPT int_or_var | "ring" OPT ( "[" LIST1 term "]" ) | "ring_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) +| "match" ltac2_expr5 "with" OPT ltac2_branches "end" | qualid LIST1 tactic_arg ] @@ -1465,26 +1677,6 @@ hloc: [ | "in" "(" "value" "of" ident ")" ] -in_clause: [ -| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) -| "*" "|-" OPT concl_occ -| "*" OPT ( "at" occs_nums ) -] - -concl_occ: [ -| "*" OPT ( "at" occs_nums ) -] - -hypident_occ: [ -| hypident OPT ( "at" occs_nums ) -] - -hypident: [ -| ident -| "(" "type" "of" ident ")" -| "(" "value" "of" ident ")" -] - as_ipat: [ | "as" simple_intropattern ] @@ -1507,12 +1699,7 @@ as_name: [ ] rewriter: [ -| "!" constr_with_bindings_arg -| "?" constr_with_bindings_arg -| num "!" constr_with_bindings_arg -| num [ "?" | "?" ] constr_with_bindings_arg -| num constr_with_bindings_arg -| constr_with_bindings_arg +| OPT num OPT [ "?" | "!" ] constr_with_bindings_arg ] oriented_rewriter: [ @@ -1554,9 +1741,9 @@ naming_intropattern: [ ] intropattern: [ -| simple_intropattern | "*" | "**" +| simple_intropattern ] simple_intropattern: [ @@ -1597,9 +1784,367 @@ bindings_with_parameters: [ | "(" ident LIST0 simple_binder ":=" term ")" ] -clause_dft_concl: [ -| "in" in_clause -| OPT ( "at" occs_nums ) +q_clause: [ +| ltac2_clause (* Ltac2 plugin *) +] + +ltac2_clause: [ +| "in" ltac2_in_clause (* Ltac2 plugin *) +| "at" ltac2_occs_nums (* Ltac2 plugin *) +] + +ltac2_in_clause: [ +| "*" OPT ltac2_occs (* Ltac2 plugin *) +| "*" "|-" OPT ltac2_concl_occ (* Ltac2 plugin *) +| LIST0 ltac2_hypident_occ SEP "," OPT ( "|-" OPT ltac2_concl_occ ) (* Ltac2 plugin *) +] + +q_occurrences: [ +| OPT ltac2_occs (* Ltac2 plugin *) +] + +ltac2_occs: [ +| "at" ltac2_occs_nums (* Ltac2 plugin *) +] + +ltac2_occs_nums: [ +| OPT "-" LIST1 [ num (* Ltac2 plugin *) | "$" ident ] (* Ltac2 plugin *) +] + +ltac2_concl_occ: [ +| "*" OPT ltac2_occs (* Ltac2 plugin *) +] + +ltac2_hypident_occ: [ +| ltac2_hypident OPT ltac2_occs (* Ltac2 plugin *) +] + +ltac2_hypident: [ +| ident_or_anti (* Ltac2 plugin *) +| "(" "type" "of" ident_or_anti ")" (* Ltac2 plugin *) +| "(" "value" "of" ident_or_anti ")" (* Ltac2 plugin *) +] + +q_induction_clause: [ +| ltac2_induction_clause (* Ltac2 plugin *) +] + +ltac2_induction_clause: [ +| ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT ltac2_clause (* Ltac2 plugin *) +] + +ltac2_as_or_and_ipat: [ +| "as" ltac2_or_and_intropattern (* Ltac2 plugin *) +] + +ltac2_eqn_ipat: [ +| "eqn" ":" ltac2_naming_intropattern (* Ltac2 plugin *) +] + +q_conversion: [ +| ltac2_conversion (* Ltac2 plugin *) +] + +ltac2_conversion: [ +| term (* Ltac2 plugin *) +| term "with" term (* Ltac2 plugin *) +] + +q_rewriting: [ +| ltac2_oriented_rewriter (* Ltac2 plugin *) +] + +ltac2_oriented_rewriter: [ +| [ "->" | "<-" ] ltac2_rewriter (* Ltac2 plugin *) +] + +ltac2_rewriter: [ +| OPT num OPT [ "?" | "!" ] ltac2_constr_with_bindings +] + +q_dispatch: [ +| ltac2_for_each_goal (* Ltac2 plugin *) +] + +ltac2_for_each_goal: [ +| ltac2_goal_tactics (* Ltac2 plugin *) +| OPT ( ltac2_goal_tactics "|" ) OPT ltac2_expr ".." OPT ( "|" ltac2_goal_tactics ) (* Ltac2 plugin *) +] + +ltac2_goal_tactics: [ +| LIST0 ( OPT ltac2_expr ) SEP "|" (* Ltac2 plugin *) +] + +q_strategy_flag: [ +| ltac2_strategy_flag (* Ltac2 plugin *) +] + +ltac2_strategy_flag: [ +| LIST1 ltac2_red_flag (* Ltac2 plugin *) +| OPT ltac2_delta_flag (* Ltac2 plugin *) +] + +ltac2_red_flag: [ +| "beta" (* Ltac2 plugin *) +| "iota" (* Ltac2 plugin *) +| "match" (* Ltac2 plugin *) +| "fix" (* Ltac2 plugin *) +| "cofix" (* Ltac2 plugin *) +| "zeta" (* Ltac2 plugin *) +| "delta" OPT ltac2_delta_flag (* Ltac2 plugin *) +] + +ltac2_delta_flag: [ +| OPT "-" "[" LIST1 refglobal "]" +] + +q_reference: [ +| refglobal (* Ltac2 plugin *) +] + +refglobal: [ +| "&" ident (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "$" ident (* Ltac2 plugin *) +] + +q_hintdb: [ +| hintdb (* Ltac2 plugin *) +] + +hintdb: [ +| "*" (* Ltac2 plugin *) +| LIST1 ident_or_anti (* Ltac2 plugin *) +] + +q_constr_matching: [ +| ltac2_match_list (* Ltac2 plugin *) +] + +ltac2_match_key: [ +| "lazy_match!" +| "match!" +| "multi_match!" +] + +ltac2_match_list: [ +| OPT "|" LIST1 ltac2_match_rule SEP "|" +] + +ltac2_match_rule: [ +| ltac2_match_pattern "=>" ltac2_expr (* Ltac2 plugin *) +] + +ltac2_match_pattern: [ +| cpattern (* Ltac2 plugin *) +| "context" OPT ident "[" cpattern "]" (* Ltac2 plugin *) +] + +q_goal_matching: [ +| goal_match_list (* Ltac2 plugin *) +] + +goal_match_list: [ +| OPT "|" LIST1 gmatch_rule SEP "|" +] + +gmatch_rule: [ +| gmatch_pattern "=>" ltac2_expr (* Ltac2 plugin *) +] + +gmatch_pattern: [ +| "[" LIST0 gmatch_hyp_pattern SEP "," "|-" ltac2_match_pattern "]" (* Ltac2 plugin *) +] + +gmatch_hyp_pattern: [ +| name ":" ltac2_match_pattern (* Ltac2 plugin *) +] + +q_move_location: [ +| move_location (* Ltac2 plugin *) +] + +move_location: [ +| "at" "top" (* Ltac2 plugin *) +| "at" "bottom" (* Ltac2 plugin *) +| "after" ident_or_anti (* Ltac2 plugin *) +| "before" ident_or_anti (* Ltac2 plugin *) +] + +q_pose: [ +| pose (* Ltac2 plugin *) +] + +pose: [ +| "(" ident_or_anti ":=" term ")" (* Ltac2 plugin *) +| term OPT ltac2_as_name (* Ltac2 plugin *) +] + +ltac2_as_name: [ +| "as" ident_or_anti (* Ltac2 plugin *) +] + +q_assert: [ +| assertion (* Ltac2 plugin *) +] + +assertion: [ +| "(" ident_or_anti ":=" term ")" (* Ltac2 plugin *) +| "(" ident_or_anti ":" term ")" OPT ltac2_by_tactic (* Ltac2 plugin *) +| term OPT ltac2_as_ipat OPT ltac2_by_tactic (* Ltac2 plugin *) +] + +ltac2_as_ipat: [ +| "as" ltac2_simple_intropattern (* Ltac2 plugin *) +] + +ltac2_by_tactic: [ +| "by" ltac2_expr (* Ltac2 plugin *) +] + +ltac2_entry: [ +] + +tac2def_body: [ +| [ "_" | ident ] LIST0 tac2pat0 ":=" ltac2_expr (* Ltac2 plugin *) +] + +tac2typ_def: [ +| OPT tac2typ_prm qualid OPT ( [ ":=" | "::=" ] tac2typ_knd ) (* Ltac2 plugin *) +] + +tac2typ_prm: [ +| ltac2_typevar (* Ltac2 plugin *) +| "(" LIST1 ltac2_typevar SEP "," ")" (* Ltac2 plugin *) +] + +tac2typ_knd: [ +| ltac2_type (* Ltac2 plugin *) +| "[" OPT ( OPT "|" LIST1 tac2alg_constructor SEP "|" ) "]" (* Ltac2 plugin *) +| "[" ".." "]" (* Ltac2 plugin *) +| "{" OPT ( LIST1 tac2rec_field SEP ";" OPT ";" ) "}" (* Ltac2 plugin *) +] + +tac2alg_constructor: [ +| ident (* Ltac2 plugin *) +| ident "(" LIST0 ltac2_type SEP "," ")" (* Ltac2 plugin *) +] + +tac2rec_field: [ +| OPT "mutable" ident ":" ltac2_type (* Ltac2 plugin *) +] + +ltac2_scope: [ +| string (* Ltac2 plugin *) +| int (* Ltac2 plugin *) +| name (* Ltac2 plugin *) +| name "(" LIST1 ltac2_scope SEP "," ")" (* Ltac2 plugin *) +] + +ltac2_expr: [ +| ltac2_expr5 ";" ltac2_expr (* Ltac2 plugin *) +| ltac2_expr5 (* Ltac2 plugin *) +] + +ltac2_expr5: [ +| "fun" LIST1 tac2pat0 "=>" ltac2_expr (* Ltac2 plugin *) +| "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" ltac2_expr (* Ltac2 plugin *) +| ltac2_expr3 (* Ltac2 plugin *) +] + +ltac2_let_clause: [ +| LIST1 tac2pat0 ":=" ltac2_expr (* Ltac2 plugin *) +] + +ltac2_expr3: [ +| LIST1 ltac2_expr2 SEP "," (* Ltac2 plugin *) +] + +ltac2_expr2: [ +| ltac2_expr1 "::" ltac2_expr2 (* Ltac2 plugin *) +| ltac2_expr1 (* Ltac2 plugin *) +] + +ltac2_expr1: [ +| ltac2_expr0 LIST1 ltac2_expr0 (* Ltac2 plugin *) +| ltac2_expr0 ".(" qualid ")" (* Ltac2 plugin *) +| ltac2_expr0 ".(" qualid ")" ":=" ltac2_expr5 (* Ltac2 plugin *) +| ltac2_expr0 (* Ltac2 plugin *) +] + +tac2rec_fieldexpr: [ +| qualid ":=" ltac2_expr1 (* Ltac2 plugin *) +] + +ltac2_expr0: [ +| "(" ltac2_expr ")" (* Ltac2 plugin *) +| "(" ltac2_expr ":" ltac2_type ")" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "[" LIST0 ltac2_expr5 SEP ";" "]" (* Ltac2 plugin *) +| "{" OPT ( LIST1 tac2rec_fieldexpr OPT ";" ) "}" (* Ltac2 plugin *) +| ltac2_tactic_atom (* Ltac2 plugin *) +] + +ltac2_tactic_atom: [ +| int (* Ltac2 plugin *) +| string (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "@" ident (* Ltac2 plugin *) +| "&" lident (* Ltac2 plugin *) +| "'" term (* Ltac2 plugin *) +| ltac2_quotations +] + +ltac2_quotations: [ +| "ident" ":" "(" lident ")" +| "constr" ":" "(" term ")" +| "open_constr" ":" "(" term ")" +| "pattern" ":" "(" cpattern ")" +| "reference" ":" "(" [ "&" ident | qualid ] ")" +| "ltac1" ":" "(" ltac1_expr_in_env ")" +| "ltac1val" ":" "(" ltac1_expr_in_env ")" +] + +ltac1_expr_in_env: [ +| ltac_expr (* Ltac2 plugin *) +| LIST0 ident "|-" ltac_expr (* Ltac2 plugin *) +] + +ltac2_branches: [ +| OPT "|" LIST1 ( tac2pat1 "=>" ltac2_expr ) SEP "|" +] + +tac2pat1: [ +| qualid LIST1 tac2pat0 (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "[" "]" (* Ltac2 plugin *) +| tac2pat0 "::" tac2pat0 (* Ltac2 plugin *) +| tac2pat0 (* Ltac2 plugin *) +] + +tac2pat0: [ +| "_" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "(" OPT atomic_tac2pat ")" (* Ltac2 plugin *) +] + +atomic_tac2pat: [ +| tac2pat1 ":" ltac2_type (* Ltac2 plugin *) +| tac2pat1 "," LIST0 tac2pat1 SEP "," (* Ltac2 plugin *) +| tac2pat1 (* Ltac2 plugin *) +] + +tac2mode: [ +| ltac2_expr [ "." | "..." ] (* Ltac2 plugin *) +| "Eval" red_expr "in" term +| "Compute" term +| "Check" term +| "About" reference OPT univ_name_list +| "SearchHead" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) ] clause_dft_all: [ @@ -1636,17 +2181,6 @@ constr_with_bindings: [ | one_term OPT ( "with" bindings ) ] -destruction_arg: [ -| num -| constr_with_bindings -| constr_with_bindings_arg -] - -constr_with_bindings_arg: [ -| ">" constr_with_bindings -| constr_with_bindings -] - conversion: [ | one_term | one_term "with" one_term diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 01c4e5fd72..d719731464 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -183,8 +183,6 @@ let meta_ctr, meta_counter_summary_tag = let new_meta () = incr meta_ctr; !meta_ctr -let mk_new_meta () = EConstr.mkMeta(new_meta()) - (* The list of non-instantiated existential declarations (order is important) *) let non_instantiated sigma = @@ -522,9 +520,7 @@ let restrict_evar evd evk filter ?src candidates = let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in (* Mark new evar as future goal, removing previous one, circumventing Proofview.advance but making Proof.run_tactic catch these. *) - let future_goals = Evd.save_future_goals evd in - let future_goals = Evd.filter_future_goals (fun evk' -> not (Evar.equal evk evk')) future_goals in - let evd = Evd.restore_future_goals evd future_goals in + let evd = Evd.remove_future_goal evd evk in (Evd.declare_future_goal evk' evd, evk') let rec check_and_clear_in_constr env evdref err ids global c = diff --git a/engine/evarutil.mli b/engine/evarutil.mli index a8fc9ef5e2..9d2c29547e 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -21,7 +21,6 @@ open EConstr (** [new_meta] is a generator of unique meta variables *) val new_meta : unit -> metavariable -val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) diff --git a/engine/evd.ml b/engine/evd.ml index 92657c41a9..62a818ee6f 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -451,8 +451,6 @@ let key id (_, idtoev) = end -type goal_kind = ToShelve | ToGiveUp - type evar_flags = { obligation_evars : Evar.Set.t; restricted_evars : Evar.t Evar.Map.t; @@ -466,6 +464,133 @@ type side_effects = { seff_roles : side_effect_role Cmap.t; } +module FutureGoals : sig + + type t = private { + comb : Evar.t list; + shelf : Evar.t list; + principal : Evar.t option; (** if [Some e], [e] must be + contained in + [comb]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + } + + val map_filter : (Evar.t -> Evar.t option) -> t -> t + (** Applies a function on the future goals *) + + val filter : (Evar.t -> bool) -> t -> t + (** Applies a filter on the future goals *) + + type stack + + val empty_stack : stack + + val push : stack -> stack + val pop : stack -> t * stack + + val add : shelve:bool -> principal:bool -> Evar.t -> stack -> stack + val remove : Evar.t -> stack -> stack + + val fold : ('a -> Evar.t -> 'a) -> 'a -> stack -> 'a + + val put_shelf : Evar.t list -> stack -> stack + +end = struct + + type t = { + comb : Evar.t list; + shelf : Evar.t list; + principal : Evar.t option; (** if [Some e], [e] must be + contained in + [comb]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + } + + type stack = t list + + let set f = function + | [] -> anomaly Pp.(str"future_goals stack should not be empty") + | hd :: tl -> + f hd :: tl + + let add ~shelve ~principal evk stack = + let add fgl = + let (comb,shelf) = + if shelve then (fgl.comb,evk::fgl.shelf) + else (evk::fgl.comb,fgl.shelf) + in + let principal = + if principal then + match fgl.principal with + | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") + | None -> Some evk + else fgl.principal + in + { comb; shelf; principal } + in + set add stack + + let remove e stack = + let remove fgl = + let filter e' = not (Evar.equal e e') in + let principal = Option.filter filter fgl.principal in + let comb = List.filter filter fgl.comb in + let shelf = List.filter filter fgl.shelf in + { principal; comb; shelf } + in + List.map remove stack + + let empty = { + principal = None; + comb = []; + shelf = []; + } + + let empty_stack = [empty] + + let push stack = empty :: stack + + let pop stack = + match stack with + | [] -> anomaly Pp.(str"future_goals stack should not be empty") + | hd :: tl -> + hd, tl + + let fold f acc stack = + let future_goals = List.hd stack in + let future_goals = future_goals.comb @ future_goals.shelf in + List.fold_left f acc future_goals + + let filter f fgl = + let comb = List.filter f fgl.comb in + let shelf = List.filter f fgl.shelf in + let principal = Option.filter f fgl.principal in + { comb; shelf; principal } + + let map_filter f fgl = + let comb = List.map_filter f fgl.comb in + let shelf = List.map_filter f fgl.shelf in + let principal = Option.bind fgl.principal f in + { comb; shelf; principal } + + let put_shelf shelved stack = + match stack with + | [] -> anomaly Pp.(str"future_goals stack should not be empty") + | hd :: tl -> + let shelf = shelved @ hd.shelf in + { hd with shelf } :: tl + +end + + type evar_map = { (* Existential variables *) defn_evars : evar_info EvMap.t; @@ -481,17 +606,9 @@ type evar_map = { evar_flags : evar_flags; (** Interactive proofs *) effects : side_effects; - future_goals : Evar.t list; (** list of newly created evars, to be - eventually turned into goals if not solved.*) - principal_future_goal : Evar.t option; (** if [Some e], [e] must be - contained - [future_goals]. The evar - [e] will inherit - properties (now: the - name) of the evar which - will be instantiated with - a term containing [e]. *) - future_goals_status : goal_kind EvMap.t; + future_goals : FutureGoals.stack; (** list of newly created evars, to be + eventually turned into goals if not solved.*) + given_up : Evar.Set.t; extras : Store.t; } @@ -590,14 +707,9 @@ let new_evar evd ?name ?typeclass_candidate evi = let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in - let principal_future_goal = match d.principal_future_goal with - | None -> None - | Some e' -> if Evar.equal e e' then None else d.principal_future_goal - in - let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in - let future_goals_status = EvMap.remove e d.future_goals_status in + let future_goals = FutureGoals.remove e d.future_goals in let evar_flags = remove_evar_flags e d.evar_flags in - { d with undf_evars; defn_evars; principal_future_goal; future_goals; future_goals_status; + { d with undf_evars; defn_evars; future_goals; evar_flags } let find d e = @@ -723,9 +835,8 @@ let empty = { metas = Metamap.empty; effects = empty_side_effects; evar_names = EvNames.empty; (* id<->key for undefined evars *) - future_goals = []; - principal_future_goal = None; - future_goals_status = EvMap.empty; + future_goals = FutureGoals.empty_stack; + given_up = Evar.Set.empty; extras = Store.empty; } @@ -735,6 +846,8 @@ let from_ctx ctx = { empty with universes = ctx } let has_undefined evd = not (EvMap.is_empty evd.undf_evars) +let has_given_up evd = not (Evar.Set.is_empty evd.given_up) + let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in @@ -1059,72 +1172,35 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects (* Future goals *) -let declare_future_goal ?tag evk evd = - { evd with future_goals = evk::evd.future_goals; - future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status } - -let declare_principal_goal ?tag evk evd = - match evd.principal_future_goal with - | None -> { evd with - future_goals = evk::evd.future_goals; - principal_future_goal=Some evk; - future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status; - } - | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") - -type future_goals = Evar.t list * Evar.t option * goal_kind EvMap.t - -let future_goals evd = evd.future_goals - -let principal_future_goal evd = evd.principal_future_goal - -let save_future_goals evd = - (evd.future_goals, evd.principal_future_goal, evd.future_goals_status) - -let reset_future_goals evd = - { evd with future_goals = [] ; principal_future_goal = None; - future_goals_status = EvMap.empty } - -let restore_future_goals evd (gls,pgl,map) = - { evd with future_goals = gls ; principal_future_goal = pgl; - future_goals_status = map } - -let fold_future_goals f sigma (gls,pgl,map) = - List.fold_left f sigma gls - -let map_filter_future_goals f (gls,pgl,map) = - (* Note: map is now a superset of filtered evs, but its size should - not be too big, so that's probably ok not to update it *) - (List.map_filter f gls,Option.bind pgl f,map) - -let filter_future_goals f (gls,pgl,map) = - (List.filter f gls,Option.bind pgl (fun a -> if f a then Some a else None),map) - -let dispatch_future_goals_gen distinguish_shelf (gls,pgl,map) = - let rec aux (comb,shelf,givenup as acc) = function - | [] -> acc - | evk :: gls -> - let acc = - try match EvMap.find evk map with - | ToGiveUp -> (comb,shelf,evk::givenup) - | ToShelve -> - if distinguish_shelf then (comb,evk::shelf,givenup) - else raise Not_found - with Not_found -> (evk::comb,shelf,givenup) in - aux acc gls in - (* Note: this reverses the order of initial list on purpose *) - let (comb,shelf,givenup) = aux ([],[],[]) gls in - (comb,shelf,givenup,pgl) - -let dispatch_future_goals = - dispatch_future_goals_gen true - -let extract_given_up_future_goals goals = - let (comb,_,givenup,_) = dispatch_future_goals_gen false goals in - (comb,givenup) - -let shelve_on_future_goals shelved (gls,pgl,map) = - (shelved @ gls, pgl, List.fold_right (fun evk -> EvMap.add evk ToShelve) shelved map) +let declare_future_goal ?(shelve=false) evk evd = + let future_goals = FutureGoals.add ~shelve ~principal:false evk evd.future_goals in + { evd with future_goals } + +let declare_principal_goal ?(shelve=false) evk evd = + let future_goals = FutureGoals.add ~shelve ~principal:true evk evd.future_goals in + { evd with future_goals } + +let push_future_goals evd = + { evd with future_goals = FutureGoals.push evd.future_goals } + +let pop_future_goals evd = + let hd, future_goals = FutureGoals.pop evd.future_goals in + hd, { evd with future_goals } + +let fold_future_goals f sigma = + FutureGoals.fold f sigma sigma.future_goals + +let shelve_on_future_goals shelved evd = + let future_goals = FutureGoals.put_shelf shelved evd.future_goals in + { evd with future_goals } + +let remove_future_goal evd evk = + { evd with future_goals = FutureGoals.remove evk evd.future_goals } + +let give_up ev evd = + { evd with given_up = Evar.Set.add ev evd.given_up } + +let given_up evd = evd.given_up (**********************************************************) (* Accessing metas *) @@ -1142,8 +1218,7 @@ let set_metas evd metas = { effects = evd.effects; evar_names = evd.evar_names; future_goals = evd.future_goals; - future_goals_status = evd.future_goals_status; - principal_future_goal = evd.principal_future_goal; + given_up = evd.given_up; extras = evd.extras; } diff --git a/engine/evd.mli b/engine/evd.mli index d338b06e0e..db5265ca0a 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -167,6 +167,10 @@ val has_undefined : evar_map -> bool (** [has_undefined sigma] is [true] if and only if there are uninstantiated evars in [sigma]. *) +val has_given_up : evar_map -> bool +(** [has_given_up sigma] is [true] if and only if + there are given up evars in [sigma]. *) + val new_evar : evar_map -> ?name:Id.t -> ?typeclass_candidate:bool -> evar_info -> evar_map * Evar.t (** Creates a fresh evar mapping to the given information. *) @@ -343,59 +347,54 @@ val drop_side_effects : evar_map -> evar_map (** {5 Future goals} *) -type goal_kind = ToShelve | ToGiveUp - -val declare_future_goal : ?tag:goal_kind -> Evar.t -> evar_map -> evar_map +val declare_future_goal : ?shelve:bool -> Evar.t -> evar_map -> evar_map (** Adds an existential variable to the list of future goals. For internal uses only. *) -val declare_principal_goal : ?tag:goal_kind -> Evar.t -> evar_map -> evar_map +val declare_principal_goal : ?shelve:bool -> Evar.t -> evar_map -> evar_map (** Adds an existential variable to the list of future goals and make it principal. Only one existential variable can be made principal, an error is raised otherwise. For internal uses only. *) -val future_goals : evar_map -> Evar.t list -(** Retrieves the list of future goals. Used by the [refine] primitive - of the tactic engine. *) +module FutureGoals : sig -val principal_future_goal : evar_map -> Evar.t option -(** Retrieves the name of the principal existential variable if there - is one. Used by the [refine] primitive of the tactic engine. *) + type t = private { + comb : Evar.t list; + shelf : Evar.t list; + principal : Evar.t option; (** if [Some e], [e] must be + contained in + [future_comb]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + } -type future_goals + val map_filter : (Evar.t -> Evar.t option) -> t -> t + (** Applies a function on the future goals *) -val save_future_goals : evar_map -> future_goals -(** Retrieves the list of future goals including the principal future - goal. Used by the [refine] primitive of the tactic engine. *) + val filter : (Evar.t -> bool) -> t -> t + (** Applies a filter on the future goals *) -val reset_future_goals : evar_map -> evar_map -(** Clears the list of future goals (as well as the principal future - goal). Used by the [refine] primitive of the tactic engine. *) +end -val restore_future_goals : evar_map -> future_goals -> evar_map -(** Sets the future goals (including the principal future goal) to a - previous value. Intended to be used after a local list of future - goals has been consumed. Used by the [refine] primitive of the - tactic engine. *) +val push_future_goals : evar_map -> evar_map -val fold_future_goals : (evar_map -> Evar.t -> evar_map) -> evar_map -> future_goals -> evar_map -(** Fold future goals *) +val pop_future_goals : evar_map -> FutureGoals.t * evar_map -val map_filter_future_goals : (Evar.t -> Evar.t option) -> future_goals -> future_goals -(** Applies a function on the future goals *) +val fold_future_goals : (evar_map -> Evar.t -> evar_map) -> evar_map -> evar_map -val filter_future_goals : (Evar.t -> bool) -> future_goals -> future_goals -(** Applies a filter on the future goals *) +(** Fold future goals *) + +val shelve_on_future_goals : Evar.t list -> evar_map -> evar_map +(** Push goals on the shelve of future goals *) -val dispatch_future_goals : future_goals -> Evar.t list * Evar.t list * Evar.t list * Evar.t option -(** Returns the future_goals dispatched into regular, shelved, given_up - goals; last argument is the goal tagged as principal if any *) +val remove_future_goal : evar_map -> Evar.t -> evar_map -val extract_given_up_future_goals : future_goals -> Evar.t list * Evar.t list -(** An ad hoc variant for Proof.proof; not for general use *) +val give_up : Evar.t -> evar_map -> evar_map -val shelve_on_future_goals : Evar.t list -> future_goals -> future_goals -(** Push goals on the shelve of future goals *) +val given_up : evar_map -> Evar.Set.t (** {5 Sort variables} diff --git a/engine/proofview.ml b/engine/proofview.ml index fd8512d73e..2fc5ade0d2 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -60,6 +60,10 @@ type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * EConstr.types * (Evd.evar_map -> EConstr.constr -> telescope) +let map_telescope_evd f = function + | TNil sigma -> TNil (f sigma) + | TCons (env,sigma,ty,g) -> TCons(env,(f sigma),ty,g) + let dependent_init = (* Goals don't have a source location. *) let src = Loc.tag @@ Evar_kinds.GoalEvar in @@ -74,9 +78,10 @@ let dependent_init = entry, { solution = sol; comb = with_empty_state gl :: comb; shelf = [] } in fun t -> + let t = map_telescope_evd Evd.push_future_goals t in let entry, v = aux t in (* The created goal are not to be shelved. *) - let solution = Evd.reset_future_goals v.solution in + let _goals, solution = Evd.pop_future_goals v.solution in entry, { v with solution } let init = @@ -230,8 +235,7 @@ let apply ~name ~poly env t sp = match ans with | Nil (e, info) -> Exninfo.iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> - let (status, gaveup) = status in - let status = (status, state.shelf, gaveup) in + let status = (status, state.shelf) in let state = { state with shelf = [] } in r, state, status, Trace.to_tree info @@ -747,17 +751,16 @@ let with_shelf tac = let open Proof in Pv.get >>= fun pv -> let { shelf; solution } = pv in - Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> + Pv.set { pv with shelf = []; solution = Evd.push_future_goals solution } >> tac >>= fun ans -> Pv.get >>= fun npv -> let { shelf = gls; solution = sigma } = npv in (* The pending future goals are necessarily coming from V82.tactic *) (* and thus considered as to shelve, as in Proof.run_tactic *) - let gls' = Evd.future_goals sigma in - let fgoals = Evd.save_future_goals solution in - let sigma = Evd.restore_future_goals sigma fgoals in + let fgl, sigma = Evd.pop_future_goals sigma in (* Ensure we mark and return only unsolved goals *) - let gls' = undefined_evars sigma (CList.rev_append gls' gls) in + let gls' = CList.rev_append fgl.Evd.FutureGoals.shelf (CList.rev_append fgl.Evd.FutureGoals.comb gls) in + let gls' = undefined_evars sigma gls' in let sigma = mark_in_evm ~goal:false sigma gls' in let npv = { npv with shelf; solution = sigma } in Pv.set npv >> tclUNIT (gls', ans) @@ -833,14 +836,18 @@ let mark_as_unsafe = Status.put false (** Gives up on the goal under focus. Reports an unsafe status. Proofs with given up goals cannot be closed. *) + +let give_up evs pv = + let solution = List.fold_left (fun sigma ev -> Evd.give_up (drop_state ev) sigma) pv.solution evs in + { pv with solution } + let give_up = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> mark_as_unsafe >> InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"give_up")) >> - Giveup.put (CList.map drop_state initial) - + Pv.modify (give_up initial) (** {7 Control primitives} *) @@ -1008,16 +1015,14 @@ module Unsafe = struct let tclPUTSHELF to_shelve = tclBIND tclGETSHELF (fun shelf -> tclSETSHELF (to_shelve@shelf)) - let tclPUTGIVENUP = Giveup.put - let tclEVARSADVANCE evd = Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) - let reset_future_goals p = - { p with solution = Evd.reset_future_goals p.solution } + let push_future_goals p = + { p with solution = Evd.push_future_goals p.solution } let mark_as_goals evd content = mark_in_evm ~goal:true evd content diff --git a/engine/proofview.mli b/engine/proofview.mli index 0f49d2f5d8..8853013a84 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -162,7 +162,7 @@ val apply -> 'a tactic -> proofview -> 'a * proofview - * (bool*Evar.t list*Evar.t list) + * (bool*Evar.t list) * Proofview_monad.Info.tree (** {7 Monadic primitives} *) @@ -470,14 +470,11 @@ module Unsafe : sig (** [tclPUTSHELF] appends goals to the shelf. *) val tclPUTSHELF : Evar.t list -> unit tactic - (** [tclPUTGIVENUP] add an given up goal. *) - val tclPUTGIVENUP : Evar.t list -> unit tactic - (** Sets the evar universe context. *) val tclEVARUNIVCONTEXT : UState.t -> unit tactic (** Clears the future goals store in the proof view. *) - val reset_future_goals : proofview -> proofview + val push_future_goals : proofview -> proofview (** Give the evars the status of a goal (changes their source location and makes them unresolvable for type classes. *) diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 2f53d5bc73..4b3dd8f633 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -180,10 +180,10 @@ module P = struct type e = { trace: bool; name : Names.Id.t; poly : bool } (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * goal list + type w = bool - let wunit = true , [] - let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2 + let wunit = true + let wprod b1 b2 = b1 && b2 type u = Info.state @@ -235,7 +235,7 @@ module Env : State with type t := Environ.env = struct end module Status : Writer with type t := bool = struct - let put s = Logical.put (s, []) + let put s = Logical.put s end module Shelf : State with type t = goal list = struct @@ -246,12 +246,6 @@ module Shelf : State with type t = goal list = struct let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) end -module Giveup : Writer with type t = goal list = struct - (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) - type t = goal list - let put gs = Logical.put (true, gs) -end - (** Lens and utilities pertaining to the info trace *) module InfoL = struct let recording = Logical.(map (fun {P.trace} -> trace) current) diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index a32b27904d..af866528c8 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -92,7 +92,7 @@ module P : sig type s = proofview * Environ.env (** Status (safe/unsafe) * given up *) - type w = bool * goal list + type w = bool val wunit : w val wprod : w -> w -> w @@ -141,10 +141,6 @@ module Status : Writer with type t := bool execution of the tactic. *) module Shelf : State with type t = goal list -(** Lens to the list of goals which were given up during the execution - of the tactic. *) -module Giveup : Writer with type t = goal list - (** Lens and utilities pertaining to the info trace *) module InfoL : sig (** [record_trace t] behaves like [t] and compute its [info] trace. *) diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 2adc35ae3e..751bddc7c4 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -220,12 +220,12 @@ let process_goal_diffs diff_goal_map oldp nsigma ng = let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } -let export_pre_goals Proof.{ sigma; goals; stack; shelf; given_up } process = +let export_pre_goals Proof.{ sigma; goals; stack; shelf } process = let process = List.map (process sigma) in { Interface.fg_goals = process goals ; Interface.bg_goals = List.(map (fun (lg,rg) -> process lg, process rg)) stack ; Interface.shelved_goals = process shelf - ; Interface.given_up_goals = process given_up + ; Interface.given_up_goals = process (Evar.Set.elements @@ Evd.given_up sigma) } let goals () = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 3667757a2f..43fef8685d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -636,10 +636,10 @@ exception Expl (* If the removal of implicit arguments is not possible, raise [Expl] *) (* [inctx] tells if the term is in a context which will enforce the external type *) (* [n] is the total number of arguments block to which the [args] belong *) -let adjust_implicit_arguments inctx n q args impl = - let rec exprec q = function +let adjust_implicit_arguments inctx n args impl = + let rec exprec = function | a::args, imp::impl when is_status_implicit imp -> - let tail = exprec (q+1) (args,impl) in + let tail = exprec (args,impl) in let visible = !Flags.raw_print || (!print_implicits && !print_implicits_explicit_args) || @@ -652,13 +652,13 @@ let adjust_implicit_arguments inctx n q args impl = (Lazy.force a,Some (make @@ ExplByName (name_of_implicit imp))) :: tail else tail - | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl) + | a::args, _::impl -> (Lazy.force a,None) :: exprec (args,impl) | args, [] -> List.map (fun a -> (Lazy.force a,None)) args (*In case of polymorphism*) | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> (* The non-explicit application cannot be parsed back with the same type *) raise Expl | [], _ -> [] - in exprec q (args,impl) + in exprec (args,impl) let extern_projection (cf,f) args impl = let ip = is_projection (List.length args) cf in @@ -750,14 +750,14 @@ let extern_applied_ref inctx impl (cf,f) us args = match extern_projection (cf,f) args impl with (* Try a [t.(f args1) args2] projection-style notation *) | Some (i,(args1,impl1),(args2,impl2)) -> - let args1 = adjust_implicit_arguments inctx n 1 args1 impl1 in - let args2 = adjust_implicit_arguments inctx n (i+1) args2 impl2 in + let args1 = adjust_implicit_arguments inctx n args1 impl1 in + let args2 = adjust_implicit_arguments inctx n args2 impl2 in let ip = Some (List.length args1) in CApp ((ip,f),args1@args2) (* A normal application node with each individual implicit arguments either dropped or made explicit *) | None -> - let args = adjust_implicit_arguments inctx n 1 args impl in + let args = adjust_implicit_arguments inctx n args impl in if args = [] then ref else CApp ((None, f), args) with Expl -> (* A [@f args] node *) @@ -765,10 +765,10 @@ let extern_applied_ref inctx impl (cf,f) us args = let isproj = if !print_projections then isproj else None in CAppExpl ((isproj,f,us), args) -let extern_applied_syntactic_definition n extraimpl (cf,f) syndefargs extraargs = +let extern_applied_syntactic_definition inctx n extraimpl (cf,f) syndefargs extraargs = try let syndefargs = List.map (fun a -> (a,None)) syndefargs in - let extraargs = adjust_implicit_arguments false n (n-List.length extraargs+1) extraargs extraimpl in + let extraargs = adjust_implicit_arguments inctx n extraargs extraimpl in let args = syndefargs @ extraargs in if args = [] then cf else CApp ((None, CAst.make cf), args) with Expl -> @@ -784,12 +784,12 @@ let mkFlattenedCApp (head,args) = | _ -> CApp ((None, head), args) -let extern_applied_notation n impl f args = +let extern_applied_notation inctx n impl f args = if List.is_empty args then f.CAst.v else try - let args = adjust_implicit_arguments false n (n-List.length args+1) args impl in + let args = adjust_implicit_arguments inctx n args impl in mkFlattenedCApp (f,args) with Expl -> raise No_match @@ -940,11 +940,11 @@ let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) let rec extern inctx ?impargs scopes vars r = match remove_one_coercion inctx (flatten_application r) with | Some (nargs,inctx,r') -> - (try extern_notations scopes vars (Some nargs) r + (try extern_notations inctx scopes vars (Some nargs) r with No_match -> extern inctx scopes vars r') | None -> - try extern_notations scopes vars None r + try extern_notations inctx scopes vars None r with No_match -> let loc = r.CAst.loc in @@ -1000,7 +1000,7 @@ let rec extern inctx ?impargs scopes vars r = mkFlattenedCApp (head,args)) | GLetIn (na,b,t,c) -> - CLetIn (make ?loc na,sub_extern false scopes vars b, + CLetIn (make ?loc na,sub_extern (Option.has_some t) scopes vars b, Option.map (extern_typ scopes vars) t, extern inctx ?impargs scopes (add_vname vars na) c) @@ -1197,7 +1197,7 @@ and extern_local_binder scopes vars = function extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in (assums,na::ids, CLocalDef(CAst.make na, extern false scopes vars bd, - Option.map (extern false scopes vars) ty) :: l) + Option.map (extern_typ scopes vars) ty) :: l) | GLocalAssum (na,bk,ty) -> let implicit_type = is_reserved_type na ty in @@ -1225,14 +1225,14 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in make ?loc (pll,extern inctx scopes vars c) -and extern_notations scopes vars nargs t = +and extern_notations inctx scopes vars nargs t = if !Flags.raw_print || !print_no_symbol then raise No_match; try extern_possible_prim_token scopes t with No_match -> let t = flatten_application t in - extern_notation scopes vars t (filter_enough_applied nargs (uninterp_notations t)) + extern_notation inctx scopes vars t (filter_enough_applied nargs (uninterp_notations t)) -and extern_notation (custom,scopes as allscopes) vars t rules = +and extern_notation inctx (custom,scopes as allscopes) vars t rules = match rules with | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> @@ -1313,7 +1313,7 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let c = insert_entry_coercion coercion (insert_delimiters c key) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in - CAst.make ?loc @@ extern_applied_notation nallargs argsimpls c args) + CAst.make ?loc @@ extern_applied_notation inctx nallargs argsimpls c args) | SynDefRule kn -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> @@ -1323,13 +1323,13 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let a = CRef (cf,None) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in - let c = CAst.make ?loc @@ extern_applied_syntactic_definition nallargs argsimpls (a,cf) l args in + let c = CAst.make ?loc @@ extern_applied_syntactic_definition inctx nallargs argsimpls (a,cf) l args in if isCRef_no_univ c.CAst.v && entry_has_global custom then c else match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> insert_entry_coercion coercion c with - No_match -> extern_notation allscopes vars t rules + No_match -> extern_notation inctx allscopes vars t rules let extern_glob_constr vars c = extern false (InConstrEntrySomeLevel,(None,[])) vars c diff --git a/interp/dune b/interp/dune index e9ef7ba99a..6d73d5724c 100644 --- a/interp/dune +++ b/interp/dune @@ -3,4 +3,4 @@ (synopsis "Coq's Syntactic Interpretation for AST [notations, implicits]") (public_name coq.interp) (wrapped false) - (libraries pretyping)) + (libraries zarith pretyping)) diff --git a/interp/notation.ml b/interp/notation.ml index c4e9496b95..17ae045187 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -388,7 +388,7 @@ module InnerPrimToken = struct type interpreter = | RawNumInterp of (?loc:Loc.t -> rawnum -> glob_constr) - | BigNumInterp of (?loc:Loc.t -> Bigint.bigint -> glob_constr) + | BigNumInterp of (?loc:Loc.t -> Z.t -> glob_constr) | StringInterp of (?loc:Loc.t -> string -> glob_constr) let interp_eq f f' = match f,f' with @@ -410,7 +410,7 @@ module InnerPrimToken = struct type uninterpreter = | RawNumUninterp of (any_glob_constr -> rawnum option) - | BigNumUninterp of (any_glob_constr -> Bigint.bigint option) + | BigNumUninterp of (any_glob_constr -> Z.t option) | StringUninterp of (any_glob_constr -> string option) let uninterp_eq f f' = match f,f' with @@ -612,13 +612,14 @@ let uninterp to_raw o (Glob_term.AnyGlobConstr n) = end +let z_two = Z.of_int 2 + (** Conversion from bigint to int63 *) let rec int63_of_pos_bigint i = - let open Bigint in - if equal i zero then Uint63.of_int 0 + if Z.(equal i zero) then Uint63.of_int 0 else - let (quo,rem) = div2_with_rest i in - if rem then Uint63.add (Uint63.of_int 1) + let quo, remi = Z.div_rem i z_two in + if Z.(equal remi one) then Uint63.add (Uint63.of_int 1) (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) @@ -800,24 +801,24 @@ let rawnum_of_coqint c = (** First, [positive] from/to bigint *) let rec pos_of_bigint posty n = - match Bigint.div2_with_rest n with - | (q, false) -> + match Z.div_rem n z_two with + | (q, rem) when rem = Z.zero -> let c = mkConstruct (posty, 2) in (* xO *) mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) when not (Bigint.equal q Bigint.zero) -> + | (q, _) when not (Z.equal q Z.zero) -> let c = mkConstruct (posty, 1) in (* xI *) mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) -> + | (q, _) -> mkConstruct (posty, 3) (* xH *) let rec bigint_of_pos c = match Constr.kind c with - | Construct ((_, 3), _) -> (* xH *) Bigint.one + | Construct ((_, 3), _) -> (* xH *) Z.one | App (c, [| d |]) -> begin match Constr.kind c with | Construct ((_, n), _) -> begin match n with - | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) - | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) + | 1 -> (* xI *) Z.add Z.one (Z.mul z_two (bigint_of_pos d)) + | 2 -> (* xO *) Z.mul z_two (bigint_of_pos d) | n -> assert false (* no other constructor of type positive *) end | x -> raise NotAValidPrimToken @@ -827,24 +828,24 @@ let rec bigint_of_pos c = match Constr.kind c with (** Now, [Z] from/to bigint *) let z_of_bigint { z_ty; pos_ty } n = - if Bigint.equal n Bigint.zero then + if Z.(equal n zero) then mkConstruct (z_ty, 1) (* Z0 *) else let (s, n) = - if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) - else (3, Bigint.neg n) (* Zneg *) + if Z.(leq zero n) then (2, n) (* Zpos *) + else (3, Z.neg n) (* Zneg *) in let c = mkConstruct (z_ty, s) in mkApp (c, [| pos_of_bigint pos_ty n |]) let bigint_of_z z = match Constr.kind z with - | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero + | Construct ((_, 1), _) -> (* Z0 *) Z.zero | App (c, [| d |]) -> begin match Constr.kind c with | Construct ((_, n), _) -> begin match n with | 2 -> (* Zpos *) bigint_of_pos d - | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) + | 3 -> (* Zneg *) Z.neg (bigint_of_pos d) | n -> assert false (* no other constructor of type Z *) end | _ -> raise NotAValidPrimToken @@ -861,20 +862,19 @@ let error_negative ?loc = CErrors.user_err ?loc ~hdr:"interp_int63" (Pp.str "int63 are only non-negative numbers.") let error_overflow ?loc n = - CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Bigint.to_string n)) + CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Z.to_string n)) let interp_int63 ?loc n = - let open Bigint in - if is_pos_or_zero n + if Z.(leq zero n) then - if less_than n (pow two 63) + if Z.(lt n (pow z_two 63)) then int63_of_pos_bigint ?loc n else error_overflow ?loc n else error_negative ?loc let bigint_of_int63 c = match Constr.kind c with - | Int i -> Bigint.of_string (Uint63.to_string i) + | Int i -> Z.of_string (Uint63.to_string i) | _ -> raise NotAValidPrimToken let interp o ?loc n = @@ -1429,7 +1429,7 @@ let declare_entry_coercion (scope,(entry,key)) lev entry' = let toaddright = EntryCoercionMap.fold (fun (entry'',entry''') paths l -> List.fold_right (fun ((lev'',lev'''),path) l -> - if entry' = entry'' && level_ord lev' lev'' && entry <> entry''' + if entry' = entry'' && level_ord lev'' lev' && entry <> entry''' then ((entry,entry'''),((lev,lev'''),path@[(scope,(entry,key))]))::l else l) paths l) !entry_coercion_map [] in entry_coercion_map := diff --git a/interp/notation.mli b/interp/notation.mli index 05ddd25a62..948831b317 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -101,7 +101,7 @@ val register_rawnumeral_interpretation : ?allow_overwrite:bool -> prim_token_uid -> rawnum prim_token_interpretation -> unit val register_bignumeral_interpretation : - ?allow_overwrite:bool -> prim_token_uid -> Bigint.bigint prim_token_interpretation -> unit + ?allow_overwrite:bool -> prim_token_uid -> Z.t prim_token_interpretation -> unit val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit @@ -196,8 +196,8 @@ val enable_prim_token_interpretation : prim_token_infos -> unit *) val declare_numeral_interpreter : ?local:bool -> scope_name -> required_module -> - Bigint.bigint prim_token_interpreter -> - glob_constr list * Bigint.bigint prim_token_uninterpreter * bool -> unit + Z.t prim_token_interpreter -> + glob_constr list * Z.t prim_token_uninterpreter * bool -> unit val declare_string_interpreter : ?local:bool -> scope_name -> required_module -> string prim_token_interpreter -> glob_constr list * string prim_token_uninterpreter * bool -> unit @@ -349,4 +349,4 @@ val level_of_notation : notation -> level val with_notation_protection : ('a -> 'b) -> 'a -> 'b (** Conversion from bigint to int63 *) -val int63_of_pos_bigint : Bigint.bigint -> Uint63.t +val int63_of_pos_bigint : Z.t -> Uint63.t diff --git a/interp/numTok.ml b/interp/numTok.ml index bb14649b91..124a6cd249 100644 --- a/interp/numTok.ml +++ b/interp/numTok.ml @@ -80,63 +80,14 @@ struct let to_string (sign,n) = (match sign with SPlus -> "" | SMinus -> "-") ^ UnsignedNat.to_string n let classify (_,n) = UnsignedNat.classify n - let bigint_of_string (sign,n) = - (* nasty code to remove when switching to zarith - since zarith's of_string handles hexadecimal *) - match UnsignedNat.classify n with - | CDec -> Bigint.of_string (to_string (sign,n)) - | CHex -> - let int_of_char c = match c with - | 'a'..'f' -> 10 + int_of_char c - int_of_char 'a' - | _ -> int_of_char c - int_of_char '0' in - let c16 = Bigint.of_int 16 in - let s = UnsignedNat.to_string n in - let n = ref Bigint.zero in - let len = String.length s in - for d = 2 to len - 1 do - n := Bigint.(add (mult !n c16) (of_int (int_of_char s.[d]))) - done; - match sign with SPlus -> !n | SMinus -> Bigint.neg !n + let bigint_of_string (sign,n) = Z.of_string (to_string (sign,n)) let to_bigint n = bigint_of_string n let string_of_nonneg_bigint c n = - (* nasty code to remove when switching to zarith - since zarith's format handles hexadecimal *) match c with - | CDec -> Bigint.to_string n - | CHex -> - let div16 n = - let n, r0 = Bigint.div2_with_rest n in - let n, r1 = Bigint.div2_with_rest n in - let n, r2 = Bigint.div2_with_rest n in - let n, r3 = Bigint.div2_with_rest n in - let r = match r3, r2, r1, r0 with - | false, false, false, false -> "0" - | false, false, false, true -> "1" - | false, false, true, false -> "2" - | false, false, true, true -> "3" - | false, true, false, false -> "4" - | false, true, false, true -> "5" - | false, true, true, false -> "6" - | false, true, true, true -> "7" - | true, false, false, false -> "8" - | true, false, false, true -> "9" - | true, false, true, false -> "a" - | true, false, true, true -> "b" - | true, true, false, false -> "c" - | true, true, false, true -> "d" - | true, true, true, false -> "e" - | true, true, true, true -> "f" in - n, r in - let n = ref n in - let l = ref [] in - while Bigint.is_strictly_pos !n do - let n', r = div16 !n in - n := n'; - l := r :: !l - done; - "0x" ^ String.concat "" (List.rev !l) + | CDec -> Z.format "%d" n + | CHex -> Z.format "0x%x" n let of_bigint c n = - let sign, n = if Bigint.is_strictly_neg n then (SMinus, Bigint.neg n) else (SPlus, n) in + let sign, n = if Int.equal (-1) (Z.sign n) then (SMinus, Z.neg n) else (SPlus, n) in (sign, string_of_nonneg_bigint c n) end @@ -339,13 +290,13 @@ struct let frac = UnsignedNat.to_string frac in let i = SignedNat.to_bigint (s, int ^ frac) in let e = - let e = if exp = "" then Bigint.zero else match exp.[1] with - | '+' -> Bigint.of_string (UnsignedNat.to_string (string_del_head 2 exp)) - | '-' -> Bigint.(neg (of_string (UnsignedNat.to_string (string_del_head 2 exp)))) - | _ -> Bigint.of_string (UnsignedNat.to_string (string_del_head 1 exp)) in + let e = if exp = "" then Z.zero else match exp.[1] with + | '+' -> Z.of_string (UnsignedNat.to_string (string_del_head 2 exp)) + | '-' -> Z.(neg (of_string (UnsignedNat.to_string (string_del_head 2 exp)))) + | _ -> Z.of_string (UnsignedNat.to_string (string_del_head 1 exp)) in let l = String.length frac in let l = match c with CDec -> l | CHex -> 4 * l in - Bigint.(sub e (of_int l)) in + Z.(sub e (of_int l)) in (i, match c with CDec -> EDec e | CHex -> EBin e) let of_bigint_and_exponent i e = diff --git a/interp/numTok.mli b/interp/numTok.mli index 11d5a0f980..bcfe663dd2 100644 --- a/interp/numTok.mli +++ b/interp/numTok.mli @@ -65,8 +65,8 @@ sig val classify : t -> num_class - val of_bigint : num_class -> Bigint.bigint -> t - val to_bigint : t -> Bigint.bigint + val of_bigint : num_class -> Z.t -> t + val to_bigint : t -> Z.t end (** {6 Unsigned decimal numerals } *) @@ -131,8 +131,8 @@ sig val to_string : t -> string (** Returns a string in the syntax of OCaml's float_of_string *) - val of_bigint : num_class -> Bigint.bigint -> t - val to_bigint : t -> Bigint.bigint option + val of_bigint : num_class -> Z.t -> t + val to_bigint : t -> Z.t option (** Convert from and to bigint when the denotation of a bigint *) val of_int_frac_and_exponent : SignedNat.t -> UnsignedNat.t option -> SignedNat.t option -> t @@ -140,8 +140,8 @@ sig (** n, p and q such that the number is n.p*10^q or n.p*2^q pre/postcondition: classify n = classify p, classify q = CDec *) - val of_bigint_and_exponent : Bigint.bigint -> Bigint.bigint exp -> t - val to_bigint_and_exponent : t -> Bigint.bigint * Bigint.bigint exp + val of_bigint_and_exponent : Z.t -> Z.t exp -> t + val to_bigint_and_exponent : t -> Z.t * Z.t exp (** n and p such that the number is n*10^p or n*2^p *) val classify : t -> num_class diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 7609c1a64d..9c32cd8e0e 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -107,7 +107,7 @@ type 'opaque constant_body = { const_body : (Constr.t Mod_subst.substituted, 'opaque) constant_def; const_type : types; const_relevance : Sorts.relevance; - const_body_code : Cemitcodes.to_patch_substituted option; + const_body_code : Vmemitcodes.to_patch_substituted option; const_universes : universes; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 326bf0d6ad..b9f434f179 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -116,7 +116,7 @@ let subst_const_body sub cb = const_body = body'; const_type = type'; const_body_code = - Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; + Option.map (Vmemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; const_relevance = cb.const_relevance; const_inline_code = cb.const_inline_code; diff --git a/kernel/dune b/kernel/dune index 5f7502ef6b..ce6fdc03df 100644 --- a/kernel/dune +++ b/kernel/dune @@ -11,7 +11,7 @@ (modules genOpcodeFiles)) (rule - (targets copcodes.ml) + (targets vmopcodes.ml) (action (with-stdout-to %{targets} (run ./genOpcodeFiles.exe copml)))) (rule diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index 67a672c349..2d74cca44c 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -11,7 +11,7 @@ (** List of opcodes. It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and - [copcodes.ml] files. + [vmopcodes.ml] files. 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. @@ -196,7 +196,7 @@ let pp_coq_instruct_h fmt = let pp_coq_jumptbl_h fmt = pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") -let pp_copcodes_ml fmt = +let pp_vmopcodes_ml fmt = pp_header true fmt; Array.iteri (fun n s -> Format.fprintf fmt "let op%s = %d@.@." s n @@ -210,7 +210,7 @@ let main () = match Sys.argv.(1) with | "enum" -> pp_coq_instruct_h Format.std_formatter | "jump" -> pp_coq_jumptbl_h Format.std_formatter - | "copml" -> pp_copcodes_ml Format.std_formatter + | "copml" -> pp_vmopcodes_ml Format.std_formatter | _ -> usage () | exception Invalid_argument _ -> usage () diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 41388d9f17..d4d7150222 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -15,9 +15,9 @@ Term CPrimitives Mod_subst Vmvalues -Cbytecodes -Copcodes -Cemitcodes +Vmbytecodes +Vmopcodes +Vmemitcodes Opaqueproof Declarations Entries @@ -30,12 +30,12 @@ Primred CClosure Relevanceops Reduction -Clambda +Vmlambda Nativelambda -Cbytegen +Vmbytegen Nativecode Nativelib -Csymtable +Vmsymtable Vm Vconv Nativeconv diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 44b010204b..5873d1f502 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -124,8 +124,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = { cb with const_body = def; const_universes = univs ; - const_body_code = Option.map Cemitcodes.from_val - (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } + const_body_code = Option.map Vmemitcodes.from_val + (Vmbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else diff --git a/kernel/modops.ml b/kernel/modops.ml index 77ef38dfd5..883ad79be5 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -328,7 +328,7 @@ let strengthen_const mp_from l cb resolver = let u = Univ.make_abstract_instance (Declareops.constant_polymorphic_context cb) in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); - const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } + const_body_code = Some (Vmemitcodes.from_val (Vmbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index b00b96018f..99090f0147 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -395,8 +395,8 @@ let rec get_alias env (kn, u as p) = match tps with | None -> p | Some tps -> - match Cemitcodes.force tps with - | Cemitcodes.BCalias kn' -> get_alias env (kn', u) + match Vmemitcodes.force tps with + | Vmemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p let prim env kn p args = diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 48567aa564..24aa4ed771 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -283,8 +283,8 @@ let build_constant_declaration env result = let univs = result.cook_universes in let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in let tps = - let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in - Option.map Cemitcodes.from_val res + let res = Vmbytegen.compile_constant_body ~fail_on_error:false env univs def in + Option.map Vmemitcodes.from_val res in { const_hyps = hyps; const_body = def; @@ -343,8 +343,8 @@ let translate_recipe env _kn r = let open Cooking in let result = Cooking.cook_constant r in let univs = result.cook_universes in - let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in - let tps = Option.map Cemitcodes.from_val res in + let res = Vmbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in + let tps = Option.map Vmemitcodes.from_val res in let hyps = Option.get result.cook_context in (* Trust the set of section hypotheses generated by Cooking *) let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in diff --git a/kernel/vconv.ml b/kernel/vconv.ml index f78f0d4d1e..cc2c2c0b4b 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -4,7 +4,7 @@ open Environ open Reduction open Vm open Vmvalues -open Csymtable +open Vmsymtable (* Test la structure des piles *) diff --git a/kernel/vm.ml b/kernel/vm.ml index d8c66bebd2..76954a83d8 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -44,7 +44,7 @@ external coq_interprete : tcode -> values -> atom array -> vm_global -> vm_env - "coq_interprete_byte" "coq_interprete_ml" let interprete code v env k = - coq_interprete code v (get_atom_rel ()) (Csymtable.get_global_data ()) env k + coq_interprete code v (get_atom_rel ()) (Vmsymtable.get_global_data ()) env k (* Functions over arguments *) diff --git a/kernel/cbytecodes.ml b/kernel/vmbytecodes.ml index 74405a0105..74405a0105 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/vmbytecodes.ml diff --git a/kernel/cbytecodes.mli b/kernel/vmbytecodes.mli index b703058fb7..b703058fb7 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/vmbytecodes.mli diff --git a/kernel/cbytegen.ml b/kernel/vmbytegen.ml index bacc308e1f..1274e3a867 100644 --- a/kernel/cbytegen.ml +++ b/kernel/vmbytegen.ml @@ -15,9 +15,9 @@ open Util open Names open Vmvalues -open Cbytecodes -open Cemitcodes -open Clambda +open Vmbytecodes +open Vmemitcodes +open Vmlambda open Constr open Declarations open Environ @@ -116,7 +116,7 @@ end module FvMap = Map.Make(Fv_elem) -(*spiwack: both type have been moved from Cbytegen because I needed then +(*spiwack: both type have been moved from Vmbytegen because I needed then for the retroknowledge *) type vm_env = { size : int; (* longueur de la liste [n] *) @@ -512,7 +512,7 @@ let rec get_alias env kn = match tps with | None -> kn | Some tps -> - (match Cemitcodes.force tps with + (match Vmemitcodes.force tps with | BCalias kn' -> get_alias env kn' | _ -> kn) diff --git a/kernel/cbytegen.mli b/kernel/vmbytegen.mli index d5ea2509ef..aef7ac3d6b 100644 --- a/kernel/cbytegen.mli +++ b/kernel/vmbytegen.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Cbytecodes -open Cemitcodes +open Vmbytecodes +open Vmemitcodes open Constr open Declarations open Environ diff --git a/kernel/cemitcodes.ml b/kernel/vmemitcodes.ml index ed475dca7e..2dfc9a2941 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -14,8 +14,8 @@ open Names open Vmvalues -open Cbytecodes -open Copcodes +open Vmbytecodes +open Vmopcodes open Mod_subst open CPrimitives @@ -350,7 +350,7 @@ let emit_instr env = function | Ksetfield n -> if n <= 1 then out env (opSETFIELD0+n) else (out env opSETFIELD;out_int env n) - | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" + | 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 | Kbranch lbl -> out env opBRANCH; out_label env lbl diff --git a/kernel/cemitcodes.mli b/kernel/vmemitcodes.mli index c4262f3380..5c0e103143 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/vmemitcodes.mli @@ -9,7 +9,7 @@ (************************************************************************) open Names open Vmvalues -open Cbytecodes +open Vmbytecodes type reloc_info = | Reloc_annot of annot_switch diff --git a/kernel/clambda.ml b/kernel/vmlambda.ml index 6690a379ce..332a331a7a 100644 --- a/kernel/clambda.ml +++ b/kernel/vmlambda.ml @@ -559,8 +559,8 @@ let rec get_alias env kn = match tps with | None -> kn | Some tps -> - (match Cemitcodes.force tps with - | Cemitcodes.BCalias kn' -> get_alias env kn' + (match Vmemitcodes.force tps with + | Vmemitcodes.BCalias kn' -> get_alias env kn' | _ -> kn) (* Compilation of primitive *) @@ -681,7 +681,7 @@ open Renv let rec lambda_of_constr env c = match Constr.kind c with - | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta") + | Meta _ -> raise (Invalid_argument "Vmbytegen.lambda_of_constr: Meta") | Evar (evk, args) -> let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in Levar (evk, args) diff --git a/kernel/clambda.mli b/kernel/vmlambda.mli index bd11c2667f..bd11c2667f 100644 --- a/kernel/clambda.mli +++ b/kernel/vmlambda.mli diff --git a/kernel/csymtable.ml b/kernel/vmsymtable.ml index 185fb9f5a4..85f7369654 100644 --- a/kernel/csymtable.ml +++ b/kernel/vmsymtable.ml @@ -17,11 +17,11 @@ open Util open Names open Vmvalues -open Cemitcodes -open Cbytecodes +open Vmemitcodes +open Vmbytecodes open Declarations open Environ -open Cbytegen +open Vmbytegen module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -155,7 +155,7 @@ let rec slot_for_getglobal env kn = match cb.const_body_code with | None -> set_global (val_of_constant kn) | Some code -> - match Cemitcodes.force code with + match Vmemitcodes.force code with | BCdefined(code,pl,fv) -> let v = eval_to_patch env (code,pl,fv) in set_global v diff --git a/kernel/csymtable.mli b/kernel/vmsymtable.mli index e480bfcec1..e480bfcec1 100644 --- a/kernel/csymtable.mli +++ b/kernel/vmsymtable.mli diff --git a/library/summary.ml b/library/summary.ml index 9ff707f842..221ac868fa 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -19,7 +19,8 @@ type 'a summary_declaration = { unfreeze_function : 'a -> unit; init_function : unit -> unit } -module DynMap = Dyn.Map(struct type 'a t = 'a summary_declaration end) +module Decl = struct type 'a t = 'a summary_declaration end +module DynMap = Dyn.Map(Decl) type ml_modules = (string * string option) list @@ -46,7 +47,8 @@ let declare_summary_tag sumname decl = let declare_summary sumname decl = ignore(declare_summary_tag sumname decl) -module Frozen = Dyn.Map(struct type 'a t = 'a end) +module ID = struct type 'a t = 'a end +module Frozen = Dyn.Map(ID) type frozen = { summaries : Frozen.t; @@ -57,9 +59,11 @@ type frozen = { let empty_frozen = { summaries = Frozen.empty; ml_module = None } +module HMap = Dyn.HMap(Decl)(ID) + let freeze_summaries ~marshallable : frozen = - let fold (DynMap.Any (tag, decl)) accu = Frozen.add tag (decl.freeze_function ~marshallable) accu in - { summaries = DynMap.fold fold !sum_map Frozen.empty; + let map = { HMap.map = fun tag decl -> decl.freeze_function ~marshallable } in + { summaries = HMap.map map !sum_map; ml_module = Option.map (fun decl -> decl.freeze_function ~marshallable) !sum_mod; } diff --git a/parsing/extend.ml b/parsing/extend.ml index fadfb6c5f4..a6fa6edad5 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -21,6 +21,13 @@ type production_level = | NumLevel of int | DefaultLevel (** Interpreted differently at the border or inside a rule *) +let production_level_eq lev1 lev2 = + match lev1, lev2 with + | NextLevel, NextLevel -> true + | NumLevel n1, NumLevel n2 -> Int.equal n1 n2 + | DefaultLevel, DefaultLevel -> true + | (NextLevel | NumLevel _| DefaultLevel), _ -> false + (** User-level types used to tell how to parse or interpret of the non-terminal *) type 'a constr_entry_key_gen = @@ -59,19 +66,19 @@ type constr_prod_entry_key = (** {5 AST for user-provided entries} *) type 'a user_symbol = -| Ulist1 of 'a user_symbol -| Ulist1sep of 'a user_symbol * string -| Ulist0 of 'a user_symbol -| Ulist0sep of 'a user_symbol * string -| Uopt of 'a user_symbol -| Uentry of 'a -| Uentryl of 'a * int + | Ulist1 of 'a user_symbol + | Ulist1sep of 'a user_symbol * string + | Ulist0 of 'a user_symbol + | Ulist0sep of 'a user_symbol * string + | Uopt of 'a user_symbol + | Uentry of 'a + | Uentryl of 'a * int type ('a,'b,'c) ty_user_symbol = -| TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol -| TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol -| TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol -| TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol -| TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol -| TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol -| TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol + | TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol + | TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol + | TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol diff --git a/parsing/extend.mli b/parsing/extend.mli new file mode 100644 index 0000000000..057fdb3841 --- /dev/null +++ b/parsing/extend.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Entry keys for constr notations *) + +type side = Left | Right + +type production_position = + | BorderProd of side * Gramlib.Gramext.g_assoc option + | InternalProd + +type production_level = + | NextLevel + | NumLevel of int + | DefaultLevel (** Interpreted differently at the border or inside a rule *) + +val production_level_eq : production_level -> production_level -> bool + +(** User-level types used to tell how to parse or interpret of the non-terminal *) + +type 'a constr_entry_key_gen = + | ETIdent + | ETGlobal + | ETBigint + | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) + | ETConstr of Constrexpr.notation_entry * Notation_term.constr_as_binder_kind option * 'a + | ETPattern of bool * int option (* true = strict pattern, i.e. not a single variable *) + +(** Entries level (left-hand side of grammar rules) *) + +type constr_entry_key = + (production_level * production_position) constr_entry_key_gen + +(** Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) + +type simple_constr_prod_entry_key = + production_level constr_entry_key_gen + +(** Entries used in productions (in right-hand-side of grammar rules), to parse non-terminals *) + +type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list + +type binder_target = ForBinder | ForTerm + +type constr_prod_entry_key = + | ETProdName (* Parsed as a name (ident or _) *) + | ETProdReference (* Parsed as a global reference *) + | ETProdBigint (* Parsed as an (unbounded) integer *) + | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) + | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) + | ETProdConstrList of Constrexpr.notation_entry * (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr, or subentries of those *) + | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) + +(** {5 AST for user-provided entries} *) + +type 'a user_symbol = + | Ulist1 of 'a user_symbol + | Ulist1sep of 'a user_symbol * string + | Ulist0 of 'a user_symbol + | Ulist0sep of 'a user_symbol * string + | Uopt of 'a user_symbol + | Uentry of 'a + | Uentryl of 'a * int + +type ('a,'b,'c) ty_user_symbol = + | TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol + | TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol + | TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index 19055fd425..7228f709f1 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -8,63 +8,61 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** [Big] : a wrapper around ocaml [Big_int] with nicer names, +(** [Big] : a wrapper around ocaml [ZArith] with nicer names, and a few extraction-specific constructions *) -(** To be linked with [nums.(cma|cmxa)] *) +(** To be linked with [zarith] *) -open Big_int - -type big_int = Big_int.big_int +type big_int = Z.t (** The type of big integers. *) -let zero = zero_big_int +let zero = Z.zero (** The big integer [0]. *) -let one = unit_big_int +let one = Z.one (** The big integer [1]. *) -let two = big_int_of_int 2 +let two = Z.of_int 2 (** The big integer [2]. *) (** {6 Arithmetic operations} *) -let opp = minus_big_int +let opp = Z.neg (** Unary negation. *) -let abs = abs_big_int +let abs = Z.abs (** Absolute value. *) -let add = add_big_int +let add = Z.add (** Addition. *) -let succ = succ_big_int - (** Successor (add 1). *) +let succ = Z.succ +(** Successor (add 1). *) -let add_int = add_int_big_int +let add_int = Z.add (** Addition of a small integer to a big integer. *) -let sub = sub_big_int +let sub = Z.sub (** Subtraction. *) -let pred = pred_big_int +let pred = Z.pred (** Predecessor (subtract 1). *) -let mult = mult_big_int +let mult = Z.mul (** Multiplication of two big integers. *) -let mult_int = mult_int_big_int +let mult_int x y = Z.mul (Z.of_int x) y (** Multiplication of a big integer by a small integer *) -let square = square_big_int +let square x = Z.mul x x (** Return the square of the given big integer *) -let sqrt = sqrt_big_int +let sqrt = Z.sqrt (** [sqrt_big_int a] returns the integer square root of [a], that is, the largest big integer [r] such that [r * r <= a]. Raise [Invalid_argument] if [a] is negative. *) -let quomod = quomod_big_int +let quomod = Z.div_rem (** Euclidean division of two big integers. The first part of the result is the quotient, the second part is the remainder. @@ -72,18 +70,18 @@ let quomod = quomod_big_int [a = q * b + r] and [0 <= r < |b|]. Raise [Division_by_zero] if the divisor is zero. *) -let div = div_big_int +let div = Z.div (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) -let modulo = mod_big_int +let modulo = Z.(mod) (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) -let gcd = gcd_big_int +let gcd = Z.gcd (** Greatest common divisor of two big integers. *) -let power = power_big_int_positive_big_int +let power = Z.pow (** Exponentiation functions. Return the big integer representing the first argument [a] raised to the power [b] (the second argument). Depending @@ -92,45 +90,45 @@ let power = power_big_int_positive_big_int (** {6 Comparisons and tests} *) -let sign = sign_big_int +let sign = Z.sign (** Return [0] if the given big integer is zero, [1] if it is positive, and [-1] if it is negative. *) -let compare = compare_big_int +let compare = Z.compare (** [compare_big_int a b] returns [0] if [a] and [b] are equal, [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *) -let eq = eq_big_int -let le = le_big_int -let ge = ge_big_int -let lt = lt_big_int -let gt = gt_big_int +let eq = Z.equal +let le = Z.leq +let ge = Z.geq +let lt = Z.lt +let gt = Z.gt (** Usual boolean comparisons between two big integers. *) -let max = max_big_int +let max = Z.max (** Return the greater of its two arguments. *) -let min = min_big_int +let min = Z.min (** Return the smaller of its two arguments. *) (** {6 Conversions to and from strings} *) -let to_string = string_of_big_int +let to_string = Z.to_string (** Return the string representation of the given big integer, in decimal (base 10). *) -let of_string = big_int_of_string +let of_string = Z.of_string (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, followed by one or several decimal digits. *) (** {6 Conversions to and from other numerical types} *) -let of_int = big_int_of_int +let of_int = Z.of_int (** Convert a small integer to a big integer. *) -let is_int = is_int_big_int +let is_int = Z.fits_int (** Test whether the given big integer is small enough to be representable as a small integer (type [int]) without loss of precision. On a 32-bit platform, @@ -139,7 +137,7 @@ let is_int = is_int_big_int [is_int_big_int a] returns [true] if and only if [a] is between -2{^62} and 2{^62}-1. *) -let to_int = int_of_big_int +let to_int = Z.to_int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer is not representable as a small integer. *) diff --git a/plugins/extraction/dune b/plugins/extraction/dune index 0c01dcd488..d9d675fe6a 100644 --- a/plugins/extraction/dune +++ b/plugins/extraction/dune @@ -2,6 +2,6 @@ (name extraction_plugin) (public_name coq.plugins.extraction) (synopsis "Coq's extraction plugin") - (libraries num coq.plugins.ltac)) + (libraries coq.plugins.ltac)) (coq.pp (modules g_extraction)) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 743afe4177..72e6006b7e 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -483,7 +483,10 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) ; (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id) + Proofview.V82.of_tactic + (intro_using_then heq_id + (* we get the fresh name with onLastHypId *) + (fun _ -> Proofview.tclUNIT ())) ; onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) @@ -1113,16 +1116,18 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num in let first_tac : tactic = (* every operations until fix creations *) + (* names are already refreshed *) tclTHENLIST [ observe_tac "introducing params" (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.params))) + (intros_mustbe_force (List.rev_map id_of_decl princ_info.params))) ; observe_tac "introducing predictes" (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.predicates))) + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.predicates))) ; observe_tac "introducing branches" (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.branches))) + (intros_mustbe_force (List.rev_map id_of_decl princ_info.branches))) ; observe_tac "building fixes" mk_fixes ] in let intros_after_fixes : tactic = diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 253c95fa67..066ade07d2 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -414,7 +414,8 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = observe_tclTHENLIST (fun _ _ -> str "treat_case1") [ h_intros (List.rev rev_ids) - ; Proofview.V82.of_tactic (intro_using teq_id) + ; Proofview.V82.of_tactic + (intro_using_then teq_id (fun _ -> Proofview.tclUNIT ())) ; onLastHypId (fun heq -> observe_tclTHENLIST (fun _ _ -> str "treat_case2") @@ -601,7 +602,11 @@ let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ observe_tclTHENLIST (fun _ _ -> str "") - [ Proofview.V82.of_tactic (intro_using h_id) + [ Proofview.V82.of_tactic + (intro_using_then h_id + (* We don't care about the refreshed name, + accessed only through auto? *) + (fun _ -> Proofview.tclUNIT ())) ; Proofview.V82.of_tactic (simplest_elim (mkApp (delayed_force lt_n_O, [|s_max|]))) @@ -865,7 +870,10 @@ let terminate_app_rec (f, args) expr_info continuation_tac _ g = (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) [ observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2") - [ Proofview.V82.of_tactic (intro_using rec_res_id) + [ Proofview.V82.of_tactic + (intro_using_then rec_res_id + (* refreshed name gotten from onNthHypId *) + (fun _ -> Proofview.tclUNIT ())) ; Proofview.V82.of_tactic intro ; onNthHypId 1 (fun v_bound -> onNthHypId 2 (fun v -> diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 2ca9a0e69d..88480194c8 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2125,8 +2125,7 @@ let _ = (* EJGA: We should also pass the proof name if desired, for now poly seems like enough to get reasonable behavior in practice *) - let name, poly = Id.of_string "ltac_gen", poly in - let name, poly = Id.of_string "ltac_gen", poly in + let name = Id.of_string "ltac_gen" in let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in diff --git a/plugins/nsatz/dune b/plugins/nsatz/dune index b921c9c408..3b67ab3429 100644 --- a/plugins/nsatz/dune +++ b/plugins/nsatz/dune @@ -2,6 +2,6 @@ (name nsatz_plugin) (public_name coq.plugins.nsatz) (synopsis "Coq's nsatz solver plugin") - (libraries num coq.plugins.ltac)) + (libraries coq.plugins.ltac)) (coq.pp (modules g_nsatz)) diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 387145a5d0..cbc1773ede 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -153,8 +153,8 @@ end module Make (P:Polynom.S) = struct type coef = P.t - let coef0 = P.of_num (Num.Int 0) - let coef1 = P.of_num (Num.Int 1) + let coef0 = P.of_num Q.zero + let coef1 = P.of_num Q.one let string_of_coef c = "["^(P.to_string c)^"]" (*********************************************************************** @@ -305,7 +305,7 @@ let mult_t_pol a m p = let map (b, m') = (P.multP a b, mult_mon m m') in CList.map map p -let coef_of_int x = P.of_num (Num.Int x) +let coef_of_int x = P.of_num (Q.of_int x) (* variable i *) let gen d i = diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 29d08fb4ea..f3021f4ee6 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -13,30 +13,20 @@ open Util open Constr open Tactics -open Num open Utile (*********************************************************************** Operations on coefficients *) -let num_0 = Int 0 -and num_1 = Int 1 -and num_2 = Int 2 - -let numdom r = - let r' = Ratio.normalize_ratio (ratio_of_num r) in - num_of_big_int(Ratio.numerator_ratio r'), - num_of_big_int(Ratio.denominator_ratio r') - module BigInt = struct - open Big_int + open Big_int_Z type t = big_int let of_int = big_int_of_int let coef0 = of_int 0 - let of_num = Num.big_int_of_num - let to_num = Num.num_of_big_int + let of_num = Q.to_bigint + let to_num = Q.of_bigint let equal = eq_big_int let lt = lt_big_int let le = le_big_int @@ -113,7 +103,7 @@ type vname = string type term = | Zero - | Const of Num.num + | Const of Q.t | Var of vname | Opp of term | Add of term * term @@ -122,7 +112,7 @@ type term = | Pow of term * int let const n = - if eq_num n num_0 then Zero else Const n + if Q.(equal zero) n then Zero else Const n let pow(p,i) = if Int.equal i 1 then p else Pow(p,i) let add = function (Zero,q) -> q @@ -131,8 +121,8 @@ let add = function let mul = function (Zero,_) -> Zero | (_,Zero) -> Zero - | (p,Const n) when eq_num n num_1 -> p - | (Const n,q) when eq_num n num_1 -> q + | (p,Const n) when Q.(equal one) n -> p + | (Const n,q) when Q.(equal one) n -> q | (p,q) -> Mul(p,q) let gen_constant n = lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n)) @@ -167,62 +157,64 @@ let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] let tllp () = mkt_app tlist [tlp()] -let rec mkt_pos n = - if n =/ num_1 then Lazy.force pxH - else if mod_num n num_2 =/ num_0 then - mkt_app pxO [mkt_pos (quo_num n num_2)] +let mkt_pos n = + let rec mkt_pos n = + if Z.(equal one) n then Lazy.force pxH + else if Z.is_even n then + mkt_app pxO [mkt_pos Z.(n asr 1)] else - mkt_app pxI [mkt_pos (quo_num n num_2)] + mkt_app pxI [mkt_pos Z.(n asr 1)] + in mkt_pos (Q.to_bigint n) let mkt_n n = - if Num.eq_num n num_0 + if Q.(equal zero) n then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] let mkt_z z = - if z =/ num_0 then Lazy.force z0 - else if z >/ num_0 then + if Q.(equal zero) z then Lazy.force z0 + else if Q.(lt zero) z then mkt_app zpos [mkt_pos z] else - mkt_app zneg [mkt_pos ((Int 0) -/ z)] + mkt_app zneg [mkt_pos (Q.neg z)] let rec mkt_term t = match t with -| Zero -> mkt_term (Const num_0) -| Const r -> let (n,d) = numdom r in - mkt_app ttconst [Lazy.force tz; mkt_z n] -| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] +| Zero -> mkt_term (Const Q.zero) +| Const r -> let n = r |> Q.num |> Q.of_bigint in + mkt_app ttconst [Lazy.force tz; mkt_z n] +| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (Q.of_string v)] | Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] | Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] | Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] | Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] | Pow (t1,n) -> if Int.equal n 0 then - mkt_app ttconst [Lazy.force tz; mkt_z num_1] + mkt_app ttconst [Lazy.force tz; mkt_z Q.one] else - mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] + mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (Q.of_int n)] let rec parse_pos p = match Constr.kind p with | App (a,[|p2|]) -> - if Constr.equal a (Lazy.force pxO) then num_2 */ (parse_pos p2) - else num_1 +/ (num_2 */ (parse_pos p2)) -| _ -> num_1 + if Constr.equal a (Lazy.force pxO) then Q.(mul (of_int 2)) (parse_pos p2) + else Q.(add one) Q.(mul (of_int 2) (parse_pos p2)) +| _ -> Q.one let parse_z z = match Constr.kind z with | App (a,[|p2|]) -> - if Constr.equal a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) -| _ -> num_0 + if Constr.equal a (Lazy.force zpos) then parse_pos p2 else Q.neg (parse_pos p2) +| _ -> Q.zero let parse_n z = match Constr.kind z with | App (a,[|p2|]) -> parse_pos p2 -| _ -> num_0 +| _ -> Q.zero let rec parse_term p = match Constr.kind p with | App (a,[|_;p2|]) -> - if Constr.equal a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) + if Constr.equal a (Lazy.force ttvar) then Var (Q.to_string (parse_pos p2)) else if Constr.equal a (Lazy.force ttconst) then Const (parse_z p2) else if Constr.equal a (Lazy.force ttopp) then Opp (parse_term p2) else Zero @@ -231,7 +223,7 @@ let rec parse_term p = else if Constr.equal a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) else if Constr.equal a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) else if Constr.equal a (Lazy.force ttpow) then - Pow (parse_term p2, int_of_num (parse_n p3)) + Pow (parse_term p2, Q.to_int (parse_n p3)) else Zero | _ -> Zero @@ -278,7 +270,7 @@ let term_pol_sparse nvars np t= match t with | Zero -> zeroP | Const r -> - if Num.eq_num r num_0 + if Q.(equal zero) r then zeroP else polconst d (Poly.Pint (Coef.of_num r)) | Var v -> @@ -316,7 +308,7 @@ let pol_sparse_to_term n2 p = let p = PIdeal.repr p in let rec aux p = match p with - [] -> const (num_of_string "0") + [] -> const Q.zero | (a,m)::p1 -> let m = Ideal.Monomial.repr m in let n = (Array.length m)-1 in @@ -443,8 +435,9 @@ let expand_pol lb lp = let theoremedeszeros_termes lp = let nvars = List.fold_left set_nvars_term 0 lp in match lp with - | Const (Int sugarparam)::Const (Int nparam)::lp -> - ((match sugarparam with + | Const sugarparam :: Const nparam :: lp -> + let nparam = Q.to_int nparam in + ((match Q.to_int sugarparam with |0 -> sinfo "computation without sugar"; lexico:=false; |1 -> sinfo "computation with sugar"; diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 726ad54cad..2565d88b13 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -30,7 +30,7 @@ module type Coef = sig val pgcd : t -> t -> t val hash : t -> int - val of_num : Num.num -> t + val of_num : Q.t -> t val to_string : t -> string end @@ -39,7 +39,7 @@ module type S = sig type variable = int type t = Pint of coef | Prec of variable * t array - val of_num : Num.num -> t + val of_num : Q.t -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool @@ -106,7 +106,7 @@ end module Make (C:Coef) = struct type coef = C.t -let coef_of_int i = C.of_num (Num.Int i) +let coef_of_int i = C.of_num (Q.of_int i) let coef0 = coef_of_int 0 let coef1 = coef_of_int 1 @@ -125,8 +125,8 @@ type t = (* constant polynomials *) let of_num x = Pint (C.of_num x) -let cf0 = of_num (Num.Int 0) -let cf1 = of_num (Num.Int 1) +let cf0 = of_num Q.zero +let cf1 = of_num Q.one (* nth variable *) let x n = Prec (n,[|cf0;cf1|]) diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli index 3807a8582b..91f1bcda90 100644 --- a/plugins/nsatz/polynom.mli +++ b/plugins/nsatz/polynom.mli @@ -26,7 +26,7 @@ module type Coef = sig val pgcd : t -> t -> t val hash : t -> int - val of_num : Num.num -> t + val of_num : Q.t -> t val to_string : t -> string end @@ -35,7 +35,7 @@ module type S = sig type variable = int type t = Pint of coef | Prec of variable * t array - val of_num : Num.num -> t + val of_num : Q.t -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 3ba6365783..4f7b3fbe74 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -32,7 +32,22 @@ open Tactypes open Context.Named.Declaration module NamedDecl = Context.Named.Declaration -module OmegaSolver = Omega.MakeOmegaSolver (Bigint) + +module ZOmega = struct + type bigint = Z.t + let equal = Z.equal + let less_than = Z.lt + let add = Z.add + let sub = Z.sub + let mult = Z.mul + let euclid = Z.div_rem + let neg = Z.neg + let zero = Z.zero + let one = Z.one + let to_string = Z.to_string +end + +module OmegaSolver = Omega.MakeOmegaSolver (ZOmega) open OmegaSolver (* Added by JCF, 09/03/98 *) @@ -719,7 +734,7 @@ let rec shuffle p (t1,t2) = Oplus(l2,t') else [],Oplus(t1,t2) | Oz t1,Oz t2 -> - [focused_simpl p], Oz(Bigint.add t1 t2) + [focused_simpl p], Oz(Z.add t1 t2) | t1,t2 -> if weight t1 < weight t2 then [clever_rewrite p [[P_APP 1];[P_APP 2]] @@ -741,7 +756,7 @@ let shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA10) in - if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then + if Z.add (Z.mul k1 c1) (Z.mul k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in @@ -798,7 +813,7 @@ let shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA15) in - if Bigint.add c1 (Bigint.mult k2 c2) =? zero then + if Z.add c1 (Z.mul k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) @@ -1004,7 +1019,7 @@ let reduce_factor p = function | Otimes(Oatom v,c) -> let rec compute = function | Oz n -> n - | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) + | Oplus(t1,t2) -> Z.add (compute t1) (compute t2) | _ -> CErrors.user_err Pp.(str "condense.1") in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) @@ -1055,6 +1070,9 @@ let rec clear_zero p = function let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) | t -> [],t +open Proofview +open Proofview.Notations + let replay_history tactic_normalisation = let aux = Id.of_string "auxiliary" in let aux1 = Id.of_string "auxiliary_1" in @@ -1085,8 +1103,8 @@ let replay_history tactic_normalisation = mk_integer k; mkVar id1; mkVar id2 |])]; mk_then tac; - (intros_using [aux]); - resolve_id aux; + intro_using_then aux (fun aux -> + resolve_id aux); reflexivity ] | CONTRADICTION (e1,e2) :: l -> @@ -1128,24 +1146,25 @@ let replay_history tactic_normalisation = tclTHENS (cut state_eg) [ tclTHENS - (tclTHENLIST [ - (intros_using [aux]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA1, - [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); - (intros_using [id]); - (cut (mk_gt kk dd)) ]) + (intro_using_then aux (fun aux -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA1, + [| eq1; rhs; mkVar aux; mkVar id |])]); + (clear [aux;id]); + (intro_mustbe_force id); + (cut (mk_gt kk dd)) ])) [ tclTHENS (cut (mk_gt kk izero)) - [ tclTHENLIST [ - (intros_using [aux1; aux2]); + [ intro_using_then aux1 (fun aux1 -> + intro_using_then aux2 (fun aux2 -> + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; + (intro_mustbe_force id); + (loop l) ])); tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; @@ -1156,7 +1175,7 @@ let replay_history tactic_normalisation = | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in - let d = Bigint.sub e1.constant (Bigint.mult c k) in + let d = Z.sub e1.constant (Z.mul c k) in let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in let eq2 = val_of(decompile e2) in @@ -1166,21 +1185,24 @@ let replay_history tactic_normalisation = tclTHENS (cut (mk_gt dd izero)) [ tclTHENS (cut (mk_gt kk dd)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, - [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - unfold sp_not; - (intros_using [aux]); - resolve_id aux; - mk_then tac; - assumption ] ; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; + [ intro_using_then aux2 (fun aux2 -> + intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, + [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); + (clear [aux1;aux2]); + unfold sp_not; + intro_using_then aux (fun aux -> + tclTHENLIST [ + resolve_id aux; + mk_then tac; + assumption + ])])) ; + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ]; tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; @@ -1196,29 +1218,30 @@ let replay_history tactic_normalisation = let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) - [tclTHENLIST [ - (intros_using [aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, - [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); - (intros_using [id]); - (loop l) ]; - tclTHEN (mk_then tac) reflexivity ] + [ intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, + [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); + (clear [aux1;id]); + (intro_mustbe_force id); + (loop l) ]); + tclTHEN (mk_then tac) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) [ tclTHENS (cut (mk_gt kk izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac + [ intro_using_then aux2 (fun aux2 -> + intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; + (intro_mustbe_force id); + (loop l) ])); tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; @@ -1238,13 +1261,13 @@ let replay_history tactic_normalisation = in tclTHENS (cut (mk_eq eq1 (mk_inv eq2))) - [tclTHENLIST [ - (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, - [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); - (intros_using [id]); - (loop l) ]; + [ intro_using_then aux (fun aux -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); + (clear [id1;id2;aux]); + (intro_mustbe_force id); + (loop l) ]); tclTHEN (mk_then tac) reflexivity] | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> @@ -1271,18 +1294,19 @@ let replay_history tactic_normalisation = orig.body m ({c= negone;v= v}::def.body) in tclTHENS (cut theorem) - [tclTHENLIST [ - (intros_using [aux]); - (elim_id aux); - (clear [aux]); - (intros_using [vid; aux]); - (generalize_tac + [ tclTHENLIST [ intro_using_then aux (fun aux -> + (elim_id aux) <*> + (clear [aux])); + intro_using_then vid (fun vid -> + intro_using_then aux (fun aux -> + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); mk_then tac; (clear [aux]); - (intros_using [id]); - (loop l) ]; + (intro_mustbe_force id); + (loop l) ]))]; tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () @@ -1294,8 +1318,8 @@ let replay_history tactic_normalisation = let eq = val_of(decompile e) in tclTHENS (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) - [tclTHENLIST [ mk_then tac1; (intros_using [id1]); (loop act1) ]; - tclTHENLIST [ mk_then tac2; (intros_using [id2]); (loop act2) ]] + [tclTHENLIST [ mk_then tac1; (intro_mustbe_force id1); (loop act1) ]; + tclTHENLIST [ mk_then tac2; (intro_mustbe_force id2); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; @@ -1318,7 +1342,7 @@ let replay_history tactic_normalisation = (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); mk_then tac; - (intros_using [id]); + (intro_mustbe_force id); (loop l) ] else @@ -1329,25 +1353,26 @@ let replay_history tactic_normalisation = tclTHENS (cut (mk_gt kk1 izero)) [tclTHENS (cut (mk_gt kk2 izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; - mkVar aux1;mkVar aux2; - mkVar id1;mkVar id2 |])]); - (clear [aux1;aux2]); - mk_then tac; - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ] + [ intro_using_then aux2 (fun aux2 -> + intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; + mkVar aux1;mkVar aux2; + mkVar id1;mkVar id2 |])]); + (clear [aux1;aux2]); + mk_then tac; + (intro_mustbe_force id); + (loop l) ])); + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl | CONSTANT_NUL(e) :: l -> @@ -1358,9 +1383,8 @@ let replay_history tactic_normalisation = unfold sp_Zle; simpl_in_concl; unfold sp_not; - (intros_using [aux]); - resolve_id aux; - reflexivity + intro_using_then aux (fun aux -> + resolve_id aux <*> reflexivity) ] | _ -> Proofview.tclUNIT () in @@ -1382,7 +1406,7 @@ let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = in if not (List.is_empty tac) then let id' = new_identifier () in - ((id',(tclTHENLIST [ shift_left; mk_then tac; (intros_using [id']) ])) + ((id',(tclTHENLIST [ shift_left; mk_then tac; (intro_mustbe_force id') ])) :: tactic, compile id' flag t' :: defs) else @@ -1423,10 +1447,7 @@ let destructure_omega env sigma tac_def (id,c) = let reintroduce id = (* [id] cannot be cleared if dependent: protect it by a try *) - tclTHEN (tclTRY (clear [id])) (intro_using id) - - -open Proofview.Notations + tclTHEN (tclTRY (clear [id])) (intro_using_then id (fun _ -> tclUNIT())) let coq_omega = Proofview.Goal.enter begin fun gl -> @@ -1444,10 +1465,10 @@ let coq_omega = tag_hypothesis id i; (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); - (intros_using [v; id]); + (intros_mustbe_force [v; id]); (elim_id id); (clear [id]); - (intros_using [th;id]); + (intros_mustbe_force [th;id]); tac ]), {kind = INEQ; body = [{v=intern_id v; c=one}]; @@ -1455,7 +1476,7 @@ let coq_omega = else (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); - (intros_using [v;th]); + (intros_mustbe_force [v;th]); tac ]), sys) (Proofview.tclUNIT (),[]) (dump_tables ()) @@ -1508,7 +1529,7 @@ let nat_inject = tclTHENS (tclTHEN (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intros_using [id])) + (intro_mustbe_force id)) [ tclTHENLIST [ (clever_rewrite_gen p @@ -1703,7 +1724,7 @@ let onClearedName2 id tac = (tclTRY (clear [id])) (Proofview.Goal.enter begin fun gl -> let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in - let id2 = fresh_id Id.Set.empty (add_suffix id "_right") gl in + let id2 = fresh_id (Id.Set.singleton id1) (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end) diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 1e182b52fa..582c45cde1 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -478,11 +478,16 @@ let revtoptac n0 = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in let n = nb_prod sigma concl - n0 in let dc, cl = EConstr.decompose_prod_n_assum sigma n concl in - let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in - let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in - Logic.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) + let ty = EConstr.it_mkProd_or_LetIn cl (List.rev dc) in + let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, ty)] in + Refine.refine ~typecheck:true begin fun sigma -> + let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in + let sigma, ev = Evarutil.new_evar env sigma ty in + sigma, (EConstr.mkApp (f, [|ev|])) + end end let nothing_to_inject = diff --git a/plugins/syntax/float_syntax.ml b/plugins/syntax/float_syntax.ml index 8e87fc13ca..5d8dcd04fe 100644 --- a/plugins/syntax/float_syntax.ml +++ b/plugins/syntax/float_syntax.ml @@ -48,21 +48,21 @@ let interp_float ?loc n = | None -> "" | Some f -> NumTok.UnsignedNat.to_string f in let e = match e with | None -> "0" | Some e -> NumTok.SignedNat.to_string e in - Bigint.of_string (i ^ f), + Z.of_string (i ^ f), (try int_of_string e with Failure _ -> 0) - String.length f in let m', e' = let m', e' = Float64.frshiftexp f in let m' = Float64.normfr_mantissa m' in let e' = Uint63.to_int_min e' 4096 - Float64.eshift - 53 in - Bigint.of_string (Uint63.to_string m'), + Z.of_string (Uint63.to_string m'), e' in - let c2, c5 = Bigint.(of_int 2, of_int 5) in + let c2, c5 = Z.(of_int 2, of_int 5) in (* check m*5^e <> m'*2^e' *) let check m e m' e' = - not (Bigint.(equal (mult m (pow c5 e)) (mult m' (pow c2 e')))) in + not (Z.(equal (mul m (pow c5 e)) (mul m' (pow c2 e')))) in (* check m*5^e*2^e' <> m' *) let check' m e e' m' = - not (Bigint.(equal (mult (mult m (pow c5 e)) (pow c2 e')) m')) in + not (Z.(equal (mul (mul m (pow c5 e)) (pow c2 e')) m')) in (* we now have to check m*10^e <> m'*2^e' *) if e >= 0 then if e <= e' then check m e m' (e' - e) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 23a7cc07c5..d66b9537b4 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -11,7 +11,6 @@ open Util open Names open Glob_term -open Bigint (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -47,10 +46,10 @@ let pos_of_bignat ?loc x = let ref_xH = DAst.make @@ GRef (glob_xH, None) in let ref_xO = DAst.make @@ GRef (glob_xO, None) in let rec pos_of x = - match div2_with_rest x with - | (q,false) -> DAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) - | (q,true) -> ref_xH + match Z.(div_rem x (of_int 2)) with + | (q,rem) when rem = Z.zero -> DAst.make @@ GApp (ref_xO,[pos_of q]) + | (q,_) when not Z.(equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) + | (q,_) -> ref_xH in pos_of x @@ -59,9 +58,9 @@ let pos_of_bignat ?loc x = (**********************************************************************) let rec bignat_of_pos c = match DAst.get c with - | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) - | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when GlobRef.equal a glob_xH -> Bigint.one + | GApp (r, [a]) when is_gr r glob_xO -> Z.mul Z.(of_int 2) (bignat_of_pos a) + | GApp (r, [a]) when is_gr r glob_xI -> Z.add Z.one Z.(mul (of_int 2) (bignat_of_pos a)) + | GRef (a, _) when GlobRef.equal a glob_xH -> Z.one | _ -> raise Non_closed_number (**********************************************************************) @@ -77,9 +76,9 @@ let glob_POS = GlobRef.ConstructRef path_of_POS let glob_NEG = GlobRef.ConstructRef path_of_NEG let z_of_int ?loc n = - if not (Bigint.equal n zero) then + if not Z.(equal n zero) then let sgn, n = - if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + if Z.(leq zero n) then glob_POS, n else glob_NEG, Z.neg n in DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) else DAst.make @@ GRef (glob_ZERO, None) @@ -90,8 +89,8 @@ let z_of_int ?loc n = let bigint_of_z c = match DAst.get c with | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when GlobRef.equal a glob_ZERO -> Bigint.zero + | GApp (r,[a]) when is_gr r glob_NEG -> Z.neg (bignat_of_pos a) + | GRef (a, _) when GlobRef.equal a glob_ZERO -> Z.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -122,13 +121,13 @@ let r_of_rawnum ?loc n = let rdiv r r' = DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in let pow p e = - let p = z_of_int ?loc (Bigint.of_int p) in + let p = z_of_int ?loc (Z.of_int p) in let e = pos_of_bignat e in DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [p; e]) in let n = izr (z_of_int ?loc n) in - if Bigint.is_strictly_pos e then rmult n (izr (pow p e)) - else if Bigint.is_strictly_neg e then rdiv n (izr (pow p (neg e))) + if Int.equal (Z.sign e) 1 then rmult n (izr (pow p e)) + else if Int.equal (Z.sign e) (-1) then rdiv n (izr (pow p (Z.neg e))) else n (* e = 0 *) (**********************************************************************) @@ -141,24 +140,24 @@ let rawnum_of_r c = (* choose between 123e-2 and 1.23, this is purely heuristic and doesn't play any soundness role *) let choose_exponent = - if Bigint.is_strictly_pos e then + if Int.equal (Z.sign e) 1 then true (* don't print 12 * 10^2 as 1200 to distinguish them *) else - let i = Bigint.to_string i in + let i = Z.to_string i in let li = if i.[0] = '-' then String.length i - 1 else String.length i in - let e = Bigint.neg e in - let le = String.length (Bigint.to_string e) in - Bigint.(less_than (add (of_int li) (of_int le)) e) in + let e = Z.neg e in + let le = String.length (Z.to_string e) in + Z.(lt (add (of_int li) (of_int le)) e) in (* print 123 * 10^-2 as 123e-2 *) let numTok_exponent () = NumTok.Signed.of_bigint_and_exponent i (NumTok.EDec e) in (* print 123 * 10^-2 as 1.23, precondition e < 0 *) let numTok_dot () = let s, i = - if Bigint.is_pos_or_zero i then NumTok.SPlus, Bigint.to_string i - else NumTok.SMinus, Bigint.(to_string (neg i)) in + if Z.sign i >= 0 then NumTok.SPlus, Z.to_string i + else NumTok.SMinus, Z.(to_string (neg i)) in let ni = String.length i in - let e = - (Bigint.to_int e) in + let e = - (Z.to_int e) in assert (e > 0); let i, f = if e < ni then String.sub i 0 (ni - e), String.sub i (ni - e) e @@ -178,12 +177,12 @@ let rawnum_of_r c = begin match DAst.get r with | GApp (p, [t; e]) when is_gr p glob_pow_pos -> let t = bigint_of_z t in - if not (Bigint.(equal t (of_int 10))) then + if not (Z.(equal t (of_int 10))) then raise Non_closed_number else let i = bigint_of_z l in let e = bignat_of_pos e in - let e = if is_gr md glob_Rdiv then neg e else e in + let e = if is_gr md glob_Rdiv then Z.neg e else e in numTok_of_int_exp i e | _ -> raise Non_closed_number end diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index e5fa9bada1..900ba0edb9 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -415,7 +415,7 @@ let cbv_vm env sigma c t = (* This evar-normalizes terms beforehand *) let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in - let v = Csymtable.val_of_constr env c in + let v = Vmsymtable.val_of_constr env c in EConstr.of_constr (nf_val env sigma v t) let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = diff --git a/printing/printer.ml b/printing/printer.ml index c5cb6ffad8..0f635623e7 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -780,17 +780,18 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = straightforward, but seriously, [Proof.proof] should return [evar_info]-s instead. *) let p = proof in - let Proof.{goals; stack; shelf; given_up; sigma} = Proof.data p in + let Proof.{goals; stack; shelf; sigma} = Proof.data p in + let given_up = Evd.given_up sigma in let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in let seeds = Proof.V82.top_evars p in begin match goals with | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in begin match bgoals,shelf,given_up with - | [] , [] , [] -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals + | [] , [] , 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:"); fnl () - ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:given_up + ++ 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." | [] , _ , _ -> Feedback.msg_info (str "All the remaining goals are on the shelf."); diff --git a/proofs/goal.ml b/proofs/goal.ml index 1c3aed8fc2..e8f2ab5674 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -56,12 +56,12 @@ module V82 = struct be shelved. It must not appear as a future_goal, so the future goals are restored to their initial value after the evar is created. *) - let prev_future_goals = Evd.save_future_goals evars in + let evars = Evd.push_future_goals evars in let inst = EConstr.identity_subst_val hyps in - let (evars, evk) = + let (evars,evk) = Evarutil.new_pure_evar ~src:(Loc.tag Evar_kinds.GoalEvar) ~typeclass_candidate:false ~identity:inst hyps evars concl in - let evars = Evd.restore_future_goals evars prev_future_goals in + let _, evars = Evd.pop_future_goals evars in let ev = EConstr.mkEvar (evk,inst) in (evk, ev, evars) diff --git a/proofs/goal.mli b/proofs/goal.mli index a3aa1e248f..e8439120c0 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -65,4 +65,4 @@ module V82 : sig end -module Set : sig include Set.S with type elt = goal end +module Set = Evar.Set diff --git a/proofs/proof.ml b/proofs/proof.ml index 38fcdd6e5f..d7904c56a8 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -115,8 +115,6 @@ type t = list is empty when the proof is fully unfocused. *) ; shelf : Goal.goal list (** List of goals that have been shelved. *) - ; given_up : Goal.goal list - (** List of goals that have been given up *) ; name : Names.Id.t (** the name of the theorem whose proof is being constructed *) ; poly : bool @@ -138,8 +136,7 @@ let proof p = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) p.focus_stack in let shelf = p.shelf in - let given_up = p.given_up in - (goals,stack,shelf,given_up,sigma) + (goals,stack,shelf,sigma) let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk @@ -156,7 +153,9 @@ let is_done p = let has_unresolved_evar p = Proofview.V82.has_unresolved_evar p.proofview let has_shelved_goals p = not (CList.is_empty (p.shelf)) -let has_given_up_goals p = not (CList.is_empty (p.given_up)) +let has_given_up_goals p = + let (_goals,sigma) = Proofview.proofview p.proofview in + Evd.has_given_up sigma let is_complete p = is_done p && not (has_unresolved_evar p) && @@ -292,7 +291,6 @@ let start ~name ~poly sigma goals = ; entry ; focus_stack = [] ; shelf = [] - ; given_up = [] ; name ; poly } in @@ -305,7 +303,6 @@ let dependent_start ~name ~poly goals = ; entry ; focus_stack = [] ; shelf = [] - ; given_up = [] ; name ; poly } in @@ -366,33 +363,29 @@ let update_sigma_env p env = let run_tactic env tac pr = let open Proofview.Notations in - let sp = pr.proofview in let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in let tac = tac >>= fun result -> Proofview.tclEVARMAP >>= fun sigma -> (* Already solved goals are not to be counted as shelved. Nor are they to be marked as unresolvable. *) - let retrieved = Evd.filter_future_goals (Evd.is_undefined sigma) (Evd.save_future_goals sigma) in - let retrieved,retrieved_given_up = Evd.extract_given_up_future_goals retrieved in - (* Check that retrieved given up is empty *) - if not (List.is_empty retrieved_given_up) then - CErrors.anomaly Pp.(str "Evars generated outside of proof engine (e.g. V82, clear, ...) are not supposed to be explicitly given up."); + let retrieved, sigma = Evd.pop_future_goals sigma in + let retrieved = Evd.FutureGoals.filter (Evd.is_undefined sigma) retrieved in + let retrieved = List.rev_append retrieved.Evd.FutureGoals.shelf (List.rev retrieved.Evd.FutureGoals.comb) in let sigma = Proofview.Unsafe.mark_as_goals sigma retrieved in Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT (result,retrieved) in - let { name; poly } = pr in - let ((result,retrieved),proofview,(status,to_shelve,give_up),info_trace) = - Proofview.apply ~name ~poly env tac sp + let { name; poly; proofview } = pr in + let proofview = Proofview.Unsafe.push_future_goals proofview in + let ((result,retrieved),proofview,(status,to_shelve),info_trace) = + Proofview.apply ~name ~poly env tac proofview in let sigma = Proofview.return proofview in let to_shelve = undef sigma to_shelve in let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in let proofview = Proofview.Unsafe.mark_as_unresolvables proofview to_shelve in - let given_up = pr.given_up@give_up in - let proofview = Proofview.Unsafe.reset_future_goals proofview in - { pr with proofview ; shelf ; given_up },(status,info_trace),result + { pr with proofview ; shelf },(status,info_trace),result (*** Commands ***) @@ -457,11 +450,11 @@ end let all_goals p = let add gs set = List.fold_left (fun s g -> Goal.Set.add g s) set gs in - let (goals,stack,shelf,given_up,_) = proof p in + let (goals,stack,shelf,sigma) = proof p in let set = add goals Goal.Set.empty in let set = List.fold_left (fun s gs -> let (g1, g2) = gs in add g1 (add g2 set)) set stack in let set = add shelf set in - let set = add given_up set in + let set = Goal.Set.union (Evd.given_up sigma) set in let { Evd.it = bgoals ; sigma = bsigma } = V82.background_subgoals p in add bgoals set @@ -476,15 +469,13 @@ type data = (** A representation of the focus stack *) ; shelf : Evar.t list (** A representation of the shelf *) - ; given_up : Evar.t list - (** A representation of the given up goals *) ; name : Names.Id.t (** The name of the theorem whose proof is being constructed *) ; poly : bool (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) } -let data { proofview; focus_stack; entry; shelf; given_up; name; poly } = +let data { proofview; focus_stack; entry; shelf; name; poly } = let goals, sigma = Proofview.proofview proofview in (* spiwack: beware, the bottom of the stack is used by [Proof] internally, and should not be exposed. *) @@ -495,10 +486,10 @@ let data { proofview; focus_stack; entry; shelf; given_up; name; poly } = in let stack = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) focus_stack in - { sigma; goals; entry; stack; shelf; given_up; name; poly } + { sigma; goals; entry; stack; shelf; name; poly } let pr_proof p = - let { goals=fg_goals; stack=bg_goals; shelf; given_up; _ } = data p in + let { goals=fg_goals; stack=bg_goals; shelf; sigma } = data p in Pp.( let pr_goal_list = prlist_with_sep spc Goal.pr_goal in let rec aux acc = function @@ -509,7 +500,7 @@ let pr_proof p = str "[" ++ str "focus structure: " ++ aux (pr_goal_list fg_goals) bg_goals ++ str ";" ++ spc () ++ str "shelved: " ++ pr_goal_list shelf ++ str ";" ++ spc () ++ - str "given up: " ++ pr_goal_list given_up ++ + str "given up: " ++ pr_goal_list (Evar.Set.elements @@ Evd.given_up sigma) ++ str "]" ) @@ -578,7 +569,7 @@ let refine_by_tactic ~name ~poly env sigma ty tac = let eff = Evd.eval_side_effects sigma in let sigma = Evd.drop_side_effects sigma in (* Save the existing goals *) - let prev_future_goals = Evd.save_future_goals sigma in + let sigma = Evd.push_future_goals sigma in (* Start a proof *) let prf = start ~name ~poly sigma [env, ty] in let (prf, _, ()) = @@ -589,7 +580,7 @@ let refine_by_tactic ~name ~poly env sigma ty tac = Exninfo.iraise (e, info) in (* Plug back the retrieved sigma *) - let { goals; stack; shelf; given_up; sigma; entry } = data prf in + let { goals; stack; shelf; sigma; entry } = data prf in assert (stack = []); let ans = match Proofview.initial_goals entry with | [c, _] -> c @@ -602,14 +593,12 @@ let refine_by_tactic ~name ~poly env sigma ty tac = let sigma = Evd.drop_side_effects sigma in let sigma = Evd.emit_side_effects eff sigma in (* Restore former goals *) - let sigma = Evd.restore_future_goals sigma prev_future_goals in + let _goals, sigma = Evd.pop_future_goals sigma in (* Push remaining goals as future_goals which is the only way we have to inform the caller that there are goals to collect while not being encapsulated in the monad *) (* Goals produced by tactic "shelve" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (* Goals produced by tactic "give_up" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in + let sigma = List.fold_right (Evd.declare_future_goal ~shelve:true) shelf sigma in (* Other goals *) let sigma = List.fold_right Evd.declare_future_goal goals sigma in (* Get rid of the fresh side-effects by internalizing them in the term diff --git a/proofs/proof.mli b/proofs/proof.mli index 2d4966676e..a0d4759bfc 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -45,8 +45,6 @@ type data = (** A representation of the focus stack *) ; shelf : Evar.t list (** A representation of the shelf *) - ; given_up : Evar.t list - (** A representation of the given up goals *) ; name : Names.Id.t (** The name of the theorem whose proof is being constructed *) ; poly : bool; diff --git a/proofs/refine.ml b/proofs/refine.ml index a10bbcbdd4..51d6c923b6 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -51,19 +51,18 @@ let generic_refine ~typecheck f gl = let state = Proofview.Goal.state gl in (* Save the [future_goals] state to restore them after the refinement. *) - let prev_future_goals = Evd.save_future_goals sigma in + let sigma = Evd.push_future_goals sigma in (* Create the refinement term *) - Proofview.Unsafe.tclEVARS (Evd.reset_future_goals sigma) >>= fun () -> + Proofview.Unsafe.tclEVARS sigma >>= fun () -> f >>= fun (v, c) -> - Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclEVARMAP >>= fun sigma' -> Proofview.V82.wrap_exceptions begin fun () -> - let evs = Evd.save_future_goals sigma in (* Redo the effects in sigma in the monad's env *) - let privates_csts = Evd.eval_side_effects sigma in + let privates_csts = Evd.eval_side_effects sigma' in let env = Safe_typing.push_private_constants env privates_csts.Evd.seff_private in (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in - let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in + let sigma = if typecheck then Evd.fold_future_goals fold sigma' else sigma' in (* Check that the refined term is typesafe *) let sigma = if typecheck then Typing.check env sigma c concl else sigma in (* Check that the goal itself does not appear in the refined term *) @@ -73,17 +72,16 @@ let generic_refine ~typecheck f gl = else Pretype_errors.error_occur_check env sigma self c in (* Restore the [future goals] state. *) - let sigma = Evd.restore_future_goals sigma prev_future_goals in + let future_goals, sigma = Evd.pop_future_goals sigma in (* Select the goals *) - let evs = Evd.map_filter_future_goals (Proofview.Unsafe.advance sigma) evs in - let comb,shelf,given_up,evkmain = Evd.dispatch_future_goals evs in + let future_goals = Evd.FutureGoals.map_filter (Proofview.Unsafe.advance sigma) future_goals in (* Proceed to the refinement *) let sigma = match Proofview.Unsafe.advance sigma self with | None -> (* Nothing to do, the goal has been solved by side-effect *) sigma | Some self -> - match evkmain with + match future_goals.Evd.FutureGoals.principal with | None -> Evd.define self c sigma | Some evk -> let id = Evd.evar_ident self sigma in @@ -93,17 +91,16 @@ let generic_refine ~typecheck f gl = | Some id -> Evd.rename evk id sigma in (* Mark goals *) - let sigma = Proofview.Unsafe.mark_as_goals sigma comb in - let sigma = Proofview.Unsafe.mark_unresolvables sigma shelf in - let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in + let sigma = Proofview.Unsafe.mark_as_goals sigma future_goals.Evd.FutureGoals.comb in + let sigma = Proofview.Unsafe.mark_unresolvables sigma future_goals.Evd.FutureGoals.shelf in + let comb = CList.rev_map (fun x -> Proofview.goal_with_state x state) future_goals.Evd.FutureGoals.comb in let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++ Termops.Internal.print_constr_env env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> Proofview.Unsafe.tclSETGOALS comb <*> - Proofview.Unsafe.tclPUTSHELF shelf <*> - Proofview.Unsafe.tclPUTGIVENUP given_up <*> + Proofview.Unsafe.tclPUTSHELF @@ List.rev future_goals.Evd.FutureGoals.shelf <*> Proofview.tclUNIT v end diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 3d892fa5ca..e41f62361d 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -51,8 +51,8 @@ let is_focused_goal_simple ~doc id = | `Valid (Some { Vernacstate.lemmas }) -> Option.cata (Vernacstate.LemmaStack.with_top ~f:(fun proof -> let proof = Declare.Proof.get proof in - let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in - let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + let Proof.{ goals=focused; stack=r1; shelf=r2; sigma } = Proof.data proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ (Evar.Set.elements @@ Evd.given_up sigma) in if List.for_all (fun x -> simple_goal sigma x rest) focused then `Simple focused else `Not)) `Not lemmas diff --git a/stm/stm.ml b/stm/stm.ml index 3b7921f638..9999e66c45 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -834,15 +834,11 @@ module State : sig (* to send states across worker/master *) val get_cached : Stateid.t -> Vernacstate.t - val same_env : Vernacstate.t -> Vernacstate.t -> bool - - type proof_part type partial_state = [ `Full of Vernacstate.t - | `ProofOnly of Stateid.t * proof_part ] + | `ProofOnly of Stateid.t * Vernacstate.Stm.pstate ] - val proof_part_of_frozen : Vernacstate.t -> proof_part val assign : Stateid.t -> partial_state -> unit (* Handlers for initial state, prior to document creation. *) @@ -865,13 +861,9 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy - type proof_part = Vernacstate.Stm.pstate - type partial_state = [ `Full of Vernacstate.t - | `ProofOnly of Stateid.t * proof_part ] - - let proof_part_of_frozen st = Vernacstate.Stm.pstate st + | `ProofOnly of Stateid.t * Vernacstate.Stm.pstate ] let cache_state ~marshallable id = VCS.set_state id (FullState (Vernacstate.freeze_interp_state ~marshallable)) @@ -924,7 +916,6 @@ end = struct (* {{{ *) with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).") let assign id what = - let open Vernacstate in if VCS.get_state id <> EmptyState then () else try match what with | `Full s -> @@ -932,9 +923,11 @@ end = struct (* {{{ *) try let prev = (VCS.visit id).next in if is_cached_and_valid prev - then { s with lemmas = - PG_compat.copy_terminators - ~src:((get_cached prev).lemmas) ~tgt:s.lemmas } + then + let open Vernacstate in + { s with + lemmas = PG_compat.copy_terminators + ~src:((get_cached prev).lemmas) ~tgt:s.lemmas } else s with VCS.Expired -> s in VCS.set_state id (FullState s) @@ -953,8 +946,6 @@ end = struct (* {{{ *) execution_error ?loc id (iprint (e, info)); (e, Stateid.add info ~valid id) - let same_env = Vernacstate.Stm.same_env - (* [define] puts the system in state [id] calling [f ()] *) (* [safe_id] is the last known valid state before execution *) let define ~doc ?safe_id ?(redefine=false) ?(cache=false) ?(feedback_processed=true) @@ -1549,8 +1540,8 @@ end = struct (* {{{ *) match prev, this with | _, None -> None | Some (prev, o, `Cmd { cast = { expr }}), Some n - when is_tac expr && State.same_env o n -> (* A pure tactic *) - Some (id, `ProofOnly (prev, State.proof_part_of_frozen n)) + 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"); Some (id, `Full s) @@ -1931,7 +1922,8 @@ end = struct (* {{{ *) str" solves the goal and leaves no unresolved existential variables. The following" ++ str" existentials remain unsolved: " ++ prlist (Termops.pr_existential_key sigma) (Evar.Set.elements evars)) end) () - with e when CErrors.noncritical e -> RespError (CErrors.print e) + with e when CErrors.noncritical e -> + RespError (CErrors.print e ++ spc() ++ str "(for subgoal "++int (fst r_ast) ++ str ")") let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 2f55cc071f..ccb69cf845 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -715,8 +715,8 @@ module Search = struct shelve_goals shelved <*> (if List.is_empty goals then tclUNIT () else - let sigma' = make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in - with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state goals)) >>= + let make_unresolvables = tclEVARMAP >>= fun sigma -> Unsafe.tclEVARS @@ make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in + with_shelf (make_unresolvables <*> Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state goals)) >>= fun s -> result s i (Some (Option.default 0 k + j))) end in with_shelf res >>= fun (sh, ()) -> @@ -934,7 +934,7 @@ module Search = struct let tac = tac <*> Proofview.Unsafe.tclGETGOALS >>= fun stuck -> Proofview.shelve_goals (List.map Proofview_monad.drop_state stuck) in let evm = Evd.set_typeclass_evars evm Evar.Set.empty in - let fgoals = Evd.save_future_goals evm in + let evm = Evd.push_future_goals evm in let _, pv = Proofview.init evm [] in let pv = Proofview.unshelve goalsl pv in try @@ -956,20 +956,19 @@ module Search = struct (str "leaking evar " ++ int (Evar.repr ev) ++ spc () ++ pr_ev evm' ev); acc && okev) evm' true); - let fgoals = Evd.shelve_on_future_goals shelved fgoals in - let evm' = Evd.restore_future_goals evm' fgoals in + let _, evm' = Evd.pop_future_goals evm' in + let evm' = Evd.shelve_on_future_goals shelved evm' in let nongoals' = Evar.Set.fold (fun ev acc -> match Evarutil.advance evm' ev with | Some ev' -> Evar.Set.add ev acc | None -> acc) (Evar.Set.union goals nongoals) (Evd.get_typeclass_evars evm') in + (* let evm' = { evm' with metas = evm.metas } *) let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in let evm' = Evd.set_typeclass_evars evm' nongoals' in Some evm' in - let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply ~name ~poly env tac pv in - if not (List.is_empty gaveup) then - CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals."); + let (), pv', (unsafe, shelved), _ = Proofview.apply ~name ~poly env tac pv in if Proofview.finished pv' then finish pv' shelved else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found diff --git a/tactics/elim.ml b/tactics/elim.ml index 415c980c2a..274ebc9f60 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -82,10 +82,10 @@ let general_decompose recognizer c = Proofview.Goal.enter begin fun gl -> let typc = pf_get_type_of gl c in tclTHENS (cut typc) - [ tclTHEN (intro_using tmphyp_name) - (onLastHypId - (ifOnHyp recognizer (general_decompose_aux recognizer) - (fun id -> clear [id]))); + [ intro_using_then tmphyp_name (fun id -> + ifOnHyp recognizer (general_decompose_aux recognizer) + (fun id -> clear [id]) + id); exact_no_check c ] end diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 57d793b2a5..d4cc193eb3 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -150,12 +150,12 @@ let injHyp id = let diseqCase hyps eqonleft = let diseq = Id.of_string "diseq" in let absurd = Id.of_string "absurd" in - (tclTHEN (intro_using diseq) - (tclTHEN (choose_noteq eqonleft) + (intro_using_then diseq (fun diseq -> + tclTHEN (choose_noteq eqonleft) (tclTHEN (rewrite_and_clear (List.rev hyps)) (tclTHEN (red_in_concl) - (tclTHEN (intro_using absurd) - (tclTHEN (Simple.apply (mkVar diseq)) + (intro_using_then absurd (fun absurd -> + tclTHEN (Simple.apply (mkVar diseq)) (tclTHEN (injHyp absurd) (full_trivial [])))))))) diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index c463c06cd5..a8747e0a7c 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -60,7 +60,7 @@ let set_strategy_one ref l = Global.set_strategy k l; match k,l with ConstKey sp, Conv_oracle.Opaque -> - Csymtable.set_opaque_const sp + Vmsymtable.set_opaque_const sp | ConstKey sp, _ -> let cb = Global.lookup_constant sp in (match cb.const_body with @@ -69,7 +69,7 @@ let set_strategy_one ref l = (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); - | _ -> Csymtable.set_transparent_const sp) + | _ -> Vmsymtable.set_transparent_const sp) | _ -> () let cache_strategy (_,str) = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 70cea89ccb..eb7b7e363f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1068,6 +1068,10 @@ let rec intros_using = function | [] -> Proofview.tclUNIT() | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l) +let rec intros_mustbe_force = function + | [] -> Proofview.tclUNIT() + | str::l -> Tacticals.New.tclTHEN (intro_mustbe_force str) (intros_mustbe_force l) + let rec intros_using_then_helper tac acc = function | [] -> tac (List.rev acc) | str::l -> intro_using_then str (fun str' -> intros_using_then_helper tac (str'::acc) l) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 00739306a7..54c781af5c 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -65,10 +65,13 @@ val intro_avoiding : Id.Set.t -> unit Proofview.tactic val intro_replacing : Id.t -> unit Proofview.tactic val intro_using : Id.t -> unit Proofview.tactic +[@@ocaml.deprecated "Prefer [intro_using_then] to avoid renaming issues."] val intro_using_then : Id.t -> (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intro_mustbe_force : Id.t -> unit Proofview.tactic +val intros_mustbe_force : Id.t list -> unit Proofview.tactic val intro_then : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intros_using : Id.t list -> unit Proofview.tactic +[@@ocaml.deprecated "Prefer [intros_using_then] to avoid renaming issues."] val intros_using_then : Id.t list -> (Id.t list -> unit Proofview.tactic) -> unit Proofview.tactic val intros_replacing : Id.t list -> unit Proofview.tactic val intros_possibly_replacing : Id.t list -> unit Proofview.tactic diff --git a/test-suite/bugs/closed/bug_10939.v b/test-suite/bugs/closed/bug_10939.v new file mode 100644 index 0000000000..e4adc35554 --- /dev/null +++ b/test-suite/bugs/closed/bug_10939.v @@ -0,0 +1,5 @@ +Goal False. +Proof. + epose proof ltac:(shelve). (* works *) + epose proof ltac:(admit). (* anomaly *) +Abort. diff --git a/test-suite/bugs/closed/bug_12676.v b/test-suite/bugs/closed/bug_12676.v new file mode 100644 index 0000000000..5118ddb472 --- /dev/null +++ b/test-suite/bugs/closed/bug_12676.v @@ -0,0 +1,13 @@ + + +Definition nat_eq_dec(i j:nat) : {i=j}+{i<>j}. +Proof. + pose (diseq := false). + decide equality. +Defined. + +Set Mangle Names. +Definition nat_eq_dec_mangle (i j:nat) : {i=j}+{i<>j}. +Proof. + decide equality. (*Error: Anomaly "variable diseq unbound." ...*) +Defined. diff --git a/test-suite/bugs/closed/bug_12860.v b/test-suite/bugs/closed/bug_12860.v new file mode 100644 index 0000000000..243aeceba2 --- /dev/null +++ b/test-suite/bugs/closed/bug_12860.v @@ -0,0 +1,10 @@ +Require Import Coq.nsatz.NsatzTactic. +Require Import Coq.ZArith.ZArith Coq.QArith.QArith. + +Goal forall x y : Z, (x + y = y + x)%Z. + intros; nsatz. +Qed. + +Goal forall x y : Q, Qeq (x + y) (y + x). + intros; nsatz. +Qed. diff --git a/test-suite/bugs/closed/bug_12907.v b/test-suite/bugs/closed/bug_12907.v new file mode 100644 index 0000000000..4cd79cc1af --- /dev/null +++ b/test-suite/bugs/closed/bug_12907.v @@ -0,0 +1,7 @@ +From Coq Require Export Lia. +Set Mangle Names. +Lemma test (n : nat) : n <= 10 -> n <= 20. +Proof. lia. Qed. + +Lemma test2 : 0 < 1. +Proof. lia. Qed. diff --git a/test-suite/bugs/closed/bug_4095.v b/test-suite/bugs/closed/bug_4095.v index 3d3015c383..d667022e68 100644 --- a/test-suite/bugs/closed/bug_4095.v +++ b/test-suite/bugs/closed/bug_4095.v @@ -71,18 +71,9 @@ Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred) refine (P _ _) end. Undo. - Fail lazymatch goal with + lazymatch goal with | |- ?R (?f ?a ?b) (?f ?a' ?b') => let P := constr:(fun H H' => Morphisms.proper_prf a a' H b b' H') in set(p:=P) - end. (* Toplevel input, characters 15-182: -Error: Cannot infer an instance of type -"PointedOPred" for the variable p in environment: -T : Type -O0 : T -> OPred -O1 : T -> PointedOPred -tr : T -> T -O2 : PointedOPred -x0 : T -H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *) + end. Abort. diff --git a/test-suite/bugs/closed/bug_5703.v b/test-suite/bugs/closed/bug_5703.v new file mode 100644 index 0000000000..c6e9eab9a7 --- /dev/null +++ b/test-suite/bugs/closed/bug_5703.v @@ -0,0 +1,9 @@ +Class A := {}. +Instance a:A := {}. +Hint Extern 0 A => abstract (exact a) : typeclass_instances. +Lemma lem : A. +Proof. + let a := constr:(_:A) in + let b := type of a in + exact a. +Defined. diff --git a/test-suite/output-coqchk/bug_12845.out b/test-suite/output-coqchk/bug_12845.out new file mode 100644 index 0000000000..bef45bf2f6 --- /dev/null +++ b/test-suite/output-coqchk/bug_12845.out @@ -0,0 +1,14 @@ + +CONTEXT SUMMARY +=============== + +* Theory: Set is predicative + +* Axioms: <none> + +* Constants/Inductives relying on type-in-type: <none> + +* Constants/Inductives relying on unsafe (co)fixpoints: <none> + +* Inductives whose positivity is assumed: <none> + diff --git a/test-suite/output-coqchk/bug_12845.v b/test-suite/output-coqchk/bug_12845.v new file mode 100644 index 0000000000..d16146855b --- /dev/null +++ b/test-suite/output-coqchk/bug_12845.v @@ -0,0 +1,13 @@ +Module Type A. + Module B. + Axiom t : Set. + End B. +End A. + +Module a : A. + Module B. + Definition t : Set := unit. + End B. +End a. + +Check a.B.t. diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 2265028d3e..d8b88b8c1c 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -17,3 +17,7 @@ fix f (x : nat) : option nat := match x with | S _ => x end : nat -> option nat +fun x : False => let y := False_rect (A:=bool) x in y + : False -> bool +fun x : False => let y : True := False_rect x in y + : False -> True diff --git a/test-suite/output/Implicit.v b/test-suite/output/Implicit.v index a7c4399e38..86420bd8c8 100644 --- a/test-suite/output/Implicit.v +++ b/test-suite/output/Implicit.v @@ -61,3 +61,13 @@ Coercion some_nat := @Some nat. Check fix f x := match x with 0 => None | n => some_nat n end. End MatchBranchesInContext. + +Module LetInContext. + +Set Implicit Arguments. +Set Contextual Implicit. +Axiom False_rect : forall A:Type, False -> A. +Check fun x:False => let y:= False_rect (A:=bool) x in y. (* will not be in context: explicitation *) +Check fun x:False => let y:= False_rect (A:=True) x in y. (* will be in context: no explicitation *) + +End LetInContext. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index fa03ec8193..ce51acac95 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -123,3 +123,5 @@ File "stdin", line 297, characters 0-30: Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] 0 :=: 0 : Prop +fun x : nat => <{ x; (S x) }> + : nat -> nat diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 90d8da2bec..73445bad12 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -298,3 +298,18 @@ Notation "x :=: y" := (x = y). Check (0 :=: 0). End Bug12691. + +Module CoercionEntryTransitivity. + +Declare Custom Entry com. +Declare Custom Entry com_top. +Notation "<{ e }>" := e (at level 0, e custom com_top at level 99). +Notation "x ; y" := + (x + y) + (in custom com_top at level 90, x custom com at level 90, right associativity). +Notation "x" := x (in custom com at level 0, x constr at level 0). +Notation "x" := x (in custom com_top at level 90, x custom com at level 90). + +Check fun x => <{ x ; (S x) }>. + +End CoercionEntryTransitivity. diff --git a/test-suite/output/Notations5.out b/test-suite/output/Notations5.out index f59306c454..a6c2553a89 100644 --- a/test-suite/output/Notations5.out +++ b/test-suite/output/Notations5.out @@ -146,8 +146,10 @@ v : forall (B : Type) (b : B), 0 = 0 /\ b = b @v 0 : forall (B : Type) (b : B), 0 = 0 /\ b = b -v 0 (B:=bool) +v 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=v 0 (B:=bool)} + : nat v : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b v 0 @@ -166,8 +168,10 @@ v : forall (B : Type) (b : B), 0 = 0 /\ b = b @v 0 : forall (B : Type) (b : B), 0 = 0 /\ b = b -v 0 (B:=bool) +v 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=v 0 (B:=bool)} + : nat ## : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b where @@ -192,10 +196,12 @@ where : 0 = 0 /\ true = true ## 0 0 true : 0 = 0 /\ true = true -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=## 0 0 (B:=bool)} + : nat ## ?A : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b where @@ -230,10 +236,12 @@ where : forall b : ?B, 0 = 0 /\ b = b where ?B : [ |- Type] -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=## 0 0 (B:=bool)} + : nat ## 0 0 true : 0 = 0 /\ true = true ## 0 0 true @@ -246,10 +254,12 @@ where : forall b : ?B, 0 = 0 /\ b = b where ?B : [ |- Type] -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=## 0 0 (B:=bool)} + : nat ## 0 0 true : 0 = 0 /\ true = true ## 0 0 true diff --git a/test-suite/output/Notations5.v b/test-suite/output/Notations5.v index 09d5e31c48..010b0da4a9 100644 --- a/test-suite/output/Notations5.v +++ b/test-suite/output/Notations5.v @@ -189,7 +189,9 @@ Module AppliedTermsPrinting. Check @v 0. (* @v 0 *) Check @p nat 0 0 bool. - (* v 0 (B:=bool) *) + (* v 0 *) + Eval simpl in (fun x => _:nat) (@p nat 0 0 bool). + (* ?n@{x:=v 0 (B:=bool)} *) End AtAbbreviationForPartialApplication. @@ -217,7 +219,9 @@ Module AppliedTermsPrinting. Check @v 0. (* @v 0 *) Check @p nat 0 0 bool. - (* v 0 (B:=bool) *) + (* v 0 *) + Eval simpl in (fun x => _:nat) (@p nat 0 0 bool). + (* ?n@{x:=v 0 (B:=bool)} *) End AbbreviationForPartialApplication. @@ -247,9 +251,11 @@ Module AppliedTermsPrinting. Check ## 0 0 true. (* ## 0 0 true *) Check p 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) Check ## 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) + Eval simpl in (fun x => _:nat) (@p nat 0 0 bool). + (* ?n@{x:=## 0 0 (B:=bool)} *) End NotationForHeadApplication. @@ -301,9 +307,11 @@ Module AppliedTermsPrinting. Check ## 0 0. (* ## 0 0 *) Check p 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) Check ## 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) + Eval simpl in (fun x => _:nat) (## 0 0 (B:=bool)). + (* ?n@{## 0 0 (B:=bool)} *) Check p 0 0 true. (* ## 0 0 true *) Check ## 0 0 true. @@ -327,9 +335,11 @@ Module AppliedTermsPrinting. Check ## 0 0. (* ## 0 0 *) Check p 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) Check ## 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) + Eval simpl in (fun x => _:nat) (## 0 0 (B:=bool)). + (* ?n@{## 0 0 (B:=bool)} *) Check p 0 0 true. (* ## 0 0 true *) Check ## 0 0 true. diff --git a/test-suite/output/Partac.out b/test-suite/output/Partac.out new file mode 100644 index 0000000000..889e698fa2 --- /dev/null +++ b/test-suite/output/Partac.out @@ -0,0 +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) +The command has indeed failed with message: +The term "0" has type "nat" while it is expected to have type "bool". +(for subgoal 2) diff --git a/test-suite/output/Partac.v b/test-suite/output/Partac.v new file mode 100644 index 0000000000..f579ee683b --- /dev/null +++ b/test-suite/output/Partac.v @@ -0,0 +1,6 @@ +Goal nat * bool. +Proof. + split. + Fail par: exact false. + Fail par: exact 0. +Abort. diff --git a/test-suite/output/ssr_error_multiple_intro_after_case.v b/test-suite/output/ssr_error_multiple_intro_after_case.v index 1f87966693..18997b8686 100644 --- a/test-suite/output/ssr_error_multiple_intro_after_case.v +++ b/test-suite/output/ssr_error_multiple_intro_after_case.v @@ -1,3 +1,4 @@ Require Import ssreflect. Goal forall p : nat * nat , True. case => x x. +Abort. diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index b2c5884ed7..ef2f139133 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -20,7 +20,10 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac zchecker := - intros ?__wit ?__varmap ?__ff ; + let __wit := fresh "__wit" in + let __varmap := fresh "__varmap" in + let __ff := fresh "__ff" in + intros __wit __varmap __ff ; exact (ZTautoChecker_sound __ff __wit (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) (@find Z Z0 __varmap)). diff --git a/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v index 70180f47c7..b684775bb4 100644 --- a/theories/nsatz/Nsatz.v +++ b/theories/nsatz/Nsatz.v @@ -75,43 +75,3 @@ red. exact Rmult_comm. Defined. Instance Rdi : (Integral_domain (Rcr:=Rcri)). constructor. exact Rmult_integral. exact R_one_zero. Defined. - -(* Rational numbers *) -Require Import QArith. - -Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). -Defined. - -Instance Qri : (Ring (Ro:=Qops)). -constructor. -try apply Q_Setoid. -apply Qplus_comp. -apply Qmult_comp. -apply Qminus_comp. -apply Qopp_comp. - exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. - exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. - apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. -reflexivity. exact Qplus_opp_r. -Defined. - -Lemma Q_one_zero: not (Qeq 1%Q 0%Q). -Proof. unfold Qeq. simpl. lia. Qed. - -Instance Qcri: (Cring (Rr:=Qri)). -red. exact Qmult_comm. Defined. - -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. -exact Qmult_integral. exact Q_one_zero. Defined. - -(* Integers *) -Lemma Z_one_zero: 1%Z <> 0%Z. -Proof. lia. Qed. - -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. -exact Zmult_integral. exact Z_one_zero. Defined. diff --git a/theories/nsatz/NsatzTactic.v b/theories/nsatz/NsatzTactic.v index db7dab2c46..0d24de39d1 100644 --- a/theories/nsatz/NsatzTactic.v +++ b/theories/nsatz/NsatzTactic.v @@ -447,3 +447,43 @@ Tactic Notation "nsatz" "with" repeat equalities_to_goal; nsatz_generic radicalmax info lparam lvar end. + +(* Rational numbers *) +Require Import QArith. + +Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). +Defined. + +Instance Qri : (Ring (Ro:=Qops)). +constructor. +try apply Q_Setoid. +apply Qplus_comp. +apply Qmult_comp. +apply Qminus_comp. +apply Qopp_comp. + exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. + exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. + apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. +reflexivity. exact Qplus_opp_r. +Defined. + +Lemma Q_one_zero: not (Qeq 1%Q 0%Q). +Proof. unfold Qeq. simpl. lia. Qed. + +Instance Qcri: (Cring (Rr:=Qri)). +red. exact Qmult_comm. Defined. + +Instance Qdi : (Integral_domain (Rcr:=Qcri)). +constructor. +exact Qmult_integral. exact Q_one_zero. Defined. + +(* Integers *) +Lemma Z_one_zero: 1%Z <> 0%Z. +Proof. lia. Qed. + +Instance Zcri: (Cring (Rr:=Zr)). +red. exact Z.mul_comm. Defined. + +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. +exact Zmult_integral. exact Z_one_zero. Defined. diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index be84e217a5..f35da63fd6 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -546,6 +546,38 @@ Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. +(* additional contra lemmas involving [P,Q : Prop] *) +Lemma contra_not (P Q : Prop) : (Q -> P) -> (~ P -> ~ Q). Proof. by auto. Qed. + +Lemma contraPnot (P Q : Prop) : (Q -> ~ P) -> (P -> ~ Q). Proof. by auto. Qed. + +Lemma contraTnot (b : bool) (P : Prop) : (P -> ~~ b) -> (b -> ~ P). +Proof. by case: b; auto. Qed. + +Lemma contraNnot (P : Prop) (b : bool) : (P -> b) -> (~~ b -> ~ P). +Proof. rewrite -{1}[b]negbK; exact: contraTnot. Qed. + +Lemma contraPT (P : Prop) (b : bool) : (~~ b -> ~ P) -> P -> b. +Proof. by case: b => //= /(_ isT) nP /nP. Qed. + +Lemma contra_notT (P : Prop) (b : bool) : (~~ b -> P) -> ~ P -> b. +Proof. by case: b => //= /(_ isT) HP /(_ HP). Qed. + +Lemma contra_notN (P : Prop) (b : bool) : (b -> P) -> ~ P -> ~~ b. +Proof. rewrite -{1}[b]negbK; exact: contra_notT. Qed. + +Lemma contraPN (P : Prop) (b : bool) : (b -> ~ P) -> (P -> ~~ b). +Proof. by case: b => //=; move/(_ isT) => HP /HP. Qed. + +Lemma contraFnot (P : Prop) (b : bool) : (P -> b) -> b = false -> ~ P. +Proof. by case: b => //; auto. Qed. + +Lemma contraPF (P : Prop) (b : bool) : (b -> ~ P) -> P -> b = false. +Proof. by case: b => // /(_ isT). Qed. + +Lemma contra_notF (P : Prop) (b : bool) : (b -> P) -> ~ P -> b = false. +Proof. by case: b => // /(_ isT). Qed. + (** Coercion of sum-style datatypes into bool, which makes it possible to use ssr's boolean if rather than Coq's "generic" if. **) @@ -1310,7 +1342,8 @@ Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). -Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) + (only parsing) : fun_scope. Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. @@ -1980,12 +2013,10 @@ End MonoHomoMorphismTheory. Section MonoHomoMorphismTheory_in. -Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : {pred aT}). +Variables (aT rT : predArgType) (f : aT -> rT) (g : rT -> aT). +Variables (aD : {pred aT}) (rD : {pred rT}). Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). -Notation rD := [pred x | g x \in aD]. - Lemma monoW_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in aD &, {homo f : x y / aR x y >-> rR x y}}. @@ -1996,17 +2027,18 @@ Lemma mono2W_in : {in aD, {homo f : x / aP x >-> rP x}}. Proof. by move=> hf x hx ax; rewrite hf. Qed. -Hypothesis fgK_on : {on aD, cancel g & f}. +Hypothesis fgK : {in rD, {on aD, cancel g & f}}. +Hypothesis mem_g : {homo g : x / x \in rD >-> x \in aD}. Lemma homoRL_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> {in rD & aD, forall x y, aR (g x) y -> rR x (f y)}. -Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK ?mem_g// ?inE; apply. Qed. Lemma homoLR_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> {in aD & rD, forall x y, aR x (g y) -> rR (f x) y}. -Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK ?mem_g// ?inE; apply. Qed. Lemma homo_mono_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> @@ -2014,22 +2046,119 @@ Lemma homo_mono_in : {in rD &, {mono g : x y / rR x y >-> aR x y}}. Proof. move=> mf mg x y hx hy; case: (boolP (rR _ _))=> [/mg //|]; first exact. -by apply: contraNF=> /mf; rewrite !fgK_on //; apply. +by apply: contraNF=> /mf; rewrite !fgK ?mem_g//; apply. Qed. Lemma monoLR_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in aD & rD, forall x y, rR (f x) y = aR x (g y)}. -Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK_on // mf. Qed. +Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK ?mem_g// mf ?mem_g. Qed. Lemma monoRL_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in rD & aD, forall x y, rR x (f y) = aR (g x) y}. -Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK_on // mf. Qed. +Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK ?mem_g// mf ?mem_g. Qed. Lemma can_mono_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in rD &, {mono g : x y / rR x y >-> aR x y}}. -Proof. by move=> mf x y hx hy /=; rewrite -mf // !fgK_on. Qed. +Proof. by move=> mf x y hx hy; rewrite -mf ?mem_g// !fgK ?mem_g. Qed. End MonoHomoMorphismTheory_in. +Arguments homoRL_in {aT rT f g aD rD aR rR}. +Arguments homoLR_in {aT rT f g aD rD aR rR}. +Arguments homo_mono_in {aT rT f g aD rD aR rR}. +Arguments monoLR_in {aT rT f g aD rD aR rR}. +Arguments monoRL_in {aT rT f g aD rD aR rR}. +Arguments can_mono_in {aT rT f g aD rD aR rR}. + +Section HomoMonoMorphismFlip. +Variables (aT rT : Type) (aR : rel aT) (rR : rel rT) (f : aT -> rT). +Variable (aD aD' : {pred aT}). + +Lemma homo_sym : {homo f : x y / aR x y >-> rR x y} -> + {homo f : y x / aR x y >-> rR x y}. +Proof. by move=> fR y x; apply: fR. Qed. + +Lemma mono_sym : {mono f : x y / aR x y >-> rR x y} -> + {mono f : y x / aR x y >-> rR x y}. +Proof. by move=> fR y x; apply: fR. Qed. + +Lemma homo_sym_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in aD &, {homo f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +Lemma mono_sym_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD &, {mono f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +Lemma homo_sym_in11 : {in aD & aD', {homo f : x y / aR x y >-> rR x y}} -> + {in aD' & aD, {homo f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +Lemma mono_sym_in11 : {in aD & aD', {mono f : x y / aR x y >-> rR x y}} -> + {in aD' & aD, {mono f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +End HomoMonoMorphismFlip. +Arguments homo_sym {aT rT} [aR rR f]. +Arguments mono_sym {aT rT} [aR rR f]. +Arguments homo_sym_in {aT rT} [aR rR f aD]. +Arguments mono_sym_in {aT rT} [aR rR f aD]. +Arguments homo_sym_in11 {aT rT} [aR rR f aD aD']. +Arguments mono_sym_in11 {aT rT} [aR rR f aD aD']. + +Section CancelOn. + +Variables (aT rT : predArgType) (aD : {pred aT}) (rD : {pred rT}). +Variables (f : aT -> rT) (g : rT -> aT). + +Lemma onW_can : cancel g f -> {on aD, cancel g & f}. +Proof. by move=> fgK x xaD; apply: fgK. Qed. + +Lemma onW_can_in : {in rD, cancel g f} -> {in rD, {on aD, cancel g & f}}. +Proof. by move=> fgK x xrD xaD; apply: fgK. Qed. + +Lemma in_onW_can : cancel g f -> {in rD, {on aD, cancel g & f}}. +Proof. by move=> fgK x xrD xaD; apply: fgK. Qed. + +Lemma onS_can : (forall x, g x \in aD) -> {on aD, cancel g & f} -> cancel g f. +Proof. by move=> mem_g fgK x; apply: fgK. Qed. + +Lemma onS_can_in : {homo g : x / x \in rD >-> x \in aD} -> + {in rD, {on aD, cancel g & f}} -> {in rD, cancel g f}. +Proof. by move=> mem_g fgK x x_rD; apply/fgK/mem_g. Qed. + +Lemma in_onS_can : (forall x, g x \in aD) -> + {in rT, {on aD, cancel g & f}} -> cancel g f. +Proof. by move=> mem_g fgK x; apply/fgK. Qed. + +End CancelOn. +Arguments onW_can {aT rT} aD {f g}. +Arguments onW_can_in {aT rT} aD {rD f g}. +Arguments in_onW_can {aT rT} aD rD {f g}. +Arguments onS_can {aT rT} aD {f g}. +Arguments onS_can_in {aT rT} aD {rD f g}. +Arguments in_onS_can {aT rT} aD {f g}. + +Section inj_can_sym_in_on. +Variables (aT rT : predArgType) (aD : {pred aT}) (rD : {pred rT}). +Variables (f : aT -> rT) (g : rT -> aT). + +Lemma inj_can_sym_in_on : + {homo f : x / x \in aD >-> x \in rD} -> {in aD, {on rD, cancel f & g}} -> + {in rD &, {on aD &, injective g}} -> {in rD, {on aD, cancel g & f}}. +Proof. by move=> fD fK gI x x_rD gx_aD; apply: gI; rewrite ?inE ?fK ?fD. Qed. + +Lemma inj_can_sym_on : {in aD, cancel f g} -> + {on aD &, injective g} -> {on aD, cancel g & f}. +Proof. by move=> fK gI x gx_aD; apply: gI; rewrite ?inE ?fK. Qed. + +Lemma inj_can_sym_in : {homo f \o g : x / x \in rD} -> {on rD, cancel f & g} -> + {in rD &, injective g} -> {in rD, cancel g f}. +Proof. by move=> fgD fK gI x x_rD; apply: gI; rewrite ?fK ?fgD. Qed. + +End inj_can_sym_in_on. +Arguments inj_can_sym_in_on {aT rT aD rD f g}. +Arguments inj_can_sym_on {aT rT aD f g}. +Arguments inj_can_sym_in {aT rT rD f g}. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 0086516785..02ababd928 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -104,7 +104,7 @@ BEFORE ?= AFTER ?= # FIXME this should be generated by Coq (modules already linked by Coq) -CAMLDONTLINK=num,str,unix,dynlink,threads +CAMLDONTLINK=str,unix,dynlink,threads,num,zarith # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 79de3c86b6..9917ae0f01 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -324,12 +324,12 @@ let loop_flush_all () = let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2 let evleq e1 e2 = CList.equal Evar.equal e1 e2 let cproof p1 p2 = - let Proof.{goals=a1;stack=a2;shelf=a3;given_up=a4} = Proof.data p1 in - let Proof.{goals=b1;stack=b2;shelf=b3;given_up=b4} = Proof.data p2 in + let Proof.{goals=a1;stack=a2;shelf=a3;sigma=sigma1} = Proof.data p1 in + let Proof.{goals=b1;stack=b2;shelf=b3;sigma=sigma2} = Proof.data p2 in evleq a1 b1 && CList.equal (pequal evleq evleq) a2 b2 && CList.equal Evar.equal a3 b3 && - CList.equal Evar.equal a4 b4 + Evar.Set.equal (Evd.given_up sigma1) (Evd.given_up sigma2) let drop_last_doc = ref None diff --git a/toplevel/dune b/toplevel/dune index 2d64ae303c..5f10346ac4 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -3,8 +3,9 @@ (public_name coq.toplevel) (synopsis "Coq's Interactive Shell [terminal-based]") (wrapped false) + ; num still here due to some plugins using it (libraries num coq.stm)) -; Coqlevel provides the `Num` library to plugins, we could also use +; Interp provides the `zarith` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. (coq.pp (modules g_toplevel)) diff --git a/vernac/classes.ml b/vernac/classes.ml index f454c389dc..82a1e32a14 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -358,8 +358,9 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl id the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code the refinement manually.*) - let gls = List.rev (Evd.future_goals sigma) in - let sigma = Evd.reset_future_goals sigma in + let future_goals, sigma = Evd.pop_future_goals sigma in + let gls = List.rev_append future_goals.Evd.FutureGoals.shelf (List.rev future_goals.Evd.FutureGoals.comb) in + let sigma = Evd.push_future_goals sigma in let kind = Decls.(IsDefinition Instance) in let hook = Declare.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Declare.Info.make ~hook ~kind ~udecl ~poly () in diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 6cc48d0e48..0bdcd53c92 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -665,15 +665,21 @@ let expand_list_rule s typ tkl x n p ll = aux (i+1) (main :: tks @ hds) ll in aux 0 [] ll -let is_constr_typ typ x etyps = +let is_constr_typ (s,lev) x etyps = match List.assoc x etyps with - | ETConstr (_,_,typ') -> typ = typ' + (* TODO: factorize these rules with the ones computing the effective + sublevel sent to camlp5, so as to include the case of + DefaultLevel which are valid *) + | ETConstr (s',_,(lev',InternalProd | (NumLevel _ | NextLevel as lev'), _)) -> + Notation.notation_entry_eq s s' && production_level_eq lev lev' | _ -> false let include_possible_similar_trailing_pattern typ etyps sl l = let rec aux n = function | Terminal s :: sl, Terminal s'::l' when s = s' -> aux n (sl,l') | [], NonTerminal x ::l' when is_constr_typ typ x etyps -> try_aux n l' + | Break _ :: sl, l -> aux n (sl,l) + | sl, Break _ :: l -> aux n (sl,l) | _ -> raise Exit and try_aux n l = try aux (n+1) (sl,l) @@ -704,8 +710,8 @@ let make_production etyps symbols = | Break _ -> [] | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in match List.assoc x etyps with - | ETConstr (s,_,typ) -> - let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in + | ETConstr (s,_,(lev,_ as typ)) -> + let p,l' = include_possible_similar_trailing_pattern (s,lev) etyps sl l in expand_list_rule s typ tkl x 1 p (aux l') | ETBinder o -> check_open_binder o sl x; diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 548f59559a..540e85621a 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -112,7 +112,8 @@ let show_proof ~pstate = let show_top_evars ~proof = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let Proof.{goals;shelf;given_up;sigma} = Proof.data proof in + let Proof.{goals;shelf;sigma} = Proof.data proof in + let given_up = Evar.Set.elements @@ Evd.given_up sigma in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) let show_universes ~proof = @@ -1515,15 +1516,15 @@ let () = declare_bool_option { optdepr = false; optkey = ["Dump";"Bytecode"]; - optread = (fun () -> !Cbytegen.dump_bytecode); - optwrite = (:=) Cbytegen.dump_bytecode } + optread = (fun () -> !Vmbytegen.dump_bytecode); + optwrite = (:=) Vmbytegen.dump_bytecode } let () = declare_bool_option { optdepr = false; optkey = ["Dump";"Lambda"]; - optread = (fun () -> !Clambda.dump_lambda); - optwrite = (:=) Clambda.dump_lambda } + optread = (fun () -> !Vmlambda.dump_lambda); + optwrite = (:=) Vmlambda.dump_lambda } let () = declare_bool_option diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index ee06205427..6d12d72408 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -267,6 +267,7 @@ module Stm = struct end } + type non_pstate = Summary.frozen * Lib.frozen let non_pstate { system } = let st = System.Stm.summary system in let st = Summary.remove_from_summary st Evarutil.meta_counter_summary_tag in diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 16fab3782b..5efdb3cc68 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -64,15 +64,23 @@ val unfreeze_interp_state : t -> unit (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit -(* STM-specific state handling *) +(** STM-specific state handling *) module Stm : sig + + (** Proof state + meta/evar counters *) type pstate - (** Surgery on states related to proof state *) val pstate : t -> pstate val set_pstate : t -> pstate -> t - val non_pstate : t -> Summary.frozen * Lib.frozen + + (** Rest of the state, unfortunately this is used in low-level so we need to expose it *) + type non_pstate = Summary.frozen * Lib.frozen + val non_pstate : t -> non_pstate + + (** Checks if two states have the same Environ.env (physical eq) *) val same_env : t -> t -> bool + + (** Call [Lib.drop_objects] on the state *) val make_shallow : t -> t end |