diff options
228 files changed, 11943 insertions, 4009 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index f802040a1d..06a733be45 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -240,8 +240,7 @@ azure-pipelines.yml @coq/ci-maintainers /theories/QArith/ @herbelin -/theories/Reals/ @silene -# Secondary maintainer @ppedrot +/theories/Reals/ @coq/reals-library-maintainers /theories/Relations/ @mattam82 # Secondary maintainer @ppedrot diff --git a/.gitignore b/.gitignore index 4e02e7617c..8fd9fc614c 100644 --- a/.gitignore +++ b/.gitignore @@ -64,6 +64,8 @@ time-of-build.log time-of-build-pretty.log time-of-build-before.log time-of-build-after.log +time-of-build-pretty.log2 +time-of-build-pretty.log3 .csdp.cache test-suite/.lia.cache test-suite/.nra.cache @@ -150,6 +152,8 @@ kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe kernel/copcodes.ml kernel/uint63.ml +ide/default.bindings +ide/default_bindings_src.exe ide/index_urls.txt .lia.cache .nia.cache diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 58be1e4524..a599220bbd 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -516,7 +516,7 @@ test-suite:base+async: dependencies: - build:base variables: - COQFLAGS: "-async-proofs on" + COQFLAGS: "-async-proofs on -async-proofs-cache force" allow_failure: true only: variables: @@ -553,6 +553,9 @@ validate:quick: # Libraries are by convention the projects that depend on Coq # but not on its ML API +library:ci-argosy: + extends: .ci-template + library:ci-bedrock2: extends: .ci-template diff --git a/CHANGES.md b/CHANGES.md index 4a66fa423e..7f4f9a232b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -46,6 +46,11 @@ Specification language, type inference solved by writing an explicit `return` clause, sometimes even simply an explicit `return _` clause. +- Using non-projection values with the projection syntax is not + allowed. For instance "0.(S)" is not a valid way to write "S 0". + Projections from non-primitive (emulated) records are allowed with + warning "nonprimitive-projection-syntax". + Kernel - Added primitive integers @@ -70,6 +75,15 @@ Notations - Various bugs have been fixed (e.g. PR #9214 on removing spurious parentheses on abbreviations shortening a strict prefix of an application). +- Numeral Notations now support inductive types in the input to + printing functions (e.g., numeral notations can be defined for terms + containing things like `@cons nat O O`), and parsing functions now + fully normalize terms including parameters of constructors (so that, + e.g., a numeral notation whose parsing function outputs a proof of + `Nat.gcd x y = 1` will no longer fail to parse due to containing the + constant `Nat.gcd` in the parameter-argument of `eq_refl`). See + #9840 for more details. + Plugins - The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) @@ -109,6 +123,8 @@ Tactics - The syntax of the `autoapply` tactic was fixed to conform with preexisting documentation: it now takes a `with` clause instead of a `using` clause. + + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -149,6 +165,16 @@ Vernacular commands - `Hypotheses` and `Variables` can now take implicit binders inside sections. +- Removed deprecated option `Automatic Coercions Import`. + +- The `Show Script` command has been deprecated. + +- Option `Refine Instance Mode` has been deprecated and will be removed in + the next version. + +- `Coercion` does not warn ambiguous paths which are obviously convertible with + existing ones. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -173,6 +199,14 @@ Tools priorities, so that prefixes resolve to the most convenient bindings. The documentation pages for CoqIDE provides further details. +- The pretty timing diff scripts (flag `TIMING=1` to a + `coq_makefile`-made `Makefile`, also + `tools/make-both-single-timing-files.py`, + `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) + now correctly support non-UTF-8 characters in the output of + `coqc`/`make` as well as printing to stdout, on both python2 and + python3. + Standard Library - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about @@ -196,6 +230,9 @@ Standard Library - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. +- Moved the `auto` hints of the `FSet` library into a new + `fset` database. + Universes - Added `Print Universes Subgraph` variant of `Print Universes`. diff --git a/Makefile.ci b/Makefile.ci index 9180d51bee..000725b6b1 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -10,6 +10,7 @@ CI_TARGETS= \ ci-aac_tactics \ + ci-argosy \ ci-bedrock2 \ ci-bignums \ ci-color \ diff --git a/Makefile.doc b/Makefile.doc index 5ac3ecb63d..e89a20393c 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -31,7 +31,13 @@ DVIPS:=dvips HTMLSTYLE:=coqremote # Sphinx-related variables +OSNAME:=$(shell uname -o) +ifeq ($(OSNAME),Cygwin) +WIN_CURDIR:=$(shell cygpath -w $(CURDIR)) +SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(WIN_CURDIR)" +else SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(CURDIR)" +endif SPHINXOPTS= -j4 SPHINXWARNERROR ?= 1 ifeq ($(SPHINXWARNERROR),1) diff --git a/Makefile.dune b/Makefile.dune index 4609c563d9..ebf74978a9 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -42,8 +42,10 @@ help: @echo " - help: show this message" # We need to bootstrap with a dummy coq.plugins.ltac so install targets do work. -voboot: +plugins/ltac/dune: @echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune + +voboot: plugins/ltac/dune dune build $(DUNEOPT) @vodeps dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d diff --git a/clib/unicode.ml b/clib/unicode.ml index 1e45c0d250..a122e2c46a 100644 --- a/clib/unicode.ml +++ b/clib/unicode.ml @@ -86,6 +86,7 @@ let classify = Unicodetable.ll; (* Letter, lowercase. *) Unicodetable.lt; (* Letter, titlecase. *) Unicodetable.lo; (* Letter, others. *) + Unicodetable.lm; (* Letter, modifier. *) ]; mk_lookup_table_from_unicode_tables_for IdentPart [ diff --git a/coqpp/coqpp_ast.mli b/coqpp/coqpp_ast.mli index 8e10ec49ce..81109887ba 100644 --- a/coqpp/coqpp_ast.mli +++ b/coqpp/coqpp_ast.mli @@ -103,6 +103,7 @@ type classification = type vernac_rule = { vernac_atts : (string * string) list option; + vernac_state: string option; vernac_toks : ext_token list; vernac_class : code option; vernac_depr : bool; diff --git a/coqpp/coqpp_lex.mll b/coqpp/coqpp_lex.mll index c38755943a..81ba8ad98c 100644 --- a/coqpp/coqpp_lex.mll +++ b/coqpp/coqpp_lex.mll @@ -130,6 +130,7 @@ rule extend = parse | space { extend lexbuf } | '\"' { string lexbuf } | '\n' { newline lexbuf; extend lexbuf } +| "![" { BANGBRACKET } | "#[" { HASHBRACKET } | '[' { LBRACKET } | ']' { RBRACKET } diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index d33eef135f..baa6c2d64e 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -161,27 +161,33 @@ let is_token s = match string_split s with | [s] -> is_uident s | _ -> false -let rec parse_tokens = function +let rec parse_tokens ?(in_anon=false) = +let err_anon () = + if in_anon then + fatal (Printf.sprintf "'SELF' or 'NEXT' illegal in anonymous entry level") in +function | [GSymbString s] -> SymbToken ("", Some s) -| [GSymbQualid ("SELF", None)] -> SymbSelf -| [GSymbQualid ("NEXT", None)] -> SymbNext +| [GSymbQualid ("QUOTATION", None); GSymbString s] -> + SymbToken ("QUOTATION", Some s) +| [GSymbQualid ("SELF", None)] -> err_anon (); SymbSelf +| [GSymbQualid ("NEXT", None)] -> err_anon (); SymbNext | [GSymbQualid ("LIST0", None); tkn] -> - SymbList0 (parse_token tkn, None) + SymbList0 (parse_token ~in_anon tkn, None) | [GSymbQualid ("LIST1", None); tkn] -> - SymbList1 (parse_token tkn, None) + SymbList1 (parse_token ~in_anon tkn, None) | [GSymbQualid ("LIST0", None); tkn; GSymbQualid ("SEP", None); tkn'] -> - SymbList0 (parse_token tkn, Some (parse_token tkn')) + SymbList0 (parse_token ~in_anon tkn, Some (parse_token ~in_anon tkn')) | [GSymbQualid ("LIST1", None); tkn; GSymbQualid ("SEP", None); tkn'] -> - SymbList1 (parse_token tkn, Some (parse_token tkn')) + SymbList1 (parse_token ~in_anon tkn, Some (parse_token ~in_anon tkn')) | [GSymbQualid ("OPT", None); tkn] -> - SymbOpt (parse_token tkn) + SymbOpt (parse_token ~in_anon tkn) | [GSymbQualid (e, None)] when is_token e -> SymbToken (e, None) | [GSymbQualid (e, None); GSymbString s] when is_token e -> SymbToken (e, Some s) | [GSymbQualid (e, lvl)] when not (is_token e) -> SymbEntry (e, lvl) -| [GSymbParen tkns] -> parse_tokens tkns +| [GSymbParen tkns] -> parse_tokens ~in_anon tkns | [GSymbProd prds] -> let map p = - let map (pat, tkns) = (pat, parse_tokens tkns) in + let map (pat, tkns) = (pat, parse_tokens ~in_anon:true tkns) in (List.map map p.gprod_symbs, p.gprod_body) in SymbRules (List.map map prds) @@ -197,7 +203,7 @@ let rec parse_tokens = function in fatal (Printf.sprintf "Invalid token: %s" (db_tokens t)) -and parse_token tkn = parse_tokens [tkn] +and parse_token ~in_anon tkn = parse_tokens ~in_anon [tkn] let print_fun fmt (vars, body) = let vars = List.rev vars in @@ -212,16 +218,19 @@ let print_fun fmt (vars, body) = (** Meta-program instead of calling Tok.of_pattern here because otherwise violates value restriction *) -let print_tok fmt = function -| "", s -> fprintf fmt "Tok.KEYWORD %a" print_string s -| "IDENT", s -> fprintf fmt "Tok.IDENT %a" print_string s -| "PATTERNIDENT", s -> fprintf fmt "Tok.PATTERNIDENT %a" print_string s -| "FIELD", s -> fprintf fmt "Tok.FIELD %a" print_string s -| "INT", s -> fprintf fmt "Tok.INT %a" print_string s -| "STRING", s -> fprintf fmt "Tok.STRING %a" print_string s -| "LEFTQMARK", _ -> fprintf fmt "Tok.LEFTQMARK" -| "BULLET", s -> fprintf fmt "Tok.BULLET %a" print_string s -| "EOI", _ -> fprintf fmt "Tok.EOI" +let print_tok fmt = +let print_pat fmt = print_opt fmt print_string in +function +| "", Some s -> fprintf fmt "Tok.PKEYWORD (%a)" print_string s +| "IDENT", s -> fprintf fmt "Tok.PIDENT (%a)" print_pat s +| "PATTERNIDENT", s -> fprintf fmt "Tok.PPATTERNIDENT (%a)" print_pat s +| "FIELD", s -> fprintf fmt "Tok.PFIELD (%a)" print_pat s +| "INT", s -> fprintf fmt "Tok.PINT (%a)" print_pat s +| "STRING", s -> fprintf fmt "Tok.PSTRING (%a)" print_pat s +| "LEFTQMARK", None -> fprintf fmt "Tok.PLEFTQMARK" +| "BULLET", s -> fprintf fmt "Tok.PBULLET (%a)" print_pat s +| "QUOTATION", Some s -> fprintf fmt "Tok.PQUOTATION %a" print_string s +| "EOI", None -> fprintf fmt "Tok.PEOI" | _ -> failwith "Tok.of_pattern: not a constructor" let rec print_prod fmt p = @@ -231,16 +240,16 @@ let rec print_prod fmt p = and print_extrule fmt (tkn, vars, body) = let tkn = List.rev tkn in - fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" print_symbols tkn print_fun (vars, body) + fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" (print_symbols ~norec:false) tkn print_fun (vars, body) -and print_symbols fmt = function +and print_symbols ~norec fmt = function | [] -> fprintf fmt "Extend.Stop" | tkn :: tkns -> - fprintf fmt "Extend.Next @[(%a,@ %a)@]" print_symbols tkns print_symbol tkn + let c = if norec then "Extend.NextNoRec" else "Extend.Next" in + fprintf fmt "%s @[(%a,@ %a)@]" c (print_symbols ~norec) tkns print_symbol tkn and print_symbol fmt tkn = match tkn with | SymbToken (t, s) -> - let s = match s with None -> "" | Some s -> s in fprintf fmt "(Extend.Atoken (%a))" print_tok (t, s) | SymbEntry (e, None) -> fprintf fmt "(Extend.Aentry %s)" e @@ -264,7 +273,7 @@ and print_symbol fmt tkn = match tkn with let pr fmt (r, body) = let (vars, tkn) = List.split r in let tkn = List.rev tkn in - fprintf fmt "Extend.Rules @[({ Extend.norec_rule = %a },@ (%a))@]" print_symbols tkn print_fun (vars, body) + fprintf fmt "Extend.Rules @[(%a,@ (%a))@]" (print_symbols ~norec:true) tkn print_fun (vars, body) in let pr fmt rules = print_list fmt pr rules in fprintf fmt "(Extend.Arules %a)" pr (List.rev rules) @@ -347,9 +356,18 @@ let print_atts_right fmt = function let nota = match atts with [_] -> "" | _ -> "Attributes.Notations." in fprintf fmt "(Attributes.parse %s%a atts)" nota aux atts +let print_body_wrapper fmt r = + match r.vernac_state with + | Some "proof" -> + fprintf fmt "let proof = (%a) ~pstate:st.Vernacstate.proof in { st with Vernacstate.proof }" print_code r.vernac_body + | None -> + fprintf fmt "let () = %a in st" print_code r.vernac_body + | Some x -> + fatal ("unsupported state specifier: " ^ x) + let print_body_fun fmt r = - fprintf fmt "let coqpp_body %a%a ~st = let () = %a in st in " - print_binders r.vernac_toks print_atts_left r.vernac_atts print_code r.vernac_body + fprintf fmt "let coqpp_body %a%a ~st = @[%a@] in " + print_binders r.vernac_toks print_atts_left r.vernac_atts print_body_wrapper r let print_body fmt r = fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" diff --git a/coqpp/coqpp_parse.mly b/coqpp/coqpp_parse.mly index abe52ab46b..43ba990f6a 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -65,7 +65,7 @@ let parse_user_entry s sep = %token VERNAC TACTIC GRAMMAR EXTEND END DECLARE PLUGIN DEPRECATED ARGUMENT %token RAW_PRINTED GLOB_PRINTED %token COMMAND CLASSIFIED PRINTED TYPED INTERPRETED GLOBALIZED SUBSTITUTED BY AS -%token HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR +%token BANGBRACKET HASHBRACKET LBRACKET RBRACKET PIPE ARROW FUN COMMA EQUAL STAR %token LPAREN RPAREN COLON SEMICOLON %token GLOBAL FIRST LAST BEFORE AFTER LEVEL LEFTA RIGHTA NONA %token EOF @@ -209,13 +209,14 @@ vernac_rules: ; vernac_rule: -| PIPE vernac_attributes_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE +| PIPE vernac_attributes_opt vernac_state_opt LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE { { vernac_atts = $2; - vernac_toks = $4; - vernac_depr = $6; - vernac_class= $7; - vernac_body = $9; + vernac_state= $3; + vernac_toks = $5; + vernac_depr = $7; + vernac_class= $8; + vernac_body = $10; } } ; @@ -235,6 +236,14 @@ vernac_attribute: | qualid_or_ident { ($1, $1) } ; +vernac_state_opt: +| { None } +| BANGBRACKET vernac_state RBRACKET { Some $2 } +; + +vernac_state: +| qualid_or_ident { $1 } + rule_deprecation: | { false } | DEPRECATED { true } diff --git a/dev/ci/ci-argosy.sh b/dev/ci/ci-argosy.sh new file mode 100755 index 0000000000..6137526bf4 --- /dev/null +++ b/dev/ci/ci-argosy.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +FORCE_GIT=1 +git_download argosy + +( cd "${CI_BUILD_DIR}/argosy" && git submodule update --init --recursive && make ) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index deeec3942d..0c89809ee9 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -24,9 +24,9 @@ ######################################################################## # UniMath ######################################################################## -: "${UniMath_CI_REF:=master}" -: "${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath}" -: "${UniMath_CI_ARCHIVEURL:=${UniMath_CI_GITURL}/archive}" +: "${unimath_CI_REF:=master}" +: "${unimath_CI_GITURL:=https://github.com/UniMath/UniMath}" +: "${unimath_CI_ARCHIVEURL:=${unimath_CI_GITURL}/archive}" ######################################################################## # Unicoq + Mtac2 @@ -104,15 +104,8 @@ ######################################################################## # Coquelicot ######################################################################## -# The URL for downloading a tgz snapshot of the master branch is -# https://scm.gforge.inria.fr/anonscm/gitweb?p=coquelicot/coquelicot.git;a=snapshot;h=refs/heads/master;sf=tgz -# See https://gforge.inria.fr/scm/browser.php?group_id=3599 -# Since this URL doesn't fit to our standard mechanism and since Coquelicot doesn't seem to change frequently, -# we use a fixed version, which has a download path which does fit to our standard mechanism. -# ATTENTION: The archive URL might depend on the version! -: "${Coquelicot_CI_REF:=coquelicot-3.0.2}" -: "${Coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" -: "${Coquelicot_CI_ARCHIVEURL:=https://gforge.inria.fr/frs/download.php/file/37523}" +: "${coquelicot_CI_REF:=master}" +: "${coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" ######################################################################## # CompCert @@ -296,3 +289,10 @@ : "${stdlib2_CI_REF:=master}" : "${stdlib2_CI_GITURL:=https://github.com/coq/stdlib2}" : "${stdlib2_CI_ARCHIVEURL:=${stdlib2_CI_GITURL}/archive}" + +######################################################################## +# argosy +######################################################################## +: "${argosy_CI_REF:=master}" +: "${argosy_CI_GITURL:=https://github.com/mit-pdos/argosy}" +: "${argosy_CI_ARCHIVEURL:=${argosy_CI_GITURL}/archive}" diff --git a/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 2d242d80a4..2ac78d3c2b 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make | iconv -t UTF-8 -c `#9767` ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 5d8817491d..33627fd8ef 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -6,6 +6,6 @@ ci_dir="$(dirname "$0")" install_ssreflect FORCE_GIT=1 -git_download Coquelicot +git_download coquelicot -( cd "${CI_BUILD_DIR}/Coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) +( cd "${CI_BUILD_DIR}/coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index a7644fee23..704e278a4b 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download UniMath +git_download unimath -( cd "${CI_BUILD_DIR}/UniMath" && make BUILD_COQ=no ) +( cd "${CI_BUILD_DIR}/unimath" && make BUILD_COQ=no ) diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 5f819f31f9..cc1931d13d 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -49,9 +49,9 @@ IF "%WINDOWS%" == "enabled_all_addons" ( -addon=compcert ^
-addon=extlib ^
-addon=quickchick ^
- -addon=coquelicot ^
-addon=vst ^
-addon=aactactics
+REM -addon=coquelicot ^
) ELSE (
SET "EXTRA_ADDONS= "
)
diff --git a/dev/ci/user-overlays/08829-proj-syntax-check.sh b/dev/ci/user-overlays/08829-proj-syntax-check.sh new file mode 100644 index 0000000000..c04621114f --- /dev/null +++ b/dev/ci/user-overlays/08829-proj-syntax-check.sh @@ -0,0 +1,5 @@ +if [ "$CI_PULL_REQUEST" = "8829" ] || [ "$CI_BRANCH" = "proj-syntax-check" ]; then + lambdaRust_CI_REF=proj-syntax-check + lambdaRust_CI_GITURL=https://github.com/SkySkimmer/lambda-rust + lambdaRust_CI_ARCHIVEURL=$lambdaRust_CI_GITURL/archive +fi diff --git a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh new file mode 100644 index 0000000000..c09d1b8929 --- /dev/null +++ b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh @@ -0,0 +1,30 @@ +if [ "$CI_PULL_REQUEST" = "9129" ] || [ "$CI_BRANCH" = "proof+no_global_partial" ]; then + + aac_tactics_CI_REF=proof+no_global_partial + aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics + + # coqhammer_CI_REF=proof+no_global_partial + # coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer + + elpi_CI_REF=proof+no_global_partial + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + equations_CI_REF=proof+no_global_partial + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + ltac2_CI_REF=proof+no_global_partial + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + # unicoq_CI_REF=proof+no_global_partial + # unicoq_CI_GITURL=https://github.com/ejgallego/unicoq + + mtac2_CI_REF=proof+no_global_partial + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + + paramcoq_CI_REF=proof+no_global_partial + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + quickchick_CI_REF=proof+no_global_partial + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/09733-gares-quotations.sh b/dev/ci/user-overlays/09733-gares-quotations.sh new file mode 100644 index 0000000000..b17454fc4c --- /dev/null +++ b/dev/ci/user-overlays/09733-gares-quotations.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9733" ] || [ "$CI_BRANCH" = "quotations" ]; then + + ltac2_CI_REF=quotations + ltac2_CI_GITURL=https://github.com/gares/ltac2 + +fi diff --git a/dev/ci/user-overlays/09815-token-type.sh b/dev/ci/user-overlays/09815-token-type.sh new file mode 100644 index 0000000000..4b49011de3 --- /dev/null +++ b/dev/ci/user-overlays/09815-token-type.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "9815" ] || [ "$CI_BRANCH" = "token-type" ]; then + ltac2_CI_REF=token-type + ltac2_CI_GITURL=https://github.com/proux01/ltac2 +fi diff --git a/dev/ci/user-overlays/09870-vbgl-recordops.sh b/dev/ci/user-overlays/09870-vbgl-recordops.sh new file mode 100644 index 0000000000..bb14a8c204 --- /dev/null +++ b/dev/ci/user-overlays/09870-vbgl-recordops.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9870" ] || [ "$CI_BRANCH" = "doc-canonical" ]; then + + elpi_CI_REF=pr-9870 + elpi_CI_GITURL=https://github.com/vbgl/coq-elpi + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index b1bfac8cc9..49251d61a1 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -22,7 +22,7 @@ If you want to build the standard libraries and plugins you should call `make -f Makefile.dune voboot`. It is usually enough to do that once per-session. -More helper targets are availabe in `Makefile.dune`, `make -f +More helper targets are available in `Makefile.dune`, `make -f Makefile.dune` will display some help. Dune places build artifacts in a separate directory `_build`; it will diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 8d78559c0d..c0a5b9095c 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -63,8 +63,8 @@ Typing constructions impacted coqchk versions: ? fixed in: master/trunk (679801, r13450, 23 Sep 2010, Glondu), v8.3 (309a53f2, r13449, 22 Sep 2010, Glondu), v8.2 (41ea5f08, r14263, 6 Jul 2011, Herbelin, backport) found by: Georgi Guninski - exploit: test-suite/bugs/closed/4294.v - GH issue number: #4294 + exploit: test-suite/failure/prop_set_proof_irrelevance.v + GH issue number: none? risk: ? Module system @@ -77,7 +77,7 @@ Module system impacted coqchk versions: ? fixed in: master/trunk (d4869e059, 2 Oct 2015, Sozeau), v8.4 (40350ef3b, 9 Sep 2015, Sozeau) found by: Dénès - exploit: test-suite/bugs/closed/4294.v + exploit: test-suite/bugs/closed/bug_4294.v GH issue number: #4294 risk: ? @@ -105,7 +105,7 @@ Universes impacted coqchk versions: ? fixed in: trunk/master/v8.4 (8082d1faf, 5 Oct 2011, Herbelin), V8.3pl3 (bb582bca2, 5 Oct 2011, Herbelin), v8.2 branch (3333e8d3, 5 Oct 2011, Herbelin), v8.1 branch (a8fc2027, 5 Oct 2011, Herbelin), found by: Barras - exploit: test-suite/failure/inductive4.v + exploit: test-suite/failure/inductive.v GH issue number: none risk: unlikely to be activated by chance @@ -141,7 +141,7 @@ Primitive projections impacted coqchk versions: ? fixed in: trunk/master/v8.5 (120053a50, 4 Mar 2016, Dénès) found by: Dénès exploiting bug #4588 - exploit: test-suite/bugs/closed/4588.v + exploit: test-suite/bugs/closed/bug_4588.v GH issue number: #4588 risk: ? @@ -167,7 +167,7 @@ Conversion machines impacted coqchk versions: none (no virtual machine in coqchk) fixed in: master/trunk/v8.5 (00894adf6/596a4a525, 26-39 Mar 2015, Grégoire), v8.4 (cd2101a39, 1 Apr 2015, Grégoire), v8.3 (a0c7fc05b, 1 Apr 2015, Grégoire), v8.2 (2c6189f61, 1 Apr 2015, Grégoire), v8.1 (bb877e5b5, 29 Nov 2015, Herbelin, backport) found by: Dénès, Pédrot - exploit: test-suite/failure/vm-bug4157.v + exploit: test-suite/bugs/closed/bug_4157.v GH issue number: #4157 risk: @@ -179,7 +179,7 @@ Conversion machines impacted coqchk versions: none (no virtual machine in coqchk) fixed in: master (c9f3a6cbe, 12 Feb 2018, PR#6713, Dénès), v8.7 (c058a4182, 15 Feb 2018, Zimmermann, backport), v8.6 (a2cc54c64, 21 Feb 2018, Herbelin, backport), v8.5 (d4d550d0f, 21 Feb 2018, Herbelin, backport) found by: Dénès - exploit: test-suite/bugs/closed/6677.v + exploit: test-suite/bugs/closed/bug_6677.v GH issue number: #6677 risk: @@ -203,7 +203,7 @@ Conversion machines impacted coqchk versions: none (no native computation in coqchk) fixed in: master/trunk/v8.6 (244d7a9aa, 19 May 2016, letouzey), v8.5 (088b3161c, 19 May 2016, letouzey), found by: Letouzey, Dénès - exploit: lost? + exploit: see commit message for 244d7a9aa GH issue number: ? risk: diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 4aa0f04964..f4786d9431 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/2923bd5d0669f1ec6ab03ddce052e9c5efb46d8f.tar.gz"; - sha256 = "16cn93rpxfql5idhigyjyhc013a3hwzyy2dl1xv7h2p78sk728vw"; + url = "https://github.com/NixOS/nixpkgs/archive/8471ab76242987b11afd4486b82888e1588f8307.tar.gz"; + sha256 = "06pp6b6x78jlinxifnphkbp79dx58jr990fkm4qziq0ay5klpxd7"; }) diff --git a/dev/shim/dune b/dev/shim/dune index 39b4ef492c..e307848292 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -7,7 +7,19 @@ (with-outputs-to coqtop-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \\$@") + (run chmod +x %{targets}))))) + +(rule + (targets coqc-prelude) + (deps + %{bin:coqc} + %{project_root}/theories/Init/Prelude.vo) + (action + (with-outputs-to coqc-prelude + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqc} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) (rule @@ -20,7 +32,7 @@ (with-outputs-to %{targets} (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) (rule @@ -36,5 +48,5 @@ (with-outputs-to coqide-prelude (progn (echo "#!/usr/bin/env bash\n") - (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \\$@") (run chmod +x %{targets}))))) diff --git a/dev/tools/backport-pr.sh b/dev/tools/backport-pr.sh index 9864fd4d69..1ec8251f66 100755 --- a/dev/tools/backport-pr.sh +++ b/dev/tools/backport-pr.sh @@ -30,13 +30,15 @@ while [[ $# -gt 0 ]]; do esac done -if ! git log master --grep "Merge PR #${PRNUM}" | grep "." > /dev/null; then +MASTER=origin/master + +if ! git log $MASTER --grep "Merge PR #$PRNUM" | grep "." > /dev/null; then echo "PR #${PRNUM} does not exist." exit 1 fi -SIGNATURE_STATUS=$(git log master --grep "Merge PR #${PRNUM}" --format="%G?") -git log master --grep "Merge PR #${PRNUM}" --format="%GG" +SIGNATURE_STATUS=$(git log $MASTER --grep "Merge PR #$PRNUM" --format="%G?") +git log $MASTER --grep "Merge PR #$PRNUM" --format="%GG" if [[ "$NO_SIGNATURE_CHECK" != "true" && "$SIGNATURE_STATUS" != "G" ]]; then echo read -p "Merge commit does not have a good (valid) signature. Bypass? [y/N] " -n 1 -r @@ -47,10 +49,18 @@ if [[ "$NO_SIGNATURE_CHECK" != "true" && "$SIGNATURE_STATUS" != "G" ]]; then fi BRANCH=backport-pr-${PRNUM} -RANGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%P" | sed 's/ /../') -MESSAGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%s" | sed 's/Merge/Backport/') +RANGE=$(git log $MASTER --grep "Merge PR #$PRNUM" --format="%P" | sed 's/ /../') +MESSAGE=$(git log $MASTER --grep "Merge PR #$PRNUM" --format="%s" | sed 's/Merge/Backport/') -if git checkout -b "${BRANCH}"; then +if [[ "$(git rev-parse --abbrev-ref HEAD)" == "$BRANCH" ]]; then + + if ! git cherry-pick --continue; then + echo "Please fix the conflicts, then relaunch the script." + exit 1 + fi + git checkout - + +elif git checkout -b "$BRANCH"; then if ! git cherry-pick -x "${RANGE}"; then if [[ "$NO_CONFLICTS" == "true" ]]; then @@ -61,12 +71,8 @@ if git checkout -b "${BRANCH}"; then git branch -d "$BRANCH" exit 1 fi - echo "Please fix the conflicts, then exit." - bash - while ! git cherry-pick --continue; do - echo "Please fix the conflicts, then exit." - bash - done + echo "Please fix the conflicts, then relaunch the script." + exit 1 fi git checkout - diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 499bbba37e..74be300134 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -60,19 +60,25 @@ let prrecarg = function str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]" let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) +let get_current_context () = + try Vernacstate.Proof_global.get_current_context () + with Vernacstate.Proof_global.NoCurrentProof -> + let env = Global.env() in + Evd.from_env env, env + (* term printers *) -let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma +let envpp pp = let sigma,env = get_current_context () in pp env sigma let rawdebug = ref false let ppevar evk = pp (Evar.print evk) let pr_constr t = - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_context () in Printer.pr_constr_env env sigma t let pr_econstr t = - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_context () in Printer.pr_econstr_env env sigma t let ppconstr x = pp (pr_constr x) let ppeconstr x = pp (pr_econstr x) -let ppconstr_expr x = let sigma,env = Pfedit.get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) +let ppconstr_expr x = let sigma,env = get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) @@ -500,7 +506,7 @@ let ppist ist = (* Vernac-level debugging commands *) let in_current_context f c = - let (evmap,sign) = Pfedit.get_current_context () in + let (evmap,sign) = get_current_context () in f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp5 diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 4df284d2d9..1d0aca1caf 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -145,10 +145,12 @@ END it gives an error message that is basically impossible to understand. *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| [ "Cmd9" ] -> - { let p = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in - let pprf = Proof.partial_proof p in - Feedback.msg_notice - (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } +| ![ proof ] [ "Cmd9" ] -> + { fun ~pstate -> + Option.iter (fun (pstate : Proof_global.t) -> + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in + Feedback.msg_notice + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf)) pstate; + pstate } END diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index e370d37fc4..23f8fbe888 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,5 +1,5 @@ (* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) -let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = +let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let sigma = Evd.minimize_universes sigma in let body = EConstr.to_constr sigma body in let tyopt = Option.map (EConstr.to_constr sigma) tyopt in @@ -13,13 +13,13 @@ let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let ubinders = Evd.universe_binders sigma in let ce = Declare.definition_entry ?types:tyopt ~univs body in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ident k ce ubinders imps ?hook_data + DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data let packed_declare_definition ~poly ident value_with_constraints = let body, ctx = value_with_constraints in let sigma = Evd.from_ctx ctx in let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ident k ~opaque:false sigma udecl body None []) + ignore (edeclare ~ontop:None ident k ~opaque:false sigma udecl body None []) (* But this definition cannot be undone by Reset ident *) diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index a9d894cab5..dd21ea09bd 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -92,7 +92,7 @@ and use the ``==`` notation on terms of this type. Derived Canonical Structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We know how to use ``== `` on base types, like ``nat``, ``bool``, ``Z``. Here we show +We know how to use ``==`` on base types, like ``nat``, ``bool``, ``Z``. Here we show how to deal with type constructors, i.e. how to make the following example work: diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index d15aacad44..d5523e8561 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -154,8 +154,10 @@ Declaring Coercions .. warn:: Ambiguous path. When the coercion :token:`qualid` is added to the inheritance graph, - invalid coercion paths are ignored; they are signaled by a warning - displaying these paths of the form :g:`[fâ‚;..;fâ‚™] : C >-> D`. + invalid coercion paths are ignored. The :cmd:`Coercion` command tries to check + that they are convertible with existing ones on the same classes. + The paths for which this check fails are displayed by a warning in the form + :g:`[fâ‚;..;fâ‚™] : C >-> D`. .. cmdv:: Local Coercion @qualid : @class >-> @class @@ -322,21 +324,8 @@ are also forgotten. Coercions and Modules --------------------- -.. flag:: Automatic Coercions Import - - Since |Coq| version 8.3, the coercions present in a module are activated - only when the module is explicitly imported. Formerly, the coercions - were activated as soon as the module was required, whether it was - imported or not. - - This option makes it possible to recover the behavior of the versions of - |Coq| prior to 8.3. - -.. warn:: Coercion used but not in scope: @qualid. If you want to use this coercion, please Import the module that contains it. - - This warning is emitted when typechecking relies on a coercion - contained in a module that has not been explicitely imported. It helps - migrating code and stop relying on the option above. +The coercions present in a module are activated only when the module is +explicitly imported. Examples -------- diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 20e4c6a3d6..3b350d5dc0 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -323,7 +323,7 @@ The syntax for adding a new ring is decidable :n:`@term` declares the ring as computational. The expression :n:`@term` is the correctness proof of an equality test ``?=!`` - (which hould be evaluable). Its type should be of the form + (which should be evaluable). Its type should be of the form ``forall x y, x ?=! y = true → x == y``. morphism :n:`@term` diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index e6a5b3972c..b069cf27f4 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -561,6 +561,8 @@ Settings .. flag:: Refine Instance Mode + .. deprecated:: 8.10 + This flag allows to switch the behavior of instance declarations made through the Instance command. @@ -573,18 +575,19 @@ Settings Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? {dfs | bfs}} depth +.. cmd:: Typeclasses eauto := {? debug} {? (dfs) | (bfs) } @num :name: Typeclasses eauto This command allows more global customization of the typeclass resolution tactic. The semantics of the options are: - + ``debug`` In debug mode, the trace of successfully applied tactics is - printed. This value can also be set with :flag:`Typeclasses Debug`. + + ``debug`` This sets the debug mode. In debug mode, the trace of + successfully applied tactics is printed. The debug mode can also + be set with :flag:`Typeclasses Debug`. - + ``dfs, bfs`` This sets the search strategy to depth-first search (the - default) or breadth-first search. This value can also be set with - :flag:`Typeclasses Iterative Deepening`. + + ``(dfs)``, ``(bfs)`` This sets the search strategy to depth-first + search (the default) or breadth-first search. The search strategy + can also be set with :flag:`Typeclasses Iterative Deepening`. - + ``depth`` This sets the depth limit of the search. This value can also be set with - :opt:`Typeclasses Depth`. + + :token:`num` This sets the depth limit of the search. The depth + limit can also be set with :opt:`Typeclasses Depth`. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 18cafd1f21..695dea222f 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1430,8 +1430,8 @@ with the same physical-to-logical translation and with an empty logical prefix. The command line option ``-R`` is a variant of ``-Q`` which has the strictly same behavior regarding loadpaths, but which also makes the corresponding ``.vo`` files available through their short names in a way -not unlike the ``Import`` command (see :ref:`here <import_qualid>`). For instance, ``-R`` `path` ``Lib`` -associates to the file path `path`\ ``/path/fOO/Bar/File.vo`` the logical name +not unlike the ``Import`` command (see :ref:`here <import_qualid>`). For instance, ``-R path Lib`` +associates to the file ``/path/fOO/Bar/File.vo`` the logical name ``Lib.fOO.Bar.File``, but allows this file to be accessed through the short names ``fOO.Bar.File,Bar.File`` and ``File``. If several files with identical base name are present in different subdirectories of a diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 52e3029b8f..0322b43694 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1071,6 +1071,16 @@ Proving a subgoal as a separate lemma It may be useful to generate lemmas minimal w.r.t. the assumptions they depend on. This can be obtained thanks to the option below. + .. warning:: + + The abstract tactic, while very useful, still has some known + limitations, see https://github.com/coq/coq/issues/9146 for more + details. Thus we recommend using it caution in some + "non-standard" contexts. In particular, ``abstract`` won't + properly work when used inside quotations ``ltac:(...)``, or + if used as part of typeclass resolution, it may produce wrong + terms when in universe polymorphic mode. + .. tacv:: abstract @expr using @ident Give explicitly the name of the auxiliary lemma. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 07215a0c7e..16b158c397 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -544,6 +544,10 @@ Requesting information ``<Your Tactic Text here>``. + .. deprecated:: 8.10 + + Please use a text editor. + .. cmdv:: Show Proof :name: Show Proof diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 7b395900e9..afb0239be4 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3912,6 +3912,8 @@ At Coq startup, only the core database is nonempty and can be used. environment, including those used for ``setoid_rewrite``, from the Classes directory. +:fset: internal database for the implementation of the ``FSets`` library. + You are advised not to put your own hints in the core database, but use one or several databases specific to your development. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index e5eb7eb4f5..1e201953b3 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1473,6 +1473,10 @@ Numeral notations :n:`@ident__2` to the number will be fully reduced, and universes of the resulting term will be refreshed. + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, and + primitive integers) will be considered for printing. + .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (warning after @num). When a literal larger than :token:`num` is parsed, a warning @@ -1618,6 +1622,10 @@ String notations :n:`@ident__2` to the string will be fully reduced, and universes of the resulting term will be refreshed. + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, and + primitive integers) will be considered for printing. + .. exn:: Cannot interpret this string as a value of type @type The string notation registered for :token:`type` does not support diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index b58148ffff..b25104ddb9 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -22,6 +22,7 @@ plugins/extraction/Extraction.v plugins/funind/FunInd.v plugins/funind/Recdef.v plugins/ltac/Ltac.v +plugins/micromega/DeclConstant.v plugins/micromega/Env.v plugins/micromega/EnvRing.v plugins/micromega/Fourier.v @@ -42,3 +42,5 @@ (name runtest) (package coqide-server) (deps test-suite/summary.log)) + +; (dirs (:standard _build_ci)) diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f46ddffd6e..c452c7b307 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -4,19 +4,19 @@ open Gramext open Format - -type ('a, 'b) eq = Refl : ('a, 'a) eq +open Util (* Functorial interface *) -module type GLexerType = sig type te val lexer : te Plexing.lexer end +module type GLexerType = Plexing.Lexer module type S = sig type te + type 'c pattern type parsable - val parsable : char Stream.t -> parsable - val tokens : string -> (string * int) list + val parsable : ?loc:Loc.t -> char Stream.t -> parsable + val tokens : string -> (string option * int) list module Entry : sig type 'a e @@ -27,29 +27,36 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ('self, 'a) ty_symbol - type ('self, 'f, 'r) ty_rule + type ty_norec = TyNoRec + type ty_mayrec = TyMayRec + type ('self, 'trec, 'a) ty_symbol + type ('self, 'trec, 'f, 'r) ty_rule + type 'a ty_rules type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol - val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + val s_nterm : 'a Entry.e -> ('self, ty_norec, 'a) ty_symbol + val s_nterml : 'a Entry.e -> string -> ('self, ty_norec, 'a) ty_symbol + val s_list0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list0sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_list1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list1sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_self : ('self, 'self) ty_symbol - val s_next : ('self, 'self) ty_symbol - val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol - val r_stop : ('self, 'r, 'r) ty_rule + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_opt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol + val s_self : ('self, ty_mayrec, 'self) ty_symbol + val s_next : ('self, ty_mayrec, 'self) ty_symbol + val s_token : 'c pattern -> ('self, ty_norec, 'c) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_rules list -> ('self, ty_norec, 'a) ty_symbol + val r_stop : ('self, ty_norec, 'r, 'r) ty_rule val r_next : - ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> - ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production + ('self, _, 'a, 'r) ty_rule -> ('self, _, 'b) ty_symbol -> + ('self, ty_mayrec, 'b -> 'a, 'r) ty_rule + val r_next_norec : + ('self, ty_norec, 'a, 'r) ty_rule -> ('self, ty_norec, 'b) ty_symbol -> + ('self, ty_norec, 'b -> 'a, 'r) ty_rule + val rules : (_, ty_norec, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_rules + val production : ('a, _, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig val clear_entry : 'a Entry.e -> unit @@ -59,7 +66,7 @@ module type S = (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit + val safe_delete_rule : 'a Entry.e -> ('a, _, 'r, 'f) ty_rule -> unit end (* Implementation *) @@ -68,15 +75,15 @@ module GMake (L : GLexerType) = struct type te = L.te +type 'c pattern = 'c L.pattern type 'a parser_t = L.te Stream.t -> 'a type grammar = - { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - glexer : L.te Plexing.lexer } + { gtokens : (string * string option, int ref) Hashtbl.t } let egram = - {gtokens = Hashtbl.create 301; glexer = L.lexer } + {gtokens = Hashtbl.create 301 } let tokens con = let list = ref [] in @@ -85,6 +92,17 @@ let tokens con = egram.gtokens; !list +type ty_norec = TyNoRec +type ty_mayrec = TyMayRec + +type ('a, 'b, 'c) ty_and_rec = +| NoRec2 : (ty_norec, ty_norec, ty_norec) ty_and_rec +| MayRec2 : ('a, 'b, ty_mayrec) ty_and_rec + +type ('a, 'b, 'c, 'd) ty_and_rec3 = +| NoRec3 : (ty_norec, ty_norec, ty_norec, ty_norec) ty_and_rec3 +| MayRec3 : ('a, 'b, 'c, ty_mayrec) ty_and_rec3 + type 'a ty_entry = { ename : string; mutable estart : int -> 'a parser_t; @@ -96,45 +114,50 @@ and 'a ty_desc = | Dlevels of 'a ty_level list | Dparser of 'a parser_t -and 'a ty_level = { +and 'a ty_level = Level : (_, _, 'a) ty_rec_level -> 'a ty_level + +and ('trecs, 'trecp, 'a) ty_rec_level = { assoc : g_assoc; lname : string option; - lsuffix : ('a, 'a -> Loc.t -> 'a) ty_tree; - lprefix : ('a, Loc.t -> 'a) ty_tree; + lsuffix : ('a, 'trecs, 'a -> Loc.t -> 'a) ty_tree; + lprefix : ('a, 'trecp, Loc.t -> 'a) ty_tree; } -and ('self, 'a) ty_symbol = -| Stoken : Plexing.pattern -> ('self, string) ty_symbol -| Slist1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol -| Slist1sep : ('self, 'a) ty_symbol * ('self, _) ty_symbol * bool -> ('self, 'a list) ty_symbol -| Slist0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol -| Slist0sep : ('self, 'a) ty_symbol * ('self, _) ty_symbol * bool -> ('self, 'a list) ty_symbol -| Sopt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol -| Sself : ('self, 'self) ty_symbol -| Snext : ('self, 'self) ty_symbol -| Snterm : 'a ty_entry -> ('self, 'a) ty_symbol -| Snterml : 'a ty_entry * string -> ('self, 'a) ty_symbol -| Stree : ('self, Loc.t -> 'a) ty_tree -> ('self, 'a) ty_symbol - -and ('self, _, 'r) ty_rule = -| TStop : ('self, 'r, 'r) ty_rule -| TNext : ('self, 'a, 'r) ty_rule * ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule - -and ('self, 'a) ty_tree = -| Node : ('self, 'b, 'a) ty_node -> ('self, 'a) ty_tree -| LocAct : 'k * 'k list -> ('self, 'k) ty_tree -| DeadEnd : ('self, 'k) ty_tree - -and ('self, 'a, 'r) ty_node = { - node : ('self, 'a) ty_symbol; - son : ('self, 'a -> 'r) ty_tree; - brother : ('self, 'r) ty_tree; +and ('self, 'trec, 'a) ty_symbol = +| Stoken : 'c pattern -> ('self, ty_norec, 'c) ty_symbol +| Slist1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol +| Slist1sep : ('self, 'trec, 'a) ty_symbol * ('self, ty_norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol +| Slist0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol +| Slist0sep : ('self, 'trec, 'a) ty_symbol * ('self, ty_norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol +| Sopt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol +| Sself : ('self, ty_mayrec, 'self) ty_symbol +| Snext : ('self, ty_mayrec, 'self) ty_symbol +| Snterm : 'a ty_entry -> ('self, ty_norec, 'a) ty_symbol +| Snterml : 'a ty_entry * string -> ('self, ty_norec, 'a) ty_symbol +| Stree : ('self, 'trec, Loc.t -> 'a) ty_tree -> ('self, 'trec, 'a) ty_symbol + +and ('self, _, _, 'r) ty_rule = +| TStop : ('self, ty_norec, 'r, 'r) ty_rule +| TNext : ('trr, 'trs, 'tr) ty_and_rec * ('self, 'trr, 'a, 'r) ty_rule * ('self, 'trs, 'b) ty_symbol -> ('self, 'tr, 'b -> 'a, 'r) ty_rule + +and ('self, 'trec, 'a) ty_tree = +| Node : ('trn, 'trs, 'trb, 'tr) ty_and_rec3 * ('self, 'trn, 'trs, 'trb, 'b, 'a) ty_node -> ('self, 'tr, 'a) ty_tree +| LocAct : 'k * 'k list -> ('self, ty_norec, 'k) ty_tree +| DeadEnd : ('self, ty_norec, 'k) ty_tree + +and ('self, 'trec, 'trecs, 'trecb, 'a, 'r) ty_node = { + node : ('self, 'trec, 'a) ty_symbol; + son : ('self, 'trecs, 'a -> 'r) ty_tree; + brother : ('self, 'trecb, 'r) ty_tree; } +type 'a ty_rules = +| TRules : (_, ty_norec, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_rules + type 'a ty_production = -| TProd : ('a, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_production +| TProd : ('a, _, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_production -let rec derive_eps : type s a. (s, a) ty_symbol -> bool = +let rec derive_eps : type s r a. (s, r, a) ty_symbol -> bool = function Slist0 _ -> true | Slist0sep (_, _, _) -> true @@ -142,14 +165,14 @@ let rec derive_eps : type s a. (s, a) ty_symbol -> bool = | Stree t -> tree_derive_eps t | Slist1 _ -> false | Slist1sep (_, _, _) -> false - | Snterm _ | Snterml (_, _) -> false + | Snterm _ -> false | Snterml (_, _) -> false | Snext -> false | Sself -> false | Stoken _ -> false -and tree_derive_eps : type s a. (s, a) ty_tree -> bool = +and tree_derive_eps : type s tr a. (s, tr, a) ty_tree -> bool = function LocAct (_, _) -> true - | Node {node = s; brother = bro; son = son} -> + | Node (_, {node = s; brother = bro; son = son}) -> derive_eps s && tree_derive_eps son || tree_derive_eps bro | DeadEnd -> false @@ -158,7 +181,7 @@ let eq_entry : type a1 a2. a1 ty_entry -> a2 ty_entry -> (a1, a2) eq option = fu if (Obj.magic e1) == (Obj.magic e2) then Some (Obj.magic Refl) else None -let rec eq_symbol : type s a1 a2. (s, a1) ty_symbol -> (s, a2) ty_symbol -> (a1, a2) eq option = fun s1 s2 -> +let rec eq_symbol : type s r1 r2 a1 a2. (s, r1, a1) ty_symbol -> (s, r2, a2) ty_symbol -> (a1, a2) eq option = fun s1 s2 -> match s1, s2 with Snterm e1, Snterm e2 -> eq_entry e1 e2 | Snterml (e1, l1), Snterml (e2, l2) -> @@ -188,23 +211,42 @@ let rec eq_symbol : type s a1 a2. (s, a1) ty_symbol -> (s, a2) ty_symbol -> (a1, | Stree _, Stree _ -> None | Sself, Sself -> Some Refl | Snext, Snext -> Some Refl - | Stoken p1, Stoken p2 -> if p1 = p2 then Some Refl else None + | Stoken p1, Stoken p2 -> L.tok_pattern_eq p1 p2 | _ -> None -let is_before : type s1 s2 a1 a2. (s1, a1) ty_symbol -> (s2, a2) ty_symbol -> bool = fun s1 s2 -> +let is_before : type s1 s2 r1 r2 a1 a2. (s1, r1, a1) ty_symbol -> (s2, r2, a2) ty_symbol -> bool = fun s1 s2 -> match s1, s2 with - Stoken ("ANY", _), _ -> false - | _, Stoken ("ANY", _) -> true - | Stoken (_, s), Stoken (_, "") when s <> "" -> true - | Stoken _, Stoken _ -> false + | Stoken p1, Stoken p2 -> + snd (L.tok_pattern_strings p1) <> None + && snd (L.tok_pattern_strings p2) = None | Stoken _, _ -> true | _ -> false (** Ancilliary datatypes *) -type ('self, _) ty_symbols = -| TNil : ('self, unit) ty_symbols -| TCns : ('self, 'a) ty_symbol * ('self, 'b) ty_symbols -> ('self, 'a * 'b) ty_symbols +type 'a ty_rec = MayRec : ty_mayrec ty_rec | NoRec : ty_norec ty_rec + +type ('a, 'b, 'c) ty_and_ex = +| NR00 : (ty_mayrec, ty_mayrec, ty_mayrec) ty_and_ex +| NR01 : (ty_mayrec, ty_norec, ty_mayrec) ty_and_ex +| NR10 : (ty_norec, ty_mayrec, ty_mayrec) ty_and_ex +| NR11 : (ty_norec, ty_norec, ty_norec) ty_and_ex + +type ('a, 'b) ty_mayrec_and_ex = +| MayRecNR : ('a, 'b, _) ty_and_ex -> ('a, 'b) ty_mayrec_and_ex + +type ('s, 'a) ty_mayrec_symbol = +| MayRecSymbol : ('s, _, 'a) ty_symbol -> ('s, 'a) ty_mayrec_symbol + +type ('s, 'a) ty_mayrec_tree = +| MayRecTree : ('s, 'tr, 'a) ty_tree -> ('s, 'a) ty_mayrec_tree + +type ('s, 'a, 'r) ty_mayrec_rule = +| MayRecRule : ('s, _, 'a, 'r) ty_rule -> ('s, 'a, 'r) ty_mayrec_rule + +type ('self, 'trec, _) ty_symbols = +| TNil : ('self, ty_norec, unit) ty_symbols +| TCns : ('trh, 'trt, 'tr) ty_and_rec * ('self, 'trh, 'a) ty_symbol * ('self, 'trt, 'b) ty_symbols -> ('self, 'tr, 'a * 'b) ty_symbols (** ('i, 'p, 'f, 'r) rel_prod0 ~ ∃ α₠... αₙ. @@ -217,99 +259,196 @@ type ('i, _, 'f, _) rel_prod0 = type ('p, 'k, 'r) rel_prod = (unit, 'p, 'k, 'r) rel_prod0 -type ('s, 'i, 'k, 'r) any_symbols = -| AnyS : ('s, 'p) ty_symbols * ('i, 'p, 'k, 'r) rel_prod0 -> ('s, 'i, 'k, 'r) any_symbols - -(** FIXME *) -let rec symbols : type s p k r. (s, p) ty_symbols -> (s, k, r) ty_rule -> (s, unit, k, r) any_symbols = - fun accu r -> match r with - | TStop -> AnyS (Obj.magic accu, Rel0) - | TNext (r, s) -> - let AnyS (r, pf) = symbols (TCns (s, accu)) r in - AnyS (Obj.magic r, RelS (Obj.magic pf)) - -let get_symbols : type s k r. (s, k, r) ty_rule -> (s, unit, k, r) any_symbols = - fun r -> symbols TNil r - -let insert_tree (type s p k a) ~warning entry_name (gsymbols : (s, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, a) ty_tree) = - let rec insert : type p f k. (s, p) ty_symbols -> (p, k, f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree = - fun symbols pf tree action -> +type ('s, 'tr, 'i, 'k, 'r) any_symbols = +| AnyS : ('s, 'tr, 'p) ty_symbols * ('i, 'p, 'k, 'r) rel_prod0 -> ('s, 'tr, 'i, 'k, 'r) any_symbols + +type ('s, 'tr, 'k, 'r) ty_belast_rule = +| Belast : ('trr, 'trs, 'tr) ty_and_rec * ('s, 'trr, 'k, 'a -> 'r) ty_rule * ('s, 'trs, 'a) ty_symbol -> ('s, 'tr, 'k, 'r) ty_belast_rule + +(* unfortunately, this is quadratic, but ty_rules aren't too long + * (99% of the time of length less or equal 10 and maximum is 22 + * when compiling Coq and its standard library) *) +let rec get_symbols : type s trec k r. (s, trec, k, r) ty_rule -> (s, trec, unit, k, r) any_symbols = + let rec belast_rule : type s trr trs tr a k r. (trr, trs, tr) ty_and_rec -> (s, trr, k, r) ty_rule -> (s, trs, a) ty_symbol -> (s, tr, a -> k, r) ty_belast_rule = + fun ar r s -> match ar, r with + | NoRec2, TStop -> Belast (NoRec2, TStop, s) + | MayRec2, TStop -> Belast (MayRec2, TStop, s) + | NoRec2, TNext (NoRec2, r, s') -> + let Belast (NoRec2, r, s') = belast_rule NoRec2 r s' in + Belast (NoRec2, TNext (NoRec2, r, s), s') + | MayRec2, TNext (_, r, s') -> + let Belast (_, r, s') = belast_rule MayRec2 r s' in + Belast (MayRec2, TNext (MayRec2, r, s), s') in + function + | TStop -> AnyS (TNil, Rel0) + | TNext (MayRec2, r, s) -> + let Belast (MayRec2, r, s) = belast_rule MayRec2 r s in + let AnyS (r, pf) = get_symbols r in + AnyS (TCns (MayRec2, s, r), RelS pf) + | TNext (NoRec2, r, s) -> + let Belast (NoRec2, r, s) = belast_rule NoRec2 r s in + let AnyS (r, pf) = get_symbols r in + AnyS (TCns (NoRec2, s, r), RelS pf) + +let get_rec_symbols (type s tr p) (s : (s, tr, p) ty_symbols) : tr ty_rec = + match s with TCns (MayRec2, _, _) -> MayRec + | TCns (NoRec2, _, _) -> NoRec | TNil -> NoRec + +let get_rec_tree (type s tr f) (s : (s, tr, f) ty_tree) : tr ty_rec = + match s with Node (MayRec3, _) -> MayRec + | Node (NoRec3, _) -> NoRec | LocAct _ -> NoRec | DeadEnd -> NoRec + +let and_symbols_tree (type s trs trt p f) (s : (s, trs, p) ty_symbols) (t : (s, trt, f) ty_tree) : (trs, trt) ty_mayrec_and_ex = + match get_rec_symbols s, get_rec_tree t with + | MayRec, MayRec -> MayRecNR NR00 | MayRec, NoRec -> MayRecNR NR01 + | NoRec, MayRec -> MayRecNR NR10 | NoRec, NoRec -> MayRecNR NR11 + +let and_and_tree (type s tr' trt tr trn trs trb f) (ar : (tr', trt, tr) ty_and_rec) (arn : (trn, trs, trb, trt) ty_and_rec3) (t : (s, trb, f) ty_tree) : (tr', trb, tr) ty_and_rec = + match ar, arn, get_rec_tree t with + | MayRec2, _, MayRec -> MayRec2 | MayRec2, _, NoRec -> MayRec2 + | NoRec2, NoRec3, NoRec -> NoRec2 + +let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, tr) ty_and_ex) (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, tr, a) ty_tree = + let rec insert : type trs trt tr p f k. (trs, trt, tr) ty_and_ex -> (s, trs, p) ty_symbols -> (p, k, f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = + fun ar symbols pf tree action -> match symbols, pf with - TCns (s, sl), RelS pf -> insert_in_tree s sl pf tree action + TCns (ars, s, sl), RelS pf -> insert_in_tree ar ars s sl pf tree action | TNil, Rel0 -> - match tree with - Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert TNil Rel0 bro action} - | LocAct (old_action, action_list) -> + let node (type tb) ({node = s; son = son; brother = bro} : (_, _, _, tb, _, _) ty_node) = + let ar : (ty_norec, tb, tb) ty_and_ex = + match get_rec_tree bro with MayRec -> NR10 | NoRec -> NR11 in + {node = s; son = son; brother = insert ar TNil Rel0 bro action} in + match ar, tree with + | NR10, Node (_, n) -> Node (MayRec3, node n) + | NR11, Node (NoRec3, n) -> Node (NoRec3, node n) + | NR11, LocAct (old_action, action_list) -> begin match warning with | None -> () | Some warn_fn -> let msg = "<W> Grammar extension: " ^ - (if entry_name <> "" then "" else "in ["^entry_name^"%s], ") ^ + (if entry_name = "" then "" else "in ["^entry_name^"%s], ") ^ "some rule has been masked" in warn_fn msg end; LocAct (action, old_action :: action_list) - | DeadEnd -> LocAct (action, []) - and insert_in_tree : type a p f k. (s, a) ty_symbol -> (s, p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree = - fun s sl pf tree action -> - match try_insert s sl pf tree action with + | NR11, DeadEnd -> LocAct (action, []) + and insert_in_tree : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_ex -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = + fun ar ars s sl pf tree action -> + let ar : (trs'', trt, tr) ty_and_rec = match ar with NR11 -> NoRec2 + | NR00 -> MayRec2 | NR01 -> MayRec2 | NR10 -> MayRec2 in + match try_insert ar ars s sl pf tree action with Some t -> t - | None -> Node {node = s; son = insert sl pf DeadEnd action; brother = tree} - and try_insert : type a p f k. (s, a) ty_symbol -> (s, p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, f) ty_tree -> k -> (s, f) ty_tree option = - fun s sl pf tree action -> + | None -> + let node ar = + {node = s; son = insert ar sl pf DeadEnd action; brother = tree} in + match ar, ars, get_rec_symbols sl with + | MayRec2, MayRec2, MayRec -> Node (MayRec3, node NR01) + | MayRec2, _, NoRec -> Node (MayRec3, node NR11) + | NoRec2, NoRec2, NoRec -> Node (NoRec3, node NR11) + and try_insert : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_rec -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree option = + fun ar ars s sl pf tree action -> match tree with - Node {node = s1; son = son; brother = bro} -> + Node (arn, {node = s1; son = son; brother = bro}) -> begin match eq_symbol s s1 with | Some Refl -> - let t = Node {node = s1; son = insert sl pf son action; brother = bro} in - Some t + let MayRecNR arss = and_symbols_tree sl son in + let son = insert arss sl pf son action in + let node = {node = s1; son = son; brother = bro} in + begin match ar, ars, arn, arss with + | MayRec2, _, _, _ -> Some (Node (MayRec3, node)) + | NoRec2, NoRec2, NoRec3, NR11 -> Some (Node (NoRec3, node)) end | None -> + let ar' = and_and_tree ar arn bro in if is_before s1 s || derive_eps s && not (derive_eps s1) then let bro = - match try_insert s sl pf bro action with + match try_insert ar' ars s sl pf bro action with Some bro -> bro - | None -> Node {node = s; son = insert sl pf DeadEnd action; brother = bro} + | None -> + let MayRecNR arss = and_symbols_tree sl DeadEnd in + let son = insert arss sl pf DeadEnd action in + let node = {node = s; son = son; brother = bro} in + match ar, ars, arn, arss with + | MayRec2, _, _, _ -> Node (MayRec3, node) + | NoRec2, NoRec2, NoRec3, NR11 -> Node (NoRec3, node) in - let t = Node {node = s1; son = son; brother = bro} in Some t + let node = {node = s1; son = son; brother = bro} in + match ar, arn with + | MayRec2, _ -> Some (Node (MayRec3, node)) + | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) else - begin match try_insert s sl pf bro action with + match try_insert ar' ars s sl pf bro action with Some bro -> - let t = Node {node = s1; son = son; brother = bro} in Some t + let node = {node = s1; son = son; brother = bro} in + begin match ar, arn with + | MayRec2, _ -> Some (Node (MayRec3, node)) + | NoRec2, NoRec3 -> Some (Node (NoRec3, node)) end | None -> None - end end - | LocAct (_, _) | DeadEnd -> None + | LocAct (_, _) -> None | DeadEnd -> None in - insert gsymbols pf tree action + insert ar gsymbols pf tree action -let srules (type self a) ~warning (rl : a ty_production list) = +let insert_tree_norec (type s p k a) ~warning entry_name (gsymbols : (s, ty_norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, ty_norec, a) ty_tree) : (s, ty_norec, a) ty_tree = + insert_tree ~warning entry_name NR11 gsymbols pf action tree + +let insert_tree (type s trs trt p k a) ~warning entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = + let MayRecNR ar = and_symbols_tree gsymbols tree in + MayRecTree (insert_tree ~warning entry_name ar gsymbols pf action tree) + +let srules (type self a) ~warning (rl : a ty_rules list) : (self, ty_norec, a) ty_symbol = + let rec retype_tree : type s a. (s, ty_norec, a) ty_tree -> (self, ty_norec, a) ty_tree = + function + | Node (NoRec3, {node = s; son = son; brother = bro}) -> + Node (NoRec3, {node = retype_symbol s; son = retype_tree son; brother = retype_tree bro}) + | LocAct (k, kl) -> LocAct (k, kl) + | DeadEnd -> DeadEnd + and retype_symbol : type s a. (s, ty_norec, a) ty_symbol -> (self, ty_norec, a) ty_symbol = + function + | Stoken p -> Stoken p + | Slist1 s -> Slist1 (retype_symbol s) + | Slist1sep (s, sep, b) -> Slist1sep (retype_symbol s, retype_symbol sep, b) + | Slist0 s -> Slist0 (retype_symbol s) + | Slist0sep (s, sep, b) -> Slist0sep (retype_symbol s, retype_symbol sep, b) + | Sopt s -> Sopt (retype_symbol s) + | Snterm e -> Snterm e + | Snterml (e, l) -> Snterml (e, l) + | Stree t -> Stree (retype_tree t) in + let rec retype_rule : type s k r. (s, ty_norec, k, r) ty_rule -> (self, ty_norec, k, r) ty_rule = + function + | TStop -> TStop + | TNext (NoRec2, r, s) -> TNext (NoRec2, retype_rule r, retype_symbol s) in let t = List.fold_left - (fun tree (TProd (symbols, action)) -> + (fun tree (TRules (symbols, action)) -> + let symbols = retype_rule symbols in let AnyS (symbols, pf) = get_symbols symbols in - insert_tree ~warning "" symbols pf action tree) + insert_tree_norec ~warning "" symbols pf action tree) DeadEnd rl in - (* FIXME: use an universal self type to ensure well-typedness *) - (Obj.magic (Stree t) : (self, a) ty_symbol) + Stree t -let is_level_labelled n lev = +let is_level_labelled n (Level lev) = match lev.lname with Some n1 -> n = n1 | None -> false -let insert_level (type s p k) ~warning entry_name (symbols : (s, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = +let insert_level (type s tr p k) ~warning entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = match symbols with - | TCns (Sself, symbols) -> + | TCns (_, Sself, symbols) -> + let Level slev = slev in let RelS pf = pf in + let MayRecTree lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix in + Level {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix; + lsuffix = lsuffix; lprefix = slev.lprefix} | _ -> + let Level slev = slev in + let MayRecTree lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix in + Level {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix} + lprefix = lprefix} let empty_lev lname assoc = let assoc = @@ -317,9 +456,10 @@ let empty_lev lname assoc = Some a -> a | None -> LeftA in + Level {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -let change_lev ~warning lev n lname assoc = +let change_lev ~warning (Level lev) n lname assoc = let a = match assoc with None -> lev.assoc @@ -343,6 +483,7 @@ let change_lev ~warning lev n lname assoc = end; | None -> () end; + Level {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} let get_level ~warning entry position levs = @@ -396,21 +537,24 @@ let get_level ~warning entry position levs = lev :: levs -> [], change_lev ~warning lev "<top>", levs | [] -> [], empty_lev, [] -let change_to_self0 (type s) (type a) (entry : s ty_entry) : (s, a) ty_symbol -> (s, a) ty_symbol = +let change_to_self0 (type s) (type trec) (type a) (entry : s ty_entry) : (s, trec, a) ty_symbol -> (s, a) ty_mayrec_symbol = function | Snterm e -> begin match eq_entry e entry with - | None -> Snterm e - | Some Refl -> Sself + | None -> MayRecSymbol (Snterm e) + | Some Refl -> MayRecSymbol (Sself) end - | x -> x + | x -> MayRecSymbol x -let rec change_to_self : type s a r. s ty_entry -> (s, a, r) ty_rule -> (s, a, r) ty_rule = fun e r -> match r with -| TStop -> TStop -| TNext (r, t) -> TNext (change_to_self e r, change_to_self0 e t) +let rec change_to_self : type s trec a r. s ty_entry -> (s, trec, a, r) ty_rule -> (s, a, r) ty_mayrec_rule = fun e r -> match r with +| TStop -> MayRecRule TStop +| TNext (_, r, t) -> + let MayRecRule r = change_to_self e r in + let MayRecSymbol t = change_to_self0 e t in + MayRecRule (TNext (MayRec2, r, t)) let insert_tokens gram symbols = - let rec insert : type s a. (s, a) ty_symbol -> unit = + let rec insert : type s trec a. (s, trec, a) ty_symbol -> unit = function | Slist0 s -> insert s | Slist1 s -> insert s @@ -418,25 +562,25 @@ let insert_tokens gram symbols = | Slist1sep (s, t, _) -> insert s; insert t | Sopt s -> insert s | Stree t -> tinsert t - | Stoken ("ANY", _) -> () | Stoken tok -> - gram.glexer.Plexing.tok_using tok; + L.tok_using tok; let r = + let tok = L.tok_pattern_strings tok in try Hashtbl.find gram.gtokens tok with Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r in incr r - | Snterm _ | Snterml (_, _) -> () + | Snterm _ -> () | Snterml (_, _) -> () | Snext -> () | Sself -> () - and tinsert : type s a. (s, a) ty_tree -> unit = + and tinsert : type s tr a. (s, tr, a) ty_tree -> unit = function - Node {node = s; brother = bro; son = son} -> + Node (_, {node = s; brother = bro; son = son}) -> insert s; tinsert bro; tinsert son - | LocAct (_, _) | DeadEnd -> () - and linsert : type s p. (s, p) ty_symbols -> unit = function + | LocAct (_, _) -> () | DeadEnd -> () + and linsert : type s tr p. (s, tr, p) ty_symbols -> unit = function | TNil -> () - | TCns (s, r) -> insert s; linsert r + | TCns (_, s, r) -> insert s; linsert r in linsert symbols @@ -460,7 +604,7 @@ let levels_of_rules ~warning entry position rules = let lev = List.fold_left (fun lev (TProd (symbols, action)) -> - let symbols = change_to_self entry symbols in + let MayRecRule symbols = change_to_self entry symbols in let AnyS (symbols, pf) = get_symbols symbols in insert_tokens egram symbols; insert_level ~warning entry.ename symbols pf action lev) @@ -472,7 +616,7 @@ let levels_of_rules ~warning entry position rules = levs1 @ List.rev levs @ levs2 let logically_eq_symbols entry = - let rec eq_symbols : type s1 s2 a1 a2. (s1, a1) ty_symbol -> (s2, a2) ty_symbol -> bool = fun s1 s2 -> + let rec eq_symbols : type s1 s2 trec1 trec2 a1 a2. (s1, trec1, a1) ty_symbol -> (s2, trec2, a2) ty_symbol -> bool = fun s1 s2 -> match s1, s2 with Snterm e1, Snterm e2 -> e1.ename = e2.ename | Snterm e1, Sself -> e1.ename = entry.ename @@ -486,16 +630,19 @@ let logically_eq_symbols entry = eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2 | Sopt s1, Sopt s2 -> eq_symbols s1 s2 | Stree t1, Stree t2 -> eq_trees t1 t2 - | Stoken p1, Stoken p2 -> p1 = p2 + | Stoken p1, Stoken p2 -> L.tok_pattern_eq p1 p2 <> None | Sself, Sself -> true | Snext, Snext -> true | _ -> false - and eq_trees : type s1 s2 a1 a2. (s1, a1) ty_tree -> (s2, a2) ty_tree -> bool = fun t1 t2 -> + and eq_trees : type s1 s2 tr1 tr2 a1 a2. (s1, tr1, a1) ty_tree -> (s2, tr2, a2) ty_tree -> bool = fun t1 t2 -> match t1, t2 with - Node n1, Node n2 -> + Node (_, n1), Node (_, n2) -> eq_symbols n1.node n2.node && eq_trees n1.son n2.son && eq_trees n1.brother n2.brother - | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true + | LocAct _, LocAct _ -> true + | LocAct _, DeadEnd -> true + | DeadEnd, LocAct _ -> true + | DeadEnd, DeadEnd -> true | _ -> false in eq_symbols @@ -509,55 +656,56 @@ let logically_eq_symbols entry = [None] if failure *) type 's ex_symbols = -| ExS : ('s, 'p) ty_symbols -> 's ex_symbols +| ExS : ('s, 'tr, 'p) ty_symbols -> 's ex_symbols let delete_rule_in_tree entry = let rec delete_in_tree : - type s p r. (s, p) ty_symbols -> (s, r) ty_tree -> (s ex_symbols option * (s, r) ty_tree) option = + type s tr tr' p r. (s, tr, p) ty_symbols -> (s, tr', r) ty_tree -> (s ex_symbols option * (s, r) ty_mayrec_tree) option = fun symbols tree -> match symbols, tree with - | TCns (s, sl), Node n -> + | TCns (_, s, sl), Node (_, n) -> if logically_eq_symbols entry s n.node then delete_son sl n else begin match delete_in_tree symbols n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) + Some (dsl, MayRecTree t) -> + Some (dsl, MayRecTree (Node (MayRec3, {node = n.node; son = n.son; brother = t}))) | None -> None end - | TCns (s, sl), _ -> None - | TNil, Node n -> + | TCns (_, s, sl), _ -> None + | TNil, Node (_, n) -> begin match delete_in_tree TNil n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) + Some (dsl, MayRecTree t) -> + Some (dsl, MayRecTree (Node (MayRec3, {node = n.node; son = n.son; brother = t}))) | None -> None end | TNil, DeadEnd -> None - | TNil, LocAct (_, []) -> Some (Some (ExS TNil), DeadEnd) - | TNil, LocAct (_, action :: list) -> Some (None, LocAct (action, list)) + | TNil, LocAct (_, []) -> Some (Some (ExS TNil), MayRecTree DeadEnd) + | TNil, LocAct (_, action :: list) -> Some (None, MayRecTree (LocAct (action, list))) and delete_son : - type s p a r. (s, p) ty_symbols -> (s, a, r) ty_node -> (s ex_symbols option * (s, r) ty_tree) option = + type s p tr trn trs trb a r. (s, tr, p) ty_symbols -> (s, trn, trs, trb, a, r) ty_node -> (s ex_symbols option * (s, r) ty_mayrec_tree) option = fun sl n -> match delete_in_tree sl n.son with - Some (Some (ExS dsl), DeadEnd) -> Some (Some (ExS (TCns (n.node, dsl))), n.brother) - | Some (Some (ExS dsl), t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some (ExS (TCns (n.node, dsl))), t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) + Some (Some (ExS dsl), MayRecTree DeadEnd) -> Some (Some (ExS (TCns (MayRec2, n.node, dsl))), MayRecTree n.brother) + | Some (Some (ExS dsl), MayRecTree t) -> + let t = Node (MayRec3, {node = n.node; son = t; brother = n.brother}) in + Some (Some (ExS (TCns (MayRec2, n.node, dsl))), MayRecTree t) + | Some (None, MayRecTree t) -> + let t = Node (MayRec3, {node = n.node; son = t; brother = n.brother}) in + Some (None, MayRecTree t) | None -> None in delete_in_tree -let rec decr_keyw_use : type s a. _ -> (s, a) ty_symbol -> unit = fun gram -> +let rec decr_keyw_use : type s tr a. _ -> (s, tr, a) ty_symbol -> unit = fun gram -> function Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in + let tok' = L.tok_pattern_strings tok in + let r = Hashtbl.find gram.gtokens tok' in decr r; if !r == 0 then begin - Hashtbl.remove gram.gtokens tok; - gram.glexer.Plexing.tok_removing tok + Hashtbl.remove gram.gtokens tok'; + L.tok_removing tok end | Slist0 s -> decr_keyw_use gram s | Slist1 s -> decr_keyw_use gram s @@ -567,69 +715,71 @@ let rec decr_keyw_use : type s a. _ -> (s, a) ty_symbol -> unit = fun gram -> | Stree t -> decr_keyw_use_in_tree gram t | Sself -> () | Snext -> () - | Snterm _ | Snterml (_, _) -> () -and decr_keyw_use_in_tree : type s a. _ -> (s, a) ty_tree -> unit = fun gram -> + | Snterm _ -> () | Snterml (_, _) -> () +and decr_keyw_use_in_tree : type s tr a. _ -> (s, tr, a) ty_tree -> unit = fun gram -> function - DeadEnd | LocAct (_, _) -> () - | Node n -> + DeadEnd -> () | LocAct (_, _) -> () + | Node (_, n) -> decr_keyw_use gram n.node; decr_keyw_use_in_tree gram n.son; decr_keyw_use_in_tree gram n.brother -and decr_keyw_use_in_list : type s p. _ -> (s, p) ty_symbols -> unit = fun gram -> +and decr_keyw_use_in_list : type s tr p. _ -> (s, tr, p) ty_symbols -> unit = fun gram -> function | TNil -> () - | TCns (s, l) -> decr_keyw_use gram s; decr_keyw_use_in_list gram l + | TCns (_, s, l) -> decr_keyw_use gram s; decr_keyw_use_in_list gram l let rec delete_rule_in_suffix entry symbols = function - lev :: levs -> + Level lev :: levs -> begin match delete_rule_in_tree entry symbols lev.lsuffix with - Some (dsl, t) -> + Some (dsl, MayRecTree t) -> begin match dsl with Some (ExS dsl) -> decr_keyw_use_in_list egram dsl | None -> () end; - begin match t with - DeadEnd when lev.lprefix == DeadEnd -> levs + begin match t, lev.lprefix with + DeadEnd, DeadEnd -> levs | _ -> let lev = {assoc = lev.assoc; lname = lev.lname; lsuffix = t; lprefix = lev.lprefix} in - lev :: levs + Level lev :: levs end | None -> - let levs = delete_rule_in_suffix entry symbols levs in lev :: levs + let levs = delete_rule_in_suffix entry symbols levs in + Level lev :: levs end | [] -> raise Not_found let rec delete_rule_in_prefix entry symbols = function - lev :: levs -> + Level lev :: levs -> begin match delete_rule_in_tree entry symbols lev.lprefix with - Some (dsl, t) -> + Some (dsl, MayRecTree t) -> begin match dsl with Some (ExS dsl) -> decr_keyw_use_in_list egram dsl | None -> () end; - begin match t with - DeadEnd when lev.lsuffix == DeadEnd -> levs + begin match t, lev.lsuffix with + DeadEnd, DeadEnd -> levs | _ -> let lev = {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = t} in - lev :: levs + Level lev :: levs end | None -> - let levs = delete_rule_in_prefix entry symbols levs in lev :: levs + let levs = delete_rule_in_prefix entry symbols levs in + Level lev :: levs end | [] -> raise Not_found -let delete_rule_in_level_list (type s p) (entry : s ty_entry) (symbols : (s, p) ty_symbols) levs = +let delete_rule_in_level_list (type s tr p) (entry : s ty_entry) (symbols : (s, tr, p) ty_symbols) levs = match symbols with - TCns (Sself, symbols) -> delete_rule_in_suffix entry symbols levs - | TCns (Snterm e, symbols') -> + TCns (_, Sself, symbols) -> delete_rule_in_suffix entry symbols levs + | TCns (_, Snterm e, symbols') -> begin match eq_entry e entry with | None -> delete_rule_in_prefix entry symbols levs | Some Refl -> @@ -637,12 +787,12 @@ let delete_rule_in_level_list (type s p) (entry : s ty_entry) (symbols : (s, p) end | _ -> delete_rule_in_prefix entry symbols levs -let rec flatten_tree : type s a. (s, a) ty_tree -> s ex_symbols list = +let rec flatten_tree : type s tr a. (s, tr, a) ty_tree -> s ex_symbols list = function DeadEnd -> [] | LocAct (_, _) -> [ExS TNil] - | Node {node = n; brother = b; son = s} -> - List.map (fun (ExS l) -> ExS (TCns (n, l))) (flatten_tree s) @ flatten_tree b + | Node (_, {node = n; brother = b; son = s}) -> + List.map (fun (ExS l) -> ExS (TCns (MayRec2, n, l))) (flatten_tree s) @ flatten_tree b let utf8_print = ref true @@ -671,7 +821,7 @@ let string_escaped s = let print_str ppf s = fprintf ppf "\"%s\"" (string_escaped s) -let rec print_symbol : type s r. formatter -> (s, r) ty_symbol -> unit = +let rec print_symbol : type s tr r. formatter -> (s, tr, r) ty_symbol -> unit = fun ppf -> function | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s @@ -683,30 +833,36 @@ let rec print_symbol : type s r. formatter -> (s, r) ty_symbol -> unit = fprintf ppf "LIST1 %a SEP %a%s" print_symbol1 s print_symbol1 t (if osep then " OPT_SEP" else "") | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm + | Stoken p when L.tok_pattern_strings p <> ("", None) -> + begin match L.tok_pattern_strings p with + | con, Some prm -> fprintf ppf "%s@ %a" con print_str prm + | con, None -> fprintf ppf "%s" con end | Snterml (e, l) -> fprintf ppf "%s%s@ LEVEL@ %a" e.ename "" print_str l | s -> print_symbol1 ppf s -and print_symbol1 : type s r. formatter -> (s, r) ty_symbol -> unit = +and print_symbol1 : type s tr r. formatter -> (s, tr, r) ty_symbol -> unit = fun ppf -> function | Snterm e -> fprintf ppf "%s%s" e.ename "" | Sself -> pp_print_string ppf "SELF" | Snext -> pp_print_string ppf "NEXT" - | Stoken ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con + | Stoken p -> + begin match L.tok_pattern_strings p with + | "", Some s -> print_str ppf s + | con, None -> pp_print_string ppf con + | con, Some prm -> fprintf ppf "(%s@ %a)" con print_str prm end | Stree t -> print_level ppf pp_print_space (flatten_tree t) | s -> fprintf ppf "(%a)" print_symbol s -and print_rule : type s p. formatter -> (s, p) ty_symbols -> unit = +and print_rule : type s tr p. formatter -> (s, tr, p) ty_symbols -> unit = fun ppf symbols -> fprintf ppf "@[<hov 0>"; - let rec fold : type s p. _ -> (s, p) ty_symbols -> unit = - fun sep symbols -> match symbols with + let rec fold : type s tr p. _ -> (s, tr, p) ty_symbols -> unit = + fun sep symbols -> + match symbols with | TNil -> () - | TCns (symbol, symbols) -> + | TCns (_, symbol, symbols) -> fprintf ppf "%t%a" sep print_symbol symbol; fold (fun ppf -> fprintf ppf ";@ ") symbols in @@ -727,9 +883,9 @@ and print_level : type s. _ -> _ -> s ex_symbols list -> _ = let print_levels ppf elev = let _ = List.fold_left - (fun sep lev -> + (fun sep (Level lev) -> let rules = - List.map (fun (ExS t) -> ExS (TCns (Sself, t))) (flatten_tree lev.lsuffix) @ + List.map (fun (ExS t) -> ExS (TCns (MayRec2, Sself, t))) (flatten_tree lev.lsuffix) @ flatten_tree lev.lprefix in fprintf ppf "%t@[<hov 2>" sep; @@ -765,31 +921,39 @@ let loc_of_token_interval bp ep = else let loc1 = !floc bp in let loc2 = !floc (pred ep) in Loc.merge loc1 loc2 -let name_of_symbol : type s a. s ty_entry -> (s, a) ty_symbol -> string = +let name_of_symbol : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> string = fun entry -> function Snterm e -> "[" ^ e.ename ^ "]" | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]" | Sself -> "[" ^ entry.ename ^ "]" | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> egram.glexer.Plexing.tok_text tok + | Stoken tok -> L.tok_text tok | _ -> "???" type ('r, 'f) tok_list = | TokNil : ('f, 'f) tok_list -| TokCns : ('r, 'f) tok_list -> (string -> 'r, 'f) tok_list +| TokCns : 'a pattern * ('r, 'f) tok_list -> ('a -> 'r, 'f) tok_list + +type ('s, 'f) tok_tree = TokTree : 'a pattern * ('s, _, 'a -> 'r) ty_tree * ('r, 'f) tok_list -> ('s, 'f) tok_tree -type ('s, 'f) tok_tree = TokTree : ('s, string -> 'r) ty_tree * ('r, 'f) tok_list -> ('s, 'f) tok_tree +let rec tok_list_length : type a b. (a, b) tok_list -> int = + function + | TokNil -> 0 + | TokCns (_, t) -> 1 + tok_list_length t -let rec get_token_list : type s r f. - s ty_entry -> _ -> _ -> _ -> (r, f) tok_list -> (s, string -> r) ty_tree -> (_ * _ * _ * (s, f) tok_tree) option = - fun entry first_tok rev_tokl last_tok pf tree -> +let rec get_token_list : type s tr a r f. + s ty_entry -> a pattern -> (r, f) tok_list -> (s, tr, a -> r) ty_tree -> (s, f) tok_tree option = + fun entry last_tok rev_tokl tree -> match tree with - Node {node = Stoken tok; son = son; brother = DeadEnd} -> - get_token_list entry first_tok (last_tok :: rev_tokl) tok (TokCns pf) son - | _ -> if rev_tokl = [] then None else Some (first_tok, rev_tokl, last_tok, TokTree (tree, pf)) + Node (_, {node = Stoken tok; son = son; brother = DeadEnd}) -> + get_token_list entry tok (TokCns (last_tok, rev_tokl)) son + | _ -> + match rev_tokl with + | TokNil -> None + | _ -> Some (TokTree (last_tok, tree, rev_tokl)) -let rec name_of_symbol_failed : type s a. s ty_entry -> (s, a) ty_symbol -> _ = +let rec name_of_symbol_failed : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> _ = fun entry -> function | Slist0 s -> name_of_symbol_failed entry s @@ -799,13 +963,13 @@ let rec name_of_symbol_failed : type s a. s ty_entry -> (s, a) ty_symbol -> _ = | Sopt s -> name_of_symbol_failed entry s | Stree t -> name_of_tree_failed entry t | s -> name_of_symbol entry s -and name_of_tree_failed : type s a. s ty_entry -> (s, a) ty_tree -> _ = +and name_of_tree_failed : type s tr a. s ty_entry -> (s, tr, a) ty_tree -> _ = fun entry -> function - Node {node = s; brother = bro; son = son} -> + Node (_, {node = s; brother = bro; son = son}) -> let tokl = match s with - Stoken tok -> get_token_list entry tok [] tok TokNil son + Stoken tok -> get_token_list entry tok TokNil son | _ -> None in begin match tokl with @@ -818,20 +982,20 @@ and name_of_tree_failed : type s a. s ty_entry -> (s, a) ty_tree -> _ = in let txt = match bro with - DeadEnd | LocAct (_, _) -> txt + DeadEnd -> txt | LocAct (_, _) -> txt | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro in txt - | Some (_, rev_tokl, last_tok, _) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - egram.glexer.Plexing.tok_text tok) - "" (List.rev (last_tok :: rev_tokl)) + | Some (TokTree (last_tok, _, rev_tokl)) -> + let rec build_str : type a b. string -> (a, b) tok_list -> string = + fun s -> function + | TokNil -> s + | TokCns (tok, t) -> build_str (L.tok_text tok ^ " " ^ s) t in + build_str (L.tok_text last_tok) rev_tokl end - | DeadEnd | LocAct (_, _) -> "???" + | DeadEnd -> "???" | LocAct (_, _) -> "???" -let tree_failed (type s a) (entry : s ty_entry) (prev_symb_result : a) (prev_symb : (s, a) ty_symbol) tree = +let tree_failed (type s tr a) (entry : s ty_entry) (prev_symb_result : a) (prev_symb : (s, tr, a) ty_symbol) tree = let txt = name_of_tree_failed entry tree in let txt = match prev_symb with @@ -866,14 +1030,9 @@ let tree_failed (type s a) (entry : s ty_entry) (prev_symb_result : a) (prev_sym txt ^ " (in [" ^ entry.ename ^ "])" let symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in + let tree = Node (MayRec3, {node = symb; brother = DeadEnd; son = DeadEnd}) in tree_failed entry prev_symb_result prev_symb tree -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false - let level_number entry lab = let rec lookup levn = function @@ -885,7 +1044,7 @@ let level_number entry lab = Dlevels elev -> lookup 0 elev | Dparser _ -> raise Not_found -let rec top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> (s, a) ty_symbol = +let rec top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> (s, ty_norec, a) ty_symbol = fun entry -> function Sself -> Snterm entry @@ -894,7 +1053,7 @@ let rec top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> (s, a) ty_symbol | Slist1sep (s, sep, b) -> Slist1sep (top_symb entry s, sep, b) | _ -> raise Stream.Failure -let entry_of_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a ty_entry = +let entry_of_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> a ty_entry = fun entry -> function Sself -> entry @@ -903,12 +1062,14 @@ let entry_of_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a ty_entry = | Snterml (e, _) -> e | _ -> raise Stream.Failure -let top_tree : type s a. s ty_entry -> (s, a) ty_tree -> (s, a) ty_tree = +let top_tree : type s tr a. s ty_entry -> (s, tr, a) ty_tree -> (s, tr, a) ty_tree = fun entry -> function - Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct (_, _) | DeadEnd -> raise Stream.Failure + Node (MayRec3, {node = s; brother = bro; son = son}) -> + Node (MayRec3, {node = top_symb entry s; brother = bro; son = son}) + | Node (NoRec3, {node = s; brother = bro; son = son}) -> + Node (NoRec3, {node = top_symb entry s; brother = bro; son = son}) + | LocAct (_, _) -> raise Stream.Failure | DeadEnd -> raise Stream.Failure let skip_if_empty bp p strm = if Stream.count strm == bp then fun a -> p strm @@ -957,18 +1118,18 @@ let call_and_push ps al strm = let al = if !item_skipped then al else a :: al in item_skipped := false; al let token_ematch gram tok = - let tematch = gram.glexer.Plexing.tok_match tok in + let tematch = L.tok_match tok in fun tok -> tematch tok -let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> r parser_t = +let rec parser_of_tree : type s tr r. s ty_entry -> int -> int -> (s, tr, r) ty_tree -> r parser_t = fun entry nlevn alevn -> function DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) - | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> + | Node (_, {node = Sself; son = LocAct (act, _); brother = DeadEnd}) -> (fun (strm__ : _ Stream.t) -> let a = entry.estart alevn strm__ in act a) - | Node {node = Sself; son = LocAct (act, _); brother = bro} -> + | Node (_, {node = Sself; son = LocAct (act, _); brother = bro}) -> let p2 = parser_of_tree entry nlevn alevn bro in (fun (strm__ : _ Stream.t) -> match @@ -976,10 +1137,10 @@ let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> with Some a -> act a | _ -> p2 strm__) - | Node {node = s; son = son; brother = DeadEnd} -> + | Node (_, {node = s; son = son; brother = DeadEnd}) -> let tokl = match s with - Stoken tok -> get_token_list entry tok [] tok TokNil son + Stoken tok -> get_token_list entry tok TokNil son | _ -> None in begin match tokl with @@ -996,19 +1157,16 @@ let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> raise (Stream.Error (tree_failed entry a s son)) in act a) - | Some (first_tok, rev_tokl, last_tok, TokTree (son, pf)) -> - let s = Stoken first_tok in + | Some (TokTree (last_tok, son, rev_tokl)) -> let lt = Stoken last_tok in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in - parser_of_token_list entry s son pf p1 - (fun (strm__ : _ Stream.t) -> raise Stream.Failure) rev_tokl - last_tok + parser_of_token_list entry son p1 rev_tokl last_tok end - | Node {node = s; son = son; brother = bro} -> + | Node (_, {node = s; son = son; brother = bro}) -> let tokl = match s with - Stoken tok -> get_token_list entry tok [] tok TokNil son + Stoken tok -> get_token_list entry tok TokNil son | _ -> None in match tokl with @@ -1028,28 +1186,28 @@ let rec parser_of_tree : type s r. s ty_entry -> int -> int -> (s, r) ty_tree -> | None -> raise (Stream.Error (tree_failed entry a s son)) end | None -> p2 strm) - | Some (first_tok, rev_tokl, last_tok, TokTree (son, pf)) -> + | Some (TokTree (last_tok, son, rev_tokl)) -> let lt = Stoken last_tok in let p2 = parser_of_tree entry nlevn alevn bro in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn lt son in let p1 = - parser_of_token_list entry lt son pf p1 p2 rev_tokl last_tok + parser_of_token_list entry son p1 rev_tokl last_tok in fun (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> p2 strm__ -and parser_cont : type s a r. - (a -> r) parser_t -> s ty_entry -> int -> int -> (s, a) ty_symbol -> (s, a -> r) ty_tree -> int -> a -> (a -> r) parser_t = +and parser_cont : type s tr tr' a r. + (a -> r) parser_t -> s ty_entry -> int -> int -> (s, tr, a) ty_symbol -> (s, tr', a -> r) ty_tree -> int -> a -> (a -> r) parser_t = fun p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) -> try p1 strm__ with Stream.Failure -> recover parser_of_tree entry nlevn alevn bp a s son strm__ -and parser_of_token_list : type s r f. - s ty_entry -> (s, string) ty_symbol -> (s, string -> r) ty_tree -> - (r, f) tok_list -> (int -> string -> (string -> r) parser_t) -> f parser_t -> _ -> _ -> f parser_t = - fun entry s son pf p1 p2 rev_tokl last_tok -> +and parser_of_token_list : type s tr lt r f. + s ty_entry -> (s, tr, lt -> r) ty_tree -> + (int -> lt -> (lt -> r) parser_t) -> (r, f) tok_list -> lt pattern -> f parser_t = + fun entry son p1 rev_tokl last_tok -> + let n = tok_list_length rev_tokl + 1 in let plast : r parser_t = - let n = List.length rev_tokl + 1 in let tematch = token_ematch egram last_tok in let ps strm = match peek_nth n strm with @@ -1063,41 +1221,24 @@ and parser_of_token_list : type s r f. let a = ps strm in match try Some (p1 bp a strm) with Stream.Failure -> None with Some act -> act a - | None -> raise (Stream.Error (tree_failed entry a s son)) + | None -> raise (Stream.Error (tree_failed entry a (Stoken last_tok) son)) in - match List.rev rev_tokl, pf with - [], TokNil -> (fun (strm__ : _ Stream.t) -> plast strm__) - | tok :: tokl, TokCns pf -> - let tematch = token_ematch egram tok in - let ps strm = - match peek_nth 1 strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = - let rec loop : type s f. _ -> _ -> (s, f) tok_list -> (string -> s) parser_t -> (string -> f) parser_t = - fun n tokl pf plast -> - match tokl, pf with - [], TokNil -> plast - | tok :: tokl, TokCns pf -> - let tematch = token_ematch egram tok in - let ps strm = - match peek_nth n strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = loop (n + 1) tokl pf (Obj.magic plast) in (* FIXME *) - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in (Obj.magic act a) (* FIXME *) - | _ -> assert false - in - loop 2 tokl pf plast - in - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in act a - | _ -> assert false -and parser_of_symbol : type s a. - s ty_entry -> int -> (s, a) ty_symbol -> a parser_t = + let rec loop : type s f. _ -> (s, f) tok_list -> s parser_t -> f parser_t = + fun n tokl plast -> match tokl with + | TokNil -> plast + | TokCns (tok, tokl) -> + let tematch = token_ematch egram tok in + let ps strm = + match peek_nth n strm with + Some tok -> tematch tok + | None -> raise Stream.Failure + in + let plast = fun (strm : _ Stream.t) -> + let a = ps strm in let act = plast strm in act a in + loop (n - 1) tokl plast in + loop (n - 1) rev_tokl plast +and parser_of_symbol : type s tr a. + s ty_entry -> int -> (s, tr, a) ty_symbol -> a parser_t = fun entry nlevn -> function | Slist0 s -> @@ -1219,22 +1360,22 @@ and parser_of_symbol : type s a. | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) | Stoken tok -> parser_of_token entry tok -and parser_of_token : type s. - s ty_entry -> Plexing.pattern -> string parser_t = +and parser_of_token : type s a. + s ty_entry -> a pattern -> a parser_t = fun entry tok -> - let f = egram.glexer.Plexing.tok_match tok in + let f = L.tok_match tok in fun strm -> match Stream.peek strm with Some tok -> let r = f tok in Stream.junk strm; r | None -> raise Stream.Failure -and parse_top_symb : type s a. s ty_entry -> (s, a) ty_symbol -> a parser_t = +and parse_top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> a parser_t = fun entry symb -> parser_of_symbol entry 0 (top_symb entry symb) let rec start_parser_of_levels entry clevn = function [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> + | Level lev :: levs -> let p1 = start_parser_of_levels entry (succ clevn) levs in match lev.lprefix with DeadEnd -> p1 @@ -1277,7 +1418,7 @@ let rec start_parser_of_levels entry clevn = let rec continue_parser_of_levels entry clevn = function [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> + | Level lev :: levs -> let p1 = continue_parser_of_levels entry (succ clevn) levs in match lev.lsuffix with DeadEnd -> p1 @@ -1398,8 +1539,8 @@ let clear_entry e = Dlevels _ -> e.edesc <- Dlevels [] | Dparser _ -> () - let parsable cs = - let (ts, lf) = L.lexer.Plexing.tok_func cs in + let parsable ?loc cs = + let (ts, lf) = L.tok_func ?loc cs in {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} module Entry = struct @@ -1432,9 +1573,11 @@ let clear_entry e = let s_self = Sself let s_next = Snext let s_token tok = Stoken tok - let s_rules ~warning (t : 'a ty_production list) = srules ~warning t + let s_rules ~warning (t : 'a ty_rules list) = srules ~warning t let r_stop = TStop - let r_next r s = TNext (r, s) + let r_next r s = TNext (MayRec2, r, s) + let r_next_norec r s = TNext (NoRec2, r, s) + let rules (p, act) = TRules (p, act) let production (p, act) = TProd (p, act) module Unsafe = struct diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index bde07ddc48..ec4ec62409 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -15,16 +15,17 @@ rule "an entry cannot call an entry of another grammar" by normal OCaml typing. *) -module type GLexerType = sig type te val lexer : te Plexing.lexer end +module type GLexerType = Plexing.Lexer (** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) module type S = sig type te + type 'c pattern type parsable - val parsable : char Stream.t -> parsable - val tokens : string -> (string * int) list + val parsable : ?loc:Loc.t -> char Stream.t -> parsable + val tokens : string -> (string option * int) list module Entry : sig type 'a e @@ -35,29 +36,37 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ('self, 'a) ty_symbol - type ('self, 'f, 'r) ty_rule + type ty_norec = TyNoRec + type ty_mayrec = TyMayRec + type ('self, 'trec, 'a) ty_symbol + type ('self, 'trec, 'f, 'r) ty_rule + type 'a ty_rules type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol - val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + val s_nterm : 'a Entry.e -> ('self, ty_norec, 'a) ty_symbol + val s_nterml : 'a Entry.e -> string -> ('self, ty_norec, 'a) ty_symbol + val s_list0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list0sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_list1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol val s_list1sep : - ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool -> - ('self, 'a list) ty_symbol - val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol - val s_self : ('self, 'self) ty_symbol - val s_next : ('self, 'self) ty_symbol - val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol - val r_stop : ('self, 'r, 'r) ty_rule + ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> + ('self, 'trec, 'a list) ty_symbol + val s_opt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol + val s_self : ('self, ty_mayrec, 'self) ty_symbol + val s_next : ('self, ty_mayrec, 'self) ty_symbol + val s_token : 'c pattern -> ('self, ty_norec, 'c) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_rules list -> ('self, ty_norec, 'a) ty_symbol + + val r_stop : ('self, ty_norec, 'r, 'r) ty_rule val r_next : - ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> - ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production + ('self, _, 'a, 'r) ty_rule -> ('self, _, 'b) ty_symbol -> + ('self, ty_mayrec, 'b -> 'a, 'r) ty_rule + val r_next_norec : + ('self, ty_norec, 'a, 'r) ty_rule -> ('self, ty_norec, 'b) ty_symbol -> + ('self, ty_norec, 'b -> 'a, 'r) ty_rule + val rules : (_, ty_norec, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_rules + val production : ('a, _, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig @@ -68,7 +77,7 @@ module type S = (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val safe_delete_rule : 'a Entry.e -> ('a, 'f, 'r) ty_rule -> unit + val safe_delete_rule : 'a Entry.e -> ('a, _, 'f, 'r) ty_rule -> unit end (** Signature type of the functor [Grammar.GMake]. The types and functions are almost the same than in generic interface, but: @@ -80,4 +89,5 @@ module type S = type (instead of (string * string)); the module parameter must specify a way to show them as (string * string) *) -module GMake (L : GLexerType) : S with type te = L.te +module GMake (L : GLexerType) : + S with type te = L.te and type 'c pattern = 'c L.pattern diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index fce5445ad8..e881ab3350 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -2,15 +2,17 @@ (* plexing.ml,v *) (* Copyright (c) INRIA 2007-2017 *) -type pattern = string * string - type location_function = int -> Loc.t -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function +type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function -type 'te lexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - } +module type Lexer = sig + type te + type 'c pattern + val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option + val tok_pattern_strings : 'c pattern -> string * string option + val tok_func : te lexer_func + val tok_using : 'c pattern -> unit + val tok_removing : 'c pattern -> unit + val tok_match : 'c pattern -> te -> 'c + val tok_text : 'c pattern -> string +end diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 6139dc4020..521eba7446 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -8,27 +8,21 @@ grammars (see module [Grammar]). It also provides some useful functions to create lexers. *) -type pattern = string * string - (* Type for values used by the generated code of the EXTEND - statement to represent terminals in entry rules. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter (corresponding to the 'wildcard' pattern). -- The way tokens patterns are interpreted to parse tokens is done - by the lexer, function [tok_match] below. *) - (** Lexer type *) -type 'te lexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - } -and 'te lexer_func = char Stream.t -> 'te Stream.t * location_function +type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function and location_function = int -> Loc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) + +module type Lexer = sig + type te + type 'c pattern + val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option + val tok_pattern_strings : 'c pattern -> string * string option + val tok_func : te lexer_func + val tok_using : 'c pattern -> unit + val tok_removing : 'c pattern -> unit + val tok_match : 'c pattern -> te -> 'c + val tok_text : 'c pattern -> string +end diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 4aa801c2b2..8da9900724 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -250,7 +250,6 @@ object(self) feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; let md = segment_model document in segment#set_model md; -(* let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -267,7 +266,6 @@ object(self) ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in let _ = segment#connect#clicked ~callback:on_click in -*) () method private tooltip_callback ~x ~y ~kbd tooltip = diff --git a/ide/idetop.ml b/ide/idetop.ml index 608577b297..f744ce2ee3 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -231,30 +231,30 @@ let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let newp = Proof_global.give_me_the_proof () in + let newp = Vernacstate.Proof_global.give_me_the_proof () in if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Proof_global.NoCurrentProof -> None;; + with Vernacstate.Proof_global.NoCurrentProof -> None;; let evars () = try let doc = get_doc () in set_doc @@ Stm.finish ~doc; - let pfts = Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Proof_global.give_me_the_proof () in let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in Some el - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None let hints () = try - let pfts = Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Proof_global.give_me_the_proof () in let Proof.{ goals; sigma } = Proof.data pfts in match goals with | [] -> None @@ -263,7 +263,7 @@ let hints () = let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None (** Other API calls *) @@ -284,11 +284,11 @@ let status force = List.rev_map Names.Id.to_string l in let proof = - try Some (Names.Id.to_string (Proof_global.get_current_proof_name ())) - with Proof_global.NoCurrentProof -> None + try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) + with Vernacstate.Proof_global.NoCurrentProof -> None in let allproofs = - let l = Proof_global.get_all_proof_names () in + let l = Vernacstate.Proof_global.get_all_proof_names () in List.map Names.Id.to_string l in { @@ -336,7 +336,8 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - List.map export_coq_object (Search.interface_search ( + let pstate = Vernacstate.Proof_global.get () in + List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 2e5de64254..b62c0a2190 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -8,10 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(* open Util open Preferences -*) type color = GDraw.color @@ -24,7 +22,6 @@ object method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end -(* let i2f = float_of_int let f2i = int_of_float @@ -35,14 +32,20 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2 | `WHITE, `WHITE -> true | _ -> false -*) + +let set_cairo_color ctx c = + let open Gdk.Color in + let c = GDraw.color c in + let cast i = i2f i /. 65536. in + Cairo.set_source_rgb ctx (cast @@ red c) (cast @@ green c) (cast @@ blue c) + class type segment_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals method clicked : callback:(int -> unit) -> GtkSignal.id end -(* + class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = object val after = false @@ -50,14 +53,11 @@ object inherit GUtil.add_ml_signals obj [clicked#disconnect] method clicked = clicked#connect ~after end -*) class segment () = let box = GBin.frame () in -(* -let eventbox = GBin.event_box ~packing:box#add () in -let draw = GMisc.image ~packing:eventbox#add () in -*) +let draw = GMisc.drawing_area ~packing:box#add () in + object (self) inherit GObj.widget box#as_widget @@ -66,56 +66,40 @@ object (self) val mutable height = 20 val mutable model : model option = None val mutable default : color = `WHITE -(* - val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () -*) val clicked = new GUtil.signal () - val mutable need_refresh = false - val refresh_timer = Ideutils.mktimer () -(* + initializer box#misc#set_size_request ~height (); let cb rect = let w = rect.Gtk.width in let h = rect.Gtk.height in - (* Only refresh when size actually changed, otherwise loops *) - if self#misc#visible && (width <> w || height <> h) then begin - width <- w; - height <- h; - self#redraw (); - end + width <- w; + height <- h in let _ = box#misc#connect#size_allocate ~callback:cb in + let () = draw#event#add [`BUTTON_PRESS] in let clicked_cb ev = match model with | None -> true | Some md -> let x = GdkEvent.Button.x ev in - let (width, _) = pixmap#size in let len = md#length in let idx = f2i ((x *. i2f len) /. i2f width) in let () = clicked#call idx in true in - let _ = eventbox#event#connect#button_press ~callback:clicked_cb in + let _ = draw#event#connect#button_press ~callback:clicked_cb in let cb show = if show then self#misc#show () else self#misc#hide () in stick show_progress_bar self cb; - (* Initial pixmap *) - draw#set_pixmap pixmap; - refresh_timer.Ideutils.run ~ms:300 - ~callback:(fun () -> if need_refresh then self#refresh (); true) -*) + let cb ctx = self#refresh ctx; false in + let _ = draw#misc#connect#draw ~callback:cb in + () + method set_model md = model <- Some md; - let changed_cb = function - | `INSERT | `REMOVE -> - if self#misc#visible then need_refresh <- true - | `SET (i, color) -> - () -(* if self#misc#visible then self#fill_range color i (i + 1)*) - in + let changed_cb _ = self#misc#queue_draw () in md#changed ~callback:changed_cb -(* - method private fill_range color i j = match model with + + method private fill_range ctx color i j = match model with | None -> () | Some md -> let i = i2f i in @@ -125,24 +109,19 @@ object (self) let x = f2i ((i *. width) /. len) in let x' = f2i ((j *. width) /. len) in let w = x' - x in - pixmap#set_foreground color; - pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true (); - draw#set_mask None; + set_cairo_color ctx color; + Cairo.rectangle ctx (i2f x) 0. ~w:(i2f w) ~h:(i2f height); + Cairo.fill ctx method set_default_color color = default <- color method default_color = default - method private redraw () = - pixmap <- GDraw.pixmap ~width ~height (); - draw#set_pixmap pixmap; - self#refresh (); - - method private refresh () = match model with + method private refresh ctx = match model with | None -> () | Some md -> - need_refresh <- false; - pixmap#set_foreground default; - pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); + set_cairo_color ctx default; + Cairo.rectangle ctx 0. 0. ~w:(i2f width) ~h:(i2f height); + Cairo.fill ctx; let make (k, cur, accu) v = match cur with | None -> pred k, Some (k, k, v), accu | Some (i, j, w) -> @@ -154,11 +133,9 @@ object (self) | None -> segments | Some p -> p :: segments in - List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments; - draw#set_mask None; + List.iter (fun (i, j, v) -> self#fill_range ctx v i (j + 1)) segments method connect = new segment_signals_impl box#as_widget clicked -*) end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 84d487f35f..07f545fee7 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -31,9 +31,7 @@ class segment : unit -> inherit GObj.widget val obj : Gtk.widget Gtk.obj method set_model : model -> unit -(* method connect : segment_signals method default_color : color method set_default_color : color -> unit -*) end diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 5ede9d6a99..7a3e9881ea 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -956,7 +956,7 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = (str "variable " ++ Id.print id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) - let _ = Context.Named.lookup id namedctx in + let _ = Environ.lookup_named_ctxt id namedctx in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) @@ -1033,7 +1033,7 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = | TrueGlobal (VarRef _) when no_secvar -> (* Rule out section vars since these should have been found by intern_var *) raise Not_found - | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args + | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), Some ref, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition ?loc sp in let nids = List.length ids in @@ -1043,7 +1043,6 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let terms = make_subst ids (List.map fst args1) in let subst = (terms, Id.Map.empty, Id.Map.empty, Id.Map.empty) in let infos = (Id.Map.empty, env) in - let projapp = match c with NRef _ -> true | _ -> false in let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in let loc = c.loc in let err () = @@ -1067,35 +1066,63 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) | Some _, _ -> err () in - c, projapp, args2 + c, None, args2 + +let warn_nonprimitive_projection = + CWarnings.create ~name:"nonprimitive-projection-syntax" ~category:"syntax" ~default:CWarnings.Disabled + Pp.(fun f -> pr_qualid f ++ str " used as a primitive projection but is not one.") + +let error_nonprojection_syntax ?loc qid = + CErrors.user_err ?loc ~hdr:"nonprojection-syntax" Pp.(pr_qualid qid ++ str" is not a projection.") + +let check_applied_projection isproj realref qid = + match isproj with + | None -> () + | Some projargs -> + let is_prim = match realref with + | None | Some (IndRef _ | ConstructRef _ | VarRef _) -> false + | Some (ConstRef c) -> + if Recordops.is_primitive_projection c then true + else if Recordops.is_projection c then false + else error_nonprojection_syntax ?loc:qid.loc qid + (* TODO check projargs, note we will need implicit argument info *) + in + if not is_prim then warn_nonprimitive_projection ?loc:qid.loc qid -let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args qid = +let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us args qid = let loc = qid.CAst.loc in if qualid_is_ident qid then - try intern_var env lvar namedctx loc (qualid_basename qid) us, args + try + let res = intern_var env lvar namedctx loc (qualid_basename qid) us in + check_applied_projection isproj None qid; + res, args with Not_found -> try - let r, projapp, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in + let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in + check_applied_projection isproj realref qid; let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then + (* check_applied_projection ?? *) (gvar (loc,qualid_basename qid) us, [], [], []), args else Nametab.error_global_not_found qid else - let r,projapp,args2 = + let r,realref,args2 = try intern_qualid qid intern env ntnvars us args with Not_found -> Nametab.error_global_not_found qid in + check_applied_projection isproj realref qid; let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 let interp_reference vars r = let (r,_,_,_),_ = - intern_applied_reference (fun _ -> error_not_enough_arguments ?loc:None) + intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; - tmp_scope = None; scopes = []; impls = empty_internalization_env} [] + tmp_scope = None; scopes = []; impls = empty_internalization_env} + Environ.empty_named_context_val (vars, Id.Map.empty) None [] r in r @@ -1826,8 +1853,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> let (c,imp,subscopes,l),_ = - intern_applied_reference intern env (Environ.named_context globalenv) - lvar us [] ref + intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) + lvar us [] ref in apply_impargs c env imp subscopes l loc @@ -1932,30 +1959,31 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CAppExpl ((isproj,ref,us), args) -> let (f,_,args_scopes,_),args = let args = List.map (fun a -> (a,None)) args in - intern_applied_reference intern env (Environ.named_context globalenv) - lvar us args ref + intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) + lvar us args ref in (* Rem: GApp(_,f,[]) stands for @f *) if args = [] then DAst.make ?loc @@ GApp (f,[]) else smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> - let f,args = match f.CAst.v with + let isproj,f,args = match f.CAst.v with (* Compact notations like "t.(f args') args" *) - | CApp ((Some _,f), args') when not (Option.has_some isproj) -> - f,args'@args + | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) - | _ -> f,args in + | _ -> isproj,f,args in let (c,impargs,args_scopes,l),args = match f.CAst.v with | CRef (ref,us) -> - intern_applied_reference intern env - (Environ.named_context globalenv) lvar us args ref + intern_applied_reference ~isproj intern env + (Environ.named_context_val globalenv) lvar us args ref | CNotation (ntn,([],[],[],[])) -> + assert (Option.is_empty isproj); let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in let x, impl, scopes, l = find_appl_head_data c in (x,impl,scopes,l), args - | _ -> (intern env f,[],[],[]), args in + | _ -> assert (Option.is_empty isproj); (intern env f,[],[],[]), args in apply_impargs c env impargs args_scopes (merge_impargs l args) loc diff --git a/interp/notation.ml b/interp/notation.ml index bc68d97bb8..2765661749 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -606,20 +606,18 @@ module PrimTokenNotation = struct At least [c] is known to be evar-free, since it comes from our own ad-hoc [constr_of_glob] or from conversions such as [coqint_of_rawnum]. -*) -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let sigma,t = Typing.type_of env sigma c in - let c' = Vnorm.cbv_vm env sigma c t in - EConstr.Unsafe.to_constr c' + It is important to fully normalize the term, *including inductive + parameters of constructors*; see + https://github.com/coq/coq/issues/9840 for details on what goes + wrong if this does not happen, e.g., from using the vm rather than + cbv. +*) -(* For testing with "compute" instead of "vm_compute" : let eval_constr env sigma (c : Constr.t) = let c = EConstr.of_constr c in let c' = Tacred.compute env sigma c in EConstr.Unsafe.to_constr c' -*) let eval_constr_app env sigma c1 c2 = eval_constr env sigma (mkApp (c1,[| c2 |])) @@ -628,12 +626,21 @@ exception NotAValidPrimToken (** The uninterp function below work at the level of [glob_constr] which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) + to [constr] for the subset that concerns us. + + Note that if you update [constr_of_glob], you should update the + corresponding numeral notation *and* string notation doc in + doc/sphinx/user-extensions/syntax-extensions.rst that describes + what it means for a term to be ground / to be able to be + considered for parsing. *) let rec constr_of_glob env sigma g = match DAst.get g with | Glob_term.GRef (ConstructRef c, _) -> let sigma,c = Evd.fresh_constructor_instance env sigma c in sigma,mkConstructU c + | Glob_term.GRef (IndRef c, _) -> + let sigma,c = Evd.fresh_inductive_instance env sigma c in + sigma,mkIndU c | Glob_term.GApp (gc, gcl) -> let sigma,c = constr_of_glob env sigma gc in let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in diff --git a/kernel/dune b/kernel/dune index a8a87a3e95..5b23a705ae 100644 --- a/kernel/dune +++ b/kernel/dune @@ -4,7 +4,7 @@ (public_name coq.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) - (libraries lib byterun)) + (libraries lib byterun dynlink)) (executable (name genOpcodeFiles) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 2f11f3dd6b..11ece78fe0 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -315,11 +315,19 @@ type conv_tab = { let push_relevance infos r = { infos with relevances = r.Context.binder_relevance :: infos.relevances } -let rec skip_pattern infos n c1 c2 = - if Int.equal n 0 then infos, c1, c2 +let push_relevances infos nas = + { infos with relevances = Array.fold_left (fun l x -> x.Context.binder_relevance :: l) infos.relevances nas } + +let rec skip_pattern infos relevances n c1 c2 = + if Int.equal n 0 then {infos with relevances}, c1, c2 else match kind c1, kind c2 with - | Lambda (x, _, c1), Lambda (_, _, c2) -> skip_pattern (push_relevance infos x) (pred n) c1 c2 - | _ -> raise IrregularPatternShape + | Lambda (x, _, c1), Lambda (_, _, c2) -> + skip_pattern infos (x.Context.binder_relevance :: relevances) (pred n) c1 c2 + | _ -> raise IrregularPatternShape + +let skip_pattern infos n c1 c2 = + if Int.equal n 0 then infos, c1, c2 + else skip_pattern infos infos.relevances n c1 c2 let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in @@ -589,7 +597,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - let infos = Array.fold_left push_relevance infos na1 in + let infos = push_relevances infos na1 in convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in @@ -608,7 +616,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - let infos = Array.fold_left push_relevance infos na1 in + let infos = push_relevances infos na1 in convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in @@ -4,4 +4,4 @@ (public_name coq.lib) (wrapped false) (modules_without_implementation xml_datatype) - (libraries dynlink coq.clib coq.config)) + (libraries coq.clib coq.config)) diff --git a/lib/loc.ml b/lib/loc.ml index 66b7a7da70..6bcdcc0341 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -29,6 +29,8 @@ let create fname line_nb bol_pos bp ep = { line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } +let initial source = create source 1 0 0 0 + let make_loc (bp, ep) = { fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; diff --git a/lib/loc.mli b/lib/loc.mli index 23df1ebd9a..1eb3cc49e8 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -32,6 +32,9 @@ val create : source -> int -> int -> int -> int -> t (** Create a location from a filename, a line number, a position of the beginning of the line, a start and end position *) +val initial : source -> t +(** Create a location corresponding to the beginning of the given source *) + val unloc : t -> int * int (** Return the start and end position of a location *) diff --git a/lib/system.ml b/lib/system.ml index fd6579dd69..c408061852 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -304,7 +304,7 @@ let with_time ~batch ~header f x = raise e (* We use argv.[0] as we don't want to resolve symlinks *) -let get_toplevel_path ?(byte=not Dynlink.is_native) top = +let get_toplevel_path ?(byte=Sys.(backend_type = Bytecode)) top = let open Filename in let dir = if String.equal (basename Sys.argv.(0)) Sys.argv.(0) then "" else dirname Sys.argv.(0) ^ dir_sep in diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 49d6cf01d9..b81d89edf9 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -19,16 +19,19 @@ open Gramlib module CharOrd = struct type t = char let compare : char -> char -> int = compare end module CharMap = Map.Make (CharOrd) +type starts_quotation = NoQuotation | Quotation + type ttree = { - node : string option; - branch : ttree CharMap.t } + node : (string * starts_quotation) option; + branch : ttree CharMap.t; +} let empty_ttree = { node = None; branch = CharMap.empty } -let ttree_add ttree str = +let ttree_add ttree (str,quot) = let rec insert tt i = if i == String.length str then - {node = Some str; branch = tt.branch} + {node = Some (str,quot); branch = tt.branch} else let c = str.[i] in let br = @@ -75,7 +78,7 @@ let ttree_elements ttree = let rec elts tt accu = let accu = match tt.node with | None -> accu - | Some s -> CString.Set.add s accu + | Some (s,_) -> CString.Set.add s accu in CharMap.fold (fun _ tt accu -> elts tt accu) tt.branch accu in @@ -259,11 +262,11 @@ let is_keyword s = try match (ttree_find !token_tree s).node with None -> false | Some _ -> true with Not_found -> false -let add_keyword str = +let add_keyword ?(quotation=NoQuotation) str = if not (is_keyword str) then begin check_keyword str; - token_tree := ttree_add !token_tree str + token_tree := ttree_add !token_tree (str,quotation) end let remove_keyword str = @@ -383,9 +386,6 @@ let rec string loc ~comm_level bp len s = match Stream.peek s with let loc = set_loc_pos loc bp ep in err loc Unterminated_string -(* To associate locations to a file name *) -let current_file = ref Loc.ToplevelInput - (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -397,21 +397,20 @@ let current_comment = Buffer.create 8192 let between_commands = ref true (* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list * Loc.source +type lexer_state = int option * string * bool * ((int * int) * string) list -let init_lexer_state f = (None,"",true,[],f) -let set_lexer_state (o,s,b,c,f) = +let init_lexer_state () = (None,"",true,[]) +let set_lexer_state (o,s,b,c) = comment_begin := o; Buffer.clear current_comment; Buffer.add_string current_comment s; between_commands := b; - comments := c; - current_file := f + comments := c let get_lexer_state () = - (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) + (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) let drop_lexer_state () = - set_lexer_state (init_lexer_state Loc.ToplevelInput) + set_lexer_state (init_lexer_state ()) -let get_comment_state (_,_,_,c,_) = c +let get_comment_state (_,_,_,c) = c let real_push_char c = Buffer.add_char current_comment c @@ -533,11 +532,62 @@ and progress_utf8 loc last nj n c tt cs = and progress_from_byte loc last nj tt cs c = progress_utf8 loc last nj (utf8_char_size loc cs c) c tt cs +type marker = Delimited of int * char list * char list | ImmediateAsciiIdent + +let peek_marker_len b e s = + let rec peek n = + match stream_nth n s with + | c -> if c = b then peek (n+1) else n, List.make n b, List.make n e + | exception Stream.Failure -> n, List.make n b, List.make n e + in + let len, start, stop = peek 0 in + if len = 0 then raise Stream.Failure + else Delimited (len, start, stop) + +let peek_marker s = + match stream_nth 0 s with + | '(' -> peek_marker_len '(' ')' s + | '[' -> peek_marker_len '[' ']' s + | '{' -> peek_marker_len '{' '}' s + | ('a'..'z' | 'A'..'Z' | '_') -> ImmediateAsciiIdent + | _ -> raise Stream.Failure + +let parse_quotation loc s = + match peek_marker s with + | ImmediateAsciiIdent -> + let c = Stream.next s in + let len = + try ident_tail loc (store 0 c) s with + Stream.Failure -> raise (Stream.Error "") + in + get_buff len + | Delimited (lenmarker, bmarker, emarker) -> + let b = Buffer.create 80 in + let commit1 c = Buffer.add_char b c; Stream.junk s in + let commit l = List.iter commit1 l in + let rec quotation depth = + match Stream.npeek lenmarker s with + | l when l = bmarker -> + commit l; + quotation (depth + 1) + | l when l = emarker -> + commit l; + if depth > 1 then quotation (depth - 1) + | c :: cs -> + commit1 c; + quotation depth + | [] -> raise Stream.Failure + in + quotation 0; + Buffer.contents b + + let find_keyword loc id s = let tt = ttree_find !token_tree id in match progress_further loc tt.node 0 tt s with | None -> raise Not_found - | Some c -> KEYWORD c + | Some (c,NoQuotation) -> KEYWORD c + | Some (c,Quotation) -> QUOTATION(c, parse_quotation loc s) let process_sequence loc bp c cs = let rec aux n cs = @@ -552,7 +602,8 @@ let process_chars ~diff_mode loc bp c cs = let t = progress_from_byte loc None (-1) !token_tree cs c in let ep = Stream.count cs in match t with - | Some t -> (KEYWORD t, set_loc_pos loc bp ep) + | Some (t,NoQuotation) -> (KEYWORD t, set_loc_pos loc bp ep) + | Some (c,Quotation) -> (QUOTATION(c, parse_quotation loc cs), set_loc_pos loc bp ep) | None -> let ep' = bp + utf8_char_size loc cs c in if diff_mode then begin @@ -739,24 +790,29 @@ let loct_add loct i loc = Hashtbl.add loct i loc we unfreeze the state of the lexer. This restores the behaviour of the lexer. B.B. *) -type te = Tok.t - (** Names of tokens, for this lexer, used in Grammar error messages *) -let token_text = function - | ("", t) -> "'" ^ t ^ "'" - | ("IDENT", "") -> "identifier" - | ("IDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT", s) -> "'" ^ s ^ "'" - | ("STRING", "") -> "string" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" - -let func next_token cs = +let token_text : type c. c Tok.p -> string = function + | PKEYWORD t -> "'" ^ t ^ "'" + | PIDENT None -> "identifier" + | PIDENT (Some t) -> "'" ^ t ^ "'" + | PINT None -> "integer" + | PINT (Some s) -> "'" ^ s ^ "'" + | PSTRING None -> "string" + | PSTRING (Some s) -> "STRING \"" ^ s ^ "\"" + | PLEFTQMARK -> "LEFTQMARK" + | PEOI -> "end of input" + | PPATTERNIDENT None -> "PATTERNIDENT" + | PPATTERNIDENT (Some s) -> "PATTERNIDENT \"" ^ s ^ "\"" + | PFIELD None -> "FIELD" + | PFIELD (Some s) -> "FIELD \"" ^ s ^ "\"" + | PBULLET None -> "BULLET" + | PBULLET (Some s) -> "BULLET \"" ^ s ^ "\"" + | PQUOTATION lbl -> "QUOTATION \"" ^ lbl ^ "\"" + +let func next_token ?loc cs = let loct = loct_create () in - let cur_loc = ref (Loc.create !current_file 1 0 0 0) in + let cur_loc = ref (Option.default Loc.(initial ToplevelInput) loc) in let ts = Stream.from (fun i -> @@ -766,17 +822,24 @@ let func next_token cs = in (ts, loct_func loct) -let make_lexer ~diff_mode = { - Plexing.tok_func = func (next_token ~diff_mode); - Plexing.tok_using = - (fun pat -> match Tok.of_pattern pat with - | KEYWORD s -> add_keyword s - | _ -> ()); - Plexing.tok_removing = (fun _ -> ()); - Plexing.tok_match = Tok.match_pattern; - Plexing.tok_text = token_text } +module MakeLexer (Diff : sig val mode : bool end) = struct + type te = Tok.t + type 'c pattern = 'c Tok.p + let tok_pattern_eq = Tok.equal_p + let tok_pattern_strings = Tok.pattern_strings + let tok_func = func (next_token ~diff_mode:Diff.mode) + let tok_using : type c. c pattern -> unit = function + | PKEYWORD s -> add_keyword ~quotation:NoQuotation s + | PQUOTATION s -> add_keyword ~quotation:Quotation s + | _ -> () + let tok_removing = (fun _ -> ()) + let tok_match = Tok.match_pattern + let tok_text = token_text +end + +module Lexer = MakeLexer (struct let mode = false end) -let lexer = make_lexer ~diff_mode:false +module LexerDiff = MakeLexer (struct let mode = true end) (** Terminal symbols interpretation *) @@ -811,6 +874,6 @@ let strip s = let terminal s = let s = strip s in let () = match s with "" -> failwith "empty token." | _ -> () in - if is_ident_not_keyword s then IDENT s - else if is_number s then INT s - else KEYWORD s + if is_ident_not_keyword s then PIDENT (Some s) + else if is_number s then PINT (Some s) + else PKEYWORD s diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index af3fd7f318..9df3e45f49 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -8,8 +8,32 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(** When one registers a keyword she can declare it starts a quotation. + In particular using QUOTATION("name:") in a grammar rule + declares "name:" as a keyword and the token QUOTATION is + matched whenever the keyword is followed by an identifier or a + parenthesized text. Eg + + constr:x + string:[....] + ltac:(....) + ltac:{....} + + The delimiter is made of 1 or more occurrences of the same parenthesis, + eg ((.....)) or [[[[....]]]]. The idea being that if the text happens to + contain the closing delimiter, one can make the delimiter longer and avoid + confusion (no escaping). Eg + + string:[[ .. ']' .. ]] + + + Nesting the delimiter is allowed, eg ((..((...))..)) is OK. + + Keywords don't need to end in ':' *) +type starts_quotation = NoQuotation | Quotation + (** This should be functional but it is not due to the interface *) -val add_keyword : string -> unit +val add_keyword : ?quotation:starts_quotation -> string -> unit val remove_keyword : string -> unit val is_keyword : string -> bool val keywords : unit -> CString.Set.t @@ -21,26 +45,14 @@ val get_keyword_state : unit -> keyword_state val check_ident : string -> unit val is_ident : string -> bool val check_keyword : string -> unit -val terminal : string -> Tok.t -(** The lexer of Coq: *) +(** When string is neither an ident nor an int, returns a keyword. *) +val terminal : string -> string Tok.p -(* modtype Grammar.GLexerType: sig - type te val - lexer : te Plexing.lexer - end - -where +(** The lexer of Coq: *) - type lexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list location) } - *) -include Gramlib.Grammar.GLexerType with type te = Tok.t +module Lexer : + Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p module Error : sig type t @@ -51,7 +63,7 @@ end (* Mainly for comments state, etc... *) type lexer_state -val init_lexer_state : Loc.source -> lexer_state +val init_lexer_state : unit -> lexer_state val set_lexer_state : lexer_state -> unit val get_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit @@ -66,4 +78,5 @@ as if it was unquoted, possibly becoming multiple tokens it was not in a comment, possibly becoming multiple tokens - return any unrecognized Ascii or UTF-8 character as a string *) -val make_lexer : diff_mode:bool -> Tok.t Gramlib.Plexing.lexer +module LexerDiff : + Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p diff --git a/parsing/extend.ml b/parsing/extend.ml index 9b5537d7f6..dd7c301dfb 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,7 +10,7 @@ (** Entry keys for constr notations *) -type 'a entry = 'a Gramlib.Grammar.GMake(CLexer).Entry.e +type 'a entry = 'a Gramlib.Grammar.GMake(CLexer.Lexer).Entry.e type side = Left | Right @@ -44,7 +44,7 @@ type simple_constr_prod_entry_key = (** Entries used in productions (in right-hand-side of grammar rules), to parse non-terminals *) -type binder_entry_kind = ETBinderOpen | ETBinderClosed of Tok.t list +type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list type binder_target = ForBinder | ForTerm @@ -54,7 +54,7 @@ type constr_prod_entry_key = | 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 (production_level * production_position) * Tok.t list (* Parsed as non-empty list of constr *) + | ETProdConstrList of (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr *) | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) (** {5 AST for user-provided entries} *) @@ -79,30 +79,34 @@ type ('a,'b,'c) ty_user_symbol = (** {5 Type-safe grammar extension} *) -type ('self, 'a) symbol = -| Atoken : Tok.t -> ('self, string) symbol -| Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol -| Alist1sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol -| Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol -| Alist0sep : ('self, 'a) symbol * ('self, _) symbol -> ('self, 'a list) symbol -| Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol -| Aself : ('self, 'self) symbol -| Anext : ('self, 'self) symbol -| Aentry : 'a entry -> ('self, 'a) symbol -| Aentryl : 'a entry * string -> ('self, 'a) symbol -| Arules : 'a rules list -> ('self, 'a) symbol - -and ('self, _, 'r) rule = -| Stop : ('self, 'r, 'r) rule -| Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule - -and ('a, 'r) norec_rule = { norec_rule : 's. ('s, 'a, 'r) rule } +type norec = NoRec (* just two *) +type mayrec = MayRec (* incompatible types *) + +type ('self, 'trec, 'a) symbol = +| Atoken : 'c Tok.p -> ('self, norec, 'c) symbol +| Alist1 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol +| Alist1sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol + -> ('self, 'trec, 'a list) symbol +| Alist0 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol +| Alist0sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol + -> ('self, 'trec, 'a list) symbol +| Aopt : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a option) symbol +| Aself : ('self, mayrec, 'self) symbol +| Anext : ('self, mayrec, 'self) symbol +| Aentry : 'a entry -> ('self, norec, 'a) symbol +| Aentryl : 'a entry * string -> ('self, norec, 'a) symbol +| Arules : 'a rules list -> ('self, norec, 'a) symbol + +and ('self, 'trec, _, 'r) rule = +| Stop : ('self, norec, 'r, 'r) rule +| Next : ('self, _, 'a, 'r) rule * ('self, _, 'b) symbol -> ('self, mayrec, 'b -> 'a, 'r) rule +| NextNoRec : ('self, norec, 'a, 'r) rule * ('self, norec, 'b) symbol -> ('self, norec, 'b -> 'a, 'r) rule and 'a rules = -| Rules : ('act, Loc.t -> 'a) norec_rule * 'act -> 'a rules +| Rules : (_, norec, 'act, Loc.t -> 'a) rule * 'act -> 'a rules type 'a production_rule = -| Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule +| Rule : ('a, _, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule type 'a single_extend_statement = string option * diff --git a/parsing/notation_gram.ml b/parsing/notation_gram.ml index fc5feba58b..6df0d6f21a 100644 --- a/parsing/notation_gram.ml +++ b/parsing/notation_gram.ml @@ -21,7 +21,7 @@ type level = Constrexpr.notation_entry * precedence * tolerability list * constr (* first argument is InCustomEntry s for custom entries *) type grammar_constr_prod_item = - | GramConstrTerminal of Tok.t + | GramConstrTerminal of string Tok.p | GramConstrNonTerminal of Extend.constr_prod_entry_key * Id.t option | GramConstrListMark of int * bool * int (* tells action rule to make a list of the n previous parsed items; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 759e60fbca..8f38e437b4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -17,7 +17,7 @@ open Gramlib (** The parser of Coq *) module G : sig - include Grammar.S with type te = Tok.t + include Grammar.S with type te = Tok.t and type 'c pattern = 'c Tok.p (* where Grammar.S @@ -59,7 +59,7 @@ module type S = type coq_parsable - val coq_parsable : ?file:Loc.source -> char Stream.t -> coq_parsable + val coq_parsable : ?loc:Loc.t -> char Stream.t -> coq_parsable val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -67,14 +67,14 @@ module type S = end with type 'a Entry.e = 'a Extend.entry = struct - include Grammar.GMake(CLexer) + include Grammar.GMake(CLexer.Lexer) type coq_parsable = parsable * CLexer.lexer_state ref - let coq_parsable ?(file=Loc.ToplevelInput) c = - let state = ref (CLexer.init_lexer_state file) in + let coq_parsable ?loc c = + let state = ref (CLexer.init_lexer_state ()) in CLexer.set_lexer_state !state; - let a = parsable c in + let a = parsable ?loc c in state := CLexer.get_lexer_state (); (a,state) @@ -107,7 +107,7 @@ end module Entry = struct - type 'a t = 'a Grammar.GMake(CLexer).Entry.e + type 'a t = 'a Grammar.GMake(CLexer.Lexer).Entry.e let create = G.Entry.create let parse = G.entry_parse @@ -118,30 +118,6 @@ struct end -module Symbols : sig - val stoken : Tok.t -> ('s, string) G.ty_symbol - val slist0sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol - val slist1sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol -end = struct - - let stoken tok = - let pattern = match tok with - | Tok.KEYWORD s -> "", s - | Tok.IDENT s -> "IDENT", s - | Tok.PATTERNIDENT s -> "PATTERNIDENT", s - | Tok.FIELD s -> "FIELD", s - | Tok.INT s -> "INT", s - | Tok.STRING s -> "STRING", s - | Tok.LEFTQMARK -> "LEFTQMARK", "" - | Tok.BULLET s -> "BULLET", s - | Tok.EOI -> "EOI", "" - in - G.s_token pattern - - let slist0sep x y = G.s_list0sep x y false - let slist1sep x y = G.s_list1sep x y false -end - (** Grammar extensions *) (** NB: [extend_statement = @@ -155,43 +131,73 @@ end (** Binding general entry keys to symbol *) -type ('s, 'a, 'r) casted_rule = Casted : ('s, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, 'a, 'r) casted_rule - -let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> (s, a) G.ty_symbol = function -| Atoken t -> Symbols.stoken t -| Alist1 s -> G.s_list1 (symbol_of_prod_entry_key s) +type ('s, 'trec, 'a, 'r) casted_rule = +| CastedRNo : ('s, G.ty_norec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, norec, 'a, 'r) casted_rule +| CastedRMay : ('s, G.ty_mayrec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, mayrec, 'a, 'r) casted_rule + +type ('s, 'trec, 'a) casted_symbol = +| CastedSNo : ('s, G.ty_norec, 'a) G.ty_symbol -> ('s, norec, 'a) casted_symbol +| CastedSMay : ('s, G.ty_mayrec, 'a) G.ty_symbol -> ('s, mayrec, 'a) casted_symbol + +let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) casted_symbol = +function +| Atoken t -> CastedSNo (G.s_token t) +| Alist1 s -> + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list1 s) + | CastedSMay s -> CastedSMay (G.s_list1 s) end | Alist1sep (s,sep) -> - Symbols.slist1sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) -| Alist0 s -> G.s_list0 (symbol_of_prod_entry_key s) + let CastedSNo sep = symbol_of_prod_entry_key sep in + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list1sep s sep false) + | CastedSMay s -> CastedSMay (G.s_list1sep s sep false) end +| Alist0 s -> + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list0 s) + | CastedSMay s -> CastedSMay (G.s_list0 s) end | Alist0sep (s,sep) -> - Symbols.slist0sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) -| Aopt s -> G.s_opt (symbol_of_prod_entry_key s) -| Aself -> G.s_self -| Anext -> G.s_next -| Aentry e -> G.s_nterm e -| Aentryl (e, n) -> G.s_nterml e n + let CastedSNo sep = symbol_of_prod_entry_key sep in + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_list0sep s sep false) + | CastedSMay s -> CastedSMay (G.s_list0sep s sep false) end +| Aopt s -> + begin match symbol_of_prod_entry_key s with + | CastedSNo s -> CastedSNo (G.s_opt s) + | CastedSMay s -> CastedSMay (G.s_opt s) end +| Aself -> CastedSMay G.s_self +| Anext -> CastedSMay G.s_next +| Aentry e -> CastedSNo (G.s_nterm e) +| Aentryl (e, n) -> CastedSNo (G.s_nterml e n) | Arules rs -> let warning msg = Feedback.msg_warning Pp.(str msg) in - G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs) + CastedSNo (G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs)) -and symbol_of_rule : type s a r. (s, a, Loc.t -> r) Extend.rule -> (s, a, Loc.t -> r) casted_rule = function -| Stop -> Casted (G.r_stop, fun act loc -> act loc) +and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) casted_rule = function +| Stop -> CastedRNo (G.r_stop, fun act loc -> act loc) | Next (r, s) -> - let Casted (r, cast) = symbol_of_rule r in - Casted (G.r_next r (symbol_of_prod_entry_key s), (fun act x -> cast (act x))) - -and symbol_of_rules : type a. a Extend.rules -> a G.ty_production = function + begin match symbol_of_rule r, symbol_of_prod_entry_key s with + | CastedRNo (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) + | CastedRNo (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) + | CastedRMay (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) + | CastedRMay (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) end +| NextNoRec (r, s) -> + let CastedRNo (r, cast) = symbol_of_rule r in + let CastedSNo s = symbol_of_prod_entry_key s in + CastedRNo (G.r_next_norec r s, (fun act x -> cast (act x))) + +and symbol_of_rules : type a. a Extend.rules -> a G.ty_rules = function | Rules (r, act) -> - let Casted (symb, cast) = symbol_of_rule r.norec_rule in - G.production (symb, cast act) + let CastedRNo (symb, cast) = symbol_of_rule r in + G.rules (symb, cast act) (** FIXME: This is a hack around a deficient camlp5 API *) -type 'a any_production = AnyProduction : ('a, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production +type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function | Rule (toks, act) -> - let Casted (symb, cast) = symbol_of_rule toks in - AnyProduction (symb, cast act) + match symbol_of_rule toks with + | CastedRNo (symb, cast) -> AnyProduction (symb, cast act) + | CastedRMay (symb, cast) -> AnyProduction (symb, cast act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, assoc, List.map of_coq_production_rule rule) @@ -303,7 +309,7 @@ let make_rule r = [None, None, r] let eoi_entry en = let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (Symbols.stoken Tok.EOI) in + let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (G.s_token Tok.PEOI) in let act = fun _ x loc -> x in let warning msg = Feedback.msg_warning Pp.(str msg) in Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.production (symbs, act)]); @@ -320,8 +326,9 @@ let map_entry f en = (* Parse a string, does NOT check if the entire string was read (use eoi_entry) *) -let parse_string f x = - let strm = Stream.of_string x in Gram.entry_parse f (Gram.coq_parsable strm) +let parse_string f ?loc x = + let strm = Stream.of_string x in + Gram.entry_parse f (Gram.coq_parsable ?loc strm) type gram_universe = string @@ -439,8 +446,11 @@ module Module = let module_expr = Entry.create "module_expr" let module_type = Entry.create "module_type" end -let epsilon_value f e = - let r = G.production (G.r_next G.r_stop (symbol_of_prod_entry_key e), (fun x _ -> f x)) in +let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = + let r = + match symbol_of_prod_entry_key e with + | CastedSNo s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) + | CastedSMay s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in let warning msg = Feedback.msg_warning Pp.(str msg) in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 3203a25b46..e361f0d00f 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -19,7 +19,7 @@ open Libnames module Parsable : sig type t - val make : ?file:Loc.source -> char Stream.t -> t + val make : ?loc:Loc.t -> char Stream.t -> t (* Get comment parsing information from the Lexer *) val comment_state : t -> ((int * int) * string) list end @@ -121,7 +121,7 @@ end (** Parse a string *) -val parse_string : 'a Entry.t -> string -> 'a +val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a val eoi_entry : 'a Entry.t -> 'a Entry.t val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t @@ -203,7 +203,7 @@ module Module : val module_type : module_ast Entry.t end -val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option +val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Extend.symbol -> 'self option (** {5 Extending the parser without synchronization} *) diff --git a/parsing/tok.ml b/parsing/tok.ml index 03825e350f..186d0502fc 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -12,6 +12,31 @@ let string_equal (s1 : string) s2 = s1 = s2 +type 'c p = + | PKEYWORD : string -> string p + | PPATTERNIDENT : string option -> string p + | PIDENT : string option -> string p + | PFIELD : string option -> string p + | PINT : string option -> string p + | PSTRING : string option -> string p + | PLEFTQMARK : unit p + | PBULLET : string option -> string p + | PQUOTATION : string -> string p + | PEOI : unit p + +let pattern_strings : type c. c p -> string * string option = + function + | PKEYWORD s -> "", Some s + | PPATTERNIDENT s -> "PATTERNIDENT", s + | PIDENT s -> "IDENT", s + | PFIELD s -> "FIELD", s + | PINT s -> "INT", s + | PSTRING s -> "STRING", s + | PLEFTQMARK -> "LEFTQMARK", None + | PBULLET s -> "BULLET", s + | PQUOTATION lbl -> "QUOTATION", Some lbl + | PEOI -> "EOI", None + type t = | KEYWORD of string | PATTERNIDENT of string @@ -21,8 +46,25 @@ type t = | STRING of string | LEFTQMARK | BULLET of string + | QUOTATION of string * string | EOI +let equal_p (type a b) (t1 : a p) (t2 : b p) : (a, b) Util.eq option = + let streq s1 s2 = match s1, s2 with None, None -> true + | Some s1, Some s2 -> string_equal s1 s2 | _ -> false in + match t1, t2 with + | PKEYWORD s1, PKEYWORD s2 when string_equal s1 s2 -> Some Util.Refl + | PPATTERNIDENT s1, PPATTERNIDENT s2 when streq s1 s2 -> Some Util.Refl + | PIDENT s1, PIDENT s2 when streq s1 s2 -> Some Util.Refl + | PFIELD s1, PFIELD s2 when streq s1 s2 -> Some Util.Refl + | PINT s1, PINT s2 when streq s1 s2 -> Some Util.Refl + | PSTRING s1, PSTRING s2 when streq s1 s2 -> Some Util.Refl + | PLEFTQMARK, PLEFTQMARK -> Some Util.Refl + | PBULLET s1, PBULLET s2 when streq s1 s2 -> Some Util.Refl + | PQUOTATION s1, PQUOTATION s2 when string_equal s1 s2 -> Some Util.Refl + | PEOI, PEOI -> Some Util.Refl + | _ -> None + let equal t1 t2 = match t1, t2 with | IDENT s1, KEYWORD s2 -> string_equal s1 s2 | KEYWORD s1, KEYWORD s2 -> string_equal s1 s2 @@ -34,6 +76,7 @@ let equal t1 t2 = match t1, t2 with | LEFTQMARK, LEFTQMARK -> true | BULLET s1, BULLET s2 -> string_equal s1 s2 | EOI, EOI -> true +| QUOTATION(s1,t1), QUOTATION(s2,t2) -> string_equal s1 s2 && string_equal t1 t2 | _ -> false let extract_string diff_mode = function @@ -58,65 +101,40 @@ let extract_string diff_mode = function | INT s -> s | LEFTQMARK -> "?" | BULLET s -> s + | QUOTATION(_,s) -> s | EOI -> "" -let to_string = function - | KEYWORD s -> Format.sprintf "%S" s - | IDENT s -> Format.sprintf "IDENT %S" s - | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s - | FIELD s -> Format.sprintf "FIELD %S" s - | INT s -> Format.sprintf "INT %s" s - | STRING s -> Format.sprintf "STRING %S" s - | LEFTQMARK -> "LEFTQMARK" - | BULLET s -> Format.sprintf "BULLET %S" s - | EOI -> "EOI" - -let match_keyword kwd = function - | KEYWORD kwd' when kwd = kwd' -> true - | _ -> false - -(* Needed to fix Camlp5 signature. - Cannot use Pp because of silly Tox -> Compat -> Pp dependency *) -let print ppf tok = Format.pp_print_string ppf (to_string tok) - -(** For camlp5, conversion from/to [Plexing.pattern], - and a match function analoguous to [Plexing.default_match] *) - -let of_pattern = function - | "", s -> KEYWORD s - | "IDENT", s -> IDENT s - | "PATTERNIDENT", s -> PATTERNIDENT s - | "FIELD", s -> FIELD s - | "INT", s -> INT s - | "STRING", s -> STRING s - | "LEFTQMARK", _ -> LEFTQMARK - | "BULLET", s -> BULLET s - | "EOI", _ -> EOI - | _ -> failwith "Tok.of_pattern: not a constructor" - -let to_pattern = function - | KEYWORD s -> "", s - | IDENT s -> "IDENT", s - | PATTERNIDENT s -> "PATTERNIDENT", s - | FIELD s -> "FIELD", s - | INT s -> "INT", s - | STRING s -> "STRING", s - | LEFTQMARK -> "LEFTQMARK", "" - | BULLET s -> "BULLET", s - | EOI -> "EOI", "" +(* Invariant, txt is "ident" or a well parenthesized "{{....}}" *) +let trim_quotation txt = + let len = String.length txt in + if len = 0 then None, txt + else + let c = txt.[0] in + if c = '(' || c = '[' || c = '{' then + let rec aux n = + if n < len && txt.[n] = c then aux (n+1) + else Some c, String.sub txt n (len - (2*n)) + in + aux 0 + else None, txt -let match_pattern = +let match_pattern (type c) (p : c p) : t -> c = let err () = raise Stream.Failure in - function - | "", "" -> (function KEYWORD s -> s | _ -> err ()) - | "IDENT", "" -> (function IDENT s -> s | _ -> err ()) - | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) - | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) - | "INT", "" -> (function INT s -> s | _ -> err ()) - | "STRING", "" -> (function STRING s -> s | _ -> err ()) - | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) - | "BULLET", "" -> (function BULLET s -> s | _ -> err ()) - | "EOI", "" -> (function EOI -> "" | _ -> err ()) - | pat -> - let tok = of_pattern pat in - function tok' -> if equal tok tok' then snd pat else err () + let seq = string_equal in + match p with + | PKEYWORD s -> (function KEYWORD s' when seq s s' -> s' | _ -> err ()) + | PIDENT None -> (function IDENT s' -> s' | _ -> err ()) + | PIDENT (Some s) -> (function (IDENT s' | KEYWORD s') when seq s s' -> s' | _ -> err ()) + | PPATTERNIDENT None -> (function PATTERNIDENT s -> s | _ -> err ()) + | PPATTERNIDENT (Some s) -> (function PATTERNIDENT s' when seq s s' -> s' | _ -> err ()) + | PFIELD None -> (function FIELD s -> s | _ -> err ()) + | PFIELD (Some s) -> (function FIELD s' when seq s s' -> s' | _ -> err ()) + | PINT None -> (function INT s -> s | _ -> err ()) + | PINT (Some s) -> (function INT s' when seq s s' -> s' | _ -> err ()) + | PSTRING None -> (function STRING s -> s | _ -> err ()) + | PSTRING (Some s) -> (function STRING s' when seq s s' -> s' | _ -> err ()) + | PLEFTQMARK -> (function LEFTQMARK -> () | _ -> err ()) + | PBULLET None -> (function BULLET s -> s | _ -> err ()) + | PBULLET (Some s) -> (function BULLET s' when seq s s' -> s' | _ -> err ()) + | PQUOTATION lbl -> (function QUOTATION(lbl',s') when string_equal lbl lbl' -> s' | _ -> err ()) + | PEOI -> (function EOI -> () | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index 5750096a28..678877720d 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -10,6 +10,20 @@ (** The type of token for the Coq lexer and parser *) +type 'c p = + | PKEYWORD : string -> string p + | PPATTERNIDENT : string option -> string p + | PIDENT : string option -> string p + | PFIELD : string option -> string p + | PINT : string option -> string p + | PSTRING : string option -> string p + | PLEFTQMARK : unit p + | PBULLET : string option -> string p + | PQUOTATION : string -> string p + | PEOI : unit p + +val pattern_strings : 'c p -> string * string option + type t = | KEYWORD of string | PATTERNIDENT of string @@ -19,17 +33,22 @@ type t = | STRING of string | LEFTQMARK | BULLET of string + | QUOTATION of string * string | EOI +val equal_p : 'a p -> 'b p -> ('a, 'b) Util.eq option + val equal : t -> t -> bool (* pass true for diff_mode *) val extract_string : bool -> t -> string -val to_string : t -> string -(* Needed to fit Camlp5 signature *) -val print : Format.formatter -> t -> unit -val match_keyword : string -> t -> bool - -(** for camlp5 *) -val of_pattern : string*string -> t -val to_pattern : t -> string*string -val match_pattern : string*string -> t -> string + +(** Utility function for the test returned by a QUOTATION token: + It returns the delimiter parenthesis, if any, and the text + without delimiters. Eg `{{{ text }}}` -> Some '{', ` text ` *) +val trim_quotation : string -> char option * string + +(** for camlp5, + eg GRAMMAR EXTEND ..... [ IDENT "x" -> .... END + is a pattern (PIDENT (Some "x")) +*) +val match_pattern : 'c p -> t -> 'c diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 978969bf59..5066c3931d 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -255,5 +255,3 @@ val find_contradiction : UF.t -> (Names.Id.t * (int * int)) list -> (Names.Id.t * (int * int)) *) - - diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index afdbfa1999..4425e41652 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -101,8 +101,7 @@ let start_deriving f suchthat lemma = in let terminator = Proof_global.make_terminator terminator in - let () = Proof_global.start_dependent_proof lemma kind goals terminator in - let _ = Proof_global.with_current_proof begin fun _ p -> + let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in + fst @@ Proof_global.with_current_proof begin fun _ p -> Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p - end in - () + end pstate diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 06ff9c48cf..6bb923118e 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,4 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> unit +val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 0cdf8fb5d8..214a9d8bb5 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -23,6 +23,6 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac } VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } -| [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { Derive.start_deriving f suchthat lemma } +| ![ proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> + { fun ~pstate -> Some Derive.(start_deriving f suchthat lemma) } END diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 0fa9be21c9..8f17f7b2dd 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -750,16 +750,19 @@ let extract_and_compile l = Feedback.msg_notice (str "Extracted code successfully compiled") (* Show the extraction of the current ongoing proof *) - -let show_extraction () = +let show_extraction ~pstate = + let pstate = match pstate with + | None -> CErrors.user_err Pp.(str "No ongoing proof") + | Some pstate -> pstate + in init ~inner:true false false; - let prf = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in + let prf = Proof_global.give_me_the_proof pstate in + let sigma, env = Pfedit.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_current_proof_name ()) in + let l = Label.of_id (Proof_global.get_current_proof_name pstate) in let fake_ref = ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 54fde2ca46..7ba7e05019 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : unit -> unit +val show_extraction : pstate:Proof_global.t option -> unit diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index 1445dffefa..d7bb27f121 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -178,6 +178,6 @@ END (* Show the extraction of the current proof *) VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY -| [ "Show" "Extraction" ] - -> { show_extraction () } +| ![ proof ] [ "Show" "Extraction" ] + -> { fun ~pstate -> let () = show_extraction ~pstate in pstate } END diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 16f376931e..287a374ab1 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -722,7 +722,7 @@ let build_proof (treat_new_case ptes_infos nb_instantiate_partial - (build_proof env sigma do_finalize) + (build_proof do_finalize) t dyn_infos) g' @@ -733,7 +733,7 @@ let build_proof ] g in - build_proof env sigma do_finalize_t {dyn_infos with info = t} g + build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin match EConstr.kind sigma (pf_concl g) with @@ -749,7 +749,7 @@ let build_proof in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = - build_proof env sigma do_finalize + build_proof do_finalize {new_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps @@ -762,7 +762,7 @@ let build_proof do_finalize dyn_infos g end | Cast(t,_,_) -> - build_proof env sigma do_finalize {dyn_infos with info = t} g + build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> do_finalize dyn_infos g | App(_,_) -> @@ -792,7 +792,7 @@ let build_proof | Lambda _ -> let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof env sigma do_finalize {dyn_infos with info = new_term} + build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> let new_infos = @@ -805,11 +805,11 @@ let build_proof h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof env sigma do_finalize new_infos + build_proof do_finalize new_infos ] g | Cast(b,_,_) -> - build_proof env sigma do_finalize {dyn_infos with info = b } g + build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> let new_finalize dyn_infos = let new_infos = @@ -819,7 +819,7 @@ let build_proof in build_proof_args env sigma do_finalize new_infos in - build_proof env sigma new_finalize {dyn_infos with info = f } g + build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) @@ -839,12 +839,12 @@ let build_proof (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof env sigma do_finalize new_infos + build_proof do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof env sigma do_finalize dyn_infos g = + and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ pr_leconstr_env (pf_env g) (project g) dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -866,7 +866,7 @@ let build_proof {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in - build_proof env sigma do_finalize + build_proof do_finalize {dyn_infos with info = arg } g in @@ -879,19 +879,7 @@ let build_proof in (* observe_tac "build_proof" *) fun g -> - let env = pf_env g in - let sigma = project g in - build_proof env sigma (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g - - - - - - - - - - + build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g (* Proof of principles from structural functions *) @@ -1002,19 +990,18 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - Lemmas.start_proof + let pstate = Lemmas.start_proof ~ontop:None (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) evd - lemma_type; - ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); - evd - - + lemma_type + in + let pstate,_ = Pfedit.by (Proofview.V82.tactic prove_replacement) pstate in + let pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + pstate, evd let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = @@ -1028,7 +1015,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + evd := snd @@ generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = match e with | Option.IsNone -> diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1217ba0eba..e9a2c285d0 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -308,31 +308,30 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in - begin - Lemmas.start_proof + let pstate = + Lemmas.start_proof ~ontop:None new_princ_name (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (EConstr.of_constr new_principle_type) - ; - (* let _tim1 = System.get_time () in *) - let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams))); - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) + in + (* let _tim1 = System.get_time () in *) + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + let pstate,_ = Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) pstate in + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) - let open Proof_global in - let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in - match entries with - | [entry] -> - discard_current (); - (id,(entry,persistence)), hook - | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") - end + let open Proof_global in + let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pstate in + match entries with + | [entry] -> + let pstate = discard_current pstate in + (id,(entry,persistence)), hook, pstate + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof @@ -382,7 +381,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort InProp; register_with_sort InSet in - let ((id,(entry,g_kind)),hook) = + let ((id,(entry,g_kind)),hook,pstate) = build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in @@ -390,25 +389,9 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - save false new_princ_name entry ~hook uctx g_kind + save new_princ_name entry ~hook uctx g_kind with e when CErrors.noncritical e -> - begin - begin - try - let id = Proof_global.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Proof_global.discard_current () - else () - else () - with e when CErrors.noncritical e -> () - end; - raise (Defining_principle e) - end -(* defined () *) - + raise (Defining_principle e) exception Not_Rec @@ -537,7 +520,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ s::l_schemes -> s,l_schemes | _ -> anomaly (Pp.str "") in - let ((_,(const,_)),_) = + let ((_,(const,_)),_,pstate) = try build_functional_principle evd false first_type @@ -547,21 +530,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ _ _ _ -> ()) with e when CErrors.noncritical e -> - begin - begin - try - let id = Proof_global.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Proof_global.discard_current () - else () - else () - with e when CErrors.noncritical e -> () - end; - raise (Defining_principle e) - end + raise (Defining_principle e) in incr i; @@ -611,7 +580,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let ((_,(const,_)),_) = + let ((_,(const,_)),_,pstate) = build_functional_principle evd false diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 6f67ab4d8b..4e8cf80ed2 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -177,7 +177,7 @@ let () = (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function -| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in @@ -223,37 +223,34 @@ let warning_error names e = } VERNAC COMMAND EXTEND NewFunctionalScheme -| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] +| ![ proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - { + { fun ~pstate -> begin - try - Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - begin - match fas with - | (_,fun_name,_)::_ -> - begin - begin - make_graph (Smartlocate.global_with_alias fun_name) - end - ; - try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - CErrors.user_err Pp.(str "Cannot generate induction principle(s)") - | e when CErrors.noncritical e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e - - end + try + Functional_principles_types.build_scheme fas; pstate + with + | Functional_principles_types.No_graph_found -> + begin + match fas with + | (_,fun_name,_)::_ -> + begin + let pstate = make_graph ~pstate (Smartlocate.global_with_alias fun_name) in + try Functional_principles_types.build_scheme fas; pstate + with + | Functional_principles_types.No_graph_found -> + CErrors.user_err Pp.(str "Cannot generate induction principle(s)") + | e when CErrors.noncritical e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e; pstate + end | _ -> assert false (* we can only have non empty list *) - end - | e when CErrors.noncritical e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e + end + | e when CErrors.noncritical e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e; pstate end - } END (***** debug only ***) @@ -266,5 +263,6 @@ END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -| ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } +| ![ proof ] ["Generate" "graph" "for" reference(c)] -> + { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index f4807954a7..275b58f0aa 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -369,7 +369,7 @@ let add_pat_variables sigma pat typ env : Environ.env = let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in - let new_env = add_pat_variables env pat typ in + let new_env = add_pat_variables env pat typ in let res = fst ( Context.Rel.fold_outside diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index b69ca7080c..a5c19f3217 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -410,11 +410,11 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error with e when CErrors.noncritical e -> on_error names e -let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = +let register_struct ~pstate is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition + ComDefinition.do_definition ~ontop:pstate ~program_mode:false fname (Decl_kinds.Global,false,Decl_kinds.Definition) pl @@ -432,9 +432,9 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - evd,List.rev rev_pconstants + pstate, evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global false fixpoint_exprl; + let pstate = ComFixpoint.do_fixpoint ~ontop:pstate Global false fixpoint_exprl in let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> @@ -448,8 +448,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Evd.from_env (Global.env ()),[]) fixpoint_exprl in - evd,List.rev rev_pconstants - + pstate,evd,List.rev rev_pconstants + let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -638,10 +638,10 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = +let do_generate_principle ~pstate pconstants on_error register_built interactive_proof + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; - let _is_struct = + let pstate, _is_struct = match fixpoint_exprl with | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = @@ -665,8 +665,8 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; - false + then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, false + else pstate, false |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with @@ -689,8 +689,8 @@ let do_generate_principle pconstants on_error register_built interactive_proof true in if register_built - then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook; - true + then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true + else pstate, true | _ -> List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> match ord with @@ -707,10 +707,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let evd,pconstants = + let pstate,evd,pconstants = if register_built - then register_struct is_rec fixpoint_exprl - else (Evd.from_env (Global.env ()),pconstants) + then register_struct ~pstate is_rec fixpoint_exprl + else pstate, Evd.from_env (Global.env ()), pconstants in let evd = ref evd in generate_principle @@ -723,10 +723,11 @@ let do_generate_principle pconstants on_error register_built interactive_proof recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then begin derive_inversion fix_names; end; - true; + if register_built then + begin derive_inversion fix_names; end; + pstate, true in - () + pstate let rec add_args id new_args = CAst.map (function | CRef (qid,_) as b -> @@ -843,13 +844,14 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph (f_ref : GlobRef.t) = +let make_graph ~pstate (f_ref : GlobRef.t) = + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in let c,c_body = match f_ref with | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - let sigma, env = Pfedit.get_current_context () in raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) end | _ -> raise (UserError (None, str "Not a function reference") ) @@ -857,8 +859,7 @@ let make_graph (f_ref : GlobRef.t) = (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom!" | Some (body, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in + let env = Global.env () in let extern_body,extern_type = with_full_print (fun () -> (Constrextern.extern_constr false env sigma (EConstr.of_constr body), @@ -902,12 +903,11 @@ let make_graph (f_ref : GlobRef.t) = [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp = Constant.modpath c in - do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; + let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in (* We register the infos *) List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + expr_list; + pstate) let do_generate_principle = do_generate_principle [] warning_error true - - diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index f209fb19fd..acf85f539e 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -5,18 +5,16 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle : - bool -> - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - unit - +val do_generate_principle : pstate:Proof_global.t option -> + bool -> + (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> + Proof_global.t option -val functional_induction : +val functional_induction : bool -> EConstr.constr -> (EConstr.constr * EConstr.constr bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma - -val make_graph : GlobRef.t -> unit +val make_graph : pstate:Proof_global.t option -> GlobRef.t -> Proof_global.t option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index e34323abf4..40f66ce5eb 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -129,7 +129,7 @@ let get_locality = function | Local -> true | Global -> false -let save with_clean id const ?hook uctx (locality,_,kind) = +let save id const ?hook uctx (locality,_,kind) = let fix_exn = Future.fix_exn_of const.const_entry_body in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> @@ -143,7 +143,6 @@ let save with_clean id const ?hook uctx (locality,_,kind) = let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in - if with_clean then Proof_global.discard_current (); Lemmas.call_hook ?hook ~fix_exn uctx [] l r; definition_message id diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 12facc5744..9670cf1fa7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -43,8 +43,7 @@ val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr val save - : bool - -> Id.t + : Id.t -> Safe_typing.private_constants Entries.definition_entry -> ?hook:Lemmas.declaration_hook -> UState.t @@ -78,15 +77,12 @@ val find_Function_infos : Constant.t -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit - val update_Function : function_info -> unit - (** debugging *) val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t val pr_table : Environ.env -> Evd.evar_map -> Pp.t - (* val function_debug : bool ref *) val do_observe : unit -> bool val do_rewrite_dependent : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 37dbfec4c9..edb698280f 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -802,16 +802,16 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - Lemmas.start_proof + let (typ,_) = lemmas_types_infos.(i) in + let pstate = Lemmas.start_proof ~ontop:None lem_id (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd - typ; - ignore (Pfedit.by + typ in + let pstate = fst @@ Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i)))); - (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); + (proving_tac i))) pstate in + let _ = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global @@ -865,13 +865,13 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - Lemmas.start_proof lem_id + let pstate = Lemmas.start_proof ~ontop:None lem_id (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma - (fst lemmas_types_infos.(i)); - ignore (Pfedit.by + (fst lemmas_types_infos.(i)) in + let pstate = fst (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i)))) ; - (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); + (proving_tac i))) pstate) in + let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None in let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index e19741a4e9..3c2b03dfe0 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -72,7 +72,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Proof_global.Transparent,None))) +let defined pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Transparent ~idopt:None let def_of_const t = match (Constr.kind t) with @@ -228,6 +228,7 @@ let observe strm = let do_observe_tac s tac g = let goal = Printer.pr_goal g in + let s = s (pf_env g) (project g) in let lmsg = (str "recdef : ") ++ s in observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; @@ -252,8 +253,8 @@ let observe_tclTHENLIST s tacl = then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (s ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (s ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl @@ -268,11 +269,11 @@ let tclUSER tac is_mes l g = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l) in - observe_tclTHENLIST (str "tclUSER1") + observe_tclTHENLIST (fun _ _ -> str "tclUSER1") [ clear_tac; if is_mes - then observe_tclTHENLIST (str "tclUSER2") + then observe_tclTHENLIST (fun _ _ -> str "tclUSER2") [ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force Indfun_common.ltof_ref))]); @@ -394,12 +395,12 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) [] rev_context in let rev_ids = pf_get_new_ids (List.rev ids) g in let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (str "treat_case1") + observe_tclTHENLIST (fun _ _ -> str "treat_case1") [ h_intros (List.rev rev_ids); Proofview.V82.of_tactic (intro_using teq_id); onLastHypId (fun heq -> - observe_tclTHENLIST (str "treat_case2")[ + observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> @@ -426,6 +427,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = let sigma = project g in + let env = pf_env g in match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") | Proj _ -> user_err Pp.(str "Function cannot treat projections") @@ -441,18 +443,18 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | Prod _ -> begin try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -480,8 +482,8 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> @@ -503,10 +505,9 @@ and travel_args jinfo is_final continuation_tac infos = travel jinfo new_continuation_tac {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = - fun g -> observe_tac - (str jinfo.message ++ Printer.pr_leconstr_env (pf_env g) (project g) expr_info.info) - (travel_aux jinfo continuation_tac expr_info) g + (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) + (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -527,16 +528,16 @@ let rec prove_lt hyple g = in let y = List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in - observe_tclTHENLIST (str "prove_lt1")[ + observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (str "prove_lt") (prove_lt hyple) + observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( - observe_tclTHENLIST (str "prove_lt2")[ + observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) + (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) end @@ -552,26 +553,26 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = let h' = next_ident_away_in_goal (h'_id) ids in let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (str "destruct_bounds_aux1")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin - observe_tac (str "destruct_bounds_aux") + observe_tac (fun _ _ -> str "destruct_bounds_aux") (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ - observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); + observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (str "destruct_bounds_aux2")[ - observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ + observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); h_intros [k;h';def]; - observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (str "unfold functional") + observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); + observe_tac (fun _ _ -> str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference infos.func)])); ( - observe_tclTHENLIST (str "test")[ + observe_tclTHENLIST (fun _ _ -> str "test")[ list_rewrite true (List.fold_right (fun e acc -> (mkVar e,true)::acc) @@ -582,16 +583,16 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) (* ; *) - (observe_tac (str "finishing") + (observe_tac (fun _ _ -> str "finishing") (tclORELSE (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (str "calling prove_lt") (prove_lt hyple))))]) + (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) ] ] )end)) ] g | (_,v_bound)::l -> - observe_tclTHENLIST (str "destruct_bounds_aux3")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); @@ -599,7 +600,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p_hyp -> (onNthHypId 2 (fun p -> - observe_tclTHENLIST (str "destruct_bounds_aux4")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -623,32 +624,33 @@ let destruct_bounds infos = let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app1")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ continuation_tac infos; - observe_tac (str "first split") + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) + observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_others")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ continuation_tac infos; - observe_tac (str "first split") + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (str "destruct_bounds") (destruct_bounds infos) + observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos let terminate_letin (na,b,t,e) expr_info continuation_tac info g = let sigma = project g in + let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -693,7 +695,7 @@ let mkDestructEq : let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (str "mkDestructEq") + observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars env sigma = @@ -705,9 +707,10 @@ let mkDestructEq : let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in + let env = pf_env g in let f_is_present = try - check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -721,45 +724,46 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') + observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS destruct_tac - (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) + (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) )) with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) + (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) )) g let terminate_app_rec (f,args) expr_info continuation_tac _ g = let sigma = project g in - List.iter (check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids)) + let env = pf_env g in + List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (str "terminate_app_rec")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app_rec1")[ - observe_tac (str "first split") + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (str "destruct_bounds (3)") + observe_tac (fun _ _ -> str "destruct_bounds (3)") (destruct_bounds new_infos) ] else tclIDTAC ] g with Not_found -> - observe_tac (str "terminate_app_rec not found") (tclTHENS + observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) [ - observe_tclTHENLIST (str "terminate_app_rec2")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); Proofview.V82.of_tactic intro; onNthHypId 1 @@ -772,14 +776,14 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = (v,v_bound)::expr_info.values_and_bounds; args_assoc=(args,mkVar v)::expr_info.args_assoc } in - observe_tclTHENLIST (str "terminate_app_rec3")[ + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "terminate_app_rec4")[ - observe_tac (str "first split") + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ + observe_tac (fun _ _ -> str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (str "destruct_bounds (2)") + observe_tac (fun _ _ -> str "destruct_bounds (2)") (destruct_bounds new_infos) ] else @@ -789,12 +793,12 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = ) ) ]; - observe_tac (str "proving decreasing") ( + observe_tac (fun _ _ -> str "proving decreasing") ( tclTHENS (* proof of args < formal args *) (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) [ - observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (str "terminate_app_rec5") + observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); + observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") [ tclTRY(list_rewrite true (List.map @@ -830,7 +834,7 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) + observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in @@ -856,9 +860,9 @@ let rec prove_le g = let _,args = decompose_app sigma t in List.hd (List.tl args) in - observe_tclTHENLIST (str "prove_le")[ + observe_tclTHENLIST (fun _ _ -> str "prove_le")[ Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (str "prove_le (rec)") (prove_le) + observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) end; @@ -868,8 +872,8 @@ let rec prove_le g = let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC | (_,p,hp)::l -> - observe_tac (str "make_rewrite_list") (tclTHENS - (observe_tac (str "rewrite heq on " ++ Id.print p ) ( + observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS + (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( (fun g -> let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in @@ -886,16 +890,16 @@ let rec make_rewrite_list expr_info max = function CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; - observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) + observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (str "prove_le(2)") prove_le + observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ] ) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (str "make_rewrite") (tclTHENS + (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) + (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS (fun g -> let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in @@ -905,30 +909,30 @@ let make_rewrite expr_info l hp max = let def_na,_,_ = destProd sigma t in Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name in - observe_tac (str "general_rewrite_bindings") + observe_tac (fun _ _ -> str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(str "make_rewrite finalize") ( + [observe_tac(fun _ _ -> str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (str "make_rewrite")[ + (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (str "unfold functional") + observe_tac (fun _ _ -> str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference expr_info.func)])); (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (str "h_reflexivity") + (observe_tac (fun _ _ -> str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity) ) ])) ; - observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) + observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (str "prove_le (3)") prove_le + observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ]) ) @@ -937,7 +941,7 @@ let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_,p,_)::l -> - observe_tclTHENLIST (str "compute_max")[ + observe_tclTHENLIST (fun _ _ -> str "compute_max")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| max; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -954,17 +958,17 @@ let rec destruct_hex expr_info acc l = match List.rev acc with | [] -> tclIDTAC | (_,p,hp)::tl -> - observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) + observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end | (v,hex)::l -> - observe_tclTHENLIST (str "destruct_hex")[ + observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ Proofview.V82.of_tactic (simplest_case (mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> observe_tac - (str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) + (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v,p,hp)::acc) l) ) ) @@ -972,7 +976,7 @@ let rec destruct_hex expr_info acc l = let rec intros_values_eq expr_info acc = tclORELSE( - observe_tclTHENLIST (str "intros_values_eq")[ + observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hex -> (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) @@ -983,23 +987,17 @@ let rec intros_values_eq expr_info acc = )) let equation_others _ expr_info continuation_tac infos = - fun g -> - let env = pf_env g in - let sigma = project g in if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) + observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (fun g -> - let env = pf_env g in - let sigma = project g in - observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []) g)) g - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) g + (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) + then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos let equation_app_rec (f,args) expr_info continuation_tac info g = @@ -1008,19 +1006,19 @@ let equation_app_rec (f,args) expr_info continuation_tac info g = try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tac (str "app_rec found") (continuation_tac new_infos) g + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g with Not_found -> if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST (str "equation_app_rec") + observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) + observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] g else - observe_tclTHENLIST (str "equation_app_rec1")[ + observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) + observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] g end @@ -1104,7 +1102,7 @@ let termination_proof_header is_mes input_type ids args_id relation (h_intros args_id) (tclTHENS (observe_tac - (str "first assert") + (fun _ _ -> str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) (mkApp (delayed_force acc_rel, @@ -1116,7 +1114,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* accesibility proof *) tclTHENS (observe_tac - (str "second assert") + (fun _ _ -> str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) @@ -1124,26 +1122,26 @@ let termination_proof_header is_mes input_type ids args_id relation ) [ (* interactive proof that the relation is well_founded *) - observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id)); + observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) observe_tac - (str "apply wf_thm") + (fun _ _ -> str "apply wf_thm") (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; (* rest of the proof *) - observe_tclTHENLIST (str "rest of proof") - [observe_tac (str "generalize") + observe_tclTHENLIST (fun _ _ -> str "rest of proof") + [observe_tac (fun _ _ -> str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; - observe_tac (str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); + observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); h_intros args_id; Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) + observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ] ) g @@ -1222,8 +1220,8 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a g end -let get_current_subgoals_types () = - let p = Proof_global.give_me_the_proof () in +let get_current_subgoals_types pstate = + let p = Proof_global.give_me_the_proof pstate in let sgs,_,_,_,sigma = Proof.proof p in sigma, List.map (Goal.V82.abstract_type sigma) sgs @@ -1283,8 +1281,8 @@ let clear_goals sigma = List.map clear_goal -let build_new_goal_type () = - let sigma, sub_gls_types = get_current_subgoals_types () in +let build_new_goal_type pstate = + let sigma, sub_gls_types = get_current_subgoals_types pstate in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) @@ -1299,9 +1297,9 @@ let is_opaque_constant c = | Declarations.Def _ -> Proof_global.Transparent | Declarations.Primitive _ -> Proof_global.Opaque -let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Proof_global.get_current_proof_name () in + let current_proof_name = Proof_global.get_current_proof_name pstate in let name = match goal_name with | Some s -> s | None -> @@ -1325,11 +1323,10 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in - Proof_global.discard_all (); - build_proof (Evd.from_env env) + let pstate = build_proof env (Evd.from_env env) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - observe_tclTHENLIST (str "") + observe_tclTHENLIST (fun _ _ -> str "") [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); @@ -1353,7 +1350,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; - (observe_tac (str "finishing using") + (observe_tac (fun _ _ -> str "finishing using") ( tclCOMPLETE( tclFIRST[ @@ -1369,20 +1366,19 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ) ) g) -; - Lemmas.save_proof (Vernacexpr.Proved(opacity,None)); + in + let _pstate = Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None in + () in - Lemmas.start_proof + let pstate = Lemmas.start_proof ~ontop:(Some pstate) na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) - sigma gls_type - ~hook:(Lemmas.mk_hook hook); - if Indfun_common.is_strict_tcc () + sigma gls_type ~hook:(Lemmas.mk_hook hook) in + let pstate = if Indfun_common.is_strict_tcc () then - ignore (by (Proofview.V82.tactic (tclIDTAC))) + fst @@ by (Proofview.V82.tactic (tclIDTAC)) pstate else - begin - ignore (by (Proofview.V82.tactic begin + fst @@ by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) @@ -1398,14 +1394,12 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ) using_lemmas) ) tclIDTAC) - g end)) - end; + g end) pstate + in try - ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *) + Some (fst @@ by (Proofview.V82.tactic tclIDTAC) pstate) (* raises UserError _ if the proof is complete *) with UserError _ -> - defined () - - + defined pstate let com_terminate tcc_lemma_name @@ -1418,32 +1412,26 @@ let com_terminate thm_name using_lemmas nb_args ctx hook = - let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evd, env = Pfedit.get_current_context () in (* XXX *) - Lemmas.start_proof thm_name + let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = + let pstate = Lemmas.start_proof ~ontop:None thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook; - - ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); - ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num )))) + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook in + let pstate = fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) pstate in + fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num ))) pstate in - start_proof ctx tclIDTAC tclIDTAC; + let pstate = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in try - let sigma, new_goal_type = build_new_goal_type () in + let sigma, new_goal_type = build_new_goal_type pstate in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal start_proof sigma + open_new_goal pstate start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) - (new_goal_type); + (new_goal_type) with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - defined () - - - - + defined pstate let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1453,33 +1441,27 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) let terminate_constr = EConstr.of_constr terminate_constr in let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in - observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ + observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (str "simplest_case") + observe_tac (fun _ _ -> str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); - observe_tac (str "prove_eq") (cont_tactic x)]) g;; + observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; -let (com_eqn : int -> Id.t -> - GlobRef.t -> GlobRef.t -> GlobRef.t - -> Constr.t -> unit) = - fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> +let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = let open CVars in let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let evd, env = Pfedit.get_current_context () in (* XXX *) - let evd = Evd.from_ctx (Evd.evar_universe_context evd) in + let evd = Evd.from_ctx uctx in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - (Lemmas.start_proof eq_name (Global, false, Proof Lemma) - ~sign:(Environ.named_context_val env) - evd - (EConstr.of_constr equation_lemma_type); - ignore (by + let pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd + (EConstr.of_constr equation_lemma_type) in + let pstate = fst @@ by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) @@ -1506,15 +1488,16 @@ let (com_eqn : int -> Id.t -> ih = Id.of_string "______"; } ) - ))); + )) pstate in (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; -(* Pp.msgnl (str "eqn finished"); *) - );; + let _ = Flags.silently (fun () -> Lemmas.save_proof_proved ?proof:None ~pstate ~opaque:opacity ~idopt:None) () in + () +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : unit = + generate_induction_principle using_lemmas : Proof_global.t option = let open Term in let open Constr in let open CVars in @@ -1529,15 +1512,15 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) -(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) +(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) +(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) @@ -1562,14 +1545,16 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in - (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ _ _ = + (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) + let hook uctx _ _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in (* message "start second proof"; *) - let stop = - try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + let stop = + (* XXX: What is the correct way to get sign at hook time *) + let sign = Environ.named_context_val Global.(env ()) in + try com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> begin @@ -1601,14 +1586,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num in (* XXX STATE Why do we need this... why is the toplevel protection not enought *) funind_purify (fun () -> - com_terminate - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref - (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (Lemmas.mk_hook hook)) - () + let pstate = com_terminate + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + (EConstr.of_constr rec_arg_type) + relation rec_arg_num + term_id + using_lemmas + (List.length res_vars) + evd (Lemmas.mk_hook hook) + in pstate) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 549f1fc0e4..a006c2c354 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,6 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> unit + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> Proof_global.t option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0428f08138..f5098d2a34 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -53,6 +53,7 @@ let with_delayed_uconstr ist c tac = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -348,6 +349,7 @@ let constr_flags () = { Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } let refine_tac ist simple with_classes c = @@ -813,9 +815,9 @@ END TACTIC EXTEND transparent_abstract | [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> - Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end; } | [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> - Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } + Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end; } END (* ********************************************************************* *) @@ -913,9 +915,9 @@ END the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -| [ "Grab" "Existential" "Variables" ] +| ![ proof ] [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p)) pstate } END (* Shelves all the goals under focus. *) @@ -945,9 +947,9 @@ END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve -| [ "Unshelve" ] +| ![ proof ] [ "Unshelve" ] => { classify_as_proofstep } - -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } + -> { fun ~pstate -> Option.map (Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p)) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1098,8 +1100,8 @@ END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { Proof_global.compact_the_proof () } +| ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> + { fun ~pstate -> Option.map Proof_global.compact_the_proof pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 3a4b0571d4..523c7c8305 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -58,6 +58,7 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let map c env sigma = c env sigma in List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index a348e2cea4..7eb34158e8 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -374,20 +374,21 @@ let () = declare_int_option { optwrite = fun n -> print_info_trace := n; } -let vernac_solve n info tcom b = +let vernac_solve ~pstate n info tcom b = let open Goal_select in - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Feedback.feedback Feedback.AddedAxiom + let pstate, status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + Some pstate let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s @@ -434,12 +435,12 @@ let is_explicit_terminator = function TacSolve _ -> true | _ -> false } VERNAC { tactic_mode } EXTEND VernacSolve -| [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| ![ proof ] [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in - vernac_solve g n t def + Vernacentries.vernac_require_open_proof vernac_solve g n t def } -| [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| ![ proof ] [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => { let anon_abstracting_tac = is_anonymous_abstract t in let solving_tac = is_explicit_terminator t in @@ -449,7 +450,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve VtLater } -> { let t = rm_abstract t in - vernac_solve Goal_select.SelectAll n t def + Vernacentries.vernac_require_open_proof vernac_solve Goal_select.SelectAll n t def } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index a12dee48a8..de3a9c9fa9 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -80,25 +80,25 @@ GRAMMAR EXTEND Gram open Obligations -let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac -let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac +let obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.obligation ~ontop:pstate obl t) tac) +let next_obligation ~pstate obl tac = Some (with_tac (fun t -> Obligations.next_obligation ~ontop:pstate obl t) tac) let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) } VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| [ "Obligation" integer(num) withtac(tac) ] -> +| ![ proof ] [ "Obligation" integer(num) withtac(tac) ] -> { obligation (num, None, None) tac } -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> +| ![ proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } -| [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } +| ![ proof ] [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 86a227415a..469551809c 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -180,34 +180,34 @@ TACTIC EXTEND setoid_rewrite END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts a aeq n None None None } END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts a aeq n None None (Some lemma3) } END @@ -234,64 +234,64 @@ GRAMMAR EXTEND Gram END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None None } END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } END VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - | #[ atts = rewrite_attributes; ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { - add_setoid atts [] a aeq t n; + add_setoid atts [] a aeq t n } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> { - add_setoid atts binders a aeq t n; + add_setoid atts binders a aeq t n } - | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => { VtUnknown, VtNow } -> { - add_morphism_infer atts m n; + add_morphism_infer atts m n } - | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { - add_morphism atts [] m s n; + add_morphism atts [] m s n } - | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + | #[ atts = rewrite_attributes; ] ![ proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { - add_morphism atts binders m s n; + add_morphism atts binders m s n } END @@ -310,7 +310,12 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY -| [ "Print" "Rewrite" "HintDb" preident(s) ] -> - { let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) } +| ![ proof ] [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { (* This command should not use the proof env, keeping previous + behavior as requested in review. *) + fun ~pstate -> + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s); + pstate } END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 1bdba699f7..80070a7493 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1307,7 +1307,6 @@ let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) - let pr_glob_constr_pptac env sigma c = pr_glob_constr_env env c diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index b1d5c0252f..75565c1a34 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -618,7 +618,9 @@ let solve_remaining_by env sigma holes by = in (* Only solve independent holes *) let indep = List.map_filter map holes in - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly = false + ; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with | Genarg.GenArg (Genarg.Glbwit tag, tac) -> Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) @@ -1790,15 +1792,15 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance atts binders instance fields = +let anew_instance ~pstate atts binders instance fields = let program_mode = atts.program in - new_instance ~program_mode atts.polymorphic + new_instance ~pstate ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info -let declare_instance_refl atts binders a aeq n lemma = +let declare_instance_refl ~pstate atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance atts binders instance + in anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] let declare_instance_sym atts binders a aeq n lemma = @@ -1811,47 +1813,44 @@ let declare_instance_trans atts binders a aeq n lemma = in anew_instance atts binders instance [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation atts ?(binders=[]) a aeq n refl symm trans = +let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance atts binders instance []); + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in + let _, pstate = anew_instance ~pstate atts binders instance [] in match (refl,symm,trans) with - (None, None, None) -> () + (None, None, None) -> pstate | (Some lemma1, None, None) -> - ignore (declare_instance_refl atts binders a aeq n lemma1) + snd @@ declare_instance_refl ~pstate atts binders a aeq n lemma1 | (None, Some lemma2, None) -> - ignore (declare_instance_sym atts binders a aeq n lemma2) + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (None, None, Some lemma3) -> - ignore (declare_instance_trans atts binders a aeq n lemma3) + snd @@ declare_instance_trans ~pstate atts binders a aeq n lemma3 | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl atts binders a aeq n lemma1); - ignore (declare_instance_sym atts binders a aeq n lemma2) + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + snd @@ declare_instance_sym ~pstate atts binders a aeq n lemma2 | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance atts binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)] | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance atts binders instance + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)]) + (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)] | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance atts binders instance + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n lemma1 in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n lemma2 in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)] let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) @@ -1947,18 +1946,18 @@ let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid atts binders a aeq t n = +let add_setoid ~pstate atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl, pstate = declare_instance_refl ~pstate atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym, pstate = declare_instance_sym ~pstate atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans, pstate = declare_instance_trans ~pstate atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance atts binders instance + in + snd @@ anew_instance ~pstate atts binders instance [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] let make_tactic name = @@ -1970,7 +1969,7 @@ let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer atts m n = +let add_morphism_infer ~pstate atts m n : Proof_global.t option = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); (* NB: atts.program is ignored, program mode automatically set by vernacentries *) @@ -1981,45 +1980,47 @@ let add_morphism_infer atts m n = if Lib.is_modtype () then let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,(instance,uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) + (Entries.ParameterEntry + (None,(instance,uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); + declare_projection n instance_id (ConstRef cst); + pstate else let kind = Decl_kinds.Global, atts.polymorphic, - Decl_kinds.DefinitionBody Decl_kinds.Instance + Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ _ _ = function - | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false + declare_projection n instance_id (ConstRef cst) + | _ -> assert false in let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance); - ignore (Pfedit.by (Tacinterp.interp tac))) () + Flags.silently + (fun () -> + let pstate = Lemmas.start_proof ~ontop:pstate ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () -let add_morphism atts binders m s n = +let add_morphism ~pstate atts binders m s n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), - [cHole; s; m])) + [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance - None - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + let _, pstate = new_instance ~pstate ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance + None + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in + pstate (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 2457b265f0..a200cb5ced 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -81,18 +81,18 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : rewrite_attributes -> +val declare_relation : pstate:Proof_global.t option -> rewrite_attributes -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> unit + constr_expr option -> constr_expr option -> constr_expr option -> Proof_global.t option -val add_setoid : +val add_setoid : pstate:Proof_global.t option -> rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> unit + Id.t -> Proof_global.t option -val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> unit +val add_morphism_infer : pstate:Proof_global.t option -> rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t option -val add_morphism : - rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit +val add_morphism : pstate:Proof_global.t option -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> Proof_global.t option val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index b770b97384..814be64f81 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -48,7 +48,7 @@ let atactic n = else Aentryl (Pltac.tactic_expr, string_of_int n) type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Extend.symbol -> entry_name (** Quite ad-hoc *) let get_tacentry n m = diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index eac84f0543..4398fb14ab 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -138,9 +138,10 @@ let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () (* Signature for interpretation: val_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } let extract_trace ist = if is_traced () then match TacStore.get ist.extra f_trace with @@ -544,12 +545,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = let (_, dummy_proofview) = Proofview.init sigma [] in (* Again this is called at times with no open proof! *) - let name, poly = - try - let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in - name, poly - with | Proof_global.NoCurrentProof -> Id.of_string "tacinterp", false - in + let name, poly = Id.of_string "tacinterp", ist.poly in let (trace,_,_,_) = Proofview.apply ~name ~poly env (push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) term @@ -566,11 +562,13 @@ let constr_flags () = { fail_evar = true; expand_evars = true; program_mode = false; + polymorphic = false; } (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = - interp_gen kind ist false (constr_flags ()) env sigma c + let flags = { (constr_flags ()) with polymorphic = ist.Geninterp.poly } in + interp_gen kind ist false flags env sigma c let interp_constr = interp_constr_gen WithoutTypeConstraint @@ -582,6 +580,7 @@ let open_constr_use_classes_flags () = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let open_constr_no_classes_flags () = { @@ -590,6 +589,7 @@ let open_constr_no_classes_flags () = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let pure_open_constr_flags = { @@ -598,6 +598,7 @@ let pure_open_constr_flags = { fail_evar = false; expand_evars = false; program_mode = false; + polymorphic = false; } (* Interprets an open constr *) @@ -1021,6 +1022,7 @@ let type_uconstr ?(flags = (constr_flags ())) ltac_idents = closure.idents; ltac_genargs = Id.Map.empty; } in + let flags = { flags with polymorphic = ist.Geninterp.poly } in understand_ltac flags env sigma vars expected_type term end @@ -1146,6 +1148,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (* For extensions *) | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = @@ -1153,8 +1156,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let lfun = List.fold_right2 addvar alias.Tacenv.alias_args l ist.lfun in Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in @@ -1207,12 +1211,13 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ids = extract_ids [] ist.lfun Id.Set.empty in let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> let extra = TacStore.set extra f_trace trace in - let ist = { lfun = Id.Map.empty; extra = extra; } in + let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false (val_interp ~appl ist (Tacenv.interp_ltac r)) @@ -1260,6 +1265,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = (* Interprets an application node *) and interp_app loc ist fv largs : Val.t Ftactic.t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in if has_type fv (topwit wit_tacvalue) then @@ -1277,9 +1283,11 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = if List.is_empty lvar then begin wrap_error begin - let ist = { - lfun = newlfun; - extra = TacStore.set ist.extra f_trace []; } in + let ist = + { lfun = newlfun + ; poly + ; extra = TacStore.set ist.extra f_trace [] + } in Profile_ltac.do_profile "interp_app" trace ~count_call:false (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) @@ -1317,8 +1325,10 @@ and tactic_of_value ist vle = if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with | VFun (appl,trace,lfun,[],t) -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ist = { lfun = lfun; + poly; extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) @@ -1388,6 +1398,7 @@ and interp_letin ist llc u = (** [interp_match_success lz ist succ] interprets a single matching success (of type {!Tactic_matching.t}). *) and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in let lctxt = Id.Map.map interp_context context in let hyp_subst = Id.Map.map Value.of_constr terms in @@ -1396,9 +1407,11 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = val_interp ist lhs >>= fun v -> if has_type v (topwit wit_tacvalue) then match to_tacvalue v with | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in + let ist = + { lfun = lfun + ; poly + ; extra = TacStore.set ist.extra f_trace trace + } in let tac = eval_tactic ist t in let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) @@ -1872,7 +1885,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let default_ist () = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - { lfun = Id.Map.empty; extra = extra } + { lfun = Id.Map.empty; poly = false; extra = extra } let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) @@ -1912,11 +1925,12 @@ end let interp_tac_gen lfun avoid_ids debug t = + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in - let ist = { lfun = lfun; extra = extra } in + let ist = { lfun; poly; extra } in let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) @@ -2057,20 +2071,15 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun env sigma ty tac = + let eval lfun poly env sigma ty tac = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - let ist = { lfun = lfun; extra; } in + let ist = { lfun; poly; extra; } in let tac = interp_tactic ist tac in - (* XXX: This depends on the global state which is bad; the hooking - mechanism should be modified. *) - let name, poly = - try - let (_, poly, _) = Proof_global.get_current_persistence () in - let name = Proof_global.get_current_proof_name () in - name, poly - with | Proof_global.NoCurrentProof -> - Id.of_string "ltac_gen", false - in + (* EJGA: We sould 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 (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index d9c80bb835..22a092fa8b 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -39,9 +39,10 @@ module TacStore : Store.S with and type 'a field = 'a Geninterp.TacStore.field (** Signature for interpretation: val\_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } +type interp_sign = Geninterp.interp_sign = + { lfun : value Id.Map.t + ; poly : bool + ; extra : TacStore.t } open Genintern diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 52a83a038f..04f3116664 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -370,7 +370,10 @@ let explain_ltac_call_trace last trace loc = strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - let sigma, env = Pfedit.get_current_context () in + (* XXX: This hooks into the ExplainErr extension API + so it is tricky to provide the right env for now. *) + let env = Global.env () in + let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v new file mode 100644 index 0000000000..47fcac6481 --- /dev/null +++ b/plugins/micromega/DeclConstant.v @@ -0,0 +1,68 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \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) *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2019 *) +(* *) +(************************************************************************) + +(** Declaring 'allowed' terms using type classes. + + Motivation: reification needs to know which terms are allowed. + For 'lia', the constant are only the integers built from Z0, Zpos, Zneg, xH, xO, xI. + However, if the term is ground it may be convertible to an integer. + Thus we could allow i.e. sqrt z for some integer z. + + Proposal: for each type, the user declares using type-classes the set of allowed ground terms. + *) + +Require Import List. + +(** Declarative definition of constants. + These are ground terms (without variables) of interest. + e.g. nat is built from O and S + NB: this does not need to be restricted to constructors. + *) + +(** Ground terms (see [GT] below) are built inductively from declared constants. *) + +Class DeclaredConstant {T : Type} (F : T). + +Class GT {T : Type} (F : T). + +Instance GT_O {T : Type} (F : T) {DC : DeclaredConstant F} : GT F. +Defined. + +Instance GT_APP1 {T1 T2 : Type} (F : T1 -> T2) (A : T1) : + DeclaredConstant F -> + GT A -> GT (F A). +Defined. + +Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3) + {A1 : T1} {A2 : T2} {DC:DeclaredConstant F} : + GT A1 -> GT A2 -> GT (F A1 A2). +Defined. + +Require Import ZArith. + +Instance DO : DeclaredConstant O := {}. +Instance DS : DeclaredConstant S := {}. +Instance DxH: DeclaredConstant xH := {}. +Instance DxI: DeclaredConstant xI := {}. +Instance DxO: DeclaredConstant xO := {}. +Instance DZO: DeclaredConstant Z0 := {}. +Instance DZpos: DeclaredConstant Zpos := {}. +Instance DZneg: DeclaredConstant Zneg := {}. +Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. + +Require Import QArith. + +Instance DQ : DeclaredConstant Qmake := {}. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index eb84b1203d..36ed0210e3 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -594,7 +594,7 @@ Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. - apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). @@ -1085,7 +1085,7 @@ Section POWER. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index dd6319d5c4..1582ec554e 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -18,6 +18,7 @@ Require Import ZMicromega. Require Import ZArith. Require Import RingMicromega. Require Import VarMap. +Require Import DeclConstant. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". @@ -25,18 +26,22 @@ Declare ML Module "micromega_plugin". Ltac preprocess := zify ; unfold Z.succ in * ; unfold Z.pred in *. -Ltac zchange := +Ltac zchange checker := intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit). + change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (checker __ff __wit). -Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. +Ltac zchecker_no_abstract checker := + zchange checker ; vm_compute ; reflexivity. -Ltac zchecker_abstract := abstract (zchange ; vm_cast_no_check (eq_refl true)). +Ltac zchecker_abstract checker := + abstract (zchange checker ; vm_cast_no_check (eq_refl true)). -Ltac zchecker := zchecker_no_abstract. +Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound. -Ltac lia := preprocess; xlia zchecker. +Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound. + +Ltac lia := preprocess; xlia zchecker_ext. Ltac nia := preprocess; xnlia zchecker. diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v index caaec541eb..f3cd24be8a 100644 --- a/plugins/micromega/Lqa.v +++ b/plugins/micromega/Lqa.v @@ -18,12 +18,13 @@ Require Import QMicromega. Require Import QArith. Require Import RingMicromega. Require Import VarMap. +Require Import DeclConstant. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac rchange := intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + change (Tauto.eval_bf (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit). Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v index 4ff483fbab..72e29319ff 100644 --- a/plugins/micromega/Lra.v +++ b/plugins/micromega/Lra.v @@ -24,7 +24,7 @@ Declare ML Module "micromega_plugin". Ltac rchange := intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + change (Tauto.eval_bf (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit). Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 5f01f981ef..6112eda200 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -54,8 +54,10 @@ Extract Constant Rinv => "fun x -> 1 / x". (** In order to avoid annoying build dependencies the actual extraction is only performed as a test in the test suite. *) (*Extraction "micromega.ml" -(*Recursive Extraction*) List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + List.map simpl_cone (*map_cone indexes*) + denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) (* Local Variables: *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index 62505453f9..e0e2232be5 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -87,40 +87,40 @@ Notation "x < y" := (rlt x y). Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. -exact sor.(SORle_wd). +exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. -exact sor.(SORlt_wd). +exact (SORlt_wd sor). Qed. -Add Ring SOR : sor.(SORrt). +Add Ring SOR : (SORrt sor). Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. intros x1 x2 H1 y1 y2 H2. -rewrite (sor.(SORrt).(Rsub_def) x1 y1). -rewrite (sor.(SORrt).(Rsub_def) x2 y2). +rewrite ((Rsub_def (SORrt sor)) x1 y1). +rewrite ((Rsub_def (SORrt sor)) x2 y2). rewrite H1; now rewrite H2. Qed. @@ -180,22 +180,22 @@ Qed. (* Relations *) Theorem Rle_refl : forall n : R, n <= n. -Proof sor.(SORle_refl). +Proof (SORle_refl sor). Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. -Proof sor.(SORle_antisymm). +Proof (SORle_antisymm sor). Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. -Proof sor.(SORle_trans). +Proof (SORle_trans sor). Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. -Proof sor.(SORlt_trichotomy). +Proof (SORlt_trichotomy sor). Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. -Proof sor.(SORlt_le_neq). +Proof (SORlt_le_neq sor). Theorem Rneq_0_1 : 0 ~= 1. -Proof sor.(SORneq_0_1). +Proof (SORneq_0_1 sor). Theorem Req_em : forall n m : R, n == m \/ n ~= m. Proof. @@ -274,8 +274,8 @@ Qed. Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. Proof. intros n m p; split. -apply sor.(SORplus_le_mono_l). -intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. +apply (SORplus_le_mono_l sor). +intro H. apply ((SORplus_le_mono_l sor) (p + n) (p + m) (- p)) in H. setoid_replace (- p + (p + n)) with n in H by ring. setoid_replace (- p + (p + m)) with m in H by ring. assumption. Qed. @@ -375,7 +375,7 @@ Qed. (* Times and order *) Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. -Proof sor.(SORtimes_pos_pos). +Proof (SORtimes_pos_pos sor). Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. Proof. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 2880a05d8d..0d593a321c 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -173,6 +173,7 @@ Qed. Require Import Coq.micromega.Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. + Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. @@ -182,30 +183,36 @@ Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Declare Equivalent Keys normQ RingMicromega.norm. +Definition cnfQ (Annot TX AF: Type) (f: TFormula (Formula Q) Annot TX AF) := + rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) + @tauto_checker (Formula Q) (NFormula Q) unit qunsat qdeduce - Qnormalise - Qnegate QWitness QWeakChecker f w. + (Qnormalise unit) + (Qnegate unit) QWitness (fun cl => QWeakChecker (List.map fst cl)) f w. -Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. +Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf (Qeval_formula env) f. Proof. intros f w. unfold QTautoChecker. - apply (tauto_checker_sound Qeval_formula Qeval_nformula). - apply Qeval_nformula_dec. - intros until env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). - intros t w0. - apply QWeakChecker_sound. + apply tauto_checker_sound with (eval:= Qeval_formula) (eval':= Qeval_nformula). + - apply Qeval_nformula_dec. + - intros until env. + unfold eval_nformula. unfold RingMicromega.eval_nformula. + destruct t. + apply (check_inconsistent_sound Qsor QSORaddon) ; auto. + - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). + - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_normalise_correct Qsor QSORaddon);eauto. + - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := Qeval_nformula env). + eapply QWeakChecker_sound; eauto. + tauto. Qed. (* Local Variables: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index c2b40c730f..7704e42d40 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -17,10 +17,11 @@ Require Import OrderedRing. Require Import RingMicromega. Require Import Refl. -Require Import Raxioms RIneq Rpow_def DiscrR. +Require Import Raxioms Rfunctions RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. Require Import Qreals. +Require Import DeclConstant. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -57,8 +58,6 @@ Proof. now apply Rmult_lt_0_compat. Qed. -Notation IQR := Q2R (only parsing). - Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. @@ -66,13 +65,13 @@ Proof. apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> Q2R x = Q2R y. Proof. intros. now apply Qeq_eqR, Qeq_bool_eq. Qed. -Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. +Lemma Qeq_false : forall x y, Qeq_bool x y = false -> Q2R x <> Q2R y. Proof. intros. apply Qeq_bool_neq in H. @@ -80,24 +79,24 @@ Proof. now apply eqR_Qeq. Qed. -Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. +Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> Q2R x <= Q2R y. Proof. intros. now apply Qle_Rle, Qle_bool_imp_le. Qed. -Lemma IQR_0 : IQR 0 = 0. +Lemma Q2R_0 : Q2R 0 = 0. Proof. apply Rmult_0_l. Qed. -Lemma IQR_1 : IQR 1 = 1. +Lemma Q2R_1 : Q2R 1 = 1. Proof. compute. apply Rinv_1. Qed. -Lemma IQR_inv_ext : forall x, - IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). +Lemma Q2R_inv_ext : forall x, + Q2R (/ x) = (if Qeq_bool x 0 then 0 else / Q2R x). Proof. intros. case_eq (Qeq_bool x 0). @@ -120,12 +119,12 @@ Lemma QSORaddon : R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) Qeq_bool Qle_bool - IQR nat to_nat pow. + Q2R nat to_nat pow. Proof. constructor. constructor ; intros ; try reflexivity. - apply IQR_0. - apply IQR_1. + apply Q2R_0. + apply Q2R_1. apply Q2R_plus. apply Q2R_minus. apply Q2R_mult. @@ -136,20 +135,27 @@ Proof. apply Qle_true. Qed. +(* Syntactic ring coefficients. *) -(* Syntactic ring coefficients. - For computing, we use Q. *) Inductive Rcst := -| C0 -| C1 -| CQ (r : Q) -| CZ (r : Z) -| CPlus (r1 r2 : Rcst) -| CMinus (r1 r2 : Rcst) -| CMult (r1 r2 : Rcst) -| CInv (r : Rcst) -| COpp (r : Rcst). - + | C0 + | C1 + | CQ (r : Q) + | CZ (r : Z) + | CPlus (r1 r2 : Rcst) + | CMinus (r1 r2 : Rcst) + | CMult (r1 r2 : Rcst) + | CPow (r1 : Rcst) (z:Z+nat) + | CInv (r : Rcst) + | COpp (r : Rcst). + + + +Definition z_of_exp (z : Z + nat) := + match z with + | inl z => z + | inr n => Z.of_nat n + end. Fixpoint Q_of_Rcst (r : Rcst) : Q := match r with @@ -160,42 +166,198 @@ Fixpoint Q_of_Rcst (r : Rcst) : Q := | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) - | CInv r => Qinv (Q_of_Rcst r) + | CPow r1 z => Qpower (Q_of_Rcst r1) (z_of_exp z) + | CInv r => Qinv (Q_of_Rcst r) | COpp r => Qopp (Q_of_Rcst r) end. +Definition is_neg (z: Z+nat) := + match z with + | inl (Zneg _) => true + | _ => false + end. + +Lemma is_neg_true : forall z, is_neg z = true -> (z_of_exp z < 0)%Z. +Proof. + destruct z ; simpl ; try congruence. + destruct z ; try congruence. + intros. + reflexivity. +Qed. + +Lemma is_neg_false : forall z, is_neg z = false -> (z_of_exp z >= 0)%Z. +Proof. + destruct z ; simpl ; try congruence. + destruct z ; try congruence. + compute. congruence. + compute. congruence. + generalize (Zle_0_nat n). auto with zarith. +Qed. + +Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1). + +Definition CPowR0 (z : Z) (r : Rcst) := + Z.ltb z Z0 && Qeq_bool (Q_of_Rcst r) (0 # 1). + Fixpoint R_of_Rcst (r : Rcst) : R := match r with | C0 => R0 | C1 => R1 | CZ z => IZR z - | CQ q => IQR q + | CQ q => Q2R q | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) + | CPow r1 z => + match z with + | inl z => + if CPowR0 z r1 + then R0 + else powerRZ (R_of_Rcst r1) z + | inr n => pow (R_of_Rcst r1) n + end | CInv r => - if Qeq_bool (Q_of_Rcst r) (0 # 1) - then R0 - else Rinv (R_of_Rcst r) - | COpp r => - (R_of_Rcst r) + if CInvR0 r then R0 + else Rinv (R_of_Rcst r) + | COpp r => - (R_of_Rcst r) end. -Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c. +Add Morphism Q2R with signature Qeq ==> @eq R as Q2R_m. + exact Qeq_eqR. +Qed. + +Lemma Q2R_pow_pos : forall q p, + Q2R (pow_pos Qmult q p) = pow_pos Rmult (Q2R q) p. +Proof. + induction p ; simpl;auto; + rewrite <- IHp; + repeat rewrite Q2R_mult; + reflexivity. +Qed. + +Lemma Q2R_pow_N : forall q n, + Q2R (pow_N 1%Q Qmult q n) = pow_N 1 Rmult (Q2R q) n. +Proof. + destruct n ; simpl. + - apply Q2R_1. + - apply Q2R_pow_pos. +Qed. + +Lemma Qmult_integral : forall q r, q * r == 0 -> q == 0 \/ r == 0. +Proof. + intros. + destruct (Qeq_dec q 0)%Q. + - left ; apply q0. + - apply Qmult_integral_l in H ; tauto. +Qed. + +Lemma Qpower_positive_eq_zero : forall q p, + Qpower_positive q p == 0 -> q == 0. +Proof. + unfold Qpower_positive. + induction p ; simpl; intros; + repeat match goal with + | H : _ * _ == 0 |- _ => + apply Qmult_integral in H; destruct H + end; tauto. +Qed. + +Lemma Qpower_positive_zero : forall p, + Qpower_positive 0 p == 0%Q. +Proof. + induction p ; simpl; + try rewrite IHp ; reflexivity. +Qed. + + +Lemma Q2RpowerRZ : + forall q z + (DEF : not (q == 0)%Q \/ (z >= Z0)%Z), + Q2R (q ^ z) = powerRZ (Q2R q) z. +Proof. + intros. + destruct Qpower_theory. + destruct R_power_theory. + unfold Qpower, powerRZ. + destruct z. + - apply Q2R_1. + - + change (Qpower_positive q p) + with (Qpower q (Zpos p)). + rewrite <- N2Z.inj_pos. + rewrite <- positive_N_nat. + rewrite rpow_pow_N. + rewrite rpow_pow_N0. + apply Q2R_pow_N. + - + rewrite Q2R_inv. + unfold Qpower_positive. + rewrite <- positive_N_nat. + rewrite rpow_pow_N0. + unfold pow_N. + rewrite Q2R_pow_pos. + auto. + intro. + apply Qpower_positive_eq_zero in H. + destruct DEF ; auto with arith. +Qed. + +Lemma Qpower0 : forall z, (z <> 0)%Z -> (0 ^ z == 0)%Q. Proof. - induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). - apply IQR_0. - apply IQR_1. + unfold Qpower. + destruct z;intros. + - congruence. + - apply Qpower_positive_zero. + - rewrite Qpower_positive_zero. reflexivity. - unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply Q2R_plus. - apply Q2R_minus. - apply Q2R_mult. - rewrite <- IHc. - apply IQR_inv_ext. - rewrite <- IHc. +Qed. + + +Lemma Q_of_RcstR : forall c, Q2R (Q_of_Rcst c) = R_of_Rcst c. +Proof. + induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). + - apply Q2R_0. + - apply Q2R_1. + - reflexivity. + - unfold Q2R. simpl. rewrite Rinv_1. reflexivity. + - apply Q2R_plus. + - apply Q2R_minus. + - apply Q2R_mult. + - destruct z. + destruct (CPowR0 z c) eqn:C; unfold CPowR0 in C. + + + rewrite andb_true_iff in C. + destruct C as (C1 & C2). + rewrite Z.ltb_lt in C1. + apply Qeq_bool_eq in C2. + rewrite C2. + simpl. + rewrite Qpower0 by auto with zarith. + apply Q2R_0. + + rewrite Q2RpowerRZ. + rewrite IHc. + reflexivity. + rewrite andb_false_iff in C. + destruct C. + simpl. apply Z.ltb_ge in H. + auto with zarith. + left ; apply Qeq_bool_neq; auto. + + simpl. + rewrite <- IHc. + destruct Qpower_theory. + rewrite <- nat_N_Z. + rewrite rpow_pow_N. + destruct R_power_theory. + rewrite <- (Nnat.Nat2N.id n) at 2. + rewrite rpow_pow_N0. + apply Q2R_pow_N. + - rewrite <- IHc. + unfold CInvR0. + apply Q2R_inv_ext. + - rewrite <- IHc. apply Q2R_opp. - Qed. +Qed. Require Import EnvRing. @@ -227,7 +389,7 @@ Definition Reval_formula' := eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. Definition QReval_formula := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow . + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow . Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. Proof. @@ -242,12 +404,12 @@ Proof. Qed. Definition Qeval_nformula := - eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IQR. + eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt Q2R. Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. - exact (fun env d =>eval_nformula_dec Rsor IQR env d). + exact (fun env d =>eval_nformula_dec Rsor Q2R env d). Qed. Definition RWitness := Psatz Q. @@ -279,32 +441,41 @@ Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) - runsat rdeduce - Rnormalise Rnegate - RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst) f) w. + unit runsat rdeduce + (Rnormalise unit) (Rnegate unit) + RWitness (fun cl => RWeakChecker (List.map fst cl)) (map_bformula (map_Formula Q_of_Rcst) f) w. -Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. +Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. Proof. intros f w. unfold RTautoChecker. intros TC env. - apply (tauto_checker_sound QReval_formula Qeval_nformula) with (env := env) in TC. - rewrite eval_f_map in TC. - rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. + apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. + - change (eval_f (fun x : Prop => x) (QReval_formula env)) + with + (eval_bf (QReval_formula env)) in TC. + rewrite eval_bf_map in TC. + unfold eval_bf in TC. + rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. intro. unfold QReval_formula. rewrite <- eval_formulaSC with (phiS := R_of_Rcst). rewrite Reval_formula_compat. tauto. intro. rewrite Q_of_RcstR. reflexivity. + - apply Reval_nformula_dec. - destruct t. + - destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). - now apply (cnf_normalise_correct Rsor QSORaddon). - intros. now apply (cnf_negate_correct Rsor QSORaddon). - intros t w0. - apply RWeakChecker_sound. + - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). + - now apply (cnf_normalise_correct Rsor QSORaddon). + - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := Qeval_nformula env0). + eapply RWeakChecker_sound; eauto. + tauto. Qed. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 952a1b91e7..898a3a1a28 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -36,6 +36,21 @@ trivial. intro; apply IH. Qed. + +Theorem make_impl_map : + forall (A B: Type) (eval : A -> Prop) (eval' : A*B -> Prop) (l : list (A*B)) r + (EVAL : forall x, eval' x <-> eval (fst x)), + make_impl eval' l r <-> make_impl eval (List.map fst l) r. +Proof. +induction l as [| a l IH]; simpl. +- tauto. +- intros. + rewrite EVAL. + rewrite IH. + tauto. + auto. +Qed. + Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := match l with | nil => True diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 782fab5e68..60931df517 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -81,30 +81,30 @@ Record SORaddon := mk_SOR_addon { Variable addon : SORaddon. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. - exact sor.(SORle_wd). + exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. - exact sor.(SORlt_wd). + exact (SORlt_wd sor). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. @@ -124,12 +124,12 @@ Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. Proof. - exact addon.(SORcleb_morph). + exact (SORcleb_morph addon). Qed. Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. Proof. -intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. +intros x y H1. apply (SORcneqb_morph addon). unfold cneqb, negb in H1. destruct (ceqb x y); now try discriminate. Qed. @@ -325,9 +325,9 @@ Definition map_option2 (A B C : Type) (f : A -> B -> option C) Arguments map_option2 [A B C] f o o'. Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor). Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := let (ef,o) := f in @@ -368,8 +368,8 @@ Proof. destruct f. intros. destruct o ; inversion H0 ; try discriminate. simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + rewrite (Pmul_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). rewrite H. apply (Rtimes_0_r sor). Qed. @@ -385,8 +385,8 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Pmul_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); apply OpMult_sound with (3:= H);assumption. Qed. @@ -402,8 +402,8 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Padd_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Padd_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); apply OpAdd_sound with (3:= H);assumption. Qed. @@ -422,12 +422,12 @@ Proof. (* index is out-of-bounds *) inversion H0. rewrite Heq. simpl. - now apply addon.(SORrm).(morph0). + now apply (morph0 (SORrm addon)). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Psquare_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. @@ -454,11 +454,11 @@ Proof. simpl. intro. case_eq (cO [<] c). intros. inversion H1. simpl. - rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. discriminate. (* PsatzZ *) simpl. intros. inversion H0. - simpl. apply addon.(SORrm).(morph0). + simpl. apply (morph0 (SORrm addon)). Qed. Fixpoint ge_bool (n m : nat) : bool := @@ -529,8 +529,8 @@ Proof. inv H. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Psquare_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl in *. @@ -570,12 +570,12 @@ Proof. case_eq (cO [<] c). intros. rewrite H1 in H. inv H. unfold eval_nformula. simpl. - rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. intros. rewrite H1 in H. discriminate. (* PsatzZ *) simpl in *. inv H. unfold eval_nformula. simpl. - apply addon.(SORrm).(morph0). + apply (morph0 (SORrm addon)). Qed. @@ -592,19 +592,19 @@ Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor) in + PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) + (SORrm addon). Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor) in + PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) + (SORrm addon). (* Check that a formula f is inconsistent by normalizing and comparing the @@ -631,9 +631,9 @@ intros p op H1 env. unfold check_inconsistent in H1. destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; -try rewrite <- addon.(SORrm).(morph0); trivial. +try rewrite <- (morph0 (SORrm addon)); trivial. now apply cneqb_sound. -apply addon.(SORrm).(morph_eq) in H1. congruence. +apply (morph_eq (SORrm addon)) in H1. congruence. apply cleb_sound in H1. now apply -> (Rle_ngt sor). apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. @@ -706,6 +706,8 @@ Definition psub := Psub cO cplus cminus copp ceqb. Definition padd := Padd cO cplus ceqb. +Definition pmul := Pmul cO cI cplus ctimes ceqb. + Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in @@ -736,21 +738,30 @@ let (lhs, op, rhs) := f in Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. - apply (Psub_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + apply (Psub_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. - apply (Padd_ok sor.(SORsetoid) Rops_wd + apply (Padd_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). +Qed. + +Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) == eval_pol env lhs * eval_pol env rhs. +Proof. + intros. + apply (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. + + Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). Proof. intros. - apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). + apply (norm_aux_spec (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon) (SORpower addon) ). Qed. @@ -801,29 +812,29 @@ Definition xnormalise (t:Formula C) : list (NFormula) := Import Coq.micromega.Tauto. -Definition cnf_normalise (t:Formula C) : cnf (NFormula) := - List.map (fun x => x::nil) (xnormalise t). +Definition cnf_normalise {T : Type} (t:Formula C) (tg : T) : cnf NFormula T := + List.map (fun x => (x,tg)::nil) (xnormalise t). -Add Ring SORRing : sor.(SORrt). +Add Ring SORRing : (SORrt sor). -Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t. +Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) -> eval_formula env t. Proof. - unfold cnf_normalise, xnormalise ; simpl ; intros env t. + unfold cnf_normalise, xnormalise ; simpl ; intros T env t tg. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; simpl; + destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; + simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. - (**) - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - now rewrite <- (Rminus_eq_0 sor). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + - apply (SORle_antisymm sor). + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + - now rewrite <- (Rminus_eq_0 sor). + - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. Qed. Definition xnegate (t:Formula C) : list (NFormula) := @@ -839,30 +850,27 @@ Definition xnegate (t:Formula C) : list (NFormula) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition cnf_negate (t:Formula C) : cnf (NFormula) := - List.map (fun x => x::nil) (xnegate t). +Definition cnf_negate {T : Type} (t:Formula C) (tg:T) : cnf NFormula T := + List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t. +Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) -> ~ eval_formula env t. Proof. - unfold cnf_negate, xnegate ; simpl ; intros env t. + unfold cnf_negate, xnegate ; simpl ; intros T env t tg. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; simpl; + destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. - (**) + - apply H0. rewrite H1 ; ring. - (**) - apply H1. - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - (**) - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + - apply H1. apply (SORle_antisymm sor). + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + - apply H0. now rewrite (Rle_le_minus sor) in H1. + - apply H0. now rewrite (Rle_le_minus sor) in H1. + - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + - apply H0. now rewrite (Rlt_lt_minus sor) in H1. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). @@ -912,7 +920,7 @@ Proof. unfold Env.nth. unfold jump at 2. rewrite <- Pos.add_1_l. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite (rpow_pow_N (SORpower addon)). unfold pow_N. ring. Qed. @@ -932,7 +940,7 @@ Proof. unfold Env.tail. rewrite xdenorm_correct. change (Pos.succ xH) with 2%positive. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite (rpow_pow_N (SORpower addon)). simpl. reflexivity. Qed. diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 587f2f1fa4..7b9b88c0fe 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -10,7 +10,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-20019 *) (* *) (************************************************************************) @@ -21,176 +21,363 @@ Require Import Bool. Set Implicit Arguments. +Section S. + Context {TA : Type}. (* type of interpreted atoms *) + Context {TX : Type}. (* type of uninterpreted terms (Prop) *) + Context {AA : Type}. (* type of annotations for atoms *) + Context {AF : Type}. (* type of formulae identifiers *) + #[universes(template)] - Inductive BFormula (A:Type) : Type := - | TT : BFormula A - | FF : BFormula A - | X : Prop -> BFormula A - | A : A -> BFormula A - | Cj : BFormula A -> BFormula A -> BFormula A - | D : BFormula A-> BFormula A -> BFormula A - | N : BFormula A -> BFormula A - | I : BFormula A-> BFormula A-> BFormula A. - - Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := - match f with - | TT _ => True - | FF _ => False - | A a => ev a - | X _ p => p - | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) - | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) - | N e => ~ (eval_f ev e) - | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) - end. + Inductive GFormula : Type := + | TT : GFormula + | FF : GFormula + | X : TX -> GFormula + | A : TA -> AA -> GFormula + | Cj : GFormula -> GFormula -> GFormula + | D : GFormula -> GFormula -> GFormula + | N : GFormula -> GFormula + | I : GFormula -> option AF -> GFormula -> GFormula. + + Section MAPX. + Variable F : TX -> TX. + + Fixpoint mapX (f : GFormula) : GFormula := + match f with + | TT => TT + | FF => FF + | X x => X (F x) + | A a an => A a an + | Cj f1 f2 => Cj (mapX f1) (mapX f2) + | D f1 f2 => D (mapX f1) (mapX f2) + | N f => N (mapX f) + | I f1 o f2 => I (mapX f1) o (mapX f2) + end. - Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A), - (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). - Proof. - induction f ; simpl ; try tauto. - intros. - assert (H' := H a). - auto. - Qed. + End MAPX. + + Section FOLDANNOT. + Variable ACC : Type. + Variable F : ACC -> AA -> ACC. + + Fixpoint foldA (f : GFormula) (acc : ACC) : ACC := + match f with + | TT => acc + | FF => acc + | X x => acc + | A a an => F acc an + | Cj f1 f2 + | D f1 f2 + | I f1 _ f2 => foldA f1 (foldA f2 acc) + | N f => foldA f acc + end. + End FOLDANNOT. - Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := + Definition cons_id (id : option AF) (l : list AF) := + match id with + | None => l + | Some id => id :: l + end. + + Fixpoint ids_of_formula f := match f with - | TT _ => TT _ - | FF _ => FF _ - | X _ p => X _ p - | A a => A (fct a) - | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) - | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) - | N f => N (map_bformula fct f) - | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2) + | I f id f' => cons_id id (ids_of_formula f') + | _ => nil end. - Lemma eval_f_map : forall T U (fct: T-> U) env f , - eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f. - Proof. - induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. - rewrite <- IHf. auto. - Qed. + Fixpoint collect_annot (f : GFormula) : list AA := + match f with + | TT | FF | X _ => nil + | A _ a => a ::nil + | Cj f1 f2 + | D f1 f2 + | I f1 _ f2 => collect_annot f1 ++ collect_annot f2 + | N f => collect_annot f + end. + Variable ex : TX -> Prop. (* [ex] will be the identity *) + Section EVAL. - Lemma map_simpl : forall A B f l, @map A B f l = match l with - | nil => nil - | a :: l=> (f a) :: (@map A B f l) - end. + Variable ea : TA -> Prop. + + Fixpoint eval_f (f:GFormula) {struct f}: Prop := + match f with + | TT => True + | FF => False + | A a _ => ea a + | X p => ex p + | Cj e1 e2 => (eval_f e1) /\ (eval_f e2) + | D e1 e2 => (eval_f e1) \/ (eval_f e2) + | N e => ~ (eval_f e) + | I f1 _ f2 => (eval_f f1) -> (eval_f f2) + end. + + + End EVAL. + + + + + + Lemma eval_f_morph : + forall (ev ev' : TA -> Prop) (f : GFormula), + (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). Proof. - destruct l ; reflexivity. + induction f ; simpl ; try tauto. + intros. + apply H. Qed. +End S. - Section S. - Variable Env : Type. - Variable Term : Type. - Variable eval : Env -> Term -> Prop. - Variable Term' : Type. - Variable eval' : Env -> Term' -> Prop. +(** Typical boolean formulae *) +Definition BFormula (A : Type) := @GFormula A Prop unit unit. +Section MAPATOMS. + Context {TA TA':Type}. + Context {TX : Type}. + Context {AA : Type}. + Context {AF : Type}. - Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). +Fixpoint map_bformula (fct : TA -> TA') (f : @GFormula TA TX AA AF ) : @GFormula TA' TX AA AF := + match f with + | TT => TT + | FF => FF + | X p => X p + | A a t => A (fct a) t + | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) + | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) + | N f => N (map_bformula fct f) + | I f1 a f2 => I (map_bformula fct f1) a (map_bformula fct f2) + end. - Variable unsat : Term' -> bool. +End MAPATOMS. - Variable unsat_prop : forall t, unsat t = true -> - forall env, eval' env t -> False. +Lemma map_simpl : forall A B f l, @map A B f l = match l with + | nil => nil + | a :: l=> (f a) :: (@map A B f l) + end. +Proof. + destruct l ; reflexivity. +Qed. - Variable deduce : Term' -> Term' -> option Term'. - Variable deduce_prop : forall env t t' u, - eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. +Section S. + (** A cnf tracking annotations of atoms. *) + + (** Type parameters *) + Variable Env : Type. + Variable Term : Type. + Variable Term' : Type. + Variable Annot : Type. + + Variable unsat : Term' -> bool. (* see [unsat_prop] *) + Variable deduce : Term' -> Term' -> option Term'. (* see [deduce_prop] *) - Definition clause := list Term'. - Definition cnf := list clause. + Definition clause := list (Term' * Annot). + Definition cnf := list clause. - Variable normalise : Term -> cnf. - Variable negate : Term -> cnf. + Variable normalise : Term -> Annot -> cnf. + Variable negate : Term -> Annot -> cnf. - Definition tt : cnf := @nil clause. - Definition ff : cnf := cons (@nil Term') nil. + Definition cnf_tt : cnf := @nil clause. + Definition cnf_ff : cnf := cons (@nil (Term' * Annot)) nil. + (** Our cnf is optimised and detects contradictions on the fly. *) - Fixpoint add_term (t: Term') (cl : clause) : option clause := + Fixpoint add_term (t: Term' * Annot) (cl : clause) : option clause := match cl with - | nil => - match deduce t t with - | None => Some (t ::nil) - | Some u => if unsat u then None else Some (t::nil) - end - | t'::cl => - match deduce t t' with - | None => - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - | Some u => - if unsat u then None else - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end + | nil => + match deduce (fst t) (fst t) with + | None => Some (t ::nil) + | Some u => if unsat u then None else Some (t::nil) + end + | t'::cl => + match deduce (fst t) (fst t') with + | None => + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') end + | Some u => + if unsat u then None else + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') + end + end end. Fixpoint or_clause (cl1 cl2 : clause) : option clause := match cl1 with - | nil => Some cl2 - | t::cl => match add_term t cl2 with - | None => None - | Some cl' => or_clause cl cl' - end + | nil => Some cl2 + | t::cl => match add_term t cl2 with + | None => None + | Some cl' => or_clause cl cl' + end end. -(* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. *) + (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := + List.map (fun x => (t++x)) f. *) Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_right (fun e acc => - match or_clause t e with - | None => acc - | Some cl => cl :: acc - end) nil f. + List.fold_right (fun e acc => + match or_clause t e with + | None => acc + | Some cl => cl :: acc + end) nil f. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with - | nil => tt - | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + | nil => cnf_tt + | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := f1 ++ f2. - Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := + (** TX is Prop in Coq and EConstr.constr in Ocaml. + AF i s unit in Coq and Names.Id.t in Ocaml + *) + Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF. + + Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF) {struct f}: cnf := match f with - | TT _ => if pol then tt else ff - | FF _ => if pol then ff else tt - | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) - | A x => if pol then normalise x else negate x - | N e => xcnf (negb pol) e - | Cj e1 e2 => - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + | TT => if pol then cnf_tt else cnf_ff + | FF => if pol then cnf_ff else cnf_tt + | X p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *) + | A x t => if pol then normalise x t else negate x t + | N e => xcnf (negb pol) e + | Cj e1 e2 => + (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) + | I e1 _ e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. - Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl. + Section CNFAnnot. + + (** Records annotations used to optimise the cnf. + Those need to be kept when pruning the formula. + For efficiency, this is a separate function. + *) + + + + Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot := + match cl with + | nil => (* if t is unsat, the clause is empty BUT t is needed. *) + match deduce (fst t) (fst t) with + | Some u => if unsat u then inr ((snd t)::nil) else inl (t::nil) + | None => inl (t::nil) + end + | t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *) + match deduce (fst t) (fst t') with + | Some u => if unsat u then inr ((snd t)::(snd t')::nil) + else match radd_term t cl with + | inl cl' => inl (t'::cl') + | inr l => inr l + end + | None => match radd_term t cl with + | inl cl' => inl (t'::cl') + | inr l => inr l + end + end + end. + + Fixpoint ror_clause cl1 cl2 := + match cl1 with + | nil => inl cl2 + | t::cl => match radd_term t cl2 with + | inl cl' => ror_clause cl cl' + | inr l => inr l + end + end. + + Definition ror_clause_cnf t f := + List.fold_right (fun e '(acc,tg) => + match ror_clause t e with + | inl cl => (cl :: acc,tg) + | inr l => (acc,tg++l) + end) (nil,nil) f . + + + Fixpoint ror_cnf f f' := + match f with + | nil => (cnf_tt,nil) + | e :: rst => + let (rst_f',t) := ror_cnf rst f' in + let (e_f', t') := ror_clause_cnf e f' in + (rst_f' ++ e_f', t ++ t') + end. + + Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) := + match f with + | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil) + | FF => if polarity then (cnf_ff,nil) else (cnf_tt,nil) + | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil) + | A x t => ((if polarity then normalise x t else negate x t),nil) + | N e => rxcnf (negb polarity) e + | Cj e1 e2 => + let (e1,t1) := rxcnf polarity e1 in + let (e2,t2) := rxcnf polarity e2 in + if polarity + then (e1 ++ e2, t1 ++ t2) + else let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + | D e1 e2 => + let (e1,t1) := rxcnf polarity e1 in + let (e2,t2) := rxcnf polarity e2 in + if polarity + then let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + else (e1 ++ e2, t1 ++ t2) + | I e1 _ e2 => + let (e1 , t1) := (rxcnf (negb polarity) e1) in + let (e2 , t2) := (rxcnf polarity e2) in + if polarity + then let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + else (and_cnf e1 e2, t1 ++ t2) + end. + + End CNFAnnot. + + + + Variable eval : Env -> Term -> Prop. + + Variable eval' : Env -> Term' -> Prop. + + Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). + + + Variable unsat_prop : forall t, unsat t = true -> + forall env, eval' env t -> False. + + + + Variable deduce_prop : forall env t t' u, + eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. + + + + Definition eval_tt (env : Env) (tt : Term' * Annot) := eval' env (fst tt). + + + Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval_tt env) cl. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - + Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. @@ -201,97 +388,107 @@ Set Implicit Arguments. Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with - | None => True - | Some cl => eval_clause env cl + | None => True + | Some cl => eval_clause env cl end. - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). - Proof. - induction cl. - (* BC *) - simpl. - case_eq (deduce t t) ; auto. - intros *. - case_eq (unsat t0) ; auto. - unfold eval_clause. - rewrite make_conj_cons. - intros. intro. - apply unsat_prop with (1:= H) (env := env). - apply deduce_prop with (3:= H0) ; tauto. - (* IC *) - simpl. - case_eq (deduce t a). - intro u. - case_eq (unsat u). - simpl. intros. - unfold eval_clause. - intro. - apply unsat_prop with (1:= H) (env:= env). - repeat rewrite make_conj_cons in H2. - apply deduce_prop with (3:= H0); tauto. - intro. - case_eq (add_term t cl) ; intros. - simpl in H2. - rewrite H0 in IHcl. - simpl in IHcl. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - rewrite H0 in IHcl ; simpl in *. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - case_eq (add_term t cl) ; intros. - simpl in H1. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - rewrite H in IHcl. - simpl in IHcl. - tauto. - simpl in *. - rewrite H in IHcl. - simpl in IHcl. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - Qed. - - - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). Proof. induction cl. - simpl. tauto. + - (* BC *) + simpl. + case_eq (deduce (fst t) (fst t)) ; auto. intros *. + case_eq (unsat t0) ; auto. + unfold eval_clause. + rewrite make_conj_cons. + intros. intro. + apply unsat_prop with (1:= H) (env := env). + apply deduce_prop with (3:= H0) ; tauto. + - (* IC *) simpl. - assert (HH := add_term_correct env a cl'). - case_eq (add_term a cl'). - simpl in *. + case_eq (deduce (fst t) (fst a)). + intro u. + case_eq (unsat u). + simpl. intros. + unfold eval_clause. + intro. + apply unsat_prop with (1:= H) (env:= env). + repeat rewrite make_conj_cons in H2. + apply deduce_prop with (3:= H0); tauto. + intro. + case_eq (add_term t cl) ; intros. + simpl in H2. + rewrite H0 in IHcl. + simpl in IHcl. + unfold eval_clause in *. intros. - apply IHcl in H0. - rewrite H in HH. - simpl in HH. + repeat rewrite make_conj_cons in *. + tauto. + rewrite H0 in IHcl ; simpl in *. unfold eval_clause in *. - destruct H0. + intros. repeat rewrite make_conj_cons in *. tauto. - apply HH in H0. - apply not_make_conj_cons in H0 ; auto. + case_eq (add_term t cl) ; intros. + simpl in H1. + unfold eval_clause in *. repeat rewrite make_conj_cons in *. + rewrite H in IHcl. + simpl in IHcl. tauto. - simpl. - intros. - rewrite H in HH. - simpl in HH. + simpl in *. + rewrite H in IHcl. + simpl in IHcl. unfold eval_clause in *. - assert (HH' := HH Coq.Init.Logic.I). - apply not_make_conj_cons in HH'; auto. repeat rewrite make_conj_cons in *. tauto. Qed. - + + + Lemma no_middle_eval_tt : forall env a, + eval_tt env a \/ ~ eval_tt env a. + Proof. + unfold eval_tt. + auto. + Qed. + + Hint Resolve no_middle_eval_tt : tauto. + + Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Proof. + induction cl. + - simpl. tauto. + - intros *. + simpl. + assert (HH := add_term_correct env a cl'). + case_eq (add_term a cl'). + + + intros. + apply IHcl in H0. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + destruct H0. + * + repeat rewrite make_conj_cons in *. + tauto. + * apply HH in H0. + apply not_make_conj_cons in H0 ; auto with tauto. + repeat rewrite make_conj_cons in *. + tauto. + + + intros. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + assert (HH' := HH Coq.Init.Logic.I). + apply not_make_conj_cons in HH'; auto with tauto. + repeat rewrite make_conj_cons in *. + tauto. + Qed. + Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). Proof. @@ -299,39 +496,38 @@ Set Implicit Arguments. unfold or_clause_cnf. intros until t. set (F := (fun (e : clause) (acc : list clause) => - match or_clause t e with - | Some cl => cl :: acc - | None => acc - end)). - induction f. - auto. - (**) + match or_clause t e with + | Some cl => cl :: acc + | None => acc + end)). + induction f;auto. simpl. intros. destruct f. - simpl in H. - simpl in IHf. - unfold F in H. - revert H. - intros. - apply or_clause_correct. - destruct (or_clause t a) ; simpl in * ; auto. - unfold F in H at 1. - revert H. - assert (HH := or_clause_correct t a env). - destruct (or_clause t a); simpl in HH ; - rewrite make_conj_cons in * ; intuition. - rewrite make_conj_cons in *. - tauto. + - simpl in H. + simpl in IHf. + unfold F in H. + revert H. + intros. + apply or_clause_correct. + destruct (or_clause t a) ; simpl in * ; auto. + - + unfold F in H at 1. + revert H. + assert (HH := or_clause_correct t a env). + destruct (or_clause t a); simpl in HH ; + rewrite make_conj_cons in * ; intuition. + rewrite make_conj_cons in *. + tauto. Qed. - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - Qed. + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a) -> eval_cnf env f -> eval_cnf env (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + Qed. Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). Proof. @@ -352,12 +548,11 @@ Set Implicit Arguments. right ; auto. Qed. - Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t. - - Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t. + Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. + Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t. - Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). + Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit) pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (eval env) (if pol then f else N f). Proof. induction f. (* TT *) @@ -385,10 +580,10 @@ Set Implicit Arguments. simpl. destruct pol ; simpl. intros. - apply normalise_correct ; auto. + eapply normalise_correct ; eauto. (* A 2 *) intros. - apply negate_correct ; auto. + eapply negate_correct ; eauto. auto. (* Cj *) destruct pol ; simpl. @@ -462,21 +657,21 @@ Set Implicit Arguments. Variable Witness : Type. - Variable checker : list Term' -> Witness -> bool. + Variable checker : list (Term'*Annot) -> Witness -> bool. - Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. + Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval_tt env) t False. Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := match f with - | nil => true - | e::f => match l with - | nil => false - | c::l => match checker e c with - | true => cnf_checker f l - | _ => false - end - end - end. + | nil => true + | e::f => match l with + | nil => false + | c::l => match checker e c with + | true => cnf_checker f l + | _ => false + end + end + end. Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. @@ -501,22 +696,32 @@ Set Implicit Arguments. Qed. - Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := + Definition tauto_checker (f:@GFormula Term Prop Annot unit) (w:list Witness) : bool := cnf_checker (xcnf true f) w. - Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. + Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (fun x => x) (eval env) t. Proof. unfold tauto_checker. intros. - change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). + change (eval_f (fun x => x) (eval env) t) with (eval_f (fun x => x) (eval env) (if true then t else TT)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. Qed. + Definition eval_bf {A : Type} (ea : A -> Prop) (f: BFormula A) := eval_f (fun x => x) ea f. + + + Lemma eval_bf_map : forall T U (fct: T-> U) env f , + eval_bf env (map_bformula fct f) = eval_bf (fun x => env (fct x)) f. +Proof. + induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. + rewrite <- IHf. auto. +Qed. End S. + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index c888f9af45..8148c7033c 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -33,14 +33,14 @@ Section MakeVarMap. #[universes(template)] Inductive t : Type := | Empty : t - | Leaf : A -> t - | Node : t -> A -> t -> t . + | Elt : A -> t + | Branch : t -> A -> t -> t . Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with | Empty => default - | Leaf i => i - | Node l e r => match p with + | Elt i => i + | Branch l e r => match p with | xH => e | xO p => find l p | xI p => find r p @@ -50,25 +50,25 @@ Section MakeVarMap. Fixpoint singleton (x:positive) (v : A) : t := match x with - | xH => Leaf v - | xO p => Node (singleton p v) default Empty - | xI p => Node Empty default (singleton p v) + | xH => Elt v + | xO p => Branch (singleton p v) default Empty + | xI p => Branch Empty default (singleton p v) end. Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := match m with | Empty => singleton x v - | Leaf vl => + | Elt vl => match x with - | xH => Leaf v - | xO p => Node (singleton p v) vl Empty - | xI p => Node Empty vl (singleton p v) + | xH => Elt v + | xO p => Branch (singleton p v) vl Empty + | xI p => Branch Empty vl (singleton p v) end - | Node l o r => + | Branch l o r => match x with - | xH => Node l v r - | xI p => Node l o (vm_add p v r) - | xO p => Node (vm_add p v l) o r + | xH => Branch l v r + | xI p => Branch l o (vm_add p v r) + | xO p => Branch (vm_add p v l) o r end end. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index 137453a9ed..9ff6850fdf 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -43,48 +43,48 @@ Notation "x < y" := (rlt x y). Lemma req_refl : forall x, req x x. Proof. - destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_). + destruct (SORsetoid sor) as (Equivalence_Reflexive,_,_). apply Equivalence_Reflexive. Qed. Lemma req_sym : forall x y, req x y -> req y x. Proof. - destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_). + destruct (SORsetoid sor) as (_,Equivalence_Symmetric,_). apply Equivalence_Symmetric. Qed. Lemma req_trans : forall x y z, req x y -> req y z -> req x z. Proof. - destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive). + destruct (SORsetoid sor) as (_,_,Equivalence_Transitive). apply Equivalence_Transitive. Qed. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. -exact sor.(SORle_wd). +exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. -exact sor.(SORlt_wd). +exact (SORlt_wd sor). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. @@ -115,7 +115,7 @@ Lemma Zring_morph : 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool gen_order_phi_Z. Proof. -exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). +exact (gen_phiZ_morph (SORsetoid sor) ring_ops_wd (SORrt sor)). Qed. Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. @@ -127,8 +127,8 @@ Qed. Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. Proof. -exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd - (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). +exact (ARgen_phiPOS_Psucc (SORsetoid sor) ring_ops_wd + (Rth_ARth (SORsetoid sor) ring_ops_wd (SORrt sor))). Qed. Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. @@ -142,7 +142,7 @@ Qed. Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. Proof. intros x y H. -do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); +do 2 rewrite (same_genZ (SORsetoid sor) ring_ops_wd (SORrt sor)); destruct x; destruct y; simpl in *; try discriminate. apply phi_pos1_pos. now apply clt_pos_morph. @@ -157,7 +157,7 @@ Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. Proof. unfold Z.leb; intros x y H. case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. -le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. +le_equal. apply (morph_eq Zring_morph). unfold Zeq_bool; now rewrite H1. le_less. now apply clt_morph. discriminate. Qed. @@ -172,5 +172,3 @@ apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. Qed. End InitialMorphism. - - diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index f341a04e03..ab218a1778 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -14,13 +14,14 @@ (* *) (************************************************************************) +Require Import List. +Require Import Bool. Require Import OrderedRing. Require Import RingMicromega. +Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. Require Import ZArith. -Require Import List. -Require Import Bool. (*Declare ML Module "micromega_plugin".*) Ltac flatten_bool := @@ -162,6 +163,8 @@ Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. +Definition pmul := pmul 0 1 Z.add Z.mul Zeq_bool. + Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. Declare Equivalent Keys normZ RingMicromega.norm. @@ -180,6 +183,13 @@ Proof. apply (eval_pol_add Zsor ZSORaddon). Qed. +Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) = eval_pol env lhs * eval_pol env rhs. +Proof. + intros. + apply (eval_pol_mul Zsor ZSORaddon). +Qed. + + Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . Proof. intros. @@ -202,13 +212,13 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) := Require Import Coq.micromega.Tauto BinNums. -Definition normalise (t:Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnormalise t). +Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + List.map (fun x => (x,tg)::nil) (xnormalise t). -Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t. +Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t. Proof. - unfold normalise, xnormalise; cbn -[padd]; intros env t. + unfold normalise, xnormalise; cbn -[padd]; intros T env t tg. rewrite Zeval_formula_compat. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; @@ -236,18 +246,18 @@ Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnegate t). +Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma negate_correct : forall env t, eval_cnf eval_nformula env (negate t) <-> ~ Zeval_formula env t. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. Proof. Proof. Opaque padd. - intros env t. + intros T env t tg. rewrite Zeval_formula_compat. unfold negate, xnegate ; simpl. unfold eval_cnf,eval_clause. - destruct t as [lhs o rhs]; case_eq o; simpl; + destruct t as [lhs o rhs]; case_eq o; unfold eval_tt ; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; @@ -264,9 +274,11 @@ Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. +Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) := + rxcnf Zunsat Zdeduce normalise negate true f. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := - @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZWitness ZWeakChecker f w. + @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. (* To get a complete checker, the proof format has to be enriched *) @@ -326,7 +338,9 @@ Inductive ZArithProof := | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). +(*| ExProof : positive -> positive -> positive -> ZArithProof ExProof z t x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) +. +(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) @@ -600,6 +614,186 @@ Definition valid_cut_sign (op:Op1) := | _ => false end. +Module Vars. + Import FSetPositive. + Include PositiveSet. + + Module Facts := FSetEqProperties.EqProperties(PositiveSet). + + Lemma mem_union_l : forall x s s', + mem x s = true -> + mem x (union s s') = true. + Proof. + intros. + rewrite Facts.union_mem. + rewrite H. reflexivity. + Qed. + + Lemma mem_union_r : forall x s s', + mem x s' = true -> + mem x (union s s') = true. + Proof. + intros. + rewrite Facts.union_mem. + rewrite H. rewrite orb_comm. reflexivity. + Qed. + + Lemma mem_singleton : forall p, + mem p (singleton p) = true. + Proof. + apply Facts.singleton_mem_1. + Qed. + + Lemma mem_elements : forall x v, + mem x v = true <-> List.In x (PositiveSet.elements v). + Proof. + intros. + rewrite Facts.MP.FM.elements_b. + rewrite existsb_exists. + unfold Facts.MP.FM.eqb. + split ; intros. + - destruct H as (x' & IN & EQ). + destruct (PositiveSet.E.eq_dec x x') ; try congruence. + subst ; auto. + - exists x. + split ; auto. + destruct (PositiveSet.E.eq_dec x x) ; congruence. + Qed. + + Definition max_element (vars : t) := + fold Pos.max vars xH. + + Lemma max_element_max : + forall x vars, mem x vars = true -> Pos.le x (max_element vars). + Proof. + unfold max_element. + intros. + rewrite mem_elements in H. + rewrite PositiveSet.fold_1. + set (F := (fun (a : positive) (e : PositiveSet.elt) => Pos.max e a)). + revert H. + assert (((x <= 1 -> x <= fold_left F (PositiveSet.elements vars) 1) + /\ + (List.In x (PositiveSet.elements vars) -> + x <= fold_left F (PositiveSet.elements vars) 1))%positive). + { + revert x. + generalize xH as acc. + induction (PositiveSet.elements vars). + - simpl. tauto. + - simpl. + intros. + destruct (IHl (F acc a) x). + split ; intros. + apply H. + unfold F. + rewrite Pos.max_le_iff. + tauto. + destruct H1 ; subst. + apply H. + unfold F. + rewrite Pos.max_le_iff. + simpl. + left. + apply Pos.le_refl. + tauto. + } + tauto. + Qed. + + Definition is_subset (v1 v2 : t) := + forall x, mem x v1 = true -> mem x v2 = true. + + Lemma is_subset_union_l : forall v1 v2, + is_subset v1 (union v1 v2). + Proof. + unfold is_subset. + intros. + apply mem_union_l; auto. + Qed. + + Lemma is_subset_union_r : forall v1 v2, + is_subset v1 (union v2 v1). + Proof. + unfold is_subset. + intros. + apply mem_union_r; auto. + Qed. + + + End Vars. + + +Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t := + match e with + | PEc _ => Vars.empty + | PEX _ x => Vars.singleton x + | PEadd e1 e2 | PEsub e1 e2 | PEmul e1 e2 => + let v1 := vars_of_pexpr e1 in + let v2 := vars_of_pexpr e2 in + Vars.union v1 v2 + | PEopp c => vars_of_pexpr c + | PEpow e n => vars_of_pexpr e + end. + +Definition vars_of_formula (f : Formula Z) := + match f with + | Build_Formula l o r => + let v1 := vars_of_pexpr l in + let v2 := vars_of_pexpr r in + Vars.union v1 v2 + end. + +Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type} + (F : @GFormula (Formula Z) TX TG ID) : Vars.t := + match F with + | TT => Vars.empty + | FF => Vars.empty + | X p => Vars.empty + | A a t => vars_of_formula a + | Cj f1 f2 | D f1 f2 | I f1 _ f2 => + let v1 := vars_of_bformula f1 in + let v2 := vars_of_bformula f2 in + Vars.union v1 v2 + | Tauto.N f => vars_of_bformula f + end. + +Definition bound_var (v : positive) : Formula Z := + Build_Formula (PEX _ v) OpGe (PEc 0). + +Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := + Build_Formula (PEX _ x) OpEq (PEsub (PEX _ y) (PEX _ t)). + +Section BOUND. + Context {TX TG ID : Type}. + + Variable tag_of_var : positive -> positive -> option bool -> TG. + + Definition bound_vars (fr : positive) + (v : Vars.t) : @GFormula (Formula Z) TX TG ID := + Vars.fold (fun k acc => + let y := (xO (fr + k)) in + let z := (xI (fr + k)) in + Cj + (Cj (A (mk_eq_pos k y z) (tag_of_var fr k None)) + (Cj (A (bound_var y) (tag_of_var fr k (Some false))) + (A (bound_var z) (tag_of_var fr k (Some true))))) + acc) v TT. + + Definition bound_problem (F : @GFormula (Formula Z) TX TG ID) : GFormula := + let v := vars_of_bformula F in + I (bound_vars (Pos.succ (Vars.max_element v)) v) None F. + + + Definition bound_problem_fr (fr : positive) (F : @GFormula (Formula Z) TX TG ID) : GFormula := + let v := vars_of_bformula F in + I (bound_vars fr v) None F. + + +End BOUND. + + + Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false @@ -619,6 +813,10 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end +(* | SplitProof e pf1 pf2 => + match ZChecker ((e,NonStrict)::l) pf1 , ZChecker (( +*) + | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with | Some f1 , Some f2 => @@ -993,26 +1191,299 @@ Proof. apply genCuttingPlaneNone with (2:= H2) ; auto. Qed. + + Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := - @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZArithProof ZChecker f w. + @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w. -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. +Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (fun x => x) (Zeval_formula env) f. Proof. intros f w. unfold ZTautoChecker. - apply (tauto_checker_sound Zeval_formula eval_nformula). - apply Zeval_nformula_dec. - intros until env. + apply tauto_checker_sound with (eval' := eval_nformula). + - apply Zeval_nformula_dec. + - intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). - intros env t. - rewrite normalise_correct ; auto. - intros env t. - rewrite negate_correct ; auto. - intros t w0. - apply ZChecker_sound. + - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). + - + intros env t tg. + rewrite normalise_correct ; auto. + - + intros env t tg. + rewrite negate_correct ; auto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := eval_nformula env). + eapply ZChecker_sound; eauto. + tauto. +Qed. + +Record is_diff_env_elt (fr : positive) (env env' : positive -> Z) (x:positive):= + { + eq_env : env x = env' x; + eq_diff : env x = env' (xO (fr+ x)) - env' (xI (fr + x)); + pos_xO : env' (xO (fr+x)) >= 0; + pos_xI : env' (xI (fr+x)) >= 0; + }. + + +Definition is_diff_env (s : Vars.t) (env env' : positive -> Z) := + let fr := Pos.succ (Vars.max_element s) in + forall x, Vars.mem x s = true -> + is_diff_env_elt fr env env' x. + +Definition mk_diff_env (s : Vars.t) (env : positive -> Z) := + let fr := Vars.max_element s in + fun x => + if Pos.leb x fr + then env x + else + let fr' := Pos.succ fr in + match x with + | xO x => if Z.leb (env (x - fr')%positive) 0 + then 0 else env (x -fr')%positive + | xI x => if Z.leb (env (x - fr')%positive) 0 + then - (env (x - fr')%positive) else 0 + | xH => 0 + end. + +Lemma le_xO : forall x, (x <= xO x)%positive. +Proof. + intros. + change x with (1 * x)%positive at 1. + change (xO x) with (2 * x)%positive. + apply Pos.mul_le_mono. + compute. congruence. + apply Pos.le_refl. +Qed. + +Lemma leb_xO_false : + (forall x y, x <=? y = false -> + xO x <=? y = false)%positive. +Proof. + intros. + rewrite Pos.leb_nle in *. + intro. apply H. + eapply Pos.le_trans ; eauto. + apply le_xO. +Qed. + +Lemma leb_xI_false : + (forall x y, x <=? y = false -> + xI x <=? y = false)%positive. +Proof. + intros. + rewrite Pos.leb_nle in *. + intro. apply H. + eapply Pos.le_trans ; eauto. + generalize (le_xO x). + intros. + eapply Pos.le_trans ; eauto. + change (xI x) with (Pos.succ (xO x))%positive. + apply Pos.lt_le_incl. + apply Pos.lt_succ_diag_r. +Qed. + +Lemma is_diff_env_ex : forall s env, + is_diff_env s env (mk_diff_env s env). +Proof. + intros. + unfold is_diff_env, mk_diff_env. + intros. + assert + ((Pos.succ (Vars.max_element s) + x <=? Vars.max_element s = false)%positive). + { + rewrite Pos.leb_nle. + intro. + eapply (Pos.lt_irrefl (Pos.succ (Vars.max_element s) + x)). + eapply Pos.le_lt_trans ; eauto. + generalize (Pos.lt_succ_diag_r (Vars.max_element s)). + intro. + eapply Pos.lt_trans ; eauto. + apply Pos.lt_add_r. + } + constructor. + - apply Vars.max_element_max in H. + rewrite <- Pos.leb_le in H. + rewrite H. auto. + - + rewrite leb_xO_false by auto. + rewrite leb_xI_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0); ring. + - rewrite leb_xO_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0) eqn:EQ. + apply Z.le_ge. + apply Z.le_refl. + rewrite Z.leb_gt in EQ. + apply Z.le_ge. + apply Z.lt_le_incl. + auto. + - rewrite leb_xI_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0) eqn:EQ. + rewrite Z.leb_le in EQ. + apply Z.le_ge. + apply Z.opp_nonneg_nonpos; auto. + apply Z.le_ge. + apply Z.le_refl. +Qed. + +Lemma env_bounds : forall tg env s, + let fr := Pos.succ (Vars.max_element s) in + exists env', is_diff_env s env env' + /\ + eval_bf (Zeval_formula env') (bound_vars tg fr s). +Proof. + intros. + assert (DIFF:=is_diff_env_ex s env). + exists (mk_diff_env s env). split ; auto. + unfold bound_vars. + rewrite FSetPositive.PositiveSet.fold_1. + revert DIFF. + set (env' := mk_diff_env s env). + intro. + assert (ACC : eval_bf (Zeval_formula env') TT ). + { + simpl. auto. + } + revert ACC. + match goal with + | |- context[@TT ?A ?B ?C ?D] => generalize (@TT A B C D) as acc + end. + unfold is_diff_env in DIFF. + assert (DIFFL : forall x, In x (FSetPositive.PositiveSet.elements s) -> + (x < fr)%positive /\ + is_diff_env_elt fr env env' x). + { + intros. + rewrite <- Vars.mem_elements in H. + split. + apply Vars.max_element_max in H. + unfold fr in *. + eapply Pos.le_lt_trans ; eauto. + apply Pos.lt_succ_diag_r. + apply DIFF; auto. + } + clear DIFF. + match goal with + | |- context[fold_left ?F _ _] => + set (FUN := F) + end. + induction (FSetPositive.PositiveSet.elements s). + - simpl; auto. + - simpl. + intros. + eapply IHl ; eauto. + + intros. apply DIFFL. + simpl ; auto. + + unfold FUN. + simpl. + split ; auto. + assert (HYP : (a < fr /\ is_diff_env_elt fr env env' a)%positive). + { + apply DIFFL. + simpl. tauto. + } + destruct HYP as (LT & DIFF). + destruct DIFF. + rewrite <- eq_env0. + tauto. +Qed. + +Definition agree_env (v : Vars.t) (env env' : positive -> Z) : Prop := + forall x, Vars.mem x v = true -> env x = env' x. + +Lemma agree_env_subset : forall s1 s2 env env', + agree_env s1 env env' -> + Vars.is_subset s2 s1 -> + agree_env s2 env env'. +Proof. + unfold agree_env. + intros. + apply H. apply H0; auto. +Qed. + +Lemma agree_env_union : forall s1 s2 env env', + agree_env (Vars.union s1 s2) env env' -> + agree_env s1 env env' /\ agree_env s2 env env'. +Proof. + split; + eapply agree_env_subset; eauto. + apply Vars.is_subset_union_l. + apply Vars.is_subset_union_r. +Qed. + + + +Lemma agree_env_eval_expr : + forall env env' e + (AGREE : agree_env (vars_of_pexpr e) env env'), + Zeval_expr env e = Zeval_expr env' e. +Proof. + induction e; simpl;intros; + try (apply agree_env_union in AGREE; destruct AGREE); try f_equal ; auto. + - intros ; apply AGREE. + apply Vars.mem_singleton. +Qed. + +Lemma agree_env_eval_bf : + forall env env' f + (AGREE: agree_env (vars_of_bformula f) env env'), + eval_bf (Zeval_formula env') f <-> + eval_bf (Zeval_formula env) f. +Proof. + induction f; simpl; intros ; + try (apply agree_env_union in AGREE; destruct AGREE) ; try intuition fail. + - + unfold Zeval_formula. + destruct t. + simpl in * ; intros. + apply agree_env_union in AGREE ; destruct AGREE. + rewrite <- agree_env_eval_expr with (env:=env) by auto. + rewrite <- agree_env_eval_expr with (e:= Frhs) (env:=env) by auto. + tauto. +Qed. + +Lemma bound_problem_sound : forall tg f, + (forall env' : PolEnv Z, + eval_bf (Zeval_formula env') + (bound_problem tg f)) -> + forall env, + eval_bf (Zeval_formula env) f. +Proof. + intros. + unfold bound_problem in H. + destruct (env_bounds tg env (vars_of_bformula f)) + as (env' & DIFF & EVAL). + simpl in H. + apply H in EVAL. + eapply agree_env_eval_bf ; eauto. + unfold is_diff_env, agree_env in *. + intros. + apply DIFF in H0. + destruct H0. + intuition. +Qed. + + + +Definition ZTautoCheckerExt (f : BFormula (Formula Z)) (w : list ZArithProof) : bool := + ZTautoChecker (bound_problem (fun _ _ _ => tt) f) w. + +Lemma ZTautoCheckerExt_sound : forall f w, ZTautoCheckerExt f w = true -> forall env, eval_bf (Zeval_formula env) f. +Proof. + intros. + unfold ZTautoCheckerExt in H. + specialize (ZTautoChecker_sound _ _ H). + intros ; apply bound_problem_sound with (tg:= fun _ _ _ => tt); auto. Qed. Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := @@ -1028,18 +1499,10 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. -(*Lemma hyps_of_pt_correct : forall pt l, *) - - - - - - Open Scope Z_scope. (** To ease bindings from ml code **) -(*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. @@ -1047,9 +1510,9 @@ Require VarMap. (*Definition varmap_type := VarMap.t Z. *) Definition env := PolEnv Z. -Definition node := @VarMap.Node Z. +Definition node := @VarMap.Branch Z. Definition empty := @VarMap.Empty Z. -Definition leaf := @VarMap.Leaf Z. +Definition leaf := @VarMap.Elt Z. Definition coneMember := ZWitness. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index af292c088f..3f9f4726e7 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -19,7 +19,6 @@ let debug = false -open Util open Big_int open Num open Polynomial @@ -31,6 +30,16 @@ module C2Ml = Mutils.CoqToCaml let use_simplex = ref true +type ('prf,'model) res = + | Prf of 'prf + | Model of 'model + | Unknown + +type zres = (Mc.zArithProof , (int * Mc.z list)) res + +type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res + + open Mutils type 'a number_spec = { bigint_to_number : big_int -> 'a; @@ -181,7 +190,7 @@ let build_dual_linear_system l = {coeffs = Vect.from_list ([Big_int zero_big_int ;Big_int unit_big_int]) ; op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@c::s0) - +open Util (** [direct_linear_prover l] does not handle strict inegalities *) let fourier_linear_prover l = @@ -201,11 +210,11 @@ let direct_linear_prover l = else fourier_linear_prover l let find_point l = - if !use_simplex - then Simplex.find_point l - else match Mfourier.Fourier.find_point l with - | Inr _ -> None - | Inl cert -> Some cert + if !use_simplex + then Simplex.find_point l + else match Mfourier.Fourier.find_point l with + | Inr _ -> None + | Inl cert -> Some cert let optimise v l = if !use_simplex @@ -253,9 +262,6 @@ let simple_linear_prover l = (* Fourier elimination should handle > *) dual_raw_certificate l -open ProofFormat - - let env_of_list l = snd (List.fold_left (fun (i,m) p -> (i+1,IMap.add i p m)) (0,IMap.empty) l) @@ -268,7 +274,7 @@ let linear_prover_cstr sys = match simple_linear_prover sysi with | None -> None - | Some cert -> Some (proof_of_farkas (env_of_list prfi) cert) + | Some cert -> Some (ProofFormat.proof_of_farkas (env_of_list prfi) cert) let linear_prover_cstr = if debug @@ -301,15 +307,14 @@ let develop_constraint z_spec (e,k) = - 0 = c for c a non-zero constant - e = c when the coeffs of e are all integers and c is rational *) -open ProofFormat type checksat = | Tauto (* Tautology *) - | Unsat of prf_rule (* Unsatisfiable *) - | Cut of cstr * prf_rule (* Cutting plane *) - | Normalise of cstr * prf_rule (* Coefficients may be normalised i.e relatively prime *) + | Unsat of ProofFormat.prf_rule (* Unsatisfiable *) + | Cut of cstr * ProofFormat.prf_rule (* Cutting plane *) + | Normalise of cstr * ProofFormat.prf_rule (* Coefficients may be normalised i.e relatively prime *) -exception FoundProof of prf_rule +exception FoundProof of ProofFormat.prf_rule (** [check_sat] @@ -336,17 +341,17 @@ let check_int_sat (cstr,prf) = coeffs = Vect.div gcd coeffs; op = op ; cst = cst // gcd } in - Normalise(cstr,Gcd(gcdi,prf)) + Normalise(cstr,ProofFormat.Gcd(gcdi,prf)) (* Normalise(cstr,CutPrf prf)*) end else match op with - | Eq -> Unsat (CutPrf prf) + | Eq -> Unsat (ProofFormat.CutPrf prf) | Ge -> let cstr = { coeffs = Vect.div gcd coeffs; op = op ; cst = ceiling_num (cst // gcd) - } in Cut(cstr,CutPrf prf) + } in Cut(cstr,ProofFormat.CutPrf prf) | Gt -> failwith "check_sat : Unexpected operator" @@ -363,29 +368,6 @@ let apply_and_normalise check f psys = ) [] psys -let simplify f sys = - let (sys',b) = - List.fold_left (fun (sys',b) c -> - match f c with - | None -> (c::sys',b) - | Some c' -> - (c'::sys',true) - ) ([],false) sys in - if b then Some sys' else None - -let saturate f sys = - List.fold_left (fun sys' c -> match f c with - | None -> sys' - | Some c' -> c'::sys' - ) [] sys - -let is_substitution strict ((p,o),prf) = - let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in - - match o with - | Eq -> LinPoly.search_linear pred p - | _ -> None - let is_linear_for v pc = LinPoly.is_linear (fst (fst pc)) || LinPoly.is_linear_for v (fst (fst pc)) @@ -393,11 +375,11 @@ let is_linear_for v pc = -let non_linear_pivot sys pc v pc' = +(*let non_linear_pivot sys pc v pc' = if LinPoly.is_linear (fst (fst pc')) then None (* There are other ways to deal with those *) else WithProof.linear_pivot sys pc v pc' - + *) let is_linear_substitution sys ((p,o),prf) = let pred v = v =/ Int 1 || v =/ Int (-1) in @@ -423,7 +405,33 @@ let elim_simple_linear_equality sys0 = iterate_until_stable elim sys0 -let saturate_linear_equality_non_linear sys0 = + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let subst sys = + let sys' = WithProof.subst sys in + if debug then Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + sys' + + + +(** [saturate_linear_equality sys] generate new constraints + obtained by eliminating linear equalities by pivoting. + For integers, the obtained constraints are sound but not complete. + *) + let saturate_by_linear_equalities sys0 = + WithProof.saturate_subst false sys0 + + +let saturate_by_linear_equalities sys = + let sys' = saturate_by_linear_equalities sys in + if debug then Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + sys' + + + +(* let saturate_linear_equality_non_linear sys0 = let (l,_) = extract_all (is_substitution false) sys0 in let rec elim l acc = match l with @@ -432,18 +440,51 @@ let saturate_linear_equality_non_linear sys0 = let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in elim l' (nc@acc) in elim l [] + *) +let bounded_vars (sys: WithProof.t list) = + let l = (fst (extract_all (fun ((p,o),prf) -> + LinPoly.is_variable p + ) sys)) in + List.fold_left (fun acc (i,wp) -> IMap.add i wp acc) IMap.empty l + +let rec power n p = + if n = 1 then p + else WithProof.product p (power (n-1) p) + +let bound_monomial mp m = + if Monomial.is_var m || Monomial.is_const m + then None + else + try + Some (Monomial.fold + (fun v i acc -> + let wp = IMap.find v mp in + WithProof.product (power i wp) acc) m (WithProof.const (Int 1)) + ) + with Not_found -> None + + +let bound_monomials (sys:WithProof.t list) = + let mp = bounded_vars sys in + let m = + List.fold_left (fun acc ((p,_),_) -> + Vect.fold (fun acc v _ -> let m = LinPoly.MonT.retrieve v in + match bound_monomial mp m with + | None -> acc + | Some r -> IMap.add v r acc) acc p) IMap.empty sys in + IMap.fold (fun _ e acc -> e::acc) m [] let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth ; let sys = List.map (develop_constraint n_spec) sys in - List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),Hyp i)) sys + List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),ProofFormat.Hyp i)) sys let square_of_var i = let x = LinPoly.var i in - ((LinPoly.product x x,Ge),(Square x)) + ((LinPoly.product x x,Ge),(ProofFormat.Square x)) (** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. @@ -462,7 +503,7 @@ let nlinear_preprocess (sys:WithProof.t list) = let sys = MonMap.fold (fun s m acc -> let s = LinPoly.of_monomial s in let m = LinPoly.of_monomial m in - ((m, Ge), (Square s))::acc) collect_square sys in + ((m, Ge), (ProofFormat.Square s))::acc) collect_square sys in let collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in @@ -482,16 +523,16 @@ let nlinear_preprocess (sys:WithProof.t list) = let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in - let sys2 = saturate_linear_equality_non_linear sys1 in + let sys2 = saturate_by_linear_equalities sys1 in let sys = nlinear_preprocess sys1@sys2 in let sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in let id = (List.fold_left (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in let env = CList.interval 0 id in match linear_prover_cstr sys with - | None -> None + | None -> Unknown | Some cert -> - Some (cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) + Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) let linear_prover_with_cert prfdepth sys = @@ -500,9 +541,9 @@ let linear_prover_with_cert prfdepth sys = let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in match linear_prover_cstr sys with - | None -> None + | None -> Unknown | Some cert -> - Some (cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) + Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) (* The prover is (probably) incomplete -- only searching for naive cutting planes *) @@ -643,7 +684,7 @@ open Polynomial -type prf_sys = (cstr * prf_rule) list +type prf_sys = (cstr * ProofFormat.prf_rule) list @@ -661,7 +702,7 @@ let pivot v (c1,p1) (c2,p2) = op = opAdd op1 op2 ; cst = n1 */ cv1 +/ n2 */ cv2 }, - AddPrf(mul_cst_proof cv1 p1,mul_cst_proof cv2 p2)) in + ProofFormat.add_proof (ProofFormat.mul_cst_proof cv1 p1) (ProofFormat.mul_cst_proof cv2 p2)) in match Vect.get v v1 , Vect.get v v2 with | Int 0 , _ | _ , Int 0 -> None @@ -747,7 +788,7 @@ let reduce_coprime psys = op = Eq ; cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) } in - let prf = add_proof (mul_cst_proof l1' p1) (mul_cst_proof l2' p2) in + let prf = ProofFormat.add_proof (ProofFormat.mul_cst_proof l1' p1) (ProofFormat.mul_cst_proof l2' p2) in Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) @@ -798,7 +839,7 @@ let reduce_var_change psys = let m = minus_num (vx */ l1 +/ vx' */ l2) in Some ({coeffs = Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , - AddPrf(MulC((LinPoly.constant m),p),p')) in + ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p') in Some (apply_and_normalise check_int_sat pivot_eq sys) @@ -871,40 +912,42 @@ let get_bound sys = let check_sys sys = List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys +open ProofFormat let xlia (can_enum:bool) reduction_equations sys = - let rec enum_proof (id:int) (sys:prf_sys) : ProofFormat.proof option = + let rec enum_proof (id:int) (sys:prf_sys) = if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; assert (check_sys sys) ; let nsys,prf = List.split sys in match get_bound nsys with - | None -> None (* Is the systeme really unbounded ? *) + | None -> Unknown (* Is the systeme really unbounded ? *) | Some(prf1,(lb,e,ub),prf2) -> if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e (string_of_num lb) (string_of_num ub) ; (match start_enum id e (ceiling_num lb) (floor_num ub) sys with - | Some prfl -> - Some(Enum(id,proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e, - proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl)) - | None -> None + | Prf prfl -> + Prf(ProofFormat.Enum(id,ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e, + ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl)) + | _ -> Unknown ) - and start_enum id e clb cub sys = + and start_enum id e clb cub sys = if clb >/ cub - then Some [] + then Prf [] else let eq = {coeffs = e ; op = Eq ; cst = clb} in - match aux_lia (id+1) ((eq, Def id) :: sys) with - | None -> None - | Some prf -> + match aux_lia (id+1) ((eq, ProofFormat.Def id) :: sys) with + | Unknown | Model _ -> Unknown + | Prf prf -> match start_enum id e (clb +/ (Int 1)) cub sys with - | None -> None - | Some l -> Some (prf::l) + | Prf l -> Prf (prf::l) + | _ -> Unknown - and aux_lia (id:int) (sys:prf_sys) : ProofFormat.proof option = + + and aux_lia (id:int) (sys:prf_sys) = assert (check_sys sys) ; if debug then Printf.printf "xlia: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; try @@ -912,11 +955,11 @@ let xlia (can_enum:bool) reduction_equations sys = if debug then Printf.printf "after reduction: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; match linear_prover_cstr sys with - | Some prf -> Some (Step(id,prf,Done)) - | None -> if can_enum then enum_proof id sys else None + | Some prf -> Prf (Step(id,prf,Done)) + | None -> if can_enum then enum_proof id sys else Unknown with FoundProof prf -> (* [reduction_equations] can find a proof *) - Some(Step(id,prf,Done)) in + Prf(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) let id = 1 + (List.fold_left @@ -925,10 +968,10 @@ let xlia (can_enum:bool) reduction_equations sys = try let sys = simpl_sys sys in aux_lia id sys - with FoundProof pr -> Some(Step(id,pr,Done)) in + with FoundProof pr -> Prf(Step(id,pr,Done)) in match orpf with - | None -> None - | Some prf -> + | Unknown | Model _ -> Unknown + | Prf prf -> let env = CList.interval 0 (id - 1) in if debug then begin Printf.fprintf stdout "direct proof %a\n" output_proof prf; @@ -939,21 +982,25 @@ let xlia (can_enum:bool) reduction_equations sys = if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) - *) Some prf + *) Prf prf -let xlia_simplex env sys = - match Simplex.integer_solver sys with - | None -> None - | Some prf -> - (*let _ = ProofFormat.eval_proof (env_of_list env) prf in *) +let xlia_simplex env red sys = + let compile_prf sys prf = + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let env = CList.interval 0 (id - 1) in + Prf (compile_proof env prf) in - let id = 1 + (List.fold_left - (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in - let env = CList.interval 0 (id - 1) in - Some (compile_proof env prf) + try + let sys = red sys in + + match Simplex.integer_solver sys with + | None -> Unknown + | Some prf -> compile_prf sys prf + with FoundProof prf -> compile_prf sys (Step(0,prf,Done)) let xlia env0 en red sys = - if !use_simplex then xlia_simplex env0 sys + if !use_simplex then xlia_simplex env0 red sys else xlia en red sys @@ -971,9 +1018,9 @@ let gen_bench (tac, prover) can_enum prfdepth sys = Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; begin match res with - | None -> + | Unknown | Model _ -> Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac - | Some res -> + | Prf res -> Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac end ; @@ -987,7 +1034,14 @@ let lia (can_enum:bool) (prfdepth:int) sys = if debug then begin Printf.fprintf stdout "Input problem\n"; List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "Input problem\n"; + let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" in + List.iter (fun ((p,op),_) -> Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt p) sys; end; + let sys = subst sys in + let bnd = bound_monomials sys in (* To deal with non-linear monomials *) + let sys = bnd@(saturate_by_linear_equalities sys)@sys in + let sys' = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' @@ -1013,7 +1067,7 @@ let nlia enum prfdepth sys = It would only be safe if the variable is linear... *) let sys1 = elim_simple_linear_equality sys in - let sys2 = saturate_linear_equality_non_linear sys1 in + let sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1@sys2) in let sys4 = make_cstr_system ((*sys2@*)sys3) in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index e925f1bc5e..3428428441 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -15,6 +15,15 @@ module Mc = Micromega If set, use the Simplex method, otherwise use Fourier *) val use_simplex : bool ref +type ('prf,'model) res = + | Prf of 'prf + | Model of 'model + | Unknown + +type zres = (Mc.zArithProof , (int * Mc.z list)) res + +type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res + (** [dump_file] is bound to the Coq option Dump Arith. If set to some [file], arithmetic goals are dumped in filexxx.v *) val dump_file : string option ref @@ -27,16 +36,16 @@ val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz (** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys]. If the Simplex option is set, any failure to find a proof should be considered as a bug. *) -val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incomplete -- the problem is undecidable *) -val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys]. Over the rationals, the solver is complete. *) -val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Micromega.psatz option +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incompete -- the problem is decidable. *) -val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Mc.psatz option +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7db47e13a5..ef6af16036 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -14,7 +14,7 @@ (* *) (* - Modules M, Mc, Env, Cache, CacheZ *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-2019 *) (* *) (************************************************************************) @@ -103,6 +103,7 @@ let () = *) type tag = Tag.t +module Mc = Micromega (** * An atom is of the form: @@ -111,205 +112,30 @@ type tag = Tag.t * parametrized by 'cst, which is used as the type of constants. *) -type 'cst atom = 'cst Micromega.formula +type 'cst atom = 'cst Mc.formula -(** - * Micromega's encoding of formulas. - * By order of appearance: boolean constants, variables, atoms, conjunctions, - * disjunctions, negation, implication. -*) - -type 'cst formula = - | TT - | FF - | X of EConstr.constr - | A of 'cst atom * tag * EConstr.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.Id.t option * 'cst formula +type 'cst formula = ('cst atom, EConstr.constr,tag * EConstr.constr,Names.Id.t) Mc.gFormula -(** - * Formula pretty-printer. - *) +type 'cst clause = ('cst Mc.nFormula, tag * EConstr.constr) Mc.clause +type 'cst cnf = ('cst Mc.nFormula, tag * EConstr.constr) Mc.cnf -let rec pp_formula o f = + +let rec pp_formula o (f:'cst formula) = + Mc.( match f with | TT -> output_string o "tt" | FF -> output_string o "ff" | X c -> output_string o "X " - | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t - | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 + | A(_,(t,_)) -> Printf.fprintf o "A(%a)" Tag.pp t + | Cj(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 + | I(f1,n,f2) -> Printf.fprintf o "I(%a,%s,%a)" + pp_formula f1 + (match n with + | Some id -> Names.Id.to_string id + | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - - -let rec map_atoms fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X x - | A (at,tg,cstr) -> A(fct at,tg,cstr) - | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) - | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) - | N f -> N(map_atoms fct f) - | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) - -let rec map_prop fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X (fct x) - | A (at,tg,cstr) -> A(at,tg,cstr) - | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) - | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) - | N f -> N(map_prop fct f) - | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) - -(** - * Collect the identifiers of a (string of) implications. Implication labels - * are inherited from Coq/CoC's higher order dependent type constructor (Pi). - *) - -let rec ids_of_formula f = - match f with - | I(f1,Some id,f2) -> id::(ids_of_formula f2) - | _ -> [] - -(** - * A clause is a list of (tagged) nFormulas. - * nFormulas are normalized formulas, i.e., of the form: - * cPol \{=,<>,>,>=\} 0 - * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). - *) - -type 'cst clause = ('cst Micromega.nFormula * tag) list - -(** - * A CNF is a list of clauses. - *) - -type 'cst cnf = ('cst clause) list - -(** - * True and False are empty cnfs and clauses. - *) - -let tt : 'cst cnf = [] - -let ff : 'cst cnf = [ [] ] - -(** - * A refinement of cnf with tags left out. This is an intermediary form - * between the cnf tagged list representation ('cst cnf) used to solve psatz, - * and the freeform formulas ('cst formula) that is retrieved from Coq. - *) - -module Mc = Micromega - -type 'cst mc_cnf = ('cst Mc.nFormula) list list - -(** - * From a freeform formula, build a cnf. - * The parametric functions negate and normalize are theory-dependent, and - * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v - * and RingMicromega.v). - *) - -type 'a tagged_option = T of tag list | S of 'a - -let cnf - (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) - (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = - - let negate a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in - - let normalise a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in - - let and_cnf x y = x @ y in - -let rec add_term t0 = function - | [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then T [snd t0] else S (t0::[]) - | None -> S (t0::[])) - | t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then T [snd t0 ; snd t'] - else (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l) - | None -> - (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l)) in - - - let rec or_clause cl1 cl2 = - match cl1 with - | [] -> S cl2 - | t0::cl -> - (match add_term t0 cl2 with - | S cl' -> or_clause cl cl' - | T l -> T l) in - - - - let or_clause_cnf t f = - List.fold_right (fun e (acc,tg) -> - match or_clause t e with - | S cl -> (cl :: acc,tg) - | T l -> (acc,tg@l)) f ([],[]) in - - - let rec or_cnf f f' = - match f with - | [] -> tt,[] - | e :: rst -> - let (rst_f',t) = or_cnf rst f' in - let (e_f', t') = or_clause_cnf e f' in - (rst_f' @ e_f', t @ t') in - - - let rec xcnf (polarity : bool) f = - match f with - | TT -> if polarity then (tt,[]) else (ff,[]) - | FF -> if polarity then (ff,[]) else (tt,[]) - | X p -> if polarity then (ff,[]) else (ff,[]) - | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) - | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then and_cnf e1 e2, t1 @ t2 - else let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - | D(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 - | I(e1,_,e2) -> - let e1 , t1 = (xcnf (not polarity) e1) in - let e2 , t2 = (xcnf polarity e2) in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 in - - xcnf true f + ) (** @@ -344,10 +170,11 @@ struct let mic_modules = [ ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; + ["Coq"; "micromega";"ZMicromega"]; + ["Coq"; "micromega";"Tauto"]; + ["Coq"; "micromega"; "DeclConstant"]; + ["Coq"; "micromega";"RingMicromega"]; + ["Coq"; "micromega";"EnvRing"]; ["Coq"; "micromega"; "ZMicromega"]; ["Coq"; "micromega"; "RMicromega"]; ["Coq" ; "micromega" ; "Tauto"]; @@ -405,6 +232,15 @@ struct let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") + let coq_nat = lazy (init_constant "nat") + let coq_unit = lazy (init_constant "unit") + (* let coq_option = lazy (init_constant "option")*) + let coq_None = lazy (init_constant "None") + let coq_tt = lazy (init_constant "tt") + let coq_Inl = lazy (init_constant "inl") + let coq_Inr = lazy (init_constant "inr") + + let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") @@ -431,6 +267,7 @@ struct let coq_CPlus = lazy (m_constant "CPlus") let coq_CMinus = lazy (m_constant "CMinus") let coq_CMult = lazy (m_constant "CMult") + let coq_CPow = lazy (m_constant "CPow") let coq_CInv = lazy (m_constant "CInv") let coq_COpp = lazy (m_constant "COpp") @@ -477,6 +314,7 @@ struct let coq_Rmult = lazy (r_constant "Rmult") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") + let coq_powerZR = lazy (r_constant "powerRZ") let coq_IZR = lazy (r_constant "IZR") let coq_IQR = lazy (r_constant "Q2R") @@ -508,6 +346,8 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_GT = lazy (m_constant "GT") + let coq_TT = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") @@ -615,6 +455,22 @@ struct | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) + (** [is_ground_term env sigma term] holds if the term [term] + is an instance of the typeclass [DeclConstant.GT term] + i.e. built from user-defined constants and functions. + NB: This mechanism is used to customise the reification process to decide + what to consider as a constant (see [parse_constant]) + *) + + let is_ground_term env sigma term = + let typ = Retyping.get_type_of env sigma term in + try + ignore (Typeclasses.resolve_one_typeclass env sigma (EConstr.mkApp(Lazy.force coq_GT,[| typ;term|]))) ; + true + with + | Not_found -> false + + let parse_z sigma term = let (i,c) = get_left_construct sigma term in match i with @@ -652,6 +508,7 @@ struct | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y + | Mc.CPow(x,y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t @@ -665,6 +522,11 @@ struct | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) + | Mc.CPow(x,y) -> EConstr.mkApp(Lazy.force coq_CPow, [| dump_Rcst x ; + match y with + | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_Inl,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_z z|]) + | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Inr,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_nat n|]) + |]) | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) @@ -718,9 +580,18 @@ struct | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e - let pp_cnf pp_c o f = - let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in - List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f +(* let pp_clause pp_c o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *) + + let pp_clause_tag o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f + +(* let pp_cnf pp_c o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *) + + let pp_cnf_tag o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause_tag l) f + let dump_psatz typ dump_z e = let z = Lazy.force typ in @@ -842,34 +713,74 @@ struct module Env = struct - let compute_rank_add env sigma v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if EConstr.eq_constr_nounivs sigma e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.positive n) - let get_rank env sigma v = + type t = { + vars : EConstr.t list ; + (* The list represents a mapping from EConstr.t to indexes. *) + gl : gl; + (* The evar_map may be updated due to unification of universes *) + } + + let empty gl = + { + vars = []; + gl = gl + } + + + (** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *) + let eq_constr gl x y = + let evd = gl.sigma in + match EConstr.eq_constr_universes gl.env evd x y with + | Some csts -> + let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in + begin + match Evd.add_constraints evd csts with + | evd -> Some {gl with sigma = evd} + | exception Univ.UniverseInconsistency _ -> None + end + | None -> None + + let compute_rank_add env v = + let rec _add gl vars n v = + match vars with + | [] -> (gl, [v] ,n) + | e::l -> + match eq_constr gl e v with + | Some gl' -> (gl', vars , n) + | None -> + let (gl,l',n) = _add gl l ( n+1) v in + (gl,e::l',n) in + let (gl',vars', n) = _add env.gl env.vars 1 v in + ({vars=vars';gl=gl'}, CamlToCoq.positive n) + + let get_rank env v = + let evd = env.gl.sigma in let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if EConstr.eq_constr sigma e v + if EConstr.eq_constr evd e v then n else _get_rank l (n+1) in - _get_rank env 1 + _get_rank env.vars 1 - - let empty = [] + let elements env = env.vars - let elements env = env +(* let string_of_env gl env = + let rec string_of_env i env acc = + match env with + | [] -> acc + | e::env -> string_of_env (i+1) env + (IMap.add i + (Pp.string_of_ppcmds + (Printer.pr_econstr_env gl.env gl.sigma e)) acc) in + string_of_env 1 env IMap.empty + *) + let pp gl env = + let ppl = List.mapi (fun i e -> Pp.str "x" ++ Pp.int (i+1) ++ Pp.str ":" ++ Printer.pr_econstr_env gl.env gl.sigma e)env in + List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p ) ppl (Pp.str "\n") end (* MODULE END: Env *) @@ -877,20 +788,13 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr cenv sigma parse_constant parse_exp ops_spec env term = + let parse_expr gl parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env cenv sigma term); + then ( + Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term)); -(* - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in -*) let parse_variable env term = - let (env,n) = Env.compute_rank_add env sigma term in + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in let rec parse_expr env term = @@ -899,32 +803,32 @@ struct let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in - try (Mc.PEc (parse_constant term) , env) + try (Mc.PEc (parse_constant gl term) , env) with ParseError -> - match EConstr.kind sigma term with + match EConstr.kind gl.sigma term with | App(t,args) -> ( - match EConstr.kind sigma t with + match EConstr.kind gl.sigma t with | Const c -> - ( match assoc_ops sigma t ops_spec with + ( match assoc_ops gl.sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin + | Opp -> let (expr,env) = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> + begin try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in - (power , env) + (power , env) with e when CErrors.noncritical e -> (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - ) + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + end + | Ukn s -> + if debug + then (Printf.printf "unknown op: %s\n" s; flush stdout;); + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + ) | _ -> parse_variable env term ) | _ -> parse_variable env term in @@ -954,9 +858,23 @@ struct coq_Ropp , Opp ; coq_Rpower , Power] - let zconstant = parse_z - let qconstant = parse_q + (** [parse_constant parse gl t] returns the reification of term [t]. + If [t] is a ground term, then it is first reduced to normal form + before using a 'syntactic' parser *) + let parse_constant parse gl t = + if is_ground_term gl.env gl.sigma t + then + parse gl.sigma (Redexpr.cbv_vm gl.env gl.sigma t) + else raise ParseError + + let zconstant = parse_constant parse_z + let qconstant = parse_constant parse_q + let nconstant = parse_constant parse_nat + (* NB: R is a different story. + Because it is axiomatised, reducing would not be effective. + Therefore, there is a specific parser for constant over R + *) let rconst_assoc = [ @@ -966,60 +884,69 @@ struct (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] - let rec rconstant sigma term = - match EConstr.kind sigma term with - | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 + let rconstant gl term = + + let sigma = gl.sigma in + + let rec rconstant term = + match EConstr.kind sigma term with + | Const x -> + if EConstr.eq_constr sigma term (Lazy.force coq_R0) + then Mc.C0 else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant sigma args.(0) in - let b = rconstant sigma args.(1) in - f a b - with + then Mc.C1 + else raise ParseError + | App(op,args) -> + begin + try + (* the evaluation order is important in the following *) + let f = assoc_const sigma op rconst_assoc in + let a = rconstant args.(0) in + let b = rconstant args.(1) in + f a b + with ParseError -> match op with | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant sigma args.(0) in + let arg = rconstant args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> + Mc.CPow(rconstant args.(0) , Mc.Inr (nconstant gl args.(1))) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> + Mc.CQ (qconstant gl args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> + Mc.CZ (zconstant gl args.(0)) | _ -> raise ParseError end + | _ -> raise ParseError in - | _ -> raise ParseError + rconstant term - let rconstant env sigma term = + let rconstant gl term = if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); - let res = rconstant sigma term in + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ()); + let res = rconstant gl term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res - let parse_zexpr env sigma = parse_expr env sigma - (zconstant sigma) + let parse_zexpr gl = parse_expr gl + zconstant (fun expr x -> - let exp = (parse_z sigma x) in + let exp = (zconstant gl x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr env sigma = parse_expr env sigma - (qconstant sigma) + let parse_qexpr gl = parse_expr gl + qconstant (fun expr x -> - let exp = parse_z sigma x in + let exp = zconstant gl x in match exp with | Mc.Zneg _ -> begin @@ -1031,10 +958,10 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr env sigma = parse_expr env sigma - (rconstant env sigma) + let parse_rexpr gl = parse_expr gl + rconstant (fun expr x -> - let exp = Mc.N.of_nat (parse_nat sigma x) in + let exp = Mc.N.of_nat (parse_nat gl.sigma x) in Mc.PEpow(expr,exp)) rop_spec @@ -1045,8 +972,8 @@ struct match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr gl.env sigma env lhs in - let (e2,env) = parse_expr gl.env sigma env rhs in + let (e1,env) = parse_expr gl env lhs in + let (e2,env) = parse_expr gl env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" @@ -1058,14 +985,14 @@ struct (* generic parsing of arithmetic expressions *) - let mkC f1 f2 = C(f1,f2) - let mkD f1 f2 = D(f1,f2) - let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) - let mkI f1 f2 = I(f1,None,f2) + let mkC f1 f2 = Mc.Cj(f1,f2) + let mkD f1 f2 = Mc.D(f1,f2) + let mkIff f1 f2 = Mc.Cj(Mc.I(f1,None,f2),Mc.I(f2,None,f1)) + let mkI f1 f2 = Mc.I(f1,None,f2) let mkformula_binary g term f1 f2 = match f1 , f2 with - | X _ , X _ -> X(term) + | Mc.X _ , Mc.X _ -> Mc.X(term) | _ -> g f1 f2 (** @@ -1078,8 +1005,8 @@ struct let parse_atom env tg t = try let (at,env) = parse_atom env t gl in - (A(at,tg,t), env,Tag.next tg) - with e when CErrors.noncritical e -> (X(t),env,tg) in + (Mc.A(at,(tg,t)), env,Tag.next tg) + with e when CErrors.noncritical e -> (Mc.X(t),env,tg) in let is_prop term = let sort = Retyping.get_sort_of gl.env gl.sigma term in @@ -1098,7 +1025,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) + let (f,env,tg) = xparse_formula env tg a in (Mc.N(f), env,tg) | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in @@ -1108,36 +1035,41 @@ struct let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) - | _ when is_prop term -> X(term),env,tg + | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (Mc.TT,env,tg) + | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> Mc.(FF,env,tg) + | _ when is_prop term -> Mc.X(term),env,tg | _ -> raise ParseError in xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = - let rec xdump f = + let app_ctor c args = + EConstr.mkApp(Lazy.force c, Array.of_list (typ::EConstr.mkProp::Lazy.force coq_unit :: Lazy.force coq_unit :: args)) in + + let rec xdump f = match f with - | TT -> EConstr.mkApp(Lazy.force coq_TT,[|typ|]) - | FF -> EConstr.mkApp(Lazy.force coq_FF,[|typ|]) - | C(x,y) -> EConstr.mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) - | I(x,_,y) -> EConstr.mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) - | N(x) -> EConstr.mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) - | A(x,_,_) -> EConstr.mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) - | X(t) -> EConstr.mkApp(Lazy.force coq_X,[|typ ; t|]) in + | Mc.TT -> app_ctor coq_TT [] + | Mc.FF -> app_ctor coq_FF [] + | Mc.Cj(x,y) -> app_ctor coq_And [xdump x ; xdump y] + | Mc.D(x,y) -> app_ctor coq_Or [xdump x ; xdump y] + | Mc.I(x,_,y) -> app_ctor coq_Impl [xdump x ; EConstr.mkApp(Lazy.force coq_None,[|Lazy.force coq_unit|]); xdump y] + | Mc.N(x) -> app_ctor coq_Neg [xdump x] + | Mc.A(x,_) -> app_ctor coq_Atom [dump_atom x;Lazy.force coq_tt] + | Mc.X(t) -> app_ctor coq_X [t] in xdump f - let prop_env_of_formula sigma form = + let prop_env_of_formula gl form = + Mc.( let rec doit env = function - | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env sigma t) - | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> + | TT | FF | A(_,_) -> env + | X t -> fst (Env.compute_rank_add env t) + | Cj(f1,f2) | D(f1,f2) | I(f1,_,f2) -> doit (doit env f1) f2 - | N f -> doit env f in + | N f -> doit env f + in - doit [] form + doit (Env.empty gl) form) let var_env_of_formula form = @@ -1151,14 +1083,14 @@ struct let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - + Mc.( let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,t,c) -> vars_of_atom a - | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) + | TT | FF | X _ -> ISet.empty + | A (a,(t,c)) -> vars_of_atom a + | Cj(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) | N f -> doit f in - doit form + doit form) @@ -1211,6 +1143,12 @@ let rec dump_Rcst_as_R cst = | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CPow(x,y) -> + begin + match y with + | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_powerZR,[| dump_Rcst_as_R x ; dump_z z|]) + | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Rpower,[| dump_Rcst_as_R x ; dump_nat n|]) + end | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) @@ -1246,17 +1184,17 @@ let prodn n env b = in prodrec (n,env,b) -let make_goal_of_formula sigma dexpr form = +let make_goal_of_formula gl dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - let props = prop_env_of_formula sigma form in + let props = prop_env_of_formula gl form in let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) props in + let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) (Env.elements props) in let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in @@ -1287,14 +1225,14 @@ let make_goal_of_formula sigma dexpr form = let rec xdump pi xi f = match f with - | TT -> Lazy.force coq_True - | FF -> Lazy.force coq_False - | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) - | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props sigma t in + | Mc.TT -> Lazy.force coq_True + | Mc.FF -> Lazy.force coq_False + | Mc.Cj(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) + | Mc.D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) + | Mc.I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) + | Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) + | Mc.A(x,_) -> dump_cstr xi x + | Mc.X(t) -> let idx = Env.get_rank props t in EConstr.mkRel (pi+idx) in let nb_vars = List.length vars_n in @@ -1303,10 +1241,10 @@ let make_goal_of_formula sigma dexpr form = (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) let subst_prop p = - let idx = Env.get_rank props sigma p in + let idx = Env.get_rank props p in EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - let form' = map_prop subst_prop form in + let form' = Mc.mapX subst_prop form in (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) @@ -1335,12 +1273,12 @@ end (** open M -let coq_Node = +let coq_Branch = lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Branch") +let coq_Elt = lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt") let coq_Empty = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") @@ -1353,9 +1291,9 @@ let coq_VarMap = let rec dump_varmap typ m = match m with | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Leaf v -> EConstr.mkApp(Lazy.force coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) + | Mc.Elt v -> EConstr.mkApp(Lazy.force coq_Elt,[| typ; v|]) + | Mc.Branch(l,o,r) -> + EConstr.mkApp (Lazy.force coq_Branch, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) let vm_of_list env = @@ -1425,7 +1363,9 @@ let rec parse_hyps gl parse_arith env tg hyps = (*exception ParseError*) -let parse_goal gl parse_arith env hyps term = + + +let parse_goal gl parse_arith (env:Env.t) hyps term = (* try*) let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in @@ -1459,6 +1399,40 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } +let max_tag f = 1 + (Tag.to_int (Mc.foldA (fun t1 (t2,_) -> Tag.max t1 t2) f (Tag.from 0))) + + +(** For completeness of the cutting-plane procedure, + each variable 'x' is replaced by 'y' - 'z' where + 'y' and 'z' are positive *) +let pre_processZ mt f = + + let x0 i = 2 * i in + let x1 i = 2 * i + 1 in + + let tag_of_var fr p b = + + let ip = CoqToCaml.positive fr + (CoqToCaml.positive p) in + + match b with + | None -> + let y = Mc.XO (Mc.Coq_Pos.add fr p) in + let z = Mc.XI (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x0 (x0 ip)) in + let constr = Mc.mk_eq_pos p y z in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) + | Some false -> + let y = Mc.XO (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x0 (x1 ip)) in + let constr = Mc.bound_var (Mc.XO y) in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) + | Some true -> + let z = Mc.XI (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x1 (x1 ip)) in + let constr = Mc.bound_var (Mc.XI z) in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) in + + Mc.bound_problem_fr tag_of_var mt f (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if @@ -1494,10 +1468,12 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* * The datastructures that aggregate prover attributes. *) -type ('option,'a,'prf) prover = { +open Certificate + +type ('option,'a,'prf,'model) prover = { name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : 'option * 'a list -> 'prf option ; (* the prover itself *) + get_option : unit ->'option ; (* find the options of the prover *) + prover : ('option * 'a list) -> ('prf, 'model) Certificate.res ; (* the prover itself *) hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) @@ -1507,37 +1483,37 @@ type ('option,'a,'prf) prover = { (** - * Given a list of provers and a disjunction of atoms, find a proof of any of + * Given a prover and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover * datastructure. *) -let find_witness provers polys1 = - let provers = List.map (fun p -> - (fun l -> - match p.prover (p.get_option (),l) with - | None -> None - | Some prf -> Some(prf,p)) , p.name) provers in - try_any provers (List.map fst polys1) +let find_witness p polys1 = + let polys1 = List.map fst polys1 in + match p.prover (p.get_option (), polys1) with + | Model m -> Model m + | Unknown -> Unknown + | Prf prf -> Prf(prf,p) (** - * Given a list of provers and a CNF, find a proof for each of the clauses. + * Given a prover and a CNF, find a proof for each of the clauses. * Return the proofs as a list. *) -let witness_list prover l = +let witness_list prover l = let rec xwitness_list l = match l with - | [] -> Some [] + | [] -> Prf [] | e :: l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w :: l) - ) in - xwitness_list l + match xwitness_list l with + | Model (m,e) -> Model (m,e) + | Unknown -> Unknown + | Prf l -> + match find_witness prover e with + | Model m -> Model (m,e) + | Unknown -> Unknown + | Prf w -> Prf (w::l) in + xwitness_list l let witness_list_tags = witness_list @@ -1545,6 +1521,7 @@ let witness_list_tags = witness_list * Prune the proof object, according to the 'diff' between two cnf formulas. *) + let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = @@ -1563,9 +1540,9 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let res = try prover.compact prf remap with x when CErrors.noncritical x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option () ,List.map fst new_cl) with - | None -> failwith "proof compaction error" - | Some p -> p + match prover.prover (prover.get_option (), List.map fst new_cl) with + | Unknown | Model _ -> failwith "proof compaction error" + | Prf p -> p in if debug then begin @@ -1580,11 +1557,31 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let hyps = selecti hyps_idx old_cl in is_sublist Pervasives.(=) hyps new_cl in + + let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) + if debug then + begin + Printf.printf "CNFRES\n"; flush stdout; + List.iter (fun (cl,(prf,prover)) -> + let hyps_idx = prover.hyps prf in + let hyps = selecti hyps_idx cl in + Printf.printf "\nProver %a -> %a\n" + pp_clause_tag cl pp_clause_tag hyps;flush stdout) cnf_res; + Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff'; + + end; List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' + let (o,p) = + try + List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + with Not_found -> + begin + Printf.printf "ERROR: no compatible proof" ; flush stdout; + failwith "Cannot find compatible proof" end + in + compact_proof o p x) cnf_ff' (** @@ -1593,14 +1590,15 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = *) let abstract_formula hyps f = + Mc.( let rec xabs f = match f with | X c -> X c - | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> + | A(a,(t,term)) -> if TagSet.mem t hyps then A(a,(t,term)) else X(term) + | Cj(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> C(f1,f2) ) + | f1 , f2 -> Cj(f1,f2) ) | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) @@ -1617,21 +1615,22 @@ let abstract_formula hyps f = ) | FF -> FF | TT -> TT - in xabs f + in xabs f) (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) let rec abstract_wrt_formula f1 f2 = + Mc.( match f1 , f2 with | X c , _ -> X c | A _ , A _ -> f2 - | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') + | Cj(a,b) , Cj(a',b') -> Cj(abstract_wrt_formula a a', abstract_wrt_formula b b') | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') | FF , FF -> FF | TT , TT -> TT | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula" + | _ -> failwith "abstract_wrt_formula") (** * This exception is raised by really_call_csdpcert if Coq's configure didn't @@ -1650,52 +1649,46 @@ let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) + Mc.X _ -> (cc,ids) + | _ -> (Mc.I(f,Some id,cc), id::ids)) hyps (concl,[]) -let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = +let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = (* Express the goal as one big implication *) let (ff,ids) = formula_hyps_concl polys1 polys2 in + let mt = CamlToCoq.positive (max_tag ff) in - (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in - - if debug then - begin - Feedback.msg_notice (Pp.str "Formula....\n") ; - let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff - end; + (* Construction of cnf *) + let pre_ff = (pre_process mt ff) in + let (cnf_ff,cnf_ff_tags) = cnf pre_ff in match witness_list_tags prover cnf_ff with - | None -> None - | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; + | Model m -> Model m + | Unknown -> Unknown + | Prf res -> (*Printf.printf "\nList %i" (List.length `res); *) + let hyps = List.fold_left + (fun s (cl,(prf,p)) -> + let tags = ISet.fold (fun i s -> + let t = fst (snd (List.nth cl i)) in + if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; + (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in + TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty (List.map fst cnf_ff_tags)) (List.combine cnf_ff res) in let ff' = abstract_formula hyps ff in - let cnf_ff',_ = cnf negate normalise unsat deduce ff' in + + let pre_ff' = pre_process mt ff' in + let cnf_ff',_ = cnf pre_ff' in + if debug then begin - Feedback.msg_notice (Pp.str "\nAFormula\n") ; - let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' + output_string stdout "\n"; + Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; + Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout; + Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout; + Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout; end; (* Even if it does not work, this does not mean it is not provable @@ -1709,10 +1702,18 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in - let (ff',res',ids) = (ff',res', ids_of_formula ff') in + let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Some (ids,ff',res') + Prf (ids,ff',res') + +let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = + try micromega_tauto pre_process cnf spec prover env polys1 polys2 gl + with Not_found -> + begin + Printexc.print_backtrace stdout; flush stdout; + Unknown + end (** @@ -1724,9 +1725,8 @@ let fresh_id avoid id gl = let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce + pre_process + cnf spec dumpexpr prover tac = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1734,15 +1734,19 @@ let micromega_gen let hyps = Tacmach.New.pf_hyps_types gl in try let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in + let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let dumpexpr = Lazy.force dumpexpr in + + + if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ; - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in + match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with + | Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids,ff',res') -> + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1755,7 +1759,7 @@ let micromega_gen micromega_order_change spec res' (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula sigma ff') in + let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -1785,16 +1789,10 @@ let micromega_gen ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - -let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec prover = - (micromega_gen parse_arith negate normalise unsat deduce spec prover) - - + | x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) + else raise x + end + end let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) @@ -1825,10 +1823,6 @@ let micromega_order_changer cert env ff = let micromega_genr prover tac = let parse_arith = parse_rarith in - let negate = Mc.rnegate in - let normalise = Mc.rnormalise in - let unsat = Mc.runsat in - let deduce = Mc.rdeduce in let spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; @@ -1843,21 +1837,21 @@ let micromega_genr prover tac = try let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in + let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in + let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in + let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> + match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with + | Unknown | Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids,ff',res') -> let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1869,7 +1863,7 @@ let micromega_genr prover tac = let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula sigma ff') in + let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -1910,8 +1904,8 @@ let micromega_genr prover = (micromega_genr prover) let lift_ratproof prover l = match prover l with - | None -> None - | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) + | Unknown | Model _ -> Unknown + | Prf c -> Prf (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list @@ -1982,22 +1976,22 @@ let rec z_to_q_pol e = let call_csdpcert_q provername poly = match call_csdpcert provername poly with - | None -> None + | None -> Unknown | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate") ;None) + then Prf cert + else ((print_string "buggy certificate") ;Unknown) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with - | None -> None + | None -> Unknown | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) + then Prf cert + else ((print_string "buggy certificate" ; flush stdout) ;Unknown) let xhyps_of_cone base acc prf = let rec xtract e acc = @@ -2040,12 +2034,6 @@ let hyps_of_pt pt = xhyps 0 pt ISet.empty -let hyps_of_pt pt = - let res = hyps_of_pt pt in - if debug - then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); - res - let compact_pt pt f = let translate ofset x = if x < ofset then x @@ -2140,8 +2128,8 @@ let non_linear_prover_R str o = { let non_linear_prover_Z str o = { name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -2174,52 +2162,65 @@ let nlinear_Z = { *) let lra_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ linear_prover_Q ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + linear_prover_Q let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "real_nonlinear_prover" (Some i) ) let lra_R = - micromega_genr [ linear_prover_R ] + micromega_genr linear_prover_R let psatz_R i = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] + micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i)) let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "real_nonlinear_prover" (Some i) ) let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "pure_sos" None ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "pure_sos" None) let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "pure_sos" None ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "pure_sos" None) let sos_R = - micromega_genr [ non_linear_prover_R "pure_sos" None ] + micromega_genr (non_linear_prover_R "pure_sos" None) -let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ linear_Z ] +let xlia = + micromega_gen parse_zarith pre_processZ Mc.cnfZ zz_domain_spec dump_zexpr + linear_Z + let xnlia = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ nlinear_Z ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + nlinear_Z let nra = - micromega_genr [ nlinear_prover_R ] + micromega_genr nlinear_prover_R let nqa = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ nlinear_prover_R ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + nlinear_prover_R + +(** Let expose [is_ground_tac] *) + +let is_ground_tac t = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + if is_ground_term env sigma t + then Tacticals.New.tclIDTAC + else Tacticals.New.tclFAIL 0 (Pp.str "Not ground") + end + - (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index d1776b8ca4..075594cffc 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +val is_ground_tac : EConstr.constr -> unit Proofview.tactic val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index 21f0414e9c..6bf5f76a04 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -30,6 +30,9 @@ TACTIC EXTEND RED | [ "myred" ] -> { Tactics.red_in_concl } END +TACTIC EXTEND ISGROUND +| [ "is_ground" constr(t) ] -> { Coq_micromega.is_ground_tac t } +END TACTIC EXTEND PsatzZ diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index f67f1da146..b34c3b2b7d 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1,4 +1,9 @@ +type __ = Obj.t + +type unit0 = +| Tt + (** val negb : bool -> bool **) let negb = function @@ -9,6 +14,20 @@ type nat = | O | S of nat +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +(** val fst : ('a1 * 'a2) -> 'a1 **) + +let fst = function +| x,_ -> x + +(** val snd : ('a1 * 'a2) -> 'a2 **) + +let snd = function +| _,y -> y + (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = @@ -37,6 +56,29 @@ module Coq__1 = struct end include Coq__1 +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) + +let rec nth n0 l default = + match n0 with + | O -> (match l with + | [] -> default + | x::_ -> x) + | S m -> (match l with + | [] -> default + | _::t0 -> nth m t0 default) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) + +let rec map f = function +| [] -> [] +| a::t0 -> (f a)::(map f t0) + +(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) + +let rec fold_right f a0 = function +| [] -> a0 +| b::t0 -> f b (fold_right f a0 t0) + type positive = | XI of positive | XO of positive @@ -269,29 +311,6 @@ let rec pow_pos rmul x = function | XO i0 -> let p = pow_pos rmul x i0 in rmul p p | XH -> x -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> (match l with - | [] -> default - | x::_ -> x) - | S m -> (match l with - | [] -> default - | _::t0 -> nth m t0 default) - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function -| [] -> [] -| a::t0 -> (f a)::(map f t0) - -(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - -let rec fold_right f a0 = function -| [] -> a0 -| b::t0 -> f b (fold_right f a0 t0) - module Z = struct (** val double : z -> z **) @@ -435,6 +454,12 @@ module Z = | Zpos p -> Npos p | _ -> N0 + (** val of_nat : nat -> z **) + + let of_nat = function + | O -> Z0 + | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = @@ -889,53 +914,105 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function ppow_N cO cI cadd cmul ceqb (fun p -> p) (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 -type 'a bFormula = +type ('tA, 'tX, 'aA, 'aF) gFormula = | TT | FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula - -(** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) +| X of 'tX +| A of 'tA * 'aA +| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| N of ('tA, 'tX, 'aA, 'aF) gFormula +| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option + * ('tA, 'tX, 'aA, 'aF) gFormula + +(** val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) + gFormula **) + +let rec mapX f = function +| X x -> X (f x) +| Cj (f1, f2) -> Cj ((mapX f f1), (mapX f f2)) +| D (f1, f2) -> D ((mapX f f1), (mapX f f2)) +| N f1 -> N (mapX f f1) +| I (f1, o, f2) -> I ((mapX f f1), o, (mapX f f2)) +| x -> x + +(** val foldA : + ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 **) + +let rec foldA f f0 acc = + match f0 with + | A (_, an) -> f acc an + | Cj (f1, f2) -> foldA f f1 (foldA f f2 acc) + | D (f1, f2) -> foldA f f1 (foldA f f2 acc) + | N f1 -> foldA f f1 acc + | I (f1, _, f2) -> foldA f f1 (foldA f f2 acc) + | _ -> acc + +(** val cons_id : 'a1 option -> 'a1 list -> 'a1 list **) + +let cons_id id l = + match id with + | Some id0 -> id0::l + | None -> l + +(** val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list **) + +let rec ids_of_formula = function +| I (_, id, f') -> cons_id id (ids_of_formula f') +| _ -> [] + +(** val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list **) + +let rec collect_annot = function +| A (_, a) -> a::[] +| Cj (f1, f2) -> app (collect_annot f1) (collect_annot f2) +| D (f1, f2) -> app (collect_annot f1) (collect_annot f2) +| N f0 -> collect_annot f0 +| I (f1, _, f2) -> app (collect_annot f1) (collect_annot f2) +| _ -> [] + +type 'a bFormula = ('a, __, unit0, unit0) gFormula + +(** val map_bformula : + ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) + gFormula **) let rec map_bformula fct = function | TT -> TT | FF -> FF -| X -> X -| A a -> A (fct a) +| X p -> X p +| A (a, t0) -> A ((fct a), t0) | Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) | D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) | N f0 -> N (map_bformula fct f0) -| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) +| I (f1, a, f2) -> I ((map_bformula fct f1), a, (map_bformula fct f2)) -type 'x clause = 'x list +type ('x, 'annot) clause = ('x * 'annot) list -type 'x cnf = 'x clause list +type ('x, 'annot) cnf = ('x, 'annot) clause list -(** val tt : 'a1 cnf **) +(** val cnf_tt : ('a1, 'a2) cnf **) -let tt = +let cnf_tt = [] -(** val ff : 'a1 cnf **) +(** val cnf_ff : ('a1, 'a2) cnf **) -let ff = +let cnf_ff = []::[] (** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) + clause -> ('a1, 'a2) clause option **) let rec add_term unsat deduce t0 = function | [] -> - (match deduce t0 t0 with + (match deduce (fst t0) (fst t0) with | Some u -> if unsat u then None else Some (t0::[]) | None -> Some (t0::[])) | t'::cl0 -> - (match deduce t0 t' with + (match deduce (fst t0) (fst t') with | Some u -> if unsat u then None @@ -948,8 +1025,8 @@ let rec add_term unsat deduce t0 = function | None -> None)) (** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause - -> 'a1 clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) clause -> ('a1, 'a2) clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with @@ -960,8 +1037,8 @@ let rec or_clause unsat deduce cl1 cl2 = | None -> None) (** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> - 'a1 cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) let or_clause_cnf unsat deduce t0 f = fold_right (fun e acc -> @@ -970,29 +1047,32 @@ let or_clause_cnf unsat deduce t0 f = | None -> acc) [] f (** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 - cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) let rec or_cnf unsat deduce f f' = match f with - | [] -> tt + | [] -> cnf_tt | e::rst -> app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') -(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) +(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) let and_cnf = app +type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula + (** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) + tFormula -> ('a2, 'a3) cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function -| TT -> if pol0 then tt else ff -| FF -> if pol0 then ff else tt -| X -> ff -| A x -> if pol0 then normalise0 x else negate0 x +| TT -> if pol0 then cnf_tt else cnf_ff +| FF -> if pol0 then cnf_ff else cnf_tt +| X _ -> cnf_ff +| A (x, t0) -> if pol0 then normalise0 x t0 else negate0 x t0 | Cj (e1, e2) -> if pol0 then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) @@ -1006,7 +1086,7 @@ let rec xcnf unsat deduce normalise0 negate0 pol0 = function else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e -| I (e1, e2) -> +| I (e1, _, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) @@ -1014,8 +1094,95 @@ let rec xcnf unsat deduce normalise0 negate0 pol0 = function else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) +(** val radd_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) + clause -> (('a1, 'a2) clause, 'a2 list) sum **) + +let rec radd_term unsat deduce t0 = function +| [] -> + (match deduce (fst t0) (fst t0) with + | Some u -> if unsat u then Inr ((snd t0)::[]) else Inl (t0::[]) + | None -> Inl (t0::[])) +| t'::cl0 -> + (match deduce (fst t0) (fst t') with + | Some u -> + if unsat u + then Inr ((snd t0)::((snd t')::[])) + else (match radd_term unsat deduce t0 cl0 with + | Inl cl' -> Inl (t'::cl') + | Inr l -> Inr l) + | None -> + (match radd_term unsat deduce t0 cl0 with + | Inl cl' -> Inl (t'::cl') + | Inr l -> Inr l)) + +(** val ror_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum **) + +let rec ror_clause unsat deduce cl1 cl2 = + match cl1 with + | [] -> Inl cl2 + | t0::cl -> + (match radd_term unsat deduce t0 cl2 with + | Inl cl' -> ror_clause unsat deduce cl cl' + | Inr l -> Inr l) + +(** val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) + +let ror_clause_cnf unsat deduce t0 f = + fold_right (fun e pat -> + let acc,tg = pat in + (match ror_clause unsat deduce t0 e with + | Inl cl -> (cl::acc),tg + | Inr l -> acc,(app tg l))) ([],[]) f + +(** val ror_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> + ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 list **) + +let rec ror_cnf unsat deduce f f' = + match f with + | [] -> cnf_tt,[] + | e::rst -> + let rst_f',t0 = ror_cnf unsat deduce rst f' in + let e_f',t' = ror_clause_cnf unsat deduce e f' in + (app rst_f' e_f'),(app t0 t') + +(** val rxcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) + tFormula -> ('a2, 'a3) cnf * 'a3 list **) + +let rec rxcnf unsat deduce normalise0 negate0 polarity = function +| TT -> if polarity then cnf_tt,[] else cnf_ff,[] +| FF -> if polarity then cnf_ff,[] else cnf_tt,[] +| X _ -> cnf_ff,[] +| A (x, t0) -> (if polarity then normalise0 x t0 else negate0 x t0),[] +| Cj (e1, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then (app e3 e4),(app t1 t2) + else let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) +| D (e1, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + else (app e3 e4),(app t1 t2) +| N e -> rxcnf unsat deduce normalise0 negate0 (negb polarity) e +| I (e1, _, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 (negb polarity) e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + else (and_cnf e3 e4),(app t1 t2) + (** val cnf_checker : - ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) let rec cnf_checker checker f l = match f with @@ -1026,9 +1193,9 @@ let rec cnf_checker checker f l = | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> - bool **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> + bool) -> ('a1, __, 'a3, unit0) gFormula -> 'a4 list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w @@ -1243,11 +1410,12 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = (** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> + ('a1 nFormula, 'a2) cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 tg = + map (fun x -> (x,tg)::[]) + (xnormalise cO cI cplus ctimes cminus copp ceqb t0) (** val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 @@ -1271,11 +1439,11 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t0 = (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> + ('a1 nFormula, 'a2) cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) +let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 tg = + map (fun x -> (x,tg)::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -1366,6 +1534,13 @@ let simpl_cone cO cI ctimes ceqb e = match e with | _ -> PsatzAdd (t1, t2))) | _ -> e +module PositiveSet = + struct + type tree = + | Leaf + | Node of tree * bool * tree + end + type q = { qnum : z; qden : positive } (** val qnum : q -> z **) @@ -1429,16 +1604,16 @@ let qpower q0 = function type 'a t = | Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t +| Elt of 'a +| Branch of 'a t * 'a * 'a t (** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) let rec find default vm p = match vm with | Empty -> default - | Leaf i -> i - | Node (l, e, r) -> + | Elt i -> i + | Branch (l, e, r) -> (match p with | XI p2 -> find default r p2 | XO p2 -> find default l p2 @@ -1448,24 +1623,24 @@ let rec find default vm p = let rec singleton default x v = match x with - | XI p -> Node (Empty, default, (singleton default p v)) - | XO p -> Node ((singleton default p v), default, Empty) - | XH -> Leaf v + | XI p -> Branch (Empty, default, (singleton default p v)) + | XO p -> Branch ((singleton default p v), default, Empty) + | XH -> Elt v (** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) let rec vm_add default x v = function | Empty -> singleton default x v -| Leaf vl -> +| Elt vl -> (match x with - | XI p -> Node (Empty, vl, (singleton default p v)) - | XO p -> Node ((singleton default p v), vl, Empty) - | XH -> Leaf v) -| Node (l, o, r) -> + | XI p -> Branch (Empty, vl, (singleton default p v)) + | XO p -> Branch ((singleton default p v), vl, Empty) + | XH -> Elt v) +| Branch (l, o, r) -> (match x with - | XI p -> Node (l, o, (vm_add default p v r)) - | XO p -> Node ((vm_add default p v l), o, r) - | XH -> Node (l, v, r)) + | XI p -> Branch (l, o, (vm_add default p v r)) + | XO p -> Branch ((vm_add default p v l), o, r) + | XH -> Branch (l, v, r)) type zWitness = z psatz @@ -1507,10 +1682,10 @@ let xnormalise0 t0 = | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) -(** val normalise : z formula -> z nFormula cnf **) +(** val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let normalise t0 = - map (fun x -> x::[]) (xnormalise0 t0) +let normalise t0 tg = + map (fun x -> (x,tg)::[]) (xnormalise0 t0) (** val xnegate0 : z formula -> z nFormula list **) @@ -1530,10 +1705,10 @@ let xnegate0 t0 = | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) -(** val negate : z formula -> z nFormula cnf **) +(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let negate t0 = - map (fun x -> x::[]) (xnegate0 t0) +let negate t0 tg = + map (fun x -> (x,tg)::[]) (xnegate0 t0) (** val zunsat : z nFormula -> bool **) @@ -1545,6 +1720,12 @@ let zunsat = let zdeduce = nformula_plus_nformula Z0 Z.add zeq_bool +(** val cnfZ : + (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list **) + +let cnfZ f = + rxcnf zunsat zdeduce normalise negate true f + (** val ceiling : z -> z -> z **) let ceiling a b = @@ -1629,6 +1810,145 @@ let valid_cut_sign = function | NonStrict -> true | _ -> false +module Vars = + struct + type elt = positive + + type tree = PositiveSet.tree = + | Leaf + | Node of tree * bool * tree + + type t = tree + + (** val empty : t **) + + let empty = + Leaf + + (** val add : elt -> t -> t **) + + let rec add i = function + | Leaf -> + (match i with + | XI i0 -> Node (Leaf, false, (add i0 Leaf)) + | XO i0 -> Node ((add i0 Leaf), false, Leaf) + | XH -> Node (Leaf, true, Leaf)) + | Node (l, o, r) -> + (match i with + | XI i0 -> Node (l, o, (add i0 r)) + | XO i0 -> Node ((add i0 l), o, r) + | XH -> Node (l, true, r)) + + (** val singleton : elt -> t **) + + let singleton i = + add i empty + + (** val union : t -> t -> t **) + + let rec union m m' = + match m with + | Leaf -> m' + | Node (l, o, r) -> + (match m' with + | Leaf -> m + | Node (l', o', r') -> + Node ((union l l'), (if o then true else o'), (union r r'))) + + (** val rev_append : elt -> elt -> elt **) + + let rec rev_append y x = + match y with + | XI y0 -> rev_append y0 (XI x) + | XO y0 -> rev_append y0 (XO x) + | XH -> x + + (** val rev : elt -> elt **) + + let rev x = + rev_append x XH + + (** val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 **) + + let rec xfold f m v i = + match m with + | Leaf -> v + | Node (l, b, r) -> + if b + then xfold f r (f (rev i) (xfold f l v (XO i))) (XI i) + else xfold f r (xfold f l v (XO i)) (XI i) + + (** val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 **) + + let fold f m i = + xfold f m i XH + end + +(** val vars_of_pexpr : z pExpr -> Vars.t **) + +let rec vars_of_pexpr = function +| PEc _ -> Vars.empty +| PEX x -> Vars.singleton x +| PEadd (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEsub (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEmul (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEopp c -> vars_of_pexpr c +| PEpow (e0, _) -> vars_of_pexpr e0 + +(** val vars_of_formula : z formula -> Vars.t **) + +let vars_of_formula f = + let { flhs = l; fop = _; frhs = r } = f in + let v1 = vars_of_pexpr l in let v2 = vars_of_pexpr r in Vars.union v1 v2 + +(** val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t **) + +let rec vars_of_bformula = function +| A (a, _) -> vars_of_formula a +| Cj (f1, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| D (f1, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| N f0 -> vars_of_bformula f0 +| I (f1, _, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| _ -> Vars.empty + +(** val bound_var : positive -> z formula **) + +let bound_var v = + { flhs = (PEX v); fop = OpGe; frhs = (PEc Z0) } + +(** val mk_eq_pos : positive -> positive -> positive -> z formula **) + +let mk_eq_pos x y t0 = + { flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) } + +(** val bound_vars : + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z + formula, 'a1, 'a2, 'a3) gFormula **) + +let bound_vars tag_of_var fr v = + Vars.fold (fun k acc -> + let y = XO (Coq_Pos.add fr k) in + let z0 = XI (Coq_Pos.add fr k) in + Cj ((Cj ((A ((mk_eq_pos k y z0), (tag_of_var fr k None))), (Cj ((A + ((bound_var y), (tag_of_var fr k (Some false)))), (A ((bound_var z0), + (tag_of_var fr k (Some true)))))))), acc)) v TT + +(** val bound_problem_fr : + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, + 'a1, 'a2, 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula **) + +let bound_problem_fr tag_of_var fr f = + let v = vars_of_bformula f in I ((bound_vars tag_of_var fr v), None, f) + (** val zChecker : z nFormula list -> zArithProof -> bool **) let rec zChecker l = function @@ -1675,7 +1995,8 @@ let rec zChecker l = function (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise negate zChecker f w + tauto_checker zunsat zdeduce normalise negate (fun cl -> + zChecker (map fst cl)) f w type qWitness = q psatz @@ -1685,17 +2006,17 @@ let qWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool -(** val qnormalise : q formula -> q nFormula cnf **) +(** val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let qnormalise = +let qnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool + qplus qmult qminus qopp qeq_bool t0 tg -(** val qnegate : q formula -> q nFormula cnf **) +(** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let qnegate = +let qnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + qmult qminus qopp qeq_bool t0 tg (** val qunsat : q nFormula -> bool **) @@ -1713,10 +2034,17 @@ let normQ = norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool +(** val cnfQ : + (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list **) + +let cnfQ f = + rxcnf qunsat qdeduce qnormalise qnegate true f + (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = - tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w + tauto_checker qunsat qdeduce qnormalise qnegate (fun cl -> + qWeakChecker (map fst cl)) f w type rcst = | C0 @@ -1726,9 +2054,16 @@ type rcst = | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst +| CPow of rcst * (z, nat) sum | CInv of rcst | COpp of rcst +(** val z_of_exp : (z, nat) sum -> z **) + +let z_of_exp = function +| Inl z1 -> z1 +| Inr n0 -> Z.of_nat n0 + (** val q_of_Rcst : rcst -> q **) let rec q_of_Rcst = function @@ -1739,6 +2074,7 @@ let rec q_of_Rcst = function | CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) | CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) | CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) +| CPow (r1, z0) -> qpower (q_of_Rcst r1) (z_of_exp z0) | CInv r0 -> qinv (q_of_Rcst r0) | COpp r0 -> qopp (q_of_Rcst r0) @@ -1750,17 +2086,17 @@ let rWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool -(** val rnormalise : q formula -> q nFormula cnf **) +(** val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let rnormalise = +let rnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool + qplus qmult qminus qopp qeq_bool t0 tg -(** val rnegate : q formula -> q nFormula cnf **) +(** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let rnegate = +let rnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + qmult qminus qopp qeq_bool t0 tg (** val runsat : q nFormula -> bool **) @@ -1775,5 +2111,5 @@ let rdeduce = (** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) let rTautoChecker f w = - tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker - (map_bformula (map_Formula q_of_Rcst) f) w + tauto_checker runsat rdeduce rnormalise rnegate (fun cl -> + rWeakChecker (map fst cl)) (map_bformula (map_Formula q_of_Rcst) f) w diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 72c2bf7da3..5de6caac0b 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,10 +1,23 @@ +type __ = Obj.t + +type unit0 = +| Tt + val negb : bool -> bool type nat = | O | S of nat +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val fst : ('a1 * 'a2) -> 'a1 + +val snd : ('a1 * 'a2) -> 'a2 + val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = @@ -16,6 +29,12 @@ val compOpp : comparison -> comparison val add : nat -> nat -> nat +val nth : nat -> 'a1 list -> 'a1 -> 'a1 + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 + type positive = | XI of positive | XO of positive @@ -87,12 +106,6 @@ module N : val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -val nth : nat -> 'a1 list -> 'a1 -> 'a1 - -val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 - module Z : sig val double : z -> z @@ -125,6 +138,8 @@ module Z : val to_N : z -> n + val of_nat : nat -> z + val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z @@ -163,27 +178,47 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol -val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 + pol -> 'a1 pol -val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 + pol -val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> + 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol -> 'a1 pol -val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol +val psquare : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -197,49 +232,104 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol -val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol +val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol -type 'a bFormula = +type ('tA, 'tX, 'aA, 'aF) gFormula = | TT | FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula +| X of 'tX +| A of 'tA * 'aA +| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| N of ('tA, 'tX, 'aA, 'aF) gFormula +| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula + +val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula + +val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 + +val cons_id : 'a1 option -> 'a1 list -> 'a1 list + +val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list + +val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list + +type 'a bFormula = ('a, __, unit0, unit0) gFormula + +val map_bformula : + ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula + +type ('x, 'annot) clause = ('x * 'annot) list + +type ('x, 'annot) cnf = ('x, 'annot) clause list + +val cnf_tt : ('a1, 'a2) cnf -val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula +val cnf_ff : ('a1, 'a2) cnf -type 'x clause = 'x list +val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> + ('a1, 'a2) clause option -type 'x cnf = 'x clause list +val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause -> ('a1, 'a2) clause option -val tt : 'a1 cnf +val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf -val ff : 'a1 cnf +val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> + ('a1, 'a2) cnf -val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option +val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option +type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula -val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf +val xcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, + 'a3) cnf -val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val radd_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> + (('a1, 'a2) clause, 'a2 list) sum -val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val ror_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause + -> (('a1, 'a2) clause, 'a2 list) sum -val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf +val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause + list -> ('a1, 'a2) clause list * 'a2 list -val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool +val ror_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> ('a1, 'a2) + clause list -> ('a1, 'a2) cnf * 'a2 list + +val rxcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, + 'a3) cnf * 'a3 list + +val cnf_checker : + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, + 'a3, unit0) gFormula -> 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -273,21 +363,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option -val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option +val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula + -> 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option -val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool +val check_inconsistent : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -300,27 +396,31 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol -val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val psub0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> + ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -330,7 +430,15 @@ val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula -val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz +val simpl_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz + +module PositiveSet : + sig + type tree = + | Leaf + | Node of tree * bool * tree + end type q = { qnum : z; qden : positive } @@ -358,8 +466,8 @@ val qpower : q -> z -> q type 'a t = | Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t +| Elt of 'a +| Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 @@ -379,16 +487,18 @@ val normZ : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list -val normalise : z formula -> z nFormula cnf +val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf val xnegate0 : z formula -> z nFormula list -val negate : z formula -> z nFormula cnf +val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf val zunsat : z nFormula -> bool val zdeduce : z nFormula -> z nFormula -> z nFormula option +val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list + val ceiling : z -> z -> z type zArithProof = @@ -415,6 +525,51 @@ val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option val valid_cut_sign : op1 -> bool +module Vars : + sig + type elt = positive + + type tree = PositiveSet.tree = + | Leaf + | Node of tree * bool * tree + + type t = tree + + val empty : t + + val add : elt -> t -> t + + val singleton : elt -> t + + val union : t -> t -> t + + val rev_append : elt -> elt -> elt + + val rev : elt -> elt + + val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 + + val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 + end + +val vars_of_pexpr : z pExpr -> Vars.t + +val vars_of_formula : z formula -> Vars.t + +val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t + +val bound_var : positive -> z formula + +val mk_eq_pos : positive -> positive -> positive -> z formula + +val bound_vars : + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, + 'a1, 'a2, 'a3) gFormula + +val bound_problem_fr : + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, + 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula + val zChecker : z nFormula list -> zArithProof -> bool val zTautoChecker : z formula bFormula -> zArithProof list -> bool @@ -423,9 +578,9 @@ type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool -val qnormalise : q formula -> q nFormula cnf +val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf -val qnegate : q formula -> q nFormula cnf +val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf val qunsat : q nFormula -> bool @@ -433,6 +588,8 @@ val qdeduce : q nFormula -> q nFormula -> q nFormula option val normQ : q pExpr -> q pol +val cnfQ : (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list + val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = @@ -443,18 +600,21 @@ type rcst = | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst +| CPow of rcst * (z, nat) sum | CInv of rcst | COpp of rcst +val z_of_exp : (z, nat) sum -> z + val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool -val rnormalise : q formula -> q nFormula cnf +val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf -val rnegate : q formula -> q nFormula cnf +val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf val runsat : q nFormula -> bool diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 809731ecc4..084ea39c27 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,8 +19,18 @@ (* *) (************************************************************************) +module Int = struct + type t = int + let compare : int -> int -> int = Pervasives.compare + let equal : int -> int -> bool = (=) +end -module ISet = Set.Make(Int) +module ISet = + struct + include Set.Make(Int) + + let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s + end module IMap = struct @@ -82,12 +92,69 @@ let extract pred l = | _ -> (fd, e::sys) ) (None,[]) l +let extract_best red lt l = + let rec extractb c e rst l = + match l with + [] -> Some (c,e) , rst + | e'::l' -> match red e' with + | None -> extractb c e (e'::rst) l' + | Some c' -> if lt c' c + then extractb c' e' (e::rst) l' + else extractb c e (e'::rst) l' in + match extract red l with + | None , _ -> None,l + | Some(c,e), rst -> extractb c e [] rst + + +let rec find_some pred l = + match l with + | [] -> None + | e::l -> match pred e with + | Some r -> Some r + | None -> find_some pred l + + let extract_all pred l = List.fold_left (fun (s1,s2) e -> match pred e with | None -> s1,e::s2 | Some v -> (v,e)::s1 , s2) ([],[]) l +let simplify f sys = + let (sys',b) = + List.fold_left (fun (sys',b) c -> + match f c with + | None -> (c::sys',b) + | Some c' -> + (c'::sys',true) + ) ([],false) sys in + if b then Some sys' else None + +let generate_acc f acc sys = + List.fold_left (fun sys' c -> match f c with + | None -> sys' + | Some c' -> c'::sys' + ) acc sys + + +let generate f sys = generate_acc f [] sys + + +let saturate p f sys = + let rec sat acc l = + match extract p l with + | None,_ -> acc + | Some r,l' -> + let n = generate (f r) (l'@acc) in + sat (n@acc) l' in + try sat [] sys with + x -> + begin + Printexc.print_backtrace stdout ; + raise x + end + + open Num open Big_int @@ -276,7 +343,8 @@ sig val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int - + val max : t -> t -> t + val to_int : t -> int end module Tag : Tag = @@ -286,8 +354,10 @@ struct let from i = i let next i = i + 1 + let max : int -> int -> int = Pervasives.max let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Int.compare + let to_int x = x end diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index e92f086886..739d1a73da 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,8 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Int : sig type t = int val compare : int -> int -> int val equal : int -> int -> bool end -module ISet : Set.S with type elt = int + +module ISet : sig + include Set.S with type elt = int + val pp : out_channel -> t -> unit +end module IMap : sig @@ -36,7 +41,9 @@ module Tag : sig val pp : out_channel -> t -> unit val next : t -> t + val max : t -> t -> t val from : int -> t + val to_int : t -> int end @@ -78,8 +85,18 @@ val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list val extract_all : ('a -> 'b option) -> 'a list -> ('b * 'a) list * 'a list +val extract_best : ('a -> 'b option) -> ('b -> 'b -> bool) -> 'a list -> ('b *'a) option * 'a list + +val find_some : ('a -> 'b option) -> 'a list -> 'b option + val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a +val simplify : ('a -> 'a option) -> 'a list -> 'a list option + +val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list + +val generate : ('a -> 'b option) -> 'a list -> 'b list + val app_funs : ('a -> 'b option) list -> 'a -> 'b option val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 76e7769e82..d406560fb8 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -378,6 +378,7 @@ module LinPoly = struct let pp o p = Vect.pp_gen pp_var o p + let constant c = if sign_num c = 0 then Vect.null @@ -389,6 +390,12 @@ module LinPoly = struct let mn = (MonT.retrieve v) in Monomial.is_var mn || Monomial.is_const mn) p + let is_variable p = + let ((x,v),r) = Vect.decomp_fst p in + if Vect.is_null r && v >/ Int 0 + then Monomial.get_var (MonT.retrieve x) + else None + let factorise x p = let (px,cx) = Poly.factorise x (pol_of_linpol p) in @@ -399,20 +406,6 @@ module LinPoly = struct let (a,b) = factorise x p in Vect.is_constant a - let search_linear p l = - - Vect.find (fun x v -> - if p v - then - let x' = MonT.retrieve x in - match Monomial.get_var x' with - | None -> None - | Some x -> if is_linear_for x l - then Some x - else None - else None) l - - let search_all_linear p l = Vect.fold (fun acc x v -> if p v @@ -426,12 +419,24 @@ module LinPoly = struct else acc else acc) [] l + let min_list (l:int list) = + match l with + | [] -> None + | e::l -> Some (List.fold_left Pervasives.min e l) + + let search_linear p l = + min_list (search_all_linear p l) + let product p1 p2 = linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2)) let addition p1 p2 = Vect.add p1 p2 + + let of_vect v = + Vect.fold (fun acc v vl -> addition (product (var v) (constant vl)) acc) Vect.null v + let variables p = Vect.fold (fun acc v _ -> ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p @@ -489,8 +494,8 @@ module ProofFormat = struct | Cst c -> Printf.fprintf o "Cst %s" (string_of_num c) | Zero -> Printf.fprintf o "Zero" | Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s) - | MulC(p,pr) -> Printf.fprintf o "(%a) * %a" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr - | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 + | MulC(p,pr) -> Printf.fprintf o "(%a) * (%a)" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr + | MulPrf(p1,p2) -> Printf.fprintf o "(%a) * (%a)" output_prf_rule p1 output_prf_rule p2 | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) @@ -502,6 +507,18 @@ module ProofFormat = struct output_prf_rule p1 Vect.pp v output_prf_rule p2 (pp_list ";" output_proof) pl + let rec pr_size = function + | Annot(_,p) -> pr_size p + | Zero| Square _ -> Int 0 + | Hyp _ -> Int 1 + | Def _ -> Int 1 + | Cst n -> n + | Gcd(i, p) -> pr_size p // (Big_int i) + | MulPrf(p1,p2) | AddPrf(p1,p2) -> pr_size p1 +/ pr_size p2 + | CutPrf p -> pr_size p + | MulC(v, p) -> pr_size p + + let rec pr_rule_max_id = function | Annot(_,p) -> pr_rule_max_id p | Hyp i | Def i -> i @@ -613,6 +630,48 @@ module ProofFormat = struct if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; res + module OrdPrfRule = + struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1,x2) (y1,y2) = + match c1 x1 y1 with + | 0 -> c2 x2 y2 + | i -> i + + + let rec compare p1 p2 = + match p1, p2 with + | Annot(s1,p1) , Annot(s2,p2) -> if s1 = s2 then compare p1 p2 + else Pervasives.compare s1 s2 + | Hyp i , Hyp j -> Pervasives.compare i j + | Def i , Def j -> Pervasives.compare i j + | Cst n , Cst m -> Num.compare_num n m + | Zero , Zero -> 0 + | Square v1 , Square v2 -> Vect.compare v1 v2 + | MulC(v1,p1) , MulC(v2,p2) -> cmp_pair Vect.compare compare (v1,p1) (v2,p2) + | Gcd(b1,p1) , Gcd(b2,p2) -> cmp_pair Big_int.compare_big_int compare (b1,p1) (b2,p2) + | MulPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) + | AddPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) + | CutPrf p , CutPrf p' -> compare p p' + | _ , _ -> Pervasives.compare (id_of_constr p1) (id_of_constr p2) + + end + + let add_proof x y = @@ -621,23 +680,91 @@ module ProofFormat = struct | _ -> AddPrf(x,y) - let mul_cst_proof c p = - match sign_num c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> MulC(LinPoly.constant c,p) (* [p] should represent an equality *) - | 1 -> - if eq_num (Int 1) c - then p - else MulPrf(Cst c,p) - | _ -> assert false + let rec mul_cst_proof c p = + match p with + | Annot(s,p) -> Annot(s,mul_cst_proof c p) + | MulC(v,p') -> MulC(Vect.mul c v,p') + | _ -> + match sign_num c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> MulC(LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> + if eq_num (Int 1) c + then p + else MulPrf(Cst c,p) + | _ -> assert false + + + let sMulC v p = + let (c,v') = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p + else MulC(v,p) let mul_proof p1 p2 = match p1 , p2 with | Zero , _ | _ , Zero -> Zero - | Cst (Int 1) , p | p , Cst (Int 1) -> p - | _ , _ -> MulPrf(p1,p2) + | Cst c , p | p , Cst c -> mul_cst_proof c p + | _ , _ -> + MulPrf(p1,p2) + + module PrfRuleMap = Map.Make(OrdPrfRule) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + + let rec dev_prf_rule p = + match p with + | Annot(s,p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + | MulC(v,p) -> PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf(p1,p2) -> PrfRuleMap.merge (fun k o1 o2 -> + match o1 , o2 with + | None , None -> None + | None , Some v | Some v, None -> Some v + | Some v1 , Some v2 -> Some (LinPoly.addition v1 v2)) (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf(p1, p2) -> + begin + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf(p1'',p2'')) (LinPoly.constant (Int 1)) + end + | _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + + let simplify_prf_rule p = + prf_rule_of_map (dev_prf_rule p) + + + (* + let mul_proof p1 p2 = + let res = mul_proof p1 p2 in + Printf.printf "mul_proof %a %a = %a\n" + output_prf_rule p1 output_prf_rule p2 output_prf_rule res; res + + let add_proof p1 p2 = + let res = add_proof p1 p2 in + Printf.printf "add_proof %a %a = %a\n" + output_prf_rule p1 output_prf_rule p2 output_prf_rule res; res + + + let sMulC v p = + let res = sMulC v p in + Printf.printf "sMulC %a %a = %a\n" Vect.pp v output_prf_rule p output_prf_rule res ; + res + + let mul_cst_proof c p = + let res = mul_cst_proof c p in + Printf.printf "mul_cst_proof %s %a = %a\n" (Num.string_of_num c) output_prf_rule p output_prf_rule res ; + res + *) let proof_of_farkas env vect = Vect.fold (fun prf x n -> @@ -645,6 +772,7 @@ module ProofFormat = struct + module Env = struct let rec string_of_int_list l = @@ -768,10 +896,14 @@ module WithProof = struct let output o ((lp,op),prf) = Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) ProofFormat.output_prf_rule prf + let output_sys o l = + List.iter (Printf.fprintf o "%a\n" output) l + exception InvalidProof let zero = ((Vect.null,Eq), ProofFormat.Zero) + let const n = ((LinPoly.constant n,Ge), ProofFormat.Cst n) let of_cstr (c,prf) = (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf @@ -784,7 +916,7 @@ module WithProof = struct let mult p ((p1,o1),prf1) = match o1 with - | Eq -> ((LinPoly.product p p1,o1), ProofFormat.MulC(p, prf1)) + | Eq -> ((LinPoly.product p p1,o1), ProofFormat.sMulC p prf1) | Gt| Ge -> let (n,r) = Vect.decomp_cst p in if Vect.is_null r && n >/ Int 0 then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) @@ -890,6 +1022,51 @@ module WithProof = struct end | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" + let linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = + match linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) with + | None -> None + | Some (c,p) -> Some(c, ProofFormat.simplify_prf_rule p) + + +let is_substitution strict ((p,o),prf) = + let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in + + match o with + | Eq -> LinPoly.search_linear pred p + | _ -> None + + +let subst1 sys0 = + let (oeq,sys') = extract (is_substitution true) sys0 in + match oeq with + | None -> sys0 + | Some(v,pc) -> + match simplify (linear_pivot sys0 pc v) sys' with + | None -> sys0 + | Some sys' -> sys' + + + +let subst sys0 = + let elim sys = + let (oeq,sys') = extract (is_substitution true) sys in + match oeq with + | None -> None + | Some(v,pc) -> simplify (linear_pivot sys0 pc v) sys' in + + iterate_until_stable elim sys0 + + +let saturate_subst b sys0 = + let select = is_substitution b in + let gen (v,pc) ((c,op),prf) = + if ISet.mem v (LinPoly.variables c) + then linear_pivot sys0 pc v ((c,op),prf) + else None + in + saturate select gen sys0 + + end diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 23f3470d77..b5c6fefbb5 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -28,6 +28,8 @@ module Monomial : sig @return the empty monomial i.e. without any variable *) val const : t + val is_const : t -> bool + (** [var x] @return the monomial x^1 *) val var : var -> t @@ -40,6 +42,11 @@ module Monomial : sig @return [true] iff m = x^1 for some variable x *) val is_var : t -> bool + (** [get_var m] + @return [x] iff m = x^1 for variable x *) + val get_var : t -> var option + + (** [div m1 m2] @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) val div : t -> t -> t * int @@ -141,6 +148,10 @@ module LinPoly : sig @return the monomial corresponding to the variable [x] *) val retrieve : int -> Monomial.t + (** [register m] + @return the variable index for the monomial m *) + val register : Monomial.t -> int + end (** [linpol_of_pol p] linearise the polynomial p *) @@ -161,11 +172,21 @@ module LinPoly : sig @returns 1.x where x is the variable (index) for monomial m *) val of_monomial : Monomial.t -> t + (** [of_vect v] + @returns a1.x1 + ... + an.xn + This is not the identity because xi is the variable index of xi^1 + *) + val of_vect : Vect.t -> t + (** [variables p] @return the set of variables of the polynomial p interpreted as a multi-variate polynomial *) val variables : t -> ISet.t + (** [is_variable p] + @return Some x if p = a.x for a >= 0 *) + val is_variable : t -> var option + (** [is_linear p] @return whether the multi-variate polynomial is linear. *) val is_linear : t -> bool @@ -245,6 +266,8 @@ module ProofFormat : sig | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list + val pr_size : prf_rule -> Num.num + val pr_rule_max_id : prf_rule -> int val proof_max_id : proof -> int @@ -294,9 +317,14 @@ sig (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) val output : out_channel -> t -> unit + val output_sys : out_channel -> t list -> unit + (** [zero] represents the tautology (0=0) *) val zero : t + (** [const n] represents the tautology (n>=0) *) + val const : Num.num -> t + (** [product p q] @return the polynomial p*q with its sign and proof *) val product : t -> t -> t @@ -321,4 +349,24 @@ sig *) val linear_pivot : t list -> t -> Vect.var -> t -> t option + +(** [subst sys] performs the equivalent of the 'subst' tactic of Coq. + For every p=0 \in sys such that p is linear in x with coefficient +/- 1 + i.e. p = 0 <-> x = e and x \notin e. + Replace x by e in sys + + NB: performing this transformation may hinders the non-linear prover to find a proof. + [elim_simple_linear_equality] is much more careful. + *) + + val subst : t list -> t list + + (** [subst1 sys] performs a single substitution *) + val subst1 : t list -> t list + + val saturate_subst : bool -> t list -> t list + + + val is_substitution : bool -> t -> var option + end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 4465aa1ee1..4ddeb6c2c0 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -11,9 +11,11 @@ (** A naive simplex *) open Polynomial open Num -open Util +(*open Util*) open Mutils +type ('a,'b) sum = Inl of 'a | Inr of 'b + let debug = false type iset = unit IMap.t @@ -130,12 +132,6 @@ let is_maximised rst v = violating a restriction. *) -(* let is_unbounded rst tbl vr = - IMap.for_all (fun x v -> if Vect.get vr v </ Int 0 - then not (IMap.mem vr rst) - else true - ) tbl - *) type result = | Max of num (** Maximum is reached *) @@ -335,6 +331,8 @@ let normalise_row (t : tableau) (v: Vect.t) = let add_row (nw :var) (t : tableau) (v : Vect.t) : tableau = IMap.add nw (normalise_row t v) t + + (** [push_real] performs reasoning over the rationals *) let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tableau) : certificate = if debug @@ -361,7 +359,7 @@ let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tabl Unsat (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) -(** One complication is that equalities needs some pre-processing.contents +(** One complication is that equalities needs some pre-processing. *) open Mutils open Polynomial @@ -406,25 +404,21 @@ let find_solution rst tbl = let choose_conflict (sol:Vect.t) (l: (var * Vect.t) list) = let esol = Vect.set 0 (Int 1) sol in - let is_conflict (x,v) = - if Vect.dotproduct esol v >=/ Int 0 - then None else Some(x,v) in - let (c,r) = extract is_conflict l in - match c with - | Some (c,_) -> Some (c,r) - | None -> match l with - | [] -> None - | e::l -> Some(e,l) - -(*let remove_redundant rst t = - IMap.fold (fun k v m -> if Restricted.is_restricted k rst && Vect.for_all (fun x _ -> x == 0 || Restricted.is_restricted x rst) v - then begin - if debug then - Printf.printf "%a is redundant\n" LinPoly.pp_var k; - IMap.remove k m - end - else m) t t - *) + + let rec most_violating l e (x,v) rst = + match l with + | [] -> Some((x,v),rst) + | (x',v')::l -> + let e' = Vect.dotproduct esol v' in + if e' <=/ e + then most_violating l e' (x',v') ((x,v)::rst) + else most_violating l e (x,v) ((x',v')::rst) in + + match l with + | [] -> None + | (x,v)::l -> let e = Vect.dotproduct esol v in + most_violating l e (x,v) [] + let rec solve opt l (rst:Restricted.t) (t:tableau) = @@ -515,65 +509,117 @@ let make_farkas_proof (env: WithProof.t IMap.t) vm v = WithProof.mult (Vect.cst n) (IMap.find x env) end) WithProof.zero v -(* -let incr_cut rmin x = - match rmin with - | None -> true - | Some r -> Int.compare x r = 1 - *) -let cut env rmin sol vm (rst:Restricted.t) (x,v) = -(* if not (incr_cut rmin x) - then None - else *) - let (n,r) = Vect.decomp_cst v in +let frac_num n = n -/ Num.floor_num n - let nf = Num.floor_num n in - if nf =/ n + +(* [resolv_var v rst tbl] returns (if it exists) a restricted variable vr such that v = vr *) +exception FoundVar of int + +let resolve_var v rst tbl = + let v = Vect.set v (Int 1) Vect.null in + try + IMap.iter (fun k vect -> + if Restricted.is_restricted k rst + then if Vect.equal v vect then raise (FoundVar k) + else ()) tbl ; None + with FoundVar k -> Some k + +let prepare_cut env rst tbl x v = + (* extract the unrestricted part *) + let (unrst,rstv) = Vect.partition (fun x vl -> not (Restricted.is_restricted x rst) && frac_num vl <>/ Int 0) (Vect.set 0 (Int 0) v) in + if Vect.is_null unrst + then Some rstv + else Some (Vect.fold (fun acc k i -> + match resolve_var k rst tbl with + | None -> acc (* Should not happen *) + | Some v' -> Vect.set v' i acc) + rstv unrst) + +let cut env rmin sol vm (rst:Restricted.t) tbl (x,v) = + begin + (* Printf.printf "Trying to cut %i\n" x;*) + let (n,r) = Vect.decomp_cst v in + + + let f = frac_num n in + + if f =/ Int 0 then None (* The solution is integral *) else (* This is potentially a cut *) - let cut = Vect.normalise - (Vect.fold (fun acc x n -> - if Restricted.is_restricted x rst then - Vect.set x (n -/ (Num.floor_num n)) acc - else acc - ) Vect.null r) in - if debug then Printf.fprintf stdout "Cut vector for %a : %a\n" LinPoly.pp_var x LinPoly.pp cut ; - let cut = make_farkas_proof env vm cut in - - match WithProof.cutting_plane cut with - | None -> None - | Some (v,prf) -> - if debug then begin - Printf.printf "This is a cutting plane:\n" ; - Printf.printf "%a -> %a\n" WithProof.output cut WithProof.output (v,prf); - end; - if Pervasives.(=) (snd v) Eq - then (* Unsat *) Some (x,(v,prf)) - else if eval_op Ge (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) (Int 0) - then begin - (* Can this happen? *) - if debug then Printf.printf "The cut is feasible - drop it\n"; - None - end - else Some(x,(v,prf)) - -let find_cut env u sol vm rst tbl = - (* find first *) - IMap.fold (fun x v acc -> - match acc with - | None -> cut env u sol vm rst (x,v) - | Some c -> acc) tbl None - -(* -let find_cut env u sol vm rst tbl = - IMap.fold (fun x v acc -> - match acc with - | Some c -> Some c - | None -> cut env u sol vm rst (x,v) - ) tbl None - *) + let t = + if f </ (Int 1) // (Int 2) + then + let t' = ((Int 1) // f) in + if Num.is_integer_num t' + then t' -/ Int 1 + else Num.floor_num t' + else Int 1 in + + let cut_coeff1 v = + let fv = frac_num v in + if fv <=/ (Int 1 -/ f) + then fv // (Int 1 -/ f) + else (Int 1 -/ fv) // f in + + let cut_coeff2 v = frac_num (t */ v) in + + let cut_vector ccoeff = + match prepare_cut env rst tbl x v with + | None -> Vect.null + | Some r -> + (*Printf.printf "Potential cut %a\n" LinPoly.pp r;*) + Vect.fold (fun acc x n -> Vect.set x (ccoeff n) acc) Vect.null r + in + + let lcut = List.map (fun cv -> Vect.normalise (cut_vector cv)) [cut_coeff1 ; cut_coeff2] in + + let lcut = List.map (make_farkas_proof env vm) lcut in + + let check_cutting_plane c = + match WithProof.cutting_plane c with + | None -> + if debug then Printf.printf "This is not cutting plane for %a\n%a:" LinPoly.pp_var x WithProof.output c; + None + | Some(v,prf) -> + if debug then begin + Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; + Printf.printf " %a\n" WithProof.output (v,prf); + end; + if Pervasives.(=) (snd v) Eq + then (* Unsat *) Some (x,(v,prf)) + else + let vl = (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) in + if eval_op Ge vl (Int 0) + then begin + (* Can this happen? *) + if debug then Printf.printf "The cut is feasible %s >= 0 ??\n" (Num.string_of_num vl); + None + end + else Some(x,(v,prf)) in + + find_some check_cutting_plane lcut + end + +let find_cut nb env u sol vm rst tbl = + if nb = 0 + then + IMap.fold (fun x v acc -> + match acc with + | None -> cut env u sol vm rst tbl (x,v) + | Some c -> Some c) tbl None + else + IMap.fold (fun x v acc -> + match cut env u sol vm rst tbl (x,v) , acc with + | None , Some r | Some r , None -> Some r + | None , None -> None + | Some (v,((lp,o),p1)) , Some (v',((lp',o'),p2)) -> + Some (if ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 + then (v,((lp,o),p1)) else (v',((lp',o'),p2))) + ) tbl None + + let integer_solver lp = let (l,_) = List.split lp in @@ -587,7 +633,10 @@ let integer_solver lp = | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) | Unsat c -> Inr c in + let nb = ref 0 in + let rec isolve env cr vr res = + incr nb; match res with | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) | Inl (rst,tbl,x) -> @@ -595,10 +644,11 @@ let integer_solver lp = Printf.fprintf stdout "Looking for a cut\n"; Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; + (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) end; let sol = find_solution rst tbl in - match find_cut env cr (*x*) sol vm rst tbl with + match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with | None -> None | Some(cr,((v,op),cut)) -> if Pervasives.(=) op Eq @@ -615,6 +665,8 @@ let integer_solver lp = isolve env None vr res let integer_solver lp = + if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp); + match integer_solver lp with | None -> None | Some prf -> if debug diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index b188ab4278..b80d5536eb 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -54,6 +54,17 @@ let pp_var_num pp_var o (v,n) = | Int 0 -> () | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v +let pp_var_num_smt pp_var o (v,n) = + if Int.equal v 0 + then if eq_num (Int 0) n then () + else Printf.fprintf o "%s" (string_of_num n) + else + match n with + | Int 1 -> pp_var o v + | Int -1 -> Printf.fprintf o "(- %a)" pp_var v + | Int 0 -> () + | _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v + let rec pp_gen pp_var o v = match v with @@ -66,6 +77,9 @@ let pp_var o v = Printf.fprintf o "x%i" v let pp o v = pp_gen pp_var o v +let pp_smt o v = + let list o v = List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v in + Printf.fprintf o "(+ %a)" list v let from_list (l: num list) = let rec xfrom_list i l = @@ -222,6 +236,19 @@ let decomp_cst v = | (0,vl)::v -> vl,v | _ -> Int 0,v +let rec decomp_at i v = + match v with + | [] -> (Int 0 , null) + | (vr,vl)::r -> if i = vr then (vl,r) + else if i < vr then (Int 0,v) + else decomp_at i r + +let decomp_fst v = + match v with + | [] -> ((0,Int 0),[]) + | x::v -> (x,v) + + let fold f acc v = List.fold_left (fun acc (v,i) -> f acc v i) acc v @@ -293,3 +320,19 @@ let dotproduct v1 v2 = then dot acc v1' v2 else dot acc v1 v2' in dot (Int 0) v1 v2 + + +let map f v = List.map (fun (x,v) -> f x v) v + +let abs_min_elt v = + match v with + | [] -> None + | (v,vl)::r -> + Some (List.fold_left (fun (v1,vl1) (v2,vl2) -> + if abs_num vl1 </ abs_num vl2 + then (v1,vl1) else (v2,vl2) ) (v,vl) r) + + +let partition p = List.partition (fun (vr,vl) -> p vr vl) + +let mkvar x = set x (Int 1) null diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index da6b1e8e9b..4c9b140aad 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -40,6 +40,9 @@ val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit (** [pp o v] prints the representation of the vector [v] over the channel [o] *) val pp : out_channel -> t -> unit +(** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *) +val pp_smt : out_channel -> t -> unit + (** [variables v] returns the set of variables with non-zero coefficients *) val variables : t -> ISet.t @@ -49,6 +52,11 @@ val get_cst : t -> num (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> num * t +(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : int -> t -> num * t + +val decomp_fst : t -> (var * num) * t + (** [cst c] returns the vector v=c+0.x1+...+0.xn *) val cst : num -> t @@ -70,10 +78,13 @@ val get : var -> t -> num i.e. the coefficient of the variable xi is set to ai' *) val set : var -> num -> t -> t +(** [mkvar xi] returns 1.xi *) +val mkvar : var -> t + (** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) val update : var -> (num -> num) -> t -> t -(** [fresh v] return the fresh variable with inded 1+ max (variables v) *) +(** [fresh v] return the fresh variable with index 1+ max (variables v) *) val fresh : t -> int (** [choose v] decomposes a vector [v] depending on whether it is [null] or not. @@ -154,3 +165,9 @@ val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option (** [dotproduct v1 v2] is the dot product of v1 and v2. *) val dotproduct : t -> t -> num + +val map : (var -> num -> 'a) -> t -> 'a list + +val abs_min_elt : t -> (var * num) option + +val partition : (var -> num -> bool) -> t -> t * t diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index f5d13053b1..813c521ab0 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -54,10 +54,10 @@ Record almost_field_theory : Prop := mk_afield { Section AlmostField. Variable AFth : almost_field_theory. -Let ARth := AFth.(AF_AR). -Let rI_neq_rO := AFth.(AF_1_neq_0). -Let rdiv_def := AFth.(AFdiv_def). -Let rinv_l := AFth.(AFinv_l). +Let ARth := (AF_AR AFth). +Let rI_neq_rO := (AF_1_neq_0 AFth). +Let rdiv_def := (AFdiv_def AFth). +Let rinv_l := (AFinv_l AFth). Add Morphism radd with signature (req ==> req ==> req) as radd_ext. Proof. exact (Radd_ext Reqe). Qed. @@ -115,12 +115,12 @@ Notation "- x" := (copp x) : C_scope. Infix "=?" := ceqb : C_scope. Notation "[ x ]" := (phi x) (at level 0). -Let phi_0 := CRmorph.(morph0). -Let phi_1 := CRmorph.(morph1). +Let phi_0 := (morph0 CRmorph). +Let phi_1 := (morph1 CRmorph). Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. Proof. -generalize (CRmorph.(morph_eq) c c'). +generalize ((morph_eq CRmorph) c c'). destruct (c =? c')%coef; auto. Qed. @@ -137,7 +137,7 @@ Variable get_sign_spec : sign_theory copp ceqb get_sign. Variable cdiv:C -> C -> C*C. Variable cdiv_th : div_theory req cadd cmul phi cdiv. -Let rpow_pow := pow_th.(rpow_pow_N). +Let rpow_pow := (rpow_pow_N pow_th). (* Polynomial expressions : (PExpr C) *) @@ -428,7 +428,7 @@ Qed. Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. Proof. -induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp. +induction p;simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. Qed. Lemma pow_pos_mul_l x y p : @@ -1587,7 +1587,7 @@ Section FieldAndSemiField. Definition F2AF f := mk_afield - (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). + (Rth_ARth Rsth Reqe (F_R f)) (F_1_neq_0 f) (Fdiv_def f) (Finv_l f). Record semi_field_theory : Prop := mk_sfield { SF_SR : semi_ring_theory rO rI radd rmul req; @@ -1603,10 +1603,10 @@ End MakeFieldPol. Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ - (SRth_ARth Rsth sf.(SF_SR)) - sf.(SF_1_neq_0) - sf.(SFdiv_def) - sf.(SFinv_l). + (SRth_ARth Rsth (SF_SR sf)) + (SF_1_neq_0 sf) + (SFdiv_def sf) + (SFinv_l sf). Section Complete. @@ -1621,9 +1621,9 @@ Section Complete. Notation "x == y" := (req x y) (at level 70, no associativity). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid3. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. @@ -1636,10 +1636,10 @@ Section Complete. Section AlmostField. Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). + Let ARth := (AF_AR AFth). + Let rI_neq_rO := (AF_1_neq_0 AFth). + Let rdiv_def := (AFdiv_def AFth). + Let rinv_l := (AFinv_l AFth). Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. @@ -1705,10 +1705,10 @@ End AlmostField. Section Field. Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := Fth.(F_R). - Let rI_neq_rO := Fth.(F_1_neq_0). - Let rdiv_def := Fth.(Fdiv_def). - Let rinv_l := Fth.(Finv_l). + Let Rth := (F_R Fth). + Let rI_neq_rO := (F_1_neq_0 Fth). + Let rdiv_def := (Fdiv_def Fth). + Let rinv_l := (Finv_l Fth). Let AFth := F2AF Rsth Reqe Fth. Let ARth := Rth_ARth Rsth Reqe Rth. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 15d490a6ab..4886c8b9aa 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -51,9 +51,9 @@ Section ZMORPHISM. Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid3. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. @@ -267,9 +267,9 @@ Section NMORPHISM. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. @@ -392,9 +392,9 @@ Section NWORDMORPHISM. Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid5. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. @@ -581,9 +581,9 @@ Section GEN_DIV. (* Useful tactics *) Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd with signature (req ==> req ==> req) as radd_ext. @@ -614,7 +614,7 @@ Section GEN_DIV. Proof. constructor. intros a b;unfold triv_div. - assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). + assert (X:= morph_eq morph a b);destruct (ceqb a b). Esimpl. rewrite X; trivial. rsimpl. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 12f716c496..f7cb6b688b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -600,7 +600,7 @@ Section MakeRingPol. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. - apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). @@ -810,7 +810,7 @@ Section MakeRingPol. Proof. revert l. induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). + - assert (H := (div_eucl_th div_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. @@ -827,7 +827,7 @@ Section MakeRingPol. try (case Pos.compare_spec; intros He); rewrite ?He; destr_factor; simpl; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). + - assert (H := div_eucl_th div_th c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - now rewrite <- jump_add, Pos.sub_add. @@ -1073,7 +1073,7 @@ Section POWER. - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - rewrite IHpe. Esimpl. - rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. @@ -1329,7 +1329,7 @@ Section POWER. case_eq (get_sign c);intros. assert (H1 := (morph_eq CRmorph) c0 cI). destruct (c0 ?=! cI). - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H)). Esimpl. rewrite H1;trivial. rewrite <- r_list_pow_rev;trivial;Esimpl. apply mkmultm1_ok. rewrite <- r_list_pow_rev; apply mkmult_rec_ok. @@ -1340,7 +1340,7 @@ Qed. Proof. intros;unfold mkadd_mult. case_eq (get_sign c);intros. - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. Qed. @@ -1421,7 +1421,7 @@ Qed. | xO _ => rpow r (Cp_phi (Npos p)) | 1 => r end == pow_pos rmul r p. - Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed. + Proof. destruct p; now rewrite ?(rpow_pow_N pow_th). Qed. Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 6c782269ab..3e835f5c9f 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -358,7 +358,7 @@ Section ALMOST_RING. rewrite <-(Radd_0_l Rth (- x * y)). rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). - rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth). + rewrite (Radd_comm Rth (-x)), (Ropp_def Rth). now rewrite Rmul_0_l, (Radd_0_l Rth). Qed. @@ -407,9 +407,9 @@ Section ALMOST_RING. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. Add Parametric Relation : C ceq - reflexivity proved by Csth.(@Equivalence_Reflexive _ _) - symmetry proved by Csth.(@Equivalence_Symmetric _ _) - transitivity proved by Csth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Csth) + symmetry proved by (@Equivalence_Symmetric _ _ Csth) + transitivity proved by (@Equivalence_Transitive _ _ Csth) as C_setoid. Add Morphism cadd with signature (ceq ==> ceq ==> ceq) as cadd_ext. @@ -430,7 +430,7 @@ Section ALMOST_RING. Lemma Smorph_opp x : [-!x] == -[x]. Proof. - rewrite <- (Rth.(Radd_0_l) [-!x]). + rewrite <- (Radd_0_l Rth [-!x]). rewrite <- ((Ropp_def Rth) [x]). rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). @@ -498,12 +498,12 @@ Qed. Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. Proof. - mrewrite. now rewrite !(ARth.(ARmul_comm) z). + mrewrite. now rewrite !(ARmul_comm ARth z). Qed. Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. Proof. - now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x). + now rewrite <-(ARadd_assoc ARth x), (ARadd_comm ARth x). Qed. Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index 3ce6478700..6be556b2ae 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -86,15 +86,20 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_theory id t l } - | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + | ![proof] [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + fun ~pstate -> Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> - let sigma, env = Pfedit.get_current_context () in + (* We should use the global env here as this shouldn't contain proof + data, however preserving behavior as requested in review. *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name } + ) !from_name; + pstate } END TACTIC EXTEND ring_lookup @@ -130,15 +135,20 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } -| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { +| ![proof] [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { + fun ~pstate -> Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> - let sigma, env = Pfedit.get_current_context () in + (* We should use the global env here as this shouldn't + contain proof data. *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name } + ) !field_from_name; + pstate } END TACTIC EXTEND field_lookup diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 6956120a6a..2a84469af0 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -246,6 +246,7 @@ let interp_refine ist gl rc = fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in @@ -1175,7 +1176,7 @@ let genstac (gens, clr) = tclTHENLIST (old_cleartac clr :: List.rev_map gentac gens) let gen_tmp_ids - ?(ist=Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty })) gl + ?(ist=Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })) gl = let gl, ctx = pull_ctx gl in push_ctxs ctx @@ -1232,7 +1233,7 @@ let abs_wgen keep_let f gen (gl,args,c) = let evar_closed t p = if occur_existential sigma t then CErrors.user_err ?loc:(loc_of_cpattern p) ~hdr:"ssreflect" - (pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) ++ + (pr_econstr_pat env sigma t ++ str" contains holes and matches no subterm of the goal") in match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 3fc05437da..350bb9019e 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -239,8 +239,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elimty = Reductionops.whd_all env (project gl) elimty in seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in - ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elim))); - ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elimty))); + let () = + let sigma = project gl in + ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) | _ -> assert false in @@ -255,38 +257,56 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = (* Here we try to understand if the main pattern/term the user gave is * the first pattern to be matched (i.e. if elimty ends in P t1 .. tn, * weather tn is the t the user wrote in 'elim: t' *) - let c_is_head_p, gl = match cty with + let c_is_head_p, gl = + match cty with | None -> true, gl (* The user wrote elim: _ *) | Some (c, c_ty, _) -> - let res = - (* we try to see if c unifies with the last arg of elim *) - if elim_is_dep then None else - let arg = List.assoc (n_elim_args - 1) elim_args in - let gl, arg_ty = pfe_type_of gl arg in - match saturate_until gl c c_ty (fun c c_ty gl -> - pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with - | Some (c, _, _, gl) -> Some (false, gl) - | None -> None in - match res with - | Some x -> x - | None -> - (* we try to see if c unifies with the last inferred pattern *) - let inf_arg = List.hd inf_deps_r in - let gl, inf_arg_ty = pfe_type_of gl inf_arg in - match saturate_until gl c c_ty (fun _ c_ty gl -> - pf_unify_HO gl c_ty inf_arg_ty) with - | Some (c, _, _,gl) -> true, gl - | None -> - errorstrm Pp.(str"Unable to apply the eliminator to the term"++ - spc()++pr_econstr_env env (project gl) c++spc()++str"or to unify it's type with"++ - pr_econstr_env env (project gl) inf_arg_ty) in + let rec first = function + | [] -> + errorstrm Pp.(str"Unable to apply the eliminator to the term"++ + spc()++pr_econstr_env env (project gl) c++spc()) + | x :: rest -> + match x () with + | None -> first rest + | Some (b,gl) -> b, gl + in + (* Unify two terms if their heads are not applied unif variables, eg + * not (?P x). The idea is to rule out cases where the problem is too + * vague to drive the current heuristics. *) + let pf_unify_HO_rigid gl a b = + let is_applied_evar x = match EConstr.kind (project gl) x with + | App(x,_) -> EConstr.isEvar (project gl) x + | _ -> false in + if is_applied_evar a || is_applied_evar b then + raise Evarconv.(UnableToUnify(project gl, + Pretype_errors.ProblemBeyondCapabilities)) + else pf_unify_HO gl a b in + let try_c_last_arg () = + (* we try to see if c unifies with the last arg of elim *) + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let gl, arg_ty = pfe_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO_rigid gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + let try_c_last_pattern () = + (* we try to see if c unifies with the last inferred pattern *) + if inf_deps_r = [] then None else + let inf_arg = List.hd inf_deps_r in + let gl, inf_arg_ty = pfe_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO_rigid gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> Some(true, gl) + | None -> None in + first [try_c_last_arg;try_c_last_pattern] in ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at * the type of the elimination principle *) let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern env p) in - let pp_inf_pat gl (_,_,t,_) = pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl t)) in + let pp_inf_pat gl (_,_,t,_) = pr_econstr_pat env (project gl) (fire_subst gl t) in let patterns, clr, gl = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl @@ -300,7 +320,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr c))); + ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -323,7 +343,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elim_pred, gen_eq_tac, clr, gl = let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ spc()++pp_term gl t++spc()++str"while the inferred pattern"++ - spc()++pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in + spc()++pr_econstr_pat env (project gl) (fire_subst gl inf_t)++spc()++ str"doesn't") in let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then @@ -408,7 +428,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = if not (Evar.Set.is_empty inter) then begin let i = Evar.Set.choose inter in let pat = List.find (fun t -> Evar.Set.mem i (evars_of_term t)) patterns in - errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr pat)++spc()++ + errorstrm Pp.(str"Pattern"++spc()++pr_econstr_pat env (project gl) pat++spc()++ str"was not completely instantiated and one of its variables"++spc()++ str"occurs in the type of another non-instantiated pattern variable"); end diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 15480c7a45..5abbc214de 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -205,7 +205,7 @@ let rec get_evalref env sigma c = match EConstr.kind sigma c with | App (c', _) -> get_evalref env sigma c' | Cast (c', _, _) -> get_evalref env sigma c' | Proj(c,_) -> EvalConstRef(Projection.constant c) - | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") + | _ -> errorstrm Pp.(str "The term " ++ pr_econstr_pat (Global.env ()) sigma c ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with @@ -244,7 +244,7 @@ let unfoldintac occ rdx t (kt,_) gl = try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " - ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), + ++ pr_econstr_pat env sigma0 t ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), (fun () -> try end_T () with | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") @@ -270,12 +270,12 @@ let unfoldintac occ rdx t (kt,_) gl = else try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) with _ -> errorstrm Pp.(str "The term " ++ - pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t))), + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_econstr_pat env sigma t)), fake_pmatcher_end in let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) - with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat env0 sigma (EConstr.Unsafe.to_constr t)) in + with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl concl) gl ;; @@ -325,7 +325,7 @@ let rec strip_prod_assum c = match Constr.kind c with let rule_id = mk_internal_id "rewrite rule" -exception PRtype_error +exception PRtype_error of (Environ.env * Evd.evar_map * Pretype_errors.pretype_error) option let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) @@ -351,7 +351,10 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in (* We check the proof is well typed *) let sigma, proof_ty = - try Typing.type_of env sigma proof with _ -> raise PRtype_error in + try Typing.type_of env sigma proof with + | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) + | e when CErrors.noncritical e -> raise (PRtype_error None) + in ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); try refine_with ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl @@ -412,7 +415,7 @@ let rwcltac cl rdx dir sr gl = let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> - errorstrm Pp.(str "no cast from " ++ pr_constr_pat (pf_env gl) (project gl) (EConstr.Unsafe.to_constr (snd sr)) + errorstrm Pp.(str "no cast from " ++ pr_econstr_pat (pf_env gl) (project gl) (snd sr) ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in @@ -423,13 +426,16 @@ let rwcltac cl rdx dir sr gl = in let cvtac' _ = try cvtac gl with - | PRtype_error -> + | PRtype_error e -> + let error = Option.cata (fun (env, sigma, te) -> + Pp.(fnl () ++ str "Type error was: " ++ Himsg.explain_pretype_error env sigma te)) + (Pp.mt ()) e in if occur_existential (project gl) (Tacmach.pf_concl gl) - then errorstrm Pp.(str "Rewriting impacts evars") + then errorstrm Pp.(str "Rewriting impacts evars" ++ error) else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_constr_env (pf_env gl) (project gl) - (Term.mkNamedLambda (make_annot pattern_id Sorts.Relevant) - (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) + ++ pr_econstr_env (pf_env gl) (project gl) + (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl) + ++ error) in tclTHEN cvtac' rwtac gl @@ -473,7 +479,7 @@ let rwprocess_rule dir rule gl = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat env sigma (EConstr.Unsafe.to_constr t))); + ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -532,8 +538,8 @@ let rwprocess_rule dir rule gl = sigma, (d, r', lhs, rhs) :: rs | _ -> if red = 0 then loop d sigma r t rs 1 - else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) - ++ spc() ++ str "in rule " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr (snd rule))) + else errorstrm Pp.(str "not a rewritable relation: " ++ pr_econstr_pat env sigma t + ++ spc() ++ str "in rule " ++ pr_econstr_pat env sigma (snd rule)) in let sigma, r = rule in let t = Retyping.get_type_of env sigma r in @@ -547,9 +553,9 @@ let rwrxtac occ rdx_pat dir rule gl = let find_rule rdx = let rec rwtac = function | [] -> - errorstrm Pp.(str "pattern " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr rdx) ++ + errorstrm Pp.(str "pattern " ++ pr_econstr_pat env (project gl) rdx ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (snd rule))) + str " of " ++ pr_econstr_pat env (project gl) (snd rule)) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index be9586fdd7..3cadc92bcc 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -50,7 +50,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = let c = EConstr.of_constr c in let cl = EConstr.of_constr cl in if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ - pr_constr_pat env sigma (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ + pr_econstr_pat env sigma c++spc()++str"did not match and has holes."++spc()++ str"Did you mean pose?") else let c, (gl, cty) = match EConstr.kind sigma c with | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index e9fe1f3e48..3481b25c8b 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -369,18 +369,20 @@ let tac_intro_seed interp_ipats fix = Goal.enter begin fun gl -> end end (*** [=> [: id]] ************************************************************) -[@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 in -begin fun () -> +begin fun env sigma -> + let sigma, zero = EConstr.fresh_global env sigma (lib_ref "num.nat.O") in + let sigma, succ = EConstr.fresh_global env sigma (lib_ref "num.nat.S") in let rec nat_of_n n = - if n = 0 then EConstr.mkConstruct path_of_O - else EConstr.mkApp (EConstr.mkConstruct path_of_S, [|nat_of_n (n-1)|]) in - incr ssr_abstract_id; nat_of_n !ssr_abstract_id + if n = 0 then zero + else EConstr.mkApp (succ, [|nat_of_n (n-1)|]) in + incr ssr_abstract_id; + sigma, nat_of_n !ssr_abstract_id end -let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> +let tclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let env, concl = Goal.(env gl, concl gl) in let step = begin fun sigma -> let (sigma, (abstract_proof, abstract_ty)) = @@ -389,8 +391,8 @@ let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let (sigma, ablock) = Ssrcommon.mkSsrConst "abstract_lock" env sigma in let (sigma, lock) = Evarutil.new_evar env sigma ablock in let (sigma, abstract) = Ssrcommon.mkSsrConst "abstract" env sigma in - let abstract_ty = - EConstr.mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let (sigma, abstract_id) = mk_abstract_id env sigma in + let abstract_ty = EConstr.mkApp(abstract, [|ty; abstract_id; lock|]) in let sigma, m = Evarutil.new_evar env sigma abstract_ty in sigma, (m, abstract_ty) in let sigma, kont = @@ -409,7 +411,7 @@ end let tclMK_ABSTRACT_VARS ids = List.fold_right (fun id tac -> - Tacticals.New.tclTHENFIRST (tcltclMK_ABSTRACT_VAR id) tac) ids (tclUNIT ()) + Tacticals.New.tclTHENFIRST (tclMK_ABSTRACT_VAR id) tac) ids (tclUNIT ()) (* Debugging *) let tclLOG p t = diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index d3f89147fa..0a0d9b12fa 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -566,17 +566,21 @@ let print_view_hints env sigma kind l = } VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY -| [ "Print" "Hint" "View" ssrviewpos(i) ] -> +| ![proof] [ "Print" "Hint" "View" ssrviewpos(i) ] -> { - let sigma, env = Pfedit.get_current_context () in - match i with + fun ~pstate -> + (* XXX this is incorrect *) + let sigma, env = Option.cata Pfedit.get_current_context + (let e = Global.env () in Evd.from_env e, e) pstate in + (match i with | Some k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k) | None -> List.iter (fun k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; - Ssrview.AdaptorDb.Equivalence ] + Ssrview.AdaptorDb.Equivalence ]); + pstate } END diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 5eb106cc26..1deb935d5c 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -373,6 +373,12 @@ let pr_constr_pat env sigma c0 = if isEvar c then hole_var else map wipe_evar c in pr_constr_env env sigma (wipe_evar c0) +let ehole_var = EConstr.mkVar (Id.of_string "_") +let pr_econstr_pat env sigma c0 = + let rec wipe_evar c = let open EConstr in + if isEvar sigma c then ehole_var else map sigma wipe_evar c in + pr_econstr_env env sigma (wipe_evar c0) + (* Turn (new) evars into metas *) let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = let ise = ref ise0 in @@ -694,8 +700,7 @@ let source env = match upats_origin, upats with (if fixed_upat ise p then str"term " else str"partial term ") ++ pr_constr_pat env ise (p2t p) ++ spc() | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ - pr_constr_pat env ise (p2t p) ++ fnl() + pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ pr_constr_pat env ise (p2t p) ++ fnl() | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat env ise rule ++ spc() | _, [] | None, _::_::_ -> @@ -732,13 +737,13 @@ let rec uniquize = function env, 0, uniquize (instances ()) | NoMatch when (not raise_NoMatch) -> if !failed_because_of_TC then - errorstrm (source env++strbrk"matches but type classes inference fails") + errorstrm (source env ++ strbrk"matches but type classes inference fails") else errorstrm (source env ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in - errorstrm (str"all matches of "++source env++ + errorstrm (str"all matches of "++ source env ++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); let sigma, _, ({up_f = pf; up_a = pa} as u) = @@ -823,7 +828,7 @@ let pr_pattern_aux pr_constr = function | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern env (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat env sigma (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p + pr_pattern_aux (fun t -> pr_econstr_pat env sigma (pi3 (nf_open_term sigma sigma (EConstr.of_constr t)))) p let pr_cpattern = pr_term let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) @@ -1253,10 +1258,8 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> - errorstrm (str "partial term " ++ - pr_constr_pat env sigma - (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) ++ - str " does not match any subterm of the goal") + errorstrm (str "partial term " ++ pr_econstr_pat env sigma t + ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in @@ -1264,7 +1267,7 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty }) + ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 1143bcc813..25975c84e8 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -223,6 +223,7 @@ val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.Id.t -> cpattern val pr_constr_pat : env -> evar_map -> constr -> Pp.t +val pr_econstr_pat : env -> evar_map -> econstr -> Pp.t val pf_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 73a2b99434..baa4ae0306 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -35,8 +35,23 @@ ARGUMENT EXTEND numnotoption END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] ![proof][ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - { let (sigma, env) = Pfedit.get_current_context () in - vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + + { (* It is a bug to use the proof context here, but at the request of + * the reviewers we keep this broken behavior for now. The Global env + * should be used instead, and the `env, sigma` parameteter to the + * numeral notation command removed. + *) + fun ~pstate -> + let sigma, env = match pstate with + | None -> + let env = Global.env () in + let sigma = Evd.from_env env in + sigma, env + | Some pstate -> + Pfedit.get_current_context pstate + in + vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o; + pstate } END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg index 171e0e213d..cc8c13a84b 100644 --- a/plugins/syntax/g_string.mlg +++ b/plugins/syntax/g_string.mlg @@ -19,8 +19,22 @@ open Stdarg } VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] ![proof] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) ] -> - { let (sigma, env) = Pfedit.get_current_context () in - vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) } + { (* It is a bug to use the proof context here, but at the request of + * the reviewers we keep this broken behavior for now. The Global env + * should be used instead, and the `env, sigma` parameteter to the + * numeral notation command removed. + *) + fun ~pstate -> + let sigma, env = match pstate with + | None -> + let env = Global.env () in + let sigma = Evd.from_env env in + sigma, env + | Some pstate -> + Pfedit.get_current_context pstate + in + vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc); + pstate } END diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 54a1aa9aa0..5560e5e5f5 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -120,9 +120,6 @@ let class_tab = let coercion_tab = Summary.ref ~name:"coercion_tab" (CoeTypMap.empty : coe_info_typ CoeTypMap.t) -let coercions_in_scope = - Summary.ref ~name:"coercions_in_scope" GlobRef.Set_env.empty - module ClPairOrd = struct type t = cl_index * cl_index @@ -308,9 +305,16 @@ let install_path_printer f = path_printer := f let print_path x = !path_printer x -let message_ambig l = - str"Ambiguous paths:" ++ spc () ++ - prlist_with_sep fnl print_path l +let path_comparator : (inheritance_path -> inheritance_path -> bool) ref = + ref (fun _ _ -> false) + +let install_path_comparator f = path_comparator := f + +let compare_path p q = !path_comparator p q + +let warn_ambiguous_path = + CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" + (fun l -> strbrk"Ambiguous paths: " ++ prlist_with_sep fnl print_path l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -329,21 +333,15 @@ let add_coercion_in_graph (ic,source,target) = let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = - try - if Bijint.Index.equal i j then begin - if different_class_params i then begin - let _ = lookup_path_between_class ij in - ambig_paths := (ij,p)::!ambig_paths - end - end else begin - let _ = lookup_path_between_class ij in - ambig_paths := (ij,p)::!ambig_paths - end; + if not (Bijint.Index.equal i j) || different_class_params i then + match lookup_path_between_class ij with + | q -> + if not (compare_path p q) then + ambig_paths := (ij,p)::!ambig_paths; + false + | exception Not_found -> (add_new_path ij p; true) + else false - with Not_found -> begin - add_new_path ij p; - true - end in let try_add_new_path1 ij p = let _ = try_add_new_path ij p in () @@ -364,9 +362,7 @@ let add_coercion_in_graph (ic,source,target) = end) old_inheritance_graph end; - let is_ambig = match !ambig_paths with [] -> false | _ -> true in - if is_ambig && not !Flags.quiet then - Feedback.msg_info (message_ambig !ambig_paths) + match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths type coercion = { coercion_type : coe_typ; @@ -400,13 +396,6 @@ let class_params = function let add_class cl = add_new_class cl { cl_param = class_params cl } -let get_automatically_import_coercions = - Goptions.declare_bool_option_and_ref - ~depr:true (* Remove in 8.8 *) - ~name:"automatic import of coercions" - ~key:["Automatic";"Coercions";"Import"] - ~value:false - let cache_coercion (_, c) = let () = add_class c.coercion_source in let () = add_class c.coercion_target in @@ -422,20 +411,9 @@ let cache_coercion (_, c) = let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph (xf,is,it) -let load_coercion _ o = - if get_automatically_import_coercions () then - cache_coercion o - -let set_coercion_in_scope (_, c) = - let r = c.coercion_type in - coercions_in_scope := GlobRef.Set_env.add r !coercions_in_scope - let open_coercion i o = - if Int.equal i 1 then begin - set_coercion_in_scope o; - if not (get_automatically_import_coercions ()) then - cache_coercion o - end + if Int.equal i 1 then + cache_coercion o let subst_coercion (subst, c) = let coe = subst_coe_typ subst c.coercion_type in @@ -469,10 +447,7 @@ let classify_coercion obj = let inCoercion : coercion -> obj = declare_object {(default_object "COERCION") with open_function = open_coercion; - load_function = load_coercion; - cache_function = (fun objn -> - set_coercion_in_scope objn; - cache_coercion objn); + cache_function = cache_coercion; subst_function = subst_coercion; classify_function = classify_coercion; discharge_function = discharge_coercion } @@ -532,6 +507,3 @@ let hide_coercion coe = let coe_info = coercion_info coe in Some coe_info.coe_param else None - -let is_coercion_in_scope r = - GlobRef.Set_env.mem r !coercions_in_scope diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 7c4842c8ae..bd468e62ad 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -100,6 +100,8 @@ val lookup_pattern_path_between : (* Crade *) val install_path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit +val install_path_comparator : + (inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) @@ -113,5 +115,3 @@ val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) val hide_coercion : coe_typ -> int option - -val is_coercion_in_scope : GlobRef.t -> bool diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 82411ba2ef..8c9b6550f3 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -368,20 +368,12 @@ let saturate_evd env evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd -let warn_coercion_not_in_scope = - CWarnings.create ~name:"coercion-not-in-scope" ~category:"deprecated" - Pp.(fun r -> str "Coercion used but not in scope: " ++ - Nametab.pr_global_env Id.Set.empty r ++ str ". If you want to use " - ++ str "this coercion, please Import the module that contains it.") - (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = try let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> - if not (is_coercion_in_scope i.coe_value) then - warn_coercion_not_in_scope i.coe_value; let isid = i.coe_is_identity in let isproj = i.coe_is_projection in let sigma, c = new_global sigma i.coe_value in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 28a97bb91a..0ccc4fd9f9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -503,14 +503,23 @@ let rec evar_conv_x flags env evd pbty term1 term2 = | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem true pbty,ev,term2) with - | UnifFailure (_,OccurCheck _) -> - (* Eta-expansion might apply *) default () + | UnifFailure (_,(OccurCheck _ | NotClean _)) -> + (* Eta-expansion might apply *) + (* OccurCheck: eta-expansion could solve + ?X = {| foo := ?X.(foo) |} + NotClean: pruning in solve_simple_eqn is incomplete wrt + Miller patterns *) + default () | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem false pbty,ev,term1) with - | UnifFailure (_, OccurCheck _) -> - (* Eta-expansion might apply *) default () + | UnifFailure (_, (OccurCheck _ | NotClean _)) -> + (* OccurCheck: eta-expansion could solve + ?X = {| foo := ?X.(foo) |} + NotClean: pruning in solve_simple_eqn is incomplete wrt + Miller patterns *) + default () | x -> x) | _ -> default () end diff --git a/pretyping/geninterp.ml b/pretyping/geninterp.ml index 1f8b926365..32152ad0e4 100644 --- a/pretyping/geninterp.ml +++ b/pretyping/geninterp.ml @@ -82,9 +82,10 @@ let register_val0 wit tag = (** Interpretation functions *) -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t diff --git a/pretyping/geninterp.mli b/pretyping/geninterp.mli index 606a6ebead..49d874289d 100644 --- a/pretyping/geninterp.mli +++ b/pretyping/geninterp.mli @@ -62,9 +62,10 @@ val register_val0 : ('raw, 'glb, 'top) genarg_type -> 'top Val.tag option -> uni module TacStore : Store.S -type interp_sign = { - lfun : Val.t Id.Map.t; - extra : TacStore.t } +type interp_sign = + { lfun : Val.t Id.Map.t + ; poly : bool + ; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index cd82b1993b..e76eb2a7de 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -183,7 +183,7 @@ let interp_ltac_id env id = ltac_interp_id env.lvar id module ConstrInterpObj = struct type ('r, 'g, 't) obj = - unbound_ltac_var_map -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map let name = "constr_interp" let default _ = None end @@ -192,8 +192,8 @@ module ConstrInterp = Genarg.Register(ConstrInterpObj) let register_constr_interp0 = ConstrInterp.register0 -let interp_glob_genarg env sigma ty arg = +let interp_glob_genarg env poly sigma ty arg = let open Genarg in let GenArg (Glbwit tag, arg) = arg in let interp = ConstrInterp.obj tag in - interp env.lvar.ltac_genargs env.renamed_env sigma ty arg + interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 65ae495135..cdd36bbba6 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -19,7 +19,7 @@ open Evarutil val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit (** {6 Pretyping name management} *) @@ -85,5 +85,5 @@ val interp_ltac_id : t -> Id.t -> Id.t (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) -val interp_glob_genarg : t -> evar_map -> constr -> +val interp_glob_genarg : t -> bool -> evar_map -> constr -> Genarg.glob_generic_argument -> constr * evar_map diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 8e9a2e114b..bec939b911 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -198,6 +198,7 @@ type inference_flags = { fail_evar : bool; expand_evars : bool; program_mode : bool; + polymorphic : bool; } (* Compute the set of still-undefined initial evars up to restriction @@ -474,10 +475,10 @@ let mark_obligation_evar sigma k evc = (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = +let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode k0 resolve_tc in - let pretype = pretype ~program_mode k0 resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in + let pretype = pretype ~program_mode ~poly k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -497,7 +498,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -530,7 +531,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo match tycon with | Some ty -> sigma, ty | None -> new_type_evar env sigma loc in - let c, sigma = GlobEnv.interp_glob_genarg env sigma ty arg in + let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in sigma, { uj_val = c; uj_type = ty } | GRec (fixkind,names,bl,lar,vdef) -> @@ -983,7 +984,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -1015,7 +1016,7 @@ and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype ~program_mode k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1040,7 +1041,7 @@ and pretype_instance ~program_mode k0 resolve_tc env sigma loc hyps evk update = sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1067,7 +1068,7 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1082,6 +1083,7 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = let ise_pretype_gen flags env sigma lvar kind c = let program_mode = flags.program_mode in + let poly = flags.polymorphic in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in @@ -1089,13 +1091,13 @@ let ise_pretype_gen flags env sigma lvar kind c = let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype ~program_mode k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) @@ -1106,6 +1108,7 @@ let default_inference_flags fail = { fail_evar = fail; expand_evars = true; program_mode = false; + polymorphic = false; } let no_classes_no_fail_inference_flags = { @@ -1114,6 +1117,7 @@ let no_classes_no_fail_inference_flags = { fail_evar = false; expand_evars = true; program_mode = false; + polymorphic = false; } let all_and_fail_flags = default_inference_flags true @@ -1141,3 +1145,39 @@ let understand_tcc ?flags env sigma ?expected_type c = let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) + +let path_convertible p q = + let open Classops in + let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in + let mkGVar id = DAst.make @@ Glob_term.GVar(id) in + let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in + let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Decl_kinds.Explicit,t,b) in + let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in + let path_to_gterm p = + match p with + | ic :: p' -> + let names = + List.map (fun n -> Id.of_string ("x" ^ string_of_int n)) + (List.interval 0 ic.coe_param) + in + List.fold_right + (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ + List.fold_left + (fun t ic -> + mkGApp (mkGRef ic.coe_value, + List.make ic.coe_param (mkGHole ()) @ [t])) + (mkGApp (mkGRef ic.coe_value, List.map (fun i -> mkGVar i) names)) + p' + | [] -> anomaly (str "A coercion path shouldn't be empty.") + in + try + let e = Global.env () in + let sigma,tp = understand_tcc e (Evd.from_env e) (path_to_gterm p) in + let sigma,tq = understand_tcc e sigma (path_to_gterm q) in + if Evd.has_undefined sigma then + false + else + let _ = Evarconv.unify_delay e sigma tp tq in true + with Evarconv.UnableToUnify _ | PretypeError _ -> false + +let _ = Classops.install_path_comparator path_convertible diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 3c875e69d2..1037cf6cc5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -38,6 +38,7 @@ type inference_flags = { fail_evar : bool; expand_evars : bool; program_mode : bool; + polymorphic : bool; } val default_inference_flags : bool -> inference_flags diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 6d9e3230a4..ef56458f99 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -45,14 +45,14 @@ let structure_table = let projection_table = Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" -(* TODO: could be unify struc_typ and struc_tuple ? in particular, - is the inductive always (fst constructor) ? It seems so... *) +(* TODO: could be unify struc_typ and struc_tuple ? *) type struc_tuple = - inductive * constructor * (Name.t * bool) list * Constant.t option list + constructor * (Name.t * bool) list * Constant.t option list -let load_structure i (_,(ind,id,kl,projs)) = +let load_structure i (_, (id,kl,projs)) = let open Declarations in + let ind = fst id in let mib, mip = Global.lookup_inductive ind in let n = mib.mind_nparams in let struc = @@ -65,8 +65,7 @@ let load_structure i (_,(ind,id,kl,projs)) = let cache_structure o = load_structure 1 o -let subst_structure (subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_mind subst kn in +let subst_structure (subst, (id, kl, projs as obj)) = let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) @@ -75,10 +74,10 @@ let subst_structure (subst,((kn,i),id,kl,projs as obj)) = projs in let id' = subst_constructor subst id in - if projs' == projs && kn' == kn && id' == id then obj else - ((kn',i),id',kl,projs') + if projs' == projs && id' == id then obj else + (id',kl,projs') -let discharge_structure (_,x) = Some x +let discharge_structure (_, x) = Some x let inStruc : struc_tuple -> obj = declare_object {(default_object "STRUCTURE") with @@ -88,8 +87,8 @@ let inStruc : struc_tuple -> obj = classify_function = (fun x -> Substitute x); discharge_function = discharge_structure } -let declare_structure (s,c,kl,pl) = - Lib.add_anonymous_leaf (inStruc (s,c,kl,pl)) +let declare_structure o = + Lib.add_anonymous_leaf (inStruc o) let lookup_structure indsp = Indmap.find indsp !structure_table @@ -103,6 +102,8 @@ let find_projection = function | ConstRef cst -> Cmap.find cst !projection_table | _ -> raise Not_found +let is_projection cst = Cmap.mem cst !projection_table + let prim_table = Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" @@ -277,21 +278,21 @@ let add_canonical_structure warn o = (* XXX: Undesired global access to env *) let env = Global.env () in let sigma = Evd.from_env env in - let lo = compute_canonical_projections env warn o in - List.iter (fun ((proj,(cs_pat,_ as pat)),s) -> + compute_canonical_projections env warn o |> + List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in - let ocs = try Some (assoc_pat cs_pat l) - with Not_found -> None - in match ocs with - | None -> object_table := GlobRef.Map.add proj ((pat,s)::l) !object_table; - | Some (c, cs) -> - let old_can_s = (Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF)) - and new_can_s = (Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF)) - in - let prj = (Nametab.pr_global_env Id.Set.empty proj) - and hd_val = (pr_cs_pattern cs_pat) in - if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s)) - lo + match assoc_pat cs_pat l with + | exception Not_found -> + object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table + | _, cs -> + if warn + then + let old_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr cs.o_DEF) in + let new_can_s = Termops.Internal.print_constr_env env sigma (EConstr.of_constr s.o_DEF) in + let prj = Nametab.pr_global_env Id.Set.empty proj in + let hd_val = pr_cs_pattern cs_pat in + warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) + ) let open_canonical_structure i (_, o) = if Int.equal i 1 then add_canonical_structure false o diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 3e43372b65..53a33f6bab 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -24,7 +24,7 @@ type struc_typ = { s_PROJ : Constant.t option list } type struc_tuple = - inductive * constructor * (Name.t * bool) list * Constant.t option list + constructor * (Name.t * bool) list * Constant.t option list val declare_structure : struc_tuple -> unit @@ -44,6 +44,8 @@ val find_projection_nparams : GlobRef.t -> int (** raise [Not_found] if not a projection *) val find_projection : GlobRef.t -> struc_typ +val is_projection : Constant.t -> bool + (** Sets up the mapping from constants to primitive projections *) val declare_primitive_projection : Projection.Repr.t -> Constant.t -> unit diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index d620e14a94..d042a1d650 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -102,8 +102,7 @@ let tokenize_string s = let st = CLexer.get_lexer_state () in try let istr = Stream.of_string s in - let lexer = CLexer.make_lexer ~diff_mode:true in - let lex = lexer.Gramlib.Plexing.tok_func istr in + let lex = CLexer.LexerDiff.tok_func istr in let toks = stream_tok [] (fst lex) in CLexer.set_lexer_state st; toks @@ -547,13 +546,16 @@ let match_goals ot nt = | None -> ()); !nevar_to_oevar +let get_proof_context (p : Proof.t) = + let Proof.{goals; sigma} = Proof.data p in + sigma, Refiner.pf_env { Evd.it = List.(hd goals); sigma } -let to_constr p = +let to_constr pf = let open CAst in - let pprf = Proof.partial_proof p in + let pprf = Proof.partial_proof pf in (* pprf generally has only one element, but it may have more in the derive plugin *) let t = List.hd pprf in - let sigma, env = Pfedit.get_current_context ~p () in + let sigma, env = get_proof_context pf in let x = Constrextern.extern_constr false env sigma t in (* todo: right options?? *) x.v diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 0f97a942ed..1a34105ab6 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -55,6 +55,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } in try Pretyping.understand_ltac flags env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 9509c36ec0..472db790f2 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -37,41 +37,35 @@ let get_nth_V82_goal p i = try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal -let get_goal_context_gen p i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal p i in +let get_goal_context_gen pf i = + let { it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) -let get_goal_context i = - try get_goal_context_gen (Proof_global.give_me_the_proof ()) i - with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") - | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") - -let get_current_goal_context () = - try get_goal_context_gen (Proof_global.give_me_the_proof ()) 1 - with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") - | NoSuchGoal -> - (* spiwack: returning empty evar_map, since if there is no goal, under focus, - there is no accessible evar either *) - let env = Global.env () in - (Evd.from_env env, env) +let get_goal_context pf i = + let p = Proof_global.give_me_the_proof pf in + get_goal_context_gen p i -let get_current_context ?p () = - let current_proof_by_default = function - | Some p -> p - | None -> Proof_global.give_me_the_proof () - in - try get_goal_context_gen (current_proof_by_default p) 1 - with Proof_global.NoCurrentProof -> +let get_current_goal_context pf = + let p = Proof_global.give_me_the_proof pf in + try get_goal_context_gen p 1 + with + | NoSuchGoal -> + (* spiwack: returning empty evar_map, since if there is no goal, + under focus, there is no accessible evar either. EJGA: this + seems strange, as we have pf *) let env = Global.env () in - (Evd.from_env env, env) - | NoSuchGoal -> - (* No more focused goals ? *) - let p = (current_proof_by_default p) in - let evd = Proof.in_proof p (fun x -> x) in - (evd, Global.env ()) + Evd.from_env env, env + +let get_current_context pf = + let p = Proof_global.give_me_the_proof pf in + try get_goal_context_gen p 1 + with + | NoSuchGoal -> + (* No more focused goals *) + let evd = Proof.in_proof p (fun x -> x) in + evd, Global.env () let solve ?with_end_tac gi info_lvl tac pr = - try let tac = match with_end_tac with | None -> tac | Some etac -> Proofview.tclTHEN tac etac in @@ -112,15 +106,12 @@ let solve ?with_end_tac gi info_lvl tac pr = | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) in (p,status) - with - Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof") let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) -let instantiate_nth_evar_com n com = +let instantiate_nth_evar_com n com = Proof_global.simple_with_current_proof (fun _ p -> - Proof.V82.instantiate_evar Global.(env ())n com p) - + Proof.V82.instantiate_evar Global.(env ()) n com p) (**********************************************************************) (* Shortcut to build a term using tactics *) @@ -133,21 +124,19 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in let goals = [ (Global.env_of_context sign , typ) ] in - Proof_global.start_proof evd id goal_kind goals terminator; + let pf = Proof_global.start_proof ~ontop:None evd id goal_kind goals terminator in try - let status = by tac in + let pf, status = by tac pf in let open Proof_global in - let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in + let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - discard_current (); let univs = UState.demote_seff_univs entry universes in entry, status, univs | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> let reraise = CErrors.push reraise in - Proof_global.discard_current (); iraise reraise let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 29ab00876a..2fe4bc6385 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -16,29 +16,29 @@ open Environ open Decl_kinds (** {6 ... } *) + +exception NoSuchGoal + (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) -val get_goal_context : int -> Evd.evar_map * env +val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env (** [get_current_goal_context ()] works as [get_goal_context 1] *) - -val get_current_goal_context : unit -> Evd.evar_map * env +val get_current_goal_context : Proof_global.t -> Evd.evar_map * env (** [get_current_context ()] returns the context of the current focused goal. If there is no focused goal but there is a proof in progress, it returns the corresponding evar_map. If there is no pending proof then it returns the current global environment and empty evar_map. *) - -val get_current_context : ?p:Proof.t -> unit -> Evd.evar_map * env +val get_current_context : Proof_global.t -> Evd.evar_map * env (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th - subgoal of the current focused proof or raises a [UserError] if no - proof is focused or if there is no [n]th subgoal. [solve SelectAll + subgoal of the current focused proof. [solve SelectAll tac] applies [tac] to all subgoals. *) val solve : ?with_end_tac:unit Proofview.tactic -> @@ -46,11 +46,10 @@ val solve : ?with_end_tac:unit Proofview.tactic -> Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current - focused proof or raises a UserError if there is no focused proof or - if there is no more subgoals. + focused proof. Returns [false] if an unsafe tactic has been used. *) -val by : unit Proofview.tactic -> bool +val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool (** Option telling if unification heuristics should be used. *) val use_unification_heuristics : unit -> bool @@ -60,7 +59,7 @@ val use_unification_heuristics : unit -> bool UserError if no proof is focused or if there is no such [n]th existential variable *) -val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit +val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> Proof_global.t -> Proof_global.t (** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac]. The return boolean, if [false] indicates the use of an unsafe diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 6174b75a96..86d3d9601e 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -17,7 +17,6 @@ (***********************************************************************) open Util -open Pp open Names open Context @@ -55,108 +54,66 @@ type pstate = { strength : Decl_kinds.goal_kind; } -type t = pstate list +(* The head of [t] is the actual current proof, the other ones are + to be resumed when the current proof is closed or aborted. *) +type t = pstate * pstate list + +let pstate_map f (pf, pfl) = (f pf, List.map f pfl) let make_terminator f = f let apply_terminator f = f -(* The head of [!pstates] is the actual current proof, the other ones are - to be resumed when the current proof is closed or aborted. *) -let pstates = ref ([] : pstate list) - (* combinators for the current_proof lists *) -let push a l = l := a::!l - -exception NoCurrentProof -let () = CErrors.register_handler begin function - | NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") - | _ -> raise CErrors.Unhandled -end +let push ~ontop a = + match ontop with + | None -> a , [] + | Some (l,ls) -> a, (l :: ls) (*** Proof Global manipulation ***) -let get_all_proof_names () = - List.map Proof.(function pf -> (data pf.proof).name) !pstates - -let cur_pstate () = - match !pstates with - | np::_ -> np - | [] -> raise NoCurrentProof - -let give_me_the_proof () = (cur_pstate ()).proof -let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None -let get_current_proof_name () = (Proof.data (cur_pstate ()).proof).Proof.name -let get_current_persistence () = (cur_pstate ()).strength - -let with_current_proof f = - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> - let et = - match p.endline_tactic with - | None -> Proofview.tclUNIT () - | Some tac -> - let open Geninterp in - let ist = { lfun = Id.Map.empty; extra = TacStore.empty } in - let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in - let tac = Geninterp.interp tag ist tac in - Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) - in - let (newpr,ret) = f et p.proof in - let p = { p with proof = newpr } in - pstates := p :: rest; - ret - -let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ()) - -let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact) +let get_all_proof_names (pf : t) = + let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in + pn :: pns + +let give_me_the_proof (ps,_) = ps.proof +let get_current_proof_name (ps,_) = (Proof.data ps.proof).Proof.name +let get_current_persistence (ps,_) = ps.strength + +let with_current_proof f (ps, psl) = + let et = + match ps.endline_tactic with + | None -> Proofview.tclUNIT () + | Some tac -> + let open Geninterp in + let ist = { lfun = Id.Map.empty; poly = pi2 ps.strength; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in + let (newpr,ret) = f et ps.proof in + let ps = { ps with proof = newpr } in + (ps, psl), ret + +let simple_with_current_proof f pf = + let p, () = with_current_proof (fun t p -> f t p , ()) pf in p + +let compact_the_proof pf = simple_with_current_proof (fun _ -> Proof.compact) pf (* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac = - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> pstates := { p with endline_tactic = Some tac } :: rest - -(* spiwack: it might be considered to move error messages away. - Or else to remove special exceptions from Proof_global. - Arguments for the former: there is no reason Proof_global is only - accessed directly through vernacular commands. Error message should be - pushed to external layers, and so we should be able to have a finer - control on error message on complex actions. *) -let msg_proofs () = - match get_all_proof_names () with - | [] -> (spc () ++ str"(No proof-editing in progress).") - | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ - (pr_sequence Id.print l) ++ str".") - -let there_is_a_proof () = not (List.is_empty !pstates) -let there_are_pending_proofs () = there_is_a_proof () -let check_no_pending_proof () = - if not (there_are_pending_proofs ()) then - () - else begin - CErrors.user_err - (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ - str"Use \"Abort All\" first or complete proof(s).") - end +let set_endline_tactic tac (ps, psl) = + { ps with endline_tactic = Some tac }, psl let pf_name_eq id ps = let Proof.{ name } = Proof.data ps.proof in Id.equal name id -let discard_gen id = - pstates := List.filter (fun pf -> not (pf_name_eq id pf)) !pstates - -let discard {CAst.loc;v=id} = - let n = List.length !pstates in - discard_gen id; - if Int.equal (List.length !pstates) n then - CErrors.user_err ?loc - ~hdr:"Pfedit.delete_proof" (str"No such proof" ++ msg_proofs ()) +let discard {CAst.loc;v=id} (ps, psl) = + match List.filter (fun pf -> not (pf_name_eq id pf)) (ps :: psl) with + | [] -> None + | ps :: psl -> Some (ps, psl) -let discard_current () = - if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates -let discard_all () = pstates := [] +let discard_current (ps, psl) = + if List.is_empty psl then None else Some List.(hd psl, tl psl) (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -166,30 +123,30 @@ let discard_all () = pstates := [] end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = +let start_proof ~ontop sigma name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { terminator = CEphemeron.create terminator; proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - strength = kind; - universe_decl = pl } in - push initial_state pstates + universe_decl = pl; + strength = kind } in + push ~ontop initial_state -let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = +let start_dependent_proof ~ontop name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { terminator = CEphemeron.create terminator; proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - strength = kind; - universe_decl = pl } in - push initial_state pstates + universe_decl = pl; + strength = kind } in + push ~ontop initial_state -let get_used_variables () = (cur_pstate ()).section_vars -let get_universe_decl () = (cur_pstate ()).universe_decl +let get_used_variables (pf,_) = pf.section_vars +let get_universe_decl (pf,_) = pf.universe_decl -let set_used_variables l = +let set_used_variables (ps,psl) l = let open Context.Named.Declaration in let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in @@ -210,20 +167,17 @@ let set_used_variables l = else (ctx, all_safe) in let ctx, _ = Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - match !pstates with - | [] -> raise NoCurrentProof - | p :: rest -> - if not (Option.is_empty p.section_vars) then - CErrors.user_err Pp.(str "Used section variables can be declared only once"); - pstates := { p with section_vars = Some ctx} :: rest; - ctx, [] - -let get_open_goals () = - let Proof.{ goals; stack; shelf } = Proof.data (cur_pstate ()).proof in + if not (Option.is_empty ps.section_vars) then + CErrors.user_err Pp.(str "Used section variables can be declared only once"); + (* EJGA: This is always empty thus we should modify the type *) + (ctx, []), ({ ps with section_vars = Some ctx}, psl) + +let get_open_goals (ps, _) = + let Proof.{ goals; stack; shelf } = Proof.data ps.proof in List.length goals + - List.fold_left (+) 0 + List.fold_left (+) 0 (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf + List.length shelf type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t @@ -240,8 +194,8 @@ let private_poly_univs = fun () -> !b let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now - (fpl : closed_proof_output Future.computation) = - let { section_vars; proof; terminator; universe_decl; strength } = cur_pstate () in + (fpl : closed_proof_output Future.computation) ps = + let { section_vars; proof; terminator; universe_decl; strength } = ps in let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in let constrain_variables ctx = @@ -339,8 +293,8 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now universes }, fun pr_ending -> CEphemeron.get terminator pr_ending -let return_proof ?(allow_partial=false) () = - let { proof } = cur_pstate () in +let return_proof ?(allow_partial=false) (ps,_) = + let { proof } = ps in if allow_partial then begin let proofs = Proof.partial_proof proof in let Proof.{sigma=evd} = Proof.data proof in @@ -368,43 +322,44 @@ let return_proof ?(allow_partial=false) () = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in proofs, Evd.evar_universe_context evd -let close_future_proof ~opaque ~feedback_id proof = - close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof -let close_proof ~opaque ~keep_body_ucst_separate fix_exn = +let close_future_proof ~opaque ~feedback_id (ps, psl) proof = + close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof ps + +let close_proof ~opaque ~keep_body_ucst_separate fix_exn (ps, psl) = close_proof ~opaque ~keep_body_ucst_separate ~now:true - (Future.from_val ~fix_exn (return_proof ())) + (Future.from_val ~fix_exn (return_proof (ps,psl))) ps (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator -let set_terminator hook = - match !pstates with - | [] -> raise NoCurrentProof - | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps - -let freeze ~marshallable = - if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") - else !pstates -let unfreeze s = pstates := s -let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof +let get_terminator (ps, _) = CEphemeron.get ps.terminator +let set_terminator hook (ps, psl) = + { ps with terminator = CEphemeron.create hook }, psl + let copy_terminators ~src ~tgt = - assert(List.length src = List.length tgt); - List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt + let (ps, psl), (ts,tsl) = src, tgt in + assert(List.length psl = List.length tsl); + {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl -let update_global_env pf_info = +let update_global_env (pf : t) = + let res, () = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in - (p, ()))) - -(* XXX: Bullet hook, should be really moved elsewhere *) -let () = - let hook n = - try - let prf = give_me_the_proof () in - (Proof_bullet.suggest prf) - with NoCurrentProof -> mt () - in - Proofview.set_nosuchgoals_hook hook + (p, ()))) pf + in res + +(* XXX: This hook is used to provide a better error w.r.t. bullets, + however the proof engine [surprise!] knows nothing about bullets so + here we have a layering violation. The right fix is to modify the + entry point to handle this and reraise the exception with the + needed information. *) +(* let _ = + * let hook n = + * try + * let prf = give_me_the_proof pf in + * (Proof_bullet.suggest prf) + * with NoCurrentProof -> mt () + * in + * Proofview.set_nosuchgoals_hook hook *) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 38e234eaee..e2e457483b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,23 +13,15 @@ environment. *) type t -val there_are_pending_proofs : unit -> bool -val check_no_pending_proof : unit -> unit +val get_current_proof_name : t -> Names.Id.t +val get_current_persistence : t -> Decl_kinds.goal_kind +val get_all_proof_names : t -> Names.Id.t list -val get_current_proof_name : unit -> Names.Id.t -val get_current_persistence : unit -> Decl_kinds.goal_kind -val get_all_proof_names : unit -> Names.Id.t list +val discard : Names.lident -> t -> t option +val discard_current : t -> t option -val discard : Names.lident -> unit -val discard_current : unit -> unit -val discard_all : unit -> unit - -val give_me_the_proof_opt : unit -> Proof.t option -exception NoCurrentProof -val give_me_the_proof : unit -> Proof.t -(** @raise NoCurrentProof when outside proof mode. *) - -val compact_the_proof : unit -> unit +val give_me_the_proof : t -> Proof.t +val compact_the_proof : t -> t (** When a proof is closed, it is reified into a [proof_object], where [id] is the name of the proof, [entries] the list of the proof terms @@ -60,7 +52,7 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str pl goals terminator] starts a proof of name +(** [start_proof ~ontop id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is; [terminator] is used at the end of the proof to close the proof @@ -68,25 +60,25 @@ val apply_terminator : proof_terminator -> proof_ending -> unit morphism). The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -val start_proof : +val start_proof : ontop:t option -> Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> unit + proof_terminator -> t (** Like [start_proof] except that there may be dependencies between initial goals. *) -val start_dependent_proof : +val start_dependent_proof : ontop:t option -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> unit + Proofview.telescope -> proof_terminator -> t (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes there_are_pending_proofs. *) -val update_global_env : unit -> unit +val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -96,39 +88,36 @@ type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * USt (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> unit -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> +val return_proof : ?allow_partial:bool -> t -> closed_proof_output +val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> closed_proof (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -val get_terminator : unit -> proof_terminator -val set_terminator : proof_terminator -> unit - -val get_open_goals : unit -> int +val get_terminator : t -> proof_terminator +val set_terminator : proof_terminator -> t -> t +val get_open_goals : t -> int (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> t -> t (** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> unit +val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) -val set_used_variables : - Names.Id.t list -> Constr.named_context * Names.lident list -val get_used_variables : unit -> Constr.named_context option +val set_used_variables : t -> + Names.Id.t list -> (Constr.named_context * Names.lident list) * t + +val get_used_variables : t -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) -val get_universe_decl : unit -> UState.universe_decl +val get_universe_decl : t -> UState.universe_decl -val freeze : marshallable:bool -> t -val unfreeze : t -> unit -val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 230a3207a8..d13763cdec 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -49,12 +49,13 @@ let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.proof }) -> - let proof = Proof_global.proof_of_state 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 - if List.for_all (fun x -> simple_goal sigma x rest) focused - then `Simple focused - else `Not + Option.cata (fun proof -> + let proof = Proof_global.give_me_the_proof 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 + if List.for_all (fun x -> simple_goal sigma x rest) focused + then `Simple focused + else `Not) `Not proof type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index ab388977a5..cc0de0e9df 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -139,8 +139,8 @@ let may_pierce_opaque = function | _ -> false let update_global_env () = - if Proof_global.there_are_pending_proofs () then - Proof_global.update_global_env () + if Vernacstate.Proof_global.there_are_pending_proofs () then + Vernacstate.Proof_global.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation @@ -872,7 +872,7 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy type proof_part = - Proof_global.t * + Proof_global.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) @@ -948,8 +948,8 @@ end = struct (* {{{ *) let prev = (VCS.visit id).next in if is_cached_and_valid prev then { s with proof = - Proof_global.copy_terminators - ~src:(get_cached prev).proof ~tgt:s.proof } + Vernacstate.Proof_global.copy_terminators + ~src:((get_cached prev).proof) ~tgt:s.proof } else s with VCS.Expired -> s in VCS.set_state id (FullState s) @@ -957,7 +957,7 @@ end = struct (* {{{ *) if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = - Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in + Vernacstate.Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system begin @@ -1009,8 +1009,8 @@ end = struct (* {{{ *) if feedback_processed then Hooks.(call state_computed ~doc id ~in_cache:false); VCS.reached id; - if Proof_global.there_are_pending_proofs () then - VCS.goals id (Proof_global.get_open_goals ()) + if Vernacstate.Proof_global.there_are_pending_proofs () then + VCS.goals id (Vernacstate.Proof_global.get_open_goals ()) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in @@ -1121,13 +1121,18 @@ let get_script prf = in find [] (VCS.get_branch_pos branch) +let warn_show_script_deprecated = + CWarnings.create ~name:"deprecated-show-script" ~category:"deprecated" + (fun () -> Pp.str "The “Show Script†command is deprecated.") + let show_script ?proof () = + warn_show_script_deprecated (); try let prf = try match proof with - | None -> Some (Proof_global.get_current_proof_name ()) + | None -> Some (Vernacstate.Proof_global.get_current_proof_name ()) | Some (p,_) -> Some (p.Proof_global.id) - with Proof_global.NoCurrentProof -> None + with Vernacstate.Proof_global.NoCurrentProof -> None in let cmds = get_script prf in let _,_,_,indented_cmds = @@ -1250,9 +1255,8 @@ end = struct (* {{{ *) if Int.equal n 0 then `Stop id else `Cont (n-value) let get_proof ~doc id = - let open Vernacstate in match state_of_id ~doc id with - | `Valid (Some vstate) -> Some (Proof_global.proof_of_state vstate.proof) + | `Valid (Some vstate) -> Option.map Proof_global.give_me_the_proof vstate.Vernacstate.proof | _ -> None let undo_vernac_classifier v ~doc = @@ -1291,7 +1295,7 @@ end = struct (* {{{ *) | Some vcs, _ -> vcs in let cb, _ = try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) - with Failure _ -> raise Proof_global.NoCurrentProof in + with Failure _ -> raise Vernacstate.Proof_global.NoCurrentProof in let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in @@ -1329,7 +1333,7 @@ end = struct (* {{{ *) | None -> true done; !rv - with Not_found | Proof_global.NoCurrentProof -> None + with Not_found | Vernacstate.Proof_global.NoCurrentProof -> None end (* }}} *) @@ -1590,7 +1594,7 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - let p = Proof_global.return_proof ~allow_partial:drop_pt () in + let p = Vernacstate.Proof_global.return_proof ~allow_partial:drop_pt () in if drop_pt then feedback ~id Complete; p) @@ -1617,7 +1621,7 @@ end = struct (* {{{ *) to set the state manually here *) State.unfreeze st; let pobject, _ = - Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in + Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator []) in @@ -1754,15 +1758,15 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then - let _proof = Proof_global.return_proof ~allow_partial:true () in + let _proof = Vernacstate.Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED else begin (* The original terminator, a hook, has not been saved in the .vio*) - Proof_global.set_terminator (Lemmas.standard_proof_terminator []); + Vernacstate.Proof_global.set_terminator (Lemmas.standard_proof_terminator []); let opaque = Proof_global.Opaque in let proof = - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; @@ -2012,7 +2016,7 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; State.purify (fun () -> - let Proof.{sigma=sigma0} = Proof.data (Proof_global.give_me_the_proof ()) in + let Proof.{sigma=sigma0} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( @@ -2024,7 +2028,7 @@ end = struct (* {{{ *) "goals only")) else begin let (i, ast) = r_ast in - Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + Vernacstate.Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); (* STATE SPEC: * - start : id * - return: id @@ -2033,7 +2037,7 @@ end = struct (* {{{ *) *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp r_state_fb st ast); - let Proof.{sigma} = Proof.data (Proof_global.give_me_the_proof ()) in + let Proof.{sigma} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> @@ -2060,8 +2064,14 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () + let stm_fail ~st fail f = + if fail then + Vernacentries.with_fail ~st f + else + f () + let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id - { indentation; verbose; loc; expr = e; strlen } + { indentation; verbose; loc; expr = e; strlen } : unit = let e, time, batch, fail = let rec find ~time ~batch ~fail = function @@ -2071,10 +2081,10 @@ end = struct (* {{{ *) | e -> e, time, batch, fail in find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in - Vernacentries.with_fail st fail (fun () -> + stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> - Proof_global.with_current_proof (fun _ p -> + Vernacstate.Proof_global.with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2107,7 +2117,7 @@ end = struct (* {{{ *) let open Notations in match Future.join f with | Some (pt, uc) -> - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Vernacstate.Proof_global.get_current_context () in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ @@ -2387,10 +2397,10 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () end in - match VCS.get_state base_state with + match (VCS.get_info base_state).state with | FullState { Vernacstate.proof } -> - Proof_global.unfreeze proof; - Proof_global.with_current_proof (fun _ p -> + Option.iter Vernacstate.Proof_global.unfreeze proof; + Vernacstate.Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: @@ -2560,7 +2570,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepDefined -> Proof_global.Transparent in let proof = - Proof_global.close_future_proof ~opaque ~feedback_id:id fp in + Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in @@ -2568,13 +2578,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), not redefine_qed, true | `Sync (name, `Immediate) -> (fun () -> reach eop; let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), true, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; @@ -2593,7 +2603,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in - Some(Proof_global.close_proof ~opaque + Some(Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in if keep <> VtKeep VtKeepAxiom then @@ -2604,7 +2614,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); - Proof_global.discard_all () + Vernacstate.Proof_global.discard_all () ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> reach ~cache:true start; @@ -2865,7 +2875,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) + Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Vernacstate.Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -3057,7 +3067,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) - if not in_proof && Proof_global.there_are_pending_proofs () then + if not in_proof && Vernacstate.Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in let opacity_of_produced_term = function diff --git a/tactics/auto.ml b/tactics/auto.ml index 2619620eb8..4e0ec1f7e4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -143,7 +143,8 @@ let conclPattern concl pat tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - constr_bindings env sigma >>= fun constr_bindings -> + constr_bindings env sigma >>= fun constr_bindings -> + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Stdarg.wit_constr) with @@ -152,7 +153,9 @@ let conclPattern concl pat tac = in let fold id c accu = Id.Map.add id (inj c) accu in let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in - let ist = { lfun; extra = TacStore.empty } in + let ist = { lfun + ; poly + ; extra = TacStore.empty } in match tac with | GenArg (Glbwit wit, tac) -> Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index d9c0a26f91..51708670f5 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -99,11 +99,15 @@ let one_base general_rewrite_maybe_in tac_main bas = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_rewrite_maybe_in dir c' tc) end in - let lrul = List.map (fun h -> + let open Proofview.Notations in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> + let lrul = List.map (fun h -> let tac = match h.rew_tac with | None -> Proofview.tclUNIT () | Some (Genarg.GenArg (Genarg.Glbwit wit, tac)) -> - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let ist = { Geninterp.lfun = Id.Map.empty + ; poly + ; extra = Geninterp.TacStore.empty } in Ftactic.run (Geninterp.interp wit ist tac) (fun _ -> Proofview.tclUNIT ()) in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a3620f4081..44102afd74 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -933,11 +933,12 @@ module Search = struct try (* Instance may try to call this before a proof is set up! Thus, give_me_the_proof will fail. Beware! *) - let name, poly = try - let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in - name, poly - with | Proof_global.NoCurrentProof -> - Id.of_string "instance", false + let name, poly = + (* try + * let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in + * name, poly + * with | Proof_global.NoCurrentProof -> *) + Id.of_string "instance", false in let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply ~name ~poly env tac pv diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 073d66e4aa..3fdd97616f 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -686,11 +686,6 @@ let build_r2l_rew_scheme dep env ind k = let (sigma, c) = build_case_analysis_scheme env sigma indu dep k in c, Evd.evar_universe_context sigma -let build_l2r_rew_scheme = build_l2r_rew_scheme -let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme -let build_r2l_rew_scheme = build_r2l_rew_scheme -let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme - (**********************************************************************) (* Register the rewriting schemes *) (**********************************************************************) diff --git a/tactics/hints.ml b/tactics/hints.ml index 85d75f1010..3a7e67cb3f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1514,9 +1514,9 @@ let pr_hint_term env sigma cl = (str "No hint applicable for current goal") (* print all hints that apply to the concl of the current goal *) -let pr_applicable_hint () = +let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.give_me_the_proof () in + let pts = Proof_global.give_me_the_proof pf in let Proof.{goals;sigma} = Proof.data pts in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/hints.mli b/tactics/hints.mli index dd2c63d351..e84e423faa 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -294,7 +294,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : unit -> Pp.t +val pr_applicable_hint : Proof_global.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b8308dc49b..206f35c8ba 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1161,6 +1161,7 @@ let tactic_infer_flags with_evar = { Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; Pretyping.program_mode = false; + Pretyping.polymorphic = false; } type evars_flag = bool (* true = pose evars false = fail on evars *) diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b85258505b..e0324b0232 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index 35f8701b2f..135537f8ab 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -96,7 +96,7 @@ Admitted. Polymorphic Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x. Polymorphic Definition InitialObject obj {C : SpecializedCategory obj} (o : C) := - forall o', { m : C.(Morphism) o o' | is_unique m }. + forall o', { m : Morphism C o o' | is_unique m }. Polymorphic Definition SmallCat := ComputableCategory _ SUnderlyingCategory. @@ -136,7 +136,7 @@ Section GraphObj. Definition UnderlyingGraph_ObjectOf x := match x with - | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) } + | GraphIndexSource => { sd : objC * objC & Morphism C (fst sd) (snd sd) } | GraphIndexTarget => objC end. diff --git a/test-suite/bugs/closed/bug_4157.v b/test-suite/bugs/closed/bug_4157.v new file mode 100644 index 0000000000..a9e96fcdde --- /dev/null +++ b/test-suite/bugs/closed/bug_4157.v @@ -0,0 +1,272 @@ +(** The following proof is due to a bug in `vm_compute` and was found by + Maxime Dénès and Pierre-Marie Pédrot. *) +Inductive t := +| C_0 : nat -> t +| C_1 : nat -> t +| C_2 : nat -> t +| C_3 : nat -> t +| C_4 : nat -> t +| C_5 : nat -> t +| C_6 : nat -> t +| C_7 : nat -> t +| C_8 : nat -> t +| C_9 : nat -> t +| C_10 : nat -> t +| C_11 : nat -> t +| C_12 : nat -> t +| C_13 : nat -> t +| C_14 : nat -> t +| C_15 : nat -> t +| C_16 : nat -> t +| C_17 : nat -> t +| C_18 : nat -> t +| C_19 : nat -> t +| C_20 : nat -> t +| C_21 : nat -> t +| C_22 : nat -> t +| C_23 : nat -> t +| C_24 : nat -> t +| C_25 : nat -> t +| C_26 : nat -> t +| C_27 : nat -> t +| C_28 : nat -> t +| C_29 : nat -> t +| C_30 : nat -> t +| C_31 : nat -> t +| C_32 : nat -> t +| C_33 : nat -> t +| C_34 : nat -> t +| C_35 : nat -> t +| C_36 : nat -> t +| C_37 : nat -> t +| C_38 : nat -> t +| C_39 : nat -> t +| C_40 : nat -> t +| C_41 : nat -> t +| C_42 : nat -> t +| C_43 : nat -> t +| C_44 : nat -> t +| C_45 : nat -> t +| C_46 : nat -> t +| C_47 : nat -> t +| C_48 : nat -> t +| C_49 : nat -> t +| C_50 : nat -> t +| C_51 : nat -> t +| C_52 : nat -> t +| C_53 : nat -> t +| C_54 : nat -> t +| C_55 : nat -> t +| C_56 : nat -> t +| C_57 : nat -> t +| C_58 : nat -> t +| C_59 : nat -> t +| C_60 : nat -> t +| C_61 : nat -> t +| C_62 : nat -> t +| C_63 : nat -> t +| C_64 : nat -> t +| C_65 : nat -> t +| C_66 : nat -> t +| C_67 : nat -> t +| C_68 : nat -> t +| C_69 : nat -> t +| C_70 : nat -> t +| C_71 : nat -> t +| C_72 : nat -> t +| C_73 : nat -> t +| C_74 : nat -> t +| C_75 : nat -> t +| C_76 : nat -> t +| C_77 : nat -> t +| C_78 : nat -> t +| C_79 : nat -> t +| C_80 : nat -> t +| C_81 : nat -> t +| C_82 : nat -> t +| C_83 : nat -> t +| C_84 : nat -> t +| C_85 : nat -> t +| C_86 : nat -> t +| C_87 : nat -> t +| C_88 : nat -> t +| C_89 : nat -> t +| C_90 : nat -> t +| C_91 : nat -> t +| C_92 : nat -> t +| C_93 : nat -> t +| C_94 : nat -> t +| C_95 : nat -> t +| C_96 : nat -> t +| C_97 : nat -> t +| C_98 : nat -> t +| C_99 : nat -> t +| C_100 : nat -> t +| C_101 : nat -> t +| C_102 : nat -> t +| C_103 : nat -> t +| C_104 : nat -> t +| C_105 : nat -> t +| C_106 : nat -> t +| C_107 : nat -> t +| C_108 : nat -> t +| C_109 : nat -> t +| C_110 : nat -> t +| C_111 : nat -> t +| C_112 : nat -> t +| C_113 : nat -> t +| C_114 : nat -> t +| C_115 : nat -> t +| C_116 : nat -> t +| C_117 : nat -> t +| C_118 : nat -> t +| C_119 : nat -> t +| C_120 : nat -> t +| C_121 : nat -> t +| C_122 : nat -> t +| C_123 : nat -> t +| C_124 : nat -> t +| C_125 : nat -> t +| C_126 : nat -> t +| C_127 : nat -> t +| C_128 : nat -> t +| C_129 : nat -> t +| C_130 : nat -> t +| C_131 : nat -> t +| C_132 : nat -> t +| C_133 : nat -> t +| C_134 : nat -> t +| C_135 : nat -> t +| C_136 : nat -> t +| C_137 : nat -> t +| C_138 : nat -> t +| C_139 : nat -> t +| C_140 : nat -> t +| C_141 : nat -> t +| C_142 : nat -> t +| C_143 : nat -> t +| C_144 : nat -> t +| C_145 : nat -> t +| C_146 : nat -> t +| C_147 : nat -> t +| C_148 : nat -> t +| C_149 : nat -> t +| C_150 : nat -> t +| C_151 : nat -> t +| C_152 : nat -> t +| C_153 : nat -> t +| C_154 : nat -> t +| C_155 : nat -> t +| C_156 : nat -> t +| C_157 : nat -> t +| C_158 : nat -> t +| C_159 : nat -> t +| C_160 : nat -> t +| C_161 : nat -> t +| C_162 : nat -> t +| C_163 : nat -> t +| C_164 : nat -> t +| C_165 : nat -> t +| C_166 : nat -> t +| C_167 : nat -> t +| C_168 : nat -> t +| C_169 : nat -> t +| C_170 : nat -> t +| C_171 : nat -> t +| C_172 : nat -> t +| C_173 : nat -> t +| C_174 : nat -> t +| C_175 : nat -> t +| C_176 : nat -> t +| C_177 : nat -> t +| C_178 : nat -> t +| C_179 : nat -> t +| C_180 : nat -> t +| C_181 : nat -> t +| C_182 : nat -> t +| C_183 : nat -> t +| C_184 : nat -> t +| C_185 : nat -> t +| C_186 : nat -> t +| C_187 : nat -> t +| C_188 : nat -> t +| C_189 : nat -> t +| C_190 : nat -> t +| C_191 : nat -> t +| C_192 : nat -> t +| C_193 : nat -> t +| C_194 : nat -> t +| C_195 : nat -> t +| C_196 : nat -> t +| C_197 : nat -> t +| C_198 : nat -> t +| C_199 : nat -> t +| C_200 : nat -> t +| C_201 : nat -> t +| C_202 : nat -> t +| C_203 : nat -> t +| C_204 : nat -> t +| C_205 : nat -> t +| C_206 : nat -> t +| C_207 : nat -> t +| C_208 : nat -> t +| C_209 : nat -> t +| C_210 : nat -> t +| C_211 : nat -> t +| C_212 : nat -> t +| C_213 : nat -> t +| C_214 : nat -> t +| C_215 : nat -> t +| C_216 : nat -> t +| C_217 : nat -> t +| C_218 : nat -> t +| C_219 : nat -> t +| C_220 : nat -> t +| C_221 : nat -> t +| C_222 : nat -> t +| C_223 : nat -> t +| C_224 : nat -> t +| C_225 : nat -> t +| C_226 : nat -> t +| C_227 : nat -> t +| C_228 : nat -> t +| C_229 : nat -> t +| C_230 : nat -> t +| C_231 : nat -> t +| C_232 : nat -> t +| C_233 : nat -> t +| C_234 : nat -> t +| C_235 : nat -> t +| C_236 : nat -> t +| C_237 : nat -> t +| C_238 : nat -> t +| C_239 : nat -> t +| C_240 : nat -> t +| C_241 : nat -> t +| C_242 : nat -> t +| C_243 : nat -> t +| C_244 : nat -> t +| C_245 : nat -> t +| C_246 : nat -> t +| C_247 : nat -> t +| C_248 : nat -> t +| C_249 : nat -> t +| C_250 : nat -> t +| C_251 : nat -> t +| C_252 : nat -> t +| C_253 : nat -> t +| C_254 : nat -> t +| C_255 : nat -> t +| C_256 : nat -> t. + +Definition is_256 (x : t) : bool := + match x with + | C_256 _ => true + | _ => false + end. + +Lemma falso : False. + assert (is_256 (C_256 0) = true) by reflexivity. + (* The next line was successful in 8.2pl3 *) + Fail assert (is_256 (C_256 0) = false) by (vm_compute; reflexivity). +Abort. diff --git a/test-suite/bugs/closed/bug_9663.v b/test-suite/bugs/closed/bug_9663.v new file mode 100644 index 0000000000..b5fa601278 --- /dev/null +++ b/test-suite/bugs/closed/bug_9663.v @@ -0,0 +1,2 @@ +Definition id_depfn S T (f : forall x : S, T x) := f. +Definition idn : nat -> nat := @id_depfn _ _ (fun x => x). diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh new file mode 100755 index 0000000000..e1f17725dc --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" + +python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log2 || exit $? +python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log3 || exit $? + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? + +cat time-of-build.log.in | python2 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log2 || exit $? +cat time-of-build.log.in | python3 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log3 || exit $? + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? + +(python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log2 +(python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log3 + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected new file mode 100644 index 0000000000..05c1687002 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected @@ -0,0 +1,307 @@ +Time | File Name +----------------------------------------------------------------------- +39m02.51s | Total +----------------------------------------------------------------------- +3m26.96s | Kami/Ex/Multiplier64 +3m22.44s | bedrock2/compiler/src/FlatToRiscv +2m19.56s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI +2m11.59s | Kami/Ex/Divider64 +1m44.22s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR +1m44.11s | Kami/Ex/Multiplier32 +1m41.50s | bedrock2/bedrock2/src/Examples/bsearch +1m08.57s | Kami/Ex/ProcFDInl +1m07.92s | bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO +1m01.07s | Kami/Ex/FifoCorrect +1m00.73s | Kami/Ex/Divider32 +0m50.15s | bedrock2/deps/riscv-coq/src/Proofs/EncodeBound +0m40.64s | bedrock2/bedrock2/src/Examples/FE310CompilerDemo +0m40.29s | Kami/InlineFacts +0m39.12s | Kami/Renaming +0m37.44s | Kami/Ex/SimpleFifoCorrect +0m37.08s | Kami/SemFacts +0m36.08s | ─preprbedrock2/deps/coqutil/src/Map/TestGoals +0m32.76s | Kami/ModularFacts +0m28.68s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA +0m26.60s | Kami/Lib/Word +0m26.55s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB +0m26.45s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64 +0m25.80s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64 +0m25.47s | bedrock2/processor/src/KamiRiscv +0m23.66s | bedrock2/compiler/src/EmitsValid +0m22.68s | Kami/Ex/InDepthTutorial +0m22.60s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM +0m21.68s | Kami/Specialize +0m21.59s | bedrock2/bedrock2/src/Examples/lightbulb +0m19.20s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66 +0m19.19s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ +0m17.33s | Kami/Ex/ProcDecInl +0m15.63s | bedrock2/compiler/src/examples/MMIO +0m14.78s | Kami/ParametricSyntax +0m12.11s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S +0m11.74s | bedrock2/deps/riscv-coq/src/Platform/MetricMinimal +0m09.95s | bedrock2/deps/coqutil/src/Word/Properties +0m09.77s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64 +0m09.56s | Kami/Lib/FMap +0m09.35s | bedrock2/bedrock2/src/Examples/ipow +0m09.26s | Kami/StepDet +0m09.19s | bedrock2/bedrock2/src/WeakestPreconditionProperties +0m09.16s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence +0m08.98s | Kami/RefinementFacts +0m08.68s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic +0m08.26s | bedrock2/compiler/src/FlatToRiscv32 +0m07.55s | Kami/Ex/Fifo +0m07.54s | ─ensbedrock2/deps/coqutil/src/Map/SlowGoals +0m06.99s | bedrock2/deps/riscv-coq/src/Platform/Minimal +0m06.89s | bedrock2/compiler/src/GoFlatToRiscv +0m06.82s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I +0m06.72s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI +0m06.50s | Kami/Semantics +0m06.36s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57 +0m06.32s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R +0m06.24s | Kami/PartialInlineFacts +0m06.02s | bedrock2/deps/coqutil/src/Map/Properties +0m05.62s | Kami/Ex/ProcThreeStage +0m05.56s | Kami/Decomposition +0m05.12s | Kami/Amortization +0m05.07s | Kami/Ex/SCMMInl +0m04.71s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system +0m04.46s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U +0m04.19s | Kami/ParametricInline +0m04.13s | Kami/Ex/ProcDec +0m03.88s | bedrock2/bedrock2/src/Examples/swap +0m03.81s | Kami/Ex/SC +0m03.64s | bedrock2/bedrock2/src/FE310CSemantics +0m03.39s | Kami/Tutorial +0m03.30s | bedrock2/compiler/src/examples/Fibonacci +0m03.17s | Kami/Label +0m03.17s | Kami/ModuleBoundEx +0m03.10s | Kami/ParametricEquiv +0m03.06s | Kami/Wf +0m02.50s | bedrock2/compiler/src/Pipeline +0m02.42s | Kami/Ex/ProcFDInv +0m02.42s | Kami/ParamDup +0m02.39s | Kami/Duplicate +0m02.19s | Kami/ParametricWf +0m02.11s | Kami/Ex/ProcFetchDecode +0m02.06s | bedrock2/bedrock2/src/Examples/ARPResponder +0m01.94s | Kami/MapReifyEx +0m01.89s | Kami/Syntax +0m01.88s | Kami/Ex/IsaRv32/PgmGcd +0m01.87s | Kami/Ex/IsaRv32/PgmBankerWorker1 +0m01.87s | Kami/Ex/IsaRv32/PgmMatMulReport +0m01.85s | Kami/Ex/IsaRv32/PgmBankerWorker3 +0m01.83s | Kami/Ex/IsaRv32/PgmDekker2 +0m01.83s | Kami/Ex/IsaRv32/PgmFact +0m01.83s | Kami/Ex/IsaRv32/PgmMatMulNormal1 +0m01.81s | Kami/Ex/IsaRv32/PgmBankerInit +0m01.81s | Kami/Ex/IsaRv32/PgmMatMulInit +0m01.81s | Kami/Ex/IsaRv32/PgmMatMulNormal2 +0m01.81s | Kami/Ex/RegFile +0m01.80s | Kami/Ex/IsaRv32/PgmBankerWorker2 +0m01.80s | Kami/Ex/IsaRv32/PgmPeterson1 +0m01.80s | Kami/Ex/IsaRv32/PgmPeterson2 +0m01.80s | bedrock2/bedrock2/src/ptsto_bytes +0m01.78s | Kami/Ex/IsaRv32/PgmDekker1 +0m01.78s | Kami/Ex/ProcDecInv +0m01.76s | bedrock2/bedrock2/src/Map/SeparationLogic +0m01.75s | Kami/Ex/IsaRv32/PgmBsort +0m01.74s | Kami/Ex/IsaRv32/PgmHanoi +0m01.70s | Kami/Ex/NativeFifo +0m01.52s | Kami/Lib/NatLib +0m01.51s | bedrock2/processor/src/Test +0m01.48s | Kami/SymEval +0m01.47s | Kami/Ex/MemAtomic +0m01.44s | Kami/Ex/ProcThreeStInv +0m01.35s | bedrock2/bedrock2/src/Array +0m01.34s | bedrock2/bedrock2/src/TailRecursion +0m01.30s | Kami/Ex/IsaRv32 +0m01.29s | Kami/ModuleBound +0m01.29s | bedrock2/bedrock2/src/Byte +0m01.25s | bedrock2/bedrock2/src/Examples/chacha20 +0m01.19s | Kami/Ex/ProcThreeStDec +0m01.18s | bedrock2/bedrock2/src/Scalars +0m01.17s | bedrock2/deps/riscv-coq/src/Utility/ListLib +0m01.15s | Kami/Ex/OneEltFifo +0m01.14s | bedrock2/bedrock2/src/Examples/Trace +0m01.13s | bedrock2/bedrock2/src/TODO_absint +0m01.10s | bedrock2/compiler/lib/LibTactics +0m01.08s | Kami/Lib/StringAsList +0m01.00s | bedrock2/deps/coqutil/src/Z/ZLib +0m00.99s | Kami/Lib/Struct +0m00.98s | bedrock2/compiler/src/examples/toposort +0m00.95s | bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise +0m00.94s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver +0m00.94s | bedrock2/deps/riscv-coq/src/Spec/ExecuteI +0m00.93s | Kami/Ex/ProcDecSC +0m00.92s | Kami/Ex/IsaRv32PgmExt +0m00.90s | Kami/Lib/Indexer +0m00.89s | Kami/Tactics +0m00.88s | bedrock2/compiler/src/util/ListLib +0m00.87s | Kami/Notations +0m00.84s | bedrock2/bedrock2/src/Memory +0m00.83s | Kami/Ex/ProcFDCorrect +0m00.83s | bedrock2/deps/riscv-coq/src/Utility/ZBitOps +0m00.82s | Kami/Ex/IsaRv32Pgm +0m00.82s | Kami/Lib/ilist +0m00.81s | Kami/Ex/ProcDecSCN +0m00.81s | bedrock2/deps/coqutil/src/Z/BitOps +0m00.80s | Kami/Ex/ProcFourStDec +0m00.80s | bedrock2/compiler/src/examples/EditDistExample +0m00.79s | Kami/Ext/BSyntax +0m00.79s | Kami/Ext/Extraction +0m00.77s | Kami/ParametricInlineLtac +0m00.76s | bedrock2/deps/riscv-coq/src/Platform/Example64Literal +0m00.76s | bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives +0m00.75s | Kami/Ex/ProcThreeStInl +0m00.74s | Kami/Kami +0m00.74s | bedrock2/compiler/src/examples/CompileExamples +0m00.74s | bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump +0m00.74s | bedrock2/deps/riscv-coq/src/Platform/MinimalLogging +0m00.72s | Kami/Substitute +0m00.72s | bedrock2/compiler/src/examples/TestExprImp +0m00.72s | bedrock2/deps/riscv-coq/src/Spec/Primitives +0m00.71s | Kami/Ex/MemTypes +0m00.71s | bedrock2/compiler/src/examples/InlineAssemblyMacro +0m00.71s | bedrock2/compiler/src/examples/TestFlatImp +0m00.71s | bedrock2/deps/riscv-coq/src/Platform/Memory +0m00.71s | bedrock2/deps/riscv-coq/src/Spec/Decode +0m00.70s | Kami/Inline +0m00.70s | Kami/Lib/StringAsOT +0m00.69s | bedrock2/compiler/src/FlatToRiscvDef +0m00.68s | bedrock2/compiler/src/Rem4 +0m00.67s | Kami/SymEvalTac +0m00.67s | bedrock2/compiler/src/SimplWordExpr +0m00.67s | bedrock2/deps/riscv-coq/src/Utility/Encode +0m00.66s | bedrock2/bedrock2/src/Semantics +0m00.63s | Kami/Lib/StringStringAsOT +0m00.63s | bedrock2/deps/coqutil/src/Datatypes/PropSet +0m00.61s | bedrock2/compiler/src/UnmappedMemForExtSpec +0m00.61s | bedrock2/deps/riscv-coq/src/Utility/Monads +0m00.60s | bedrock2/deps/coqutil/src/Map/SortedList +0m00.59s | Kami/Synthesize +0m00.59s | bedrock2/compiler/src/util/Common +0m00.59s | bedrock2/deps/coqutil/src/Map/SortedListWord +0m00.58s | bedrock2/deps/coqutil/src/Word/Naive +0m00.58s | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run +0m00.57s | bedrock2/bedrock2/src/BasicC64Semantics +0m00.57s | bedrock2/deps/riscv-coq/src/Utility/Utility +0m00.56s | Kami/Lib/WordSupport +0m00.56s | bedrock2/bedrock2/src/WeakestPrecondition +0m00.55s | Kami/Lib/StringEq +0m00.55s | bedrock2/bedrock2/src/BasicC32Semantics +0m00.55s | bedrock2/compiler/src/examples/highlevel/FuncMut +0m00.55s | bedrock2/deps/riscv-coq/src/Spec/ExecuteI64 +0m00.55s | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32 +0m00.54s | bedrock2/bedrock2/src/Examples/MultipleReturnValues +0m00.53s | bedrock2/compiler/src/RegAlloc2 +0m00.53s | bedrock2/deps/riscv-coq/src/Spec/ExecuteM +0m00.52s | bedrock2/bedrock2/src/ProgramLogic +0m00.52s | bedrock2/deps/riscv-coq/src/Platform/Run +0m00.52s | bedrock2/deps/riscv-coq/src/Spec/ExecuteM64 +0m00.52s | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64 +0m00.52s | bedrock2/deps/riscv-coq/src/Utility/Words32Naive +0m00.50s | bedrock2/bedrock2/src/BasicCSyntax +0m00.50s | bedrock2/compiler/src/Basic32Semantics +0m00.50s | bedrock2/compiler/src/RegAlloc3 +0m00.49s | bedrock2/bedrock2/src/BytedumpTest +0m00.49s | bedrock2/bedrock2/src/BytedumpTestα +0m00.49s | bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap +0m00.49s | bedrock2/deps/riscv-coq/src/Spec/Machine +0m00.49s | bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth +0m00.49s | bedrock2/deps/riscv-coq/src/Utility/Words64Naive +0m00.48s | bedrock2/bedrock2/src/ToCString +0m00.48s | bedrock2/compiler/src/SeparationLogic +0m00.48s | bedrock2/deps/coqutil/src/Decidable +0m00.48s | bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine +0m00.48s | bedrock2/deps/riscv-coq/src/Platform/RiscvMachine +0m00.47s | bedrock2/bedrock2/src/BasicC64Syntax +0m00.47s | bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions +0m00.46s | bedrock2/compiler/src/ZNameGen +0m00.46s | bedrock2/deps/riscv-coq/src/Platform/MetricLogging +0m00.45s | bedrock2/compiler/src/RegAllocAnnotatedNotations +0m00.45s | bedrock2/processor/src/KamiWord +0m00.44s | bedrock2/deps/coqutil/src/Map/SortedListString_test +0m00.44s | bedrock2/deps/coqutil/src/Tactics/Tactics +0m00.44s | bedrock2/deps/riscv-coq/src/Spec/Execute +0m00.44s | bedrock2/deps/riscv-coq/src/Utility/InstructionNotations +0m00.43s | bedrock2/bedrock2/src/Map/Separation +0m00.43s | bedrock2/compiler/src/RiscvWordProperties +0m00.43s | bedrock2/deps/riscv-coq/src/Spec/VirtualMemory +0m00.43s | bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions +0m00.42s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode +0m00.40s | bedrock2/compiler/src/util/Tactics +0m00.40s | bedrock2/deps/coqutil/src/Map/Interface +0m00.39s | bedrock2/deps/coqutil/src/Z/HexNotation +0m00.38s | Kami/Lib/CommonTactics +0m00.38s | Kami/Lib/Nomega +0m00.38s | bedrock2/bedrock2/src/ZNamesSyntax +0m00.37s | bedrock2/deps/coqutil/src/Map/Funext +0m00.37s | bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem +0m00.36s | Kami/Ex/Names +0m00.36s | Kami/Lib/Concat +0m00.36s | bedrock2/bedrock2/src/string2ident +0m00.36s | bedrock2/compiler/src/Simp +0m00.36s | bedrock2/deps/coqutil/src/Map/Solver +0m00.36s | bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem +0m00.35s | Kami/Lib/Misc +0m00.35s | bedrock2/bedrock2/src/Examples/StructAccess +0m00.35s | bedrock2/bedrock2/src/StructNotations +0m00.35s | bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map +0m00.35s | bedrock2/deps/coqutil/src/Map/SortedListString +0m00.34s | Kami/Lib/Reflection +0m00.34s | bedrock2/bedrock2/src/Bytedump +0m00.34s | bedrock2/deps/riscv-coq/src/Utility/Tactics +0m00.33s | bedrock2/bedrock2/src/NotationsCustomEntry +0m00.33s | bedrock2/compiler/src/util/MyOmega +0m00.32s | bedrock2/bedrock2/src/Hexdump +0m00.32s | bedrock2/compiler/src/NameGen +0m00.31s | bedrock2/compiler/lib/LibTacticsMin +0m00.30s | bedrock2/bedrock2/src/StringNamesSyntax +0m00.30s | bedrock2/compiler/src/util/Set +0m00.30s | bedrock2/compiler/src/util/SetSolverTests +0m00.29s | bedrock2/deps/coqutil/src/Datatypes/String +0m00.27s | bedrock2/deps/coqutil/src/Word/LittleEndian +0m00.27s | bedrock2/deps/riscv-coq/src/Utility/MonadTests +0m00.26s | bedrock2/deps/coqutil/src/Z/div_mod_to_equations +0m00.23s | bedrock2/deps/riscv-coq/src/Utility/MonadT +0m00.19s | bedrock2/bedrock2/src/NotationsInConstr +0m00.19s | bedrock2/deps/coqutil/src/Datatypes/HList +0m00.17s | Kami/Lib/VectorFacts +0m00.17s | bedrock2/deps/riscv-coq/src/Utility/JMonad +0m00.14s | Kami/Lib/DepEq +0m00.13s | Kami/Lib/FinNotations +0m00.13s | bedrock2/bedrock2/src/ListPred +0m00.13s | bedrock2/bedrock2/src/Variables +0m00.13s | bedrock2/deps/coqutil/src/Datatypes/List +0m00.12s | bedrock2/deps/riscv-coq/src/Utility/MonadNotations +0m00.09s | bedrock2/bedrock2/src/Lift1Prop +0m00.09s | bedrock2/deps/coqutil/src/Datatypes/Option +0m00.09s | bedrock2/deps/coqutil/src/Datatypes/Prod +0m00.07s | Kami/Lib/BasicLogic +0m00.07s | bedrock2/bedrock2/src/Syntax +0m00.06s | Kami/Lib/DepEqNat +0m00.06s | bedrock2/deps/coqutil/src/Macros/symmetry +0m00.05s | bedrock2/compiler/lib/fiat_crypto_tactics/Not +0m00.05s | bedrock2/compiler/src/util/Misc +0m00.05s | bedrock2/deps/riscv-coq/src/Utility/PowerFunc +0m00.05s | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet +0m00.04s | bedrock2/bedrock2/src/Markers +0m00.04s | bedrock2/bedrock2/src/Notations +0m00.04s | bedrock2/compiler/lib/fiat_crypto_tactics/Test +0m00.04s | bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose +0m00.04s | bedrock2/compiler/src/NoActionSyntaxParams +0m00.04s | bedrock2/compiler/src/eqexact +0m00.04s | bedrock2/compiler/src/examples/highlevel/For +0m00.04s | bedrock2/compiler/src/on_hyp_containing +0m00.04s | bedrock2/compiler/src/util/Learning +0m00.04s | bedrock2/deps/coqutil/src/Datatypes/PrimitivePair +0m00.04s | bedrock2/deps/coqutil/src/Macros/subst +0m00.04s | bedrock2/deps/coqutil/src/Macros/unique +0m00.04s | bedrock2/deps/coqutil/src/Tactics/eabstract +0m00.04s | bedrock2/deps/coqutil/src/Tactics/letexists +0m00.04s | bedrock2/deps/coqutil/src/Tactics/rdelta +0m00.04s | bedrock2/deps/coqutil/src/Tactics/syntactic_unify +0m00.04s | bedrock2/deps/coqutil/src/dlet +0m00.04s | bedrock2/deps/coqutil/src/sanity +0m00.04s | bedrock2/deps/riscv-coq/src/Utility/MMIOTrace +0m00.03s | bedrock2/compiler/src/util/LogGoal
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build.log.in new file mode 100644 index 0000000000..a306586175 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build.log.in @@ -0,0 +1,3856 @@ +bedrock2/deps/coqutil/src/Tactics/eabstract (real: 0.17, user: 0.04, sys: 0.03, mem: 55016 ko) +bedrock2/deps/coqutil/src/sanity (real: 0.18, user: 0.04, sys: 0.03, mem: 54804 ko) +bedrock2/deps/coqutil/src/Tactics/letexists (real: 0.17, user: 0.04, sys: 0.03, mem: 55296 ko) +bedrock2/deps/coqutil/src/Tactics/rdelta (real: 0.17, user: 0.04, sys: 0.04, mem: 54916 ko) +bedrock2/deps/coqutil/src/Macros/subst (real: 0.16, user: 0.04, sys: 0.03, mem: 54100 ko) +bedrock2/deps/coqutil/src/dlet (real: 0.17, user: 0.04, sys: 0.03, mem: 54440 ko) +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 9, characters 2-67: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 11, characters 2-63: +Warning: Notation "{ _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 14, characters 2-67: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/deps/coqutil/src/Macros/unique (real: 0.16, user: 0.04, sys: 0.03, mem: 54384 ko) +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 15, characters 2-73: +Warning: Notation "{ ' _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v", line 17, characters 2-70: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +bedrock2/deps/coqutil/src/Datatypes/PrimitivePair (real: 0.17, user: 0.04, sys: 0.03, mem: 56232 ko) +bedrock2/deps/coqutil/src/Datatypes/List (real: 0.58, user: 0.13, sys: 0.09, mem: 142420 ko) +bedrock2/deps/coqutil/src/Datatypes/String (real: 0.85, user: 0.29, sys: 0.16, mem: 252176 ko) +bedrock2/deps/coqutil/src/Datatypes/Option (real: 0.37, user: 0.09, sys: 0.06, mem: 108600 ko) +make[1]: Entering directory 'bedrock2' +make -C bedrock2/deps/coqutil +make[2]: Entering directory 'bedrock2/deps/coqutil' +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = coqutil -arg "-async-proofs-tac-j 1" bedrock2/deps/coqutil/src/Tactics/Tactics.v bedrock2/deps/coqutil/src/Tactics/eabstract.v bedrock2/deps/coqutil/src/Tactics/letexists.v bedrock2/deps/coqutil/src/Tactics/rdelta.v bedrock2/deps/coqutil/src/Tactics/syntactic_unify.v bedrock2/deps/coqutil/src/dlet.v bedrock2/deps/coqutil/src/Map/Funext.v bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map.v bedrock2/deps/coqutil/src/Map/SortedListString.v bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap.v bedrock2/deps/coqutil/src/Map/SortedListWord.v bedrock2/deps/coqutil/src/Map/Properties.v bedrock2/deps/coqutil/src/Map/TestLemmas.v bedrock2/deps/coqutil/src/Map/Interface.v bedrock2/deps/coqutil/src/Map/TestGoals.v bedrock2/deps/coqutil/src/Map/SlowGoals.v bedrock2/deps/coqutil/src/Map/SortedListString_test.v bedrock2/deps/coqutil/src/Map/Solver.v bedrock2/deps/coqutil/src/Map/SortedList.v bedrock2/deps/coqutil/src/Z/div_mod_to_equations.v bedrock2/deps/coqutil/src/Z/ZLib.v bedrock2/deps/coqutil/src/Z/HexNotation.v bedrock2/deps/coqutil/src/Z/BitOps.v bedrock2/deps/coqutil/src/Datatypes/String.v bedrock2/deps/coqutil/src/Datatypes/List.v bedrock2/deps/coqutil/src/Datatypes/PropSet.v bedrock2/deps/coqutil/src/Datatypes/Option.v bedrock2/deps/coqutil/src/Datatypes/Prod.v bedrock2/deps/coqutil/src/Datatypes/HList.v bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v bedrock2/deps/coqutil/src/Word/Naive.v bedrock2/deps/coqutil/src/Word/Properties.v bedrock2/deps/coqutil/src/Word/Interface.v bedrock2/deps/coqutil/src/Word/LittleEndian.v bedrock2/deps/coqutil/src/sanity.v bedrock2/deps/coqutil/src/Decidable.v bedrock2/deps/coqutil/src/Macros/subst.v bedrock2/deps/coqutil/src/Macros/symmetry.v bedrock2/deps/coqutil/src/Macros/unique.v -o Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/deps/coqutil' +COQDEP VFILES +COQC bedrock2/deps/coqutil/src/Tactics/eabstract.v +COQC bedrock2/deps/coqutil/src/sanity.v +COQC bedrock2/deps/coqutil/src/Tactics/letexists.v +COQC bedrock2/deps/coqutil/src/Tactics/rdelta.v +COQC bedrock2/deps/coqutil/src/dlet.v +COQC bedrock2/deps/coqutil/src/Macros/subst.v +COQC bedrock2/deps/coqutil/src/Macros/unique.v +COQC bedrock2/deps/coqutil/src/Datatypes/PrimitivePair.v +COQC bedrock2/deps/coqutil/src/Datatypes/List.v +COQC bedrock2/deps/coqutil/src/Datatypes/String.v +COQC bedrock2/deps/coqutil/src/Word/Interface.v +COQC bedrock2/deps/coqutil/src/Datatypes/Option.v +COQC bedbedrock2/deps/coqutil/src/Word/Interface (real: 1.40, user: 0.31, sys: 0.22, mem: 293000 ko) +bedrock2/deps/coqutil/src/Z/div_mod_to_equations (real: 0.92, user: 0.26, sys: 0.17, mem: 238732 ko) +bedrock2/deps/coqutil/src/Z/HexNotation (real: 1.24, user: 0.39, sys: 0.18, mem: 303504 ko) +bedrock2/deps/coqutil/src/Z/ZLib (real: 2.83, user: 1.00, sys: 0.28, mem: 442912 ko) +bedrock2/deps/coqutil/src/Datatypes/Prod (real: 0.32, user: 0.09, sys: 0.06, mem: 93184 ko) +bedrock2/deps/coqutil/src/Z/BitOps (real: 2.25, user: 0.81, sys: 0.26, mem: 439216 ko) +bedrock2/deps/coqutil/src/Word/Naive (real: 1.75, user: 0.58, sys: 0.27, mem: 415316 ko) +bedrock2/deps/coqutil/src/Macros/symmetry (real: 0.23, user: 0.06, sys: 0.04, mem: 67708 ko) +bedrock2/deps/coqutil/src/Decidable (real: 1.50, user: 0.48, sys: 0.23, mem: 375156 ko) +bedrock2/deps/coqutil/src/Tactics/syntactic_unify (real: 0.18, user: 0.04, sys: 0.04, mem: 56184 ko) +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "{ _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "{ ' _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 2, characters 48-60: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 90, characters 2-19: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/deps/coqutil/src/Datatypes/HList.v", line 90, characters 2-19: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +bedrock2/deps/coqutil/src/Datatypes/HList (real: 0.63, user: 0.19, sys: 0.12, mem: 180476 ko) +bedrock2/deps/coqutil/src/Tactics/Tactics (real: 1.35, user: 0.44, sys: 0.19, mem: 321736 ko) +bedrock2/deps/coqutil/src/Word/LittleEndian (real: 0.89, user: 0.27, sys: 0.16, mem: 227732 ko) +bedrock2/deps/coqutil/src/Datatypes/PropSet (real: 1.93, user: 0.63, sys: 0.29, mem: 426168 ko) +bedrock2/deps/coqutil/src/Map/Interface (real: 1.32, user: 0.40, sys: 0.23, mem: 323944 ko) +bedrock2/deps/coqutil/src/Map/Funext (real: 1.24, user: 0.37, sys: 0.23, mem: 316400 ko) +bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map (real: 1.17, user: 0.35, sys: 0.21, mem: 295952 ko) +File "bedrock2/deps/coqutil/src/Map/SortedList.v", line 110, characters 2-28: +Warning: Use of “Require†inside a section is deprecated. +[require-in-section,deprecated] +bedrock2/deps/coqutil/src/Map/SortedList (real: 1.86, user: 0.60, sys: 0.29, mem: 426440 ko) +bedrock2/deps/coqutil/src/Word/Properties (real: 21.22, user: 9.95, sys: 0.38, mem: 568468 ko) +bedrock2/deps/coqutil/src/Map/SortedListString (real: 1.20, user: 0.35, sys: 0.22, mem: 289456 ko) +bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap (real: 1.56, user: 0.49, sys: 0.26, mem: 365272 ko) +bedrock2/deps/coqutil/src/Map/SortedListWord (real: 1.88, user: 0.59, sys: 0.30, mem: 440596 ko) +bedrock2/deps/coqutil/src/Map/Properties (real: 13.04, user: 6.02, sys: 0.32, mem: 486764 ko) +bedrock2/deps/coqutil/src/Map/SortedListString_test (real: 1.34, user: 0.44, sys: 0.21, mem: 305528 ko) +bedrock2/deps/coqutil/src/Map/Solver (real: 0.80, user: 0.36, sys: 0.21, mem: 312496 ko) +rock2/deps/coqutil/src/Z/div_mod_to_equations.v +COQC bedrock2/deps/coqutil/src/Z/ZLib.v +COQC bedrock2/deps/coqutil/src/Z/HexNotation.v +COQC bedrock2/deps/coqutil/src/Z/BitOps.v +COQC bedrock2/deps/coqutil/src/Datatypes/Prod.v +COQC bedrock2/deps/coqutil/src/Word/Naive.v +COQC bedrock2/deps/coqutil/src/Word/Properties.v +COQC bedrock2/deps/coqutil/src/Macros/symmetry.v +COQC bedrock2/deps/coqutil/src/Decidable.v +COQC bedrock2/deps/coqutil/src/Tactics/syntactic_unify.v +COQC bedrock2/deps/coqutil/src/Datatypes/HList.v +COQC bedrock2/deps/coqutil/src/Tactics/Tactics.v +COQC bedrock2/deps/coqutil/src/Word/LittleEndian.v +COQC bedrock2/deps/coqutil/src/Datatypes/PropSet.v +COQC bedrock2/deps/coqutil/src/Map/Interface.v +COQC bedrock2/deps/coqutil/src/Map/Funext.v +COQC bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map.v +COQC bedrock2/deps/coqutil/src/Map/SortedList.v +COQC bedrock2/deps/coqutil/src/Map/Properties.v +COQC bedrock2/deps/coqutil/src/Map/SortedListString.v +COQC bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap.v +COQC bedrock2/deps/coqutil/src/Map/SortedListWord.v +COQC bedrock2/deps/coqutil/src/Map/SortedListString_test.v +COQC bedrock2/deps/coqutil/src/Map/Solver.v +COQC bedrock2/deps/coqutil/src/Map/TestGoals.v +COQC bedrock2/deps/coqutil/src/Map/TestLemmas.v +Finished transaction in 0.297 secs (0.095u,0.05s) (successful) +Part 1a: Small goals (originally took <5s each) +Finished transaction in 0.35 secs (0.143u,0.032s) (successful) +Finished transaction in 0.438 secs (0.204u,0.008s) (successful) +End of TestLemmas.v +total time: 1.147s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.1% 99.9% 15 0.252s +─map_solver_core ----------------------- 1.0% 69.6% 15 0.209s +─map_solver_core_impl ------------------ 0.9% 68.2% 0 0.207s +─map_specialize ------------------------ 0.2% 54.9% 15 0.199s +─map_specialize_step ------------------- 24.9% 54.7% 42 0.146s +─preprocess_impl ----------------------- 1.8% 30.1% 15 0.043s +─abstract_unrecogs --------------------- 3.2% 19.8% 15 0.030s +─unrecogs_in_prop ---------------------- 15.2% 15.2% 0 0.017s +─specialize (constr_with_bindings) ----- 12.3% 12.3% 769 0.081s +─canonicalize_map_hyp ------------------ 2.3% 8.9% 316 0.011s +─unrecogs_in_option_value -------------- 3.6% 8.3% 0 0.013s +─maps_propositional -------------------- 0.3% 6.5% 15 0.009s +─ensure_no_body ------------------------ 2.1% 5.3% 602 0.006s +─assert_fails -------------------------- 1.9% 4.4% 756 0.006s +─rew_map_specs_in ---------------------- 1.3% 4.4% 316 0.010s +─canonicalize_all ---------------------- 0.6% 4.2% 15 0.006s +─maps_leaf_tac ------------------------- 0.3% 3.8% 32 0.003s +─one_rew_map_specs --------------------- 2.6% 3.5% 0 0.010s +─unrecogs_in_key ----------------------- 1.6% 2.9% 0 0.001s +─pose proof H as H' -------------------- 2.8% 2.8% 448 0.000s +─tac ----------------------------------- 1.8% 2.5% 756 0.000s +─revert_all_Props bedrock2/deps/coqutil/src/Map/TestLemmas (real: 3.68, user: 1.47, sys: 0.32, mem: 435336 ko) +---------------------- 2.1% 2.2% 15 0.003s +─autounfold (hintbases) (clause_dft_conc 2.2% 2.2% 62 0.001s +─unrecogs_in_map ----------------------- 1.4% 2.0% 0 0.002s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.1% 99.9% 15 0.252s + ├─map_solver_core --------------------- 1.0% 69.6% 15 0.209s + │└map_solver_core_impl ---------------- 0.9% 68.2% 0 0.207s + │ ├─map_specialize -------------------- 0.2% 54.9% 15 0.199s + │ │└map_specialize_step --------------- 24.9% 54.7% 42 0.146s + │ │ ├─specialize (constr_with_bindings) 10.7% 10.7% 448 0.081s + │ │ ├─canonicalize_map_hyp ------------ 1.2% 5.9% 154 0.011s + │ │ │└rew_map_specs_in ---------------- 0.8% 3.3% 154 0.010s + │ │ │└one_rew_map_specs --------------- 1.9% 2.5% 0 0.010s + │ │ ├─ensure_no_body ------------------ 2.1% 5.3% 602 0.006s + │ │ │└assert_fails -------------------- 1.6% 3.1% 602 0.006s + │ │ └─pose proof H as H' -------------- 2.8% 2.8% 448 0.000s + │ ├─maps_propositional ---------------- 0.3% 6.5% 15 0.009s + │ │└maps_leaf_tac --------------------- 0.3% 3.8% 32 0.003s + │ └─canonicalize_all ------------------ 0.6% 4.2% 15 0.006s + │ └canonicalize_map_hyp -------------- 1.1% 3.0% 162 0.001s + └─preprocess_impl --------------------- 1.8% 30.1% 15 0.043s + ├─abstract_unrecogs ----------------- 3.2% 19.8% 15 0.030s + │└unrecogs_in_prop ------------------ 15.2% 15.2% 0 0.017s + │└unrecogs_in_option_value ---------- 3.6% 8.3% 0 0.013s + │ ├─unrecogs_in_key ----------------- 1.1% 2.0% 0 0.001s + │ └─unrecogs_in_map ----------------- 1.4% 2.0% 0 0.002s + └─revert_all_Props ------------------ 2.1% 2.2% 15 0.003s + +COQC bedrock2/deps/coqutil/src/Map/SlowGoals.v +Finished transaction in 3.949 secs (1.835u,0.093s) (successful) +Finished transaction in 6.898 secs (3.179u,0.177s) (successful) +Finished transaction in 6.138 secs (2.811u,0.154s) (successful) +Finished transaction in 15.112 secs (7.09u,0.222s) (successful) +Finished transaction in 0.047 secs (0.024u,0.s) (successful) +End of SlowGoals.v +total time: 7.313s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver_core ----------------------- 0.0% 100.0% 1 7.312s +─map_solver_core_impl ------------------ 0.0% 100.0% 0 7.310s +─maps_propositional -------------------- 0.6% 61.3% 33 4.485s +─map_specialize ------------------------ 0.0% 38.0% 1 2.779s +─map_specialize_step ------------------- 15.8% 38.0% 37 1.817s +─maps_leaf_tac ------------------------- 0.7% 32.8% 228 0.018s +─propositional_cheap_step -------------- 25.2% 25.6% 427 0.013s +─congruence ---------------------------- 16.9% 16.9% 228 0.010s +─maps_choice_step ---------------------- 0.1% 15.7% 0 0.040s +─next ---------------------------------- 15.7% 15.7% 32 0.040s +─auto (int_or_var_opt) (auto_using) (hin 14.8% 14.8% 358 0.008s +─unify (constr) (constr) --------------- 5.5% 5.5% 4416 0.006s +─canonicalize_map_hyp ------------------ 1.0% 4.4% 822 0.008s +─specialize (constr_with_bindings) ----- 4.2% 4.2% 3293 0.008s +─ensbedrock2/deps/coqutil/src/Map/SlowGoals (real: 16.46, user: 7.54, sys: 0.41, mem: 454624 ko) +ure_no_body ------------------------ 1.5% 3.6% 3220 0.008s +─assert_fails -------------------------- 0.9% 3.2% 4005 0.008s +─pose proof H as H' -------------------- 3.0% 3.0% 2405 0.009s +─tac ----------------------------------- 1.4% 2.3% 4005 0.008s +─maps_split_step ----------------------- 0.3% 2.2% 260 0.006s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver_core ----------------------- 0.0% 100.0% 1 7.312s +└map_solver_core_impl ------------------ 0.0% 100.0% 0 7.310s + ├─maps_propositional ------------------ 0.6% 61.3% 33 4.485s + │ ├─maps_leaf_tac --------------------- 0.7% 32.8% 228 0.018s + │ │ ├─congruence ---------------------- 16.9% 16.9% 228 0.010s + │ │ └─auto (int_or_var_opt) (auto_using 14.8% 14.8% 358 0.008s + │ ├─propositional_cheap_step ---------- 25.0% 25.4% 424 0.013s + │ ├─maps_choice_step ------------------ 0.1% 15.7% 0 0.040s + │ │└next ------------------------------ 15.7% 15.7% 32 0.040s + │ └─maps_split_step ------------------- 0.3% 2.2% 260 0.006s + └─map_specialize ---------------------- 0.0% 38.0% 1 2.779s + └map_specialize_step ----------------- 15.8% 38.0% 37 1.817s + ├─unify (constr) (constr) ----------- 5.5% 5.5% 4413 0.006s + ├─canonicalize_map_hyp -------------- 0.9% 4.2% 785 0.008s + ├─ensure_no_body -------------------- 1.5% 3.6% 3220 0.008s + │└assert_fails ---------------------- 0.7% 2.1% 3220 0.008s + ├─pose proof H as H' ---------------- 3.0% 3.0% 2405 0.009s + └─specialize (constr_with_bindings) - 2.5% 2.5% 2405 0.007s + +Finished transaction in 2.274 secs (1.721u,0.068s) (successful) +Finished transaction in 1.891 secs (1.771u,0.084s) (successful) +Finished transaction in 1.713 secs (1.599u,0.076s) (successful) +Finished transaction in 0.196 secs (0.185u,0.008s) (successful) +Part 1b: Medium goals (originally took >5s each) +Finished transaction in 1.398 secs (1.318u,0.055s) (successful) +Finished transaction in 3.691 secs (3.403u,0.173s) (successful) +Finished transaction in 3.279 secs (3.017u,0.167s) (successful) +Finished transaction in 1.982 secs (1.851u,0.083s) (successful) +Finished transaction in 1.932 secs (1.8u,0.097s) (successful) +Finished transaction in 3.391 secs (3.136u,0.144s) (successful) +Finished transaction in 3.23 secs (3.024u,0.138s) (successful) +Part 1c: Large goals (originally took >50s each) +Finished transaction in 4.687 secs (4.34u,0.215s) (successful) +End of TestGoals.v +total time: 37.262s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 100.0% 18 4.555s +─map_solver_core ----------------------- 0.0% 96.9% 18 4.483s +─map_solver_core_impl ------------------ 0.0% 96.8% 0 4.482s +─map_specialize ------------------------ 0.0% 93.4% 18 4.351s +─map_specialize_step ------------------- 43.0% 93.3% 428 1.253s +─ensure_no_body ------------------------ 5.8% 13.2% 62635 0.014s +─specialize (constr_with_bindings) ----- 12.8% 12.8% 63060 0.013s +─pose proof H as H' -------------------- 11.4% 11.4% 55172 0.009s +─assert_fails -------------------------- 3.3% 9.5% 69963 0.014s +─canonicalize_map_hyp ------------------ 1.8% 7.6% 7811 0.014s +─tac ----------------------------------- 4.2% 6.2% 69963 0.014s +─preprbedrock2/deps/coqutil/src/Map/TestGoals (real: 49.22, user: 36.08, sys: 2.04, mem: 562540 ko) +ocess_impl ----------------------- 0.1% 3.1% 18 0.116s +─Tactics.ensure_new -------------------- 1.1% 3.1% 7328 0.014s +─rew_map_specs_in ---------------------- 1.0% 3.0% 7812 0.014s +─maps_propositional -------------------- 0.0% 2.8% 22 0.231s +─abstract_unrecogs --------------------- 0.4% 2.4% 18 0.107s +─unify (constr) (constr) --------------- 2.2% 2.2% 75932 0.009s +─one_rew_map_specs --------------------- 1.4% 2.1% 0 0.014s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 100.0% 18 4.555s + ├─map_solver_core --------------------- 0.0% 96.9% 18 4.483s + │└map_solver_core_impl ---------------- 0.0% 96.8% 0 4.482s + │ ├─map_specialize -------------------- 0.0% 93.4% 18 4.351s + │ │└map_specialize_step --------------- 43.0% 93.3% 428 1.253s + │ │ ├─ensure_no_body ------------------ 5.8% 13.2% 62635 0.014s + │ │ │└assert_fails -------------------- 2.9% 7.5% 62635 0.014s + │ │ │└tac ----------------------------- 3.3% 4.6% 62635 0.011s + │ │ ├─pose proof H as H' -------------- 11.4% 11.4% 55172 0.009s + │ │ ├─specialize (constr_with_bindings) 10.5% 10.5% 55172 0.010s + │ │ ├─canonicalize_map_hyp ------------ 1.7% 7.3% 7328 0.014s + │ │ │ ├─rew_map_specs_in -------------- 0.9% 2.9% 7328 0.014s + │ │ │ └─specialize (constr_with_binding 2.2% 2.2% 7328 0.013s + │ │ ├─Tactics.ensure_new -------------- 1.1% 3.1% 7328 0.014s + │ │ │└assert_fails -------------------- 0.4% 2.0% 7328 0.014s + │ │ └─unify (constr) (constr) --------- 2.2% 2.2% 75866 0.009s + │ └─maps_propositional ---------------- 0.0% 2.8% 22 0.231s + └─preprocess_impl --------------------- 0.1% 3.1% 18 0.116s + └abstract_unrecogs ------------------- 0.4% 2.4% 18 0.107s + +make[3]: Leaving directory 'bedrock2/deps/coqutil' +make[2]: Leaving directory 'bedrock2/deps/coqutil' +make -C bedrock2/deps/riscv-coq all +make -C bedrock2/bedrock2 +make[2]: Entering directory 'bedrock2/deps/riscv-coq' +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = riscv -arg "-async-proofs-tac-j 1" bedrock2/deps/riscv-coq/src/Spec/Primitives.v bedrock2/deps/riscv-coq/src/Spec/ExecuteI.v bedrock2/deps/riscv-coq/src/Spec/ExecuteI64.v bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives.v bedrock2/deps/riscv-coq/src/Spec/Machine.v bedrock2/deps/riscv-coq/src/Spec/ExecuteM.v bedrock2/deps/riscv-coq/src/Spec/ExecuteM64.v bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions.v bedrock2/deps/riscv-coq/src/Spec/Execute.v bedrock2/deps/riscv-coq/src/Spec/Decode.v bedrock2/deps/riscv-coq/src/Spec/VirtualMemory.v bedrock2/deps/riscv-coq/src/Utility/MMIOTrace.v bedrock2/deps/riscv-coq/src/Utility/InstructionNotations.v bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem.v bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise.v bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions.v bedrock2/deps/riscv-coq/src/Utility/Words32Naive.v bedrock2/deps/riscv-coq/src/Utility/JMonad.v bedrock2/deps/riscv-coq/src/Utility/Utility.v bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64.v bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run.v bedrock2/deps/riscv-coq/src/Utility/ZBitOps.v bedrock2/deps/riscv-coq/src/Utility/MonadNotations.v bedrock2/deps/riscv-coq/src/Utility/Tactics.v bedrock2/deps/riscv-coq/src/Utility/MonadTests.v bedrock2/deps/riscv-coq/src/Utility/Words64Naive.v bedrock2/deps/riscv-coq/src/Utility/Encode.v bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth.v bedrock2/deps/riscv-coq/src/Utility/MonadT.v bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem.v bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32.v bedrock2/deps/riscv-coq/src/Utility/PowerFunc.v bedrock2/deps/riscv-coq/src/Utility/ListLib.v bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v bedrock2/deps/riscv-coq/src/Utility/Monads.v bedrock2/deps/riscv-coq/src/Platform/MetricLogging.v bedrock2/deps/riscv-coq/src/Platform/Example64Literal.v bedrock2/deps/riscv-coq/src/Platform/RiscvMachine.v bedrock2/deps/riscv-coq/src/Platform/MetricMinimal.v bedrock2/deps/riscv-coq/src/Platform/Example.v bedrock2/deps/riscv-coq/src/Platform/Memory.v bedrock2/deps/riscv-coq/src/Platform/MinimalLogging.v bedrock2/deps/riscv-coq/src/Platform/Run.v bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine.v bedrock2/deps/riscv-coq/src/Platform/Minimal.v bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64.v bedrock2/deps/riscv-coq/src/Proofs/EncodeBound.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system.v bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57.v bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66.v -o Makefile.coq.all +make[2]: Entering directory 'bedrock2/bedrock2' +printf -- '-Q src bedrock2\n-Q /builds/coq/coWarning: ../coqutil/src (used in -R or -Q) is not a subdirectory of the current directory + +bedrock2/bedrock2/src/Syntax (real: 0.28, user: 0.07, sys: 0.04, mem: 93508 ko) +bedrock2/deps/riscv-coq/src/Utility/Monads (real: 1.74, user: 0.61, sys: 0.22, mem: 357880 ko) +bedrock2/deps/riscv-coq/src/Utility/Tactics (real: 1.14, user: 0.34, sys: 0.21, mem: 294376 ko) +bedrock2/bedrock2/src/Byte (real: 3.14, user: 1.29, sys: 0.27, mem: 418180 ko) +bedrock2/bedrock2/src/Notations (real: 0.16, user: 0.04, sys: 0.03, mem: 56396 ko) +bedrock2/deps/riscv-coq/src/Platform/MetricLogging (real: 1.44, user: 0.46, sys: 0.23, mem: 344552 ko) +bedrock2/deps/riscv-coq/src/Utility/MMIOTrace (real: 0.17, user: 0.04, sys: 0.03, mem: 56096 ko) +q/_build_ci/bedrock2/deps/coqutil/src coqutil\n' > _CoqProject +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = bedrock2 -arg "-async-proofs-tac-j 1" bedrock2/bedrock2/src/BasicCSyntax.v bedrock2/bedrock2/src/ToCString.v bedrock2/bedrock2/src/BytedumpTest.v bedrock2/bedrock2/src/BasicC32Semantics.v bedrock2/bedrock2/src/Byte.v bedrock2/bedrock2/src/Variables.v bedrock2/bedrock2/src/Semantics.v bedrock2/bedrock2/src/div10.v bedrock2/bedrock2/src/NotationsCustomEntry.v bedrock2/bedrock2/src/ListPred.v bedrock2/bedrock2/src/BasicC64Semantics.v bedrock2/bedrock2/src/Map/SeparationLogic.v bedrock2/bedrock2/src/Map/Separation.v bedrock2/bedrock2/src/Syntax.v bedrock2/bedrock2/src/WeakestPreconditionProperties.v bedrock2/bedrock2/src/NotationsInConstr.v bedrock2/bedrock2/src/WeakestPrecondition.v bedrock2/bedrock2/src/TODO_absint.v bedrock2/bedrock2/src/Bytedump.v bedrock2/bedrock2/src/FE310CSemantics.v bedrock2/bedrock2/src/StructNotations.v bedrock2/bedrock2/src/Examples/lightbulb.v bedrock2/bedrock2/src/Examples/MultipleReturnValues.v bedrock2/bedrock2/src/Examples/ARPResponder.v bedrock2/bedrock2/src/Examples/swap.v bedrock2/bedrock2/src/Examples/chacha20.v bedrock2/bedrock2/src/Examples/Demos.v bedrock2/bedrock2/src/Examples/bsearch.v bedrock2/bedrock2/src/Examples/Trace.v bedrock2/bedrock2/src/Examples/StructAccess.v bedrock2/bedrock2/src/Examples/FE310CompilerDemo.v bedrock2/bedrock2/src/Examples/ipow.v bedrock2/bedrock2/src/Markers.v bedrock2/bedrock2/src/Memory.v bedrock2/bedrock2/src/Structs.v bedrock2/bedrock2/src/Notations.v bedrock2/bedrock2/src/ProgramLogic.v bedrock2/bedrock2/src/Hexdump.v bedrock2/bedrock2/src/BasicC64Syntax.v bedrock2/bedrock2/src/Scalars.v bedrock2/bedrock2/src/string2ident.v bedrock2/bedrock2/src/ptsto_bytes.v bedrock2/bedrock2/src/StringNamesSyntax.v bedrock2/bedrock2/src/Lift1Prop.v bedrock2/bedrock2/src/ZNamesSyntax.v bedrock2/bedrock2/src/TailRecursion.v bedrock2/bedrock2/src/Array.v -o Makefile.coq.all +make -f Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/deps/riscv-coq' +make[3]: Entering directory 'bedrock2/bedrock2' +COQDEP VFILES +COQDEP VFILES +COQC bedrock2/bedrock2/src/Syntax.v +COQC bedrock2/deps/riscv-coq/src/Utility/Monads.v +COQC bedrock2/bedrock2/src/Byte.v +COQC bedrock2/deps/riscv-coq/src/Utility/Tactics.v +COQC bedrock2/deps/riscv-coq/src/Platform/MetricLogging.v +COQC bedrock2/bedrock2/src/Notations.v +COQC bedrock2/bedrock2/src/div10.v +COQC bedrock2/deps/riscv-coq/src/Utility/MMIOTrace.v +COQC bedrock2/deps/riscv-coq/src/Utility/nat_div_mbedrock2/bedrock2/src/div10 (real: 1.82, user: 0.61, sys: 0.29, mem: 437628 ko) +bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem (real: 1.14, user: 0.36, sys: 0.19, mem: 298516 ko) +File "bedrock2/bedrock2/src/NotationsCustomEntry.v", line 50, characters 0-51: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_nontail.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsCustomEntry.v", line 142, characters 0-45: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_tail.". [undeclared-scope,deprecated] +File "bedrock2/deps/riscv-coq/src/Utility/JMonad.v", line 13, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/NotationsCustomEntry (real: 1.07, user: 0.33, sys: 0.18, mem: 301112 ko) +bedrock2/deps/riscv-coq/src/Utility/JMonad (real: 0.64, user: 0.17, sys: 0.13, mem: 184664 ko) +bedrock2/bedrock2/src/ListPred (real: 0.47, user: 0.13, sys: 0.09, mem: 144616 ko) +File "bedrock2/deps/riscv-coq/src/Utility/MonadNotations.v", line 3, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +bedrock2/deps/riscv-coq/src/Utility/MonadNotations (real: 0.48, user: 0.12, sys: 0.11, mem: 146976 ko) +bedrock2/deps/riscv-coq/src/Utility/PowerFunc (real: 0.20, user: 0.05, sys: 0.04, mem: 65768 ko) +bedrock2/bedrock2/src/Lift1Prop (real: 0.32, user: 0.09, sys: 0.06, mem: 116312 ko) +File "bedrock2/deps/riscv-coq/src/Utility/MonadTests.v", line 10, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 5, characters 0-43: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_var.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 7, characters 0-45: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_expr.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 21, characters 0-43: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_cmd.". [undeclared-scope,deprecated] +File "bedrock2/bedrock2/src/NotationsInConstr.v", line 46, characters 0-55: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bedrock_func_body.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/NotationsInConstr (real: 0.66, user: 0.19, sys: 0.10, mem: 172428 ko) +bedrock2/deps/riscv-coq/src/Utility/MonadTests (real: 0.93, user: 0.27, sys: 0.16, mem: 255852 ko) +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 17, characters 0-102: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope monad_scope.". [undeclared-scope,deprecated] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 265, characters 2-23: +Warning: State is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 266, characters 2-37: +Warning: step is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 280, characters 2-23: +Warning: State is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 281, characters 2-37: +Warning: step is declared as a local axiom [local-declaration,scope] +File "bedrock2/deps/riscv-coq/src/Utility/MonadT.v", line 311, characters 2-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/deps/riscv-coq/src/Utility/MonadT (real: 0.78, user: 0.23, sys: 0.15, mem: 212520 ko) +od_to_quot_rem.v +COQC bedrock2/bedrock2/src/NotationsCustomEntry.v +COQC bedrock2/deps/riscv-coq/src/Utility/JMonad.v +COQC bedrock2/bedrock2/src/ListPred.v +COQC bedrock2/deps/riscv-coq/src/Utility/MonadNotations.v +COQC bedrock2/bedrock2/src/Lift1Prop.v +COQC bedrock2/deps/riscv-coq/src/Utility/PowerFunc.v +COQC bedrock2/deps/riscv-coq/src/Utility/MonadTests.v +COQC bedrock2/bedrock2/src/NotationsInConstr.v + = [(3, true); (3, false); (4, true); (4, false)] + : Id (list (nat * bool)) + = None + : Id (option (list nat)) + = [Some 3; Some 4; None] + : Id (list (option nat)) + = (tt, 5) + : Id (unit * nat) + = [(tt, 6); (tt, 7)] + : Id (list (unit * nat)) + = [0; 1; 2; 3] + : list nat + = [(tt, 0); (tt, 1); (tt, 2); (tt, 3)] + : Id (list (unit * nat)) +COQC bedrock2/bedrock2/src/Structs.v + = ([(0, 1); (0, 0)], (0, 0)) + : Id (list (nat * nat) * (nat * nat)) + = [(0, 1, (0, 1)); (1, 0, (1, 0))] + : Id (list (nat * nat * (nat * nat))) + = ([0; 1; 2; 3], 3) + : Id (list nat * nat) + = ([0; 5; 6; 15], 15) + : Id (list nat * nat) + = (tt, <<20,10,10>>) + : Id (unit * Regs) + = ([<<0,20,30>>; <<1,20,30>>; <<2,20,30>>], <<2,20,30>>) + : Id (list Regs * Regs) + = ([<<0,11,11>>; <<1,11,11>>; <<2,11,11>>; <<3,11,11>>], <<3,11,11>>) + : Id (list Regs * Regs) +COQC bedrock2/deps/riscv-coq/src/Utility/MonadT.v + = list (option nat) + : Type + = fun (A : Type) (aset : (A -> Prop) -> Prop) + (f : (A -> Prop) -> A) (b : A) => + exists a : A -> Prop, aset a /\ f a = b + : forall A : Type, + ((A -> Prop) -> Prop) -> ((A -> Prop) -> A) -> A -> Prop +runsTo_ind + : forall (initial : State) (P : State -> Prop) (P0 : Prop), + (P initial -> P0) -> + ((forall omid : option State, + step initial omid -> + exists mid : State, omid = Some mid /\ runsTo mid P) -> P0) -> + runsTo initial P -> P0 +runsTo_ind = +fun (initial : State) (P : State -> Prop) (P0 : Prop) + (f : P initial -> P0) + (f0 : (forall omid : option (option unit * State), + step initial omid -> + exists mid : State, omid = Some (Some tt, mid) /\ runsTo mid P) -> + P0) (r : runsTo initial P) => +match r with +| runsToDone _ _ x => f x +| runsToStep _ _ x => f0 x +end + : forall (initial : State) (P : State -> Prop) (P0 : Prop), + (P initial -> P0) -> + ((forall omid : option (option unit * State), + step initial omid -> + exists mid : State, omid = Some (Some tt, mid) /\ runsTo mid P) -> + P0) -> runsTo initial P -> P0 + +Argument scopes are [_ function_scope type_scope function_scope + function_scope _] +Closed under the global context +COQC bedrock2/deps/riscv-coq/src/Utility/ListLib.v + = 4%Z + : Z + = 20%Z + : Z + = 30%Z + : Z + = 90%Z + : Z + = inr + (Struct + (("first", Array 15 (Bytes 1)) + :: ("last", Array 15 (Bytes 1)) :: nil), 30%Z) + : PathError Z + type * Z + = inr (Array 15 (Bytes 1), 45%Z) + : PathError Z + type * Z + = inr (Bytes 1, 47%Z) + : PathError Z + type * Z + = fun (p : parameters) (add mul : bopname) (base : expr) => + inr + (Struct + (("first", Array 15 (Bytes 1)) + :: ("last", Array 15 (Bytes 1)) :: nil), + expr.op add base (expr.op mul (expr.literal 1) (expr.literal 30))) + : forall p : parameters, + bopname -> bopname -> expr -> PathError expr + type * expr + = fun (p : parameters) (add mul : bopname) (base : expr) => + inr + (Array 15 (Bytes 1), + expr.op add + (expr.op add base (expr.op mul (expr.literal 1) (expr.literal 30))) + (expr.literal 15)) + : forall p : parameters, + bopname -> bopname -> expr -> PathError expr + type * bedrock2/bedrock2/src/Structs (real: 1.31, user: 0.44, sys: 0.20, mem: 308516 ko) +File "bedrock2/bedrock2/src/Markers.v", line 19, characters 2-71: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope hide_markers.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/Markers (real: 0.18, user: 0.04, sys: 0.04, mem: 57444 ko) +bedrock2/bedrock2/src/string2ident (real: 1.15, user: 0.36, sys: 0.20, mem: 272052 ko) +File "bedrock2/bedrock2/src/Hexdump.v", line 16, characters 0-41: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope hexdump_scope.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/Hexdump (real: 1.06, user: 0.32, sys: 0.19, mem: 274924 ko) +bedrock2/deps/riscv-coq/src/Utility/ListLib (real: 2.96, user: 1.17, sys: 0.28, mem: 444076 ko) +bedrock2/bedrock2/src/ZNamesSyntax (real: 1.16, user: 0.38, sys: 0.18, mem: 294268 ko) +bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem (real: 1.14, user: 0.37, sys: 0.18, mem: 295668 ko) +File "bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v", line 20, characters 2-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v", line 30, characters 2-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/deps/riscv-coq/src/Utility/runsToNonDet (real: 0.20, user: 0.05, sys: 0.03, mem: 65120 ko) +bedrock2/bedrock2/src/Variables (real: 0.46, user: 0.13, sys: 0.09, mem: 149744 ko) +bedrock2/bedrock2/src/StringNamesSyntax (real: 1.02, user: 0.30, sys: 0.18, mem: 252388 ko) +File "bedrock2/bedrock2/src/Bytedump.v", line 2, characters 0-43: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bytedump_scope.". [undeclared-scope,deprecated] +bedrock2/bedrock2/src/Bytedump (real: 1.08, user: 0.34, sys: 0.18, mem: 272812 ko) +bedrock2/deps/riscv-coq/src/Utility/ZBitOps (real: 2.28, user: 0.83, sys: 0.28, mem: 439724 ko) +File "bedrock2/deps/riscv-coq/src/Utility/Utility.v", line 120, characters 0-78: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope alu_scope.". [undeclared-scope,deprecated] +bedrock2/deps/riscv-coq/src/Utility/Utility (real: 1.69, user: 0.57, sys: 0.25, mem: 358716 ko) +bedrock2/bedrock2/src/Memory (real: 2.40, user: 0.84, sys: 0.30, mem: 443020 ko) +bedrock2/bedrock2/src/Map/Separation (real: 1.31, user: 0.43, sys: 0.20, mem: 289244 ko) +bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise (real: 2.66, user: 0.95, sys: 0.32, mem: 441452 ko) +bedrock2/bedrock2/src/StructNotations (real: 1.10, user: 0.35, sys: 0.18, mem: 267768 ko) +bedrock2/deps/riscv-coq/src/Utility/Words32Naive (real: 1.51, user: 0.52, sys: 0.21, mem: 346660 ko) +bedrock2/bedrock2/src/ToCString (real: 1.34, user: 0.48, sys: 0.17, mem: 276676 ko) +bedrock2/deps/riscv-coq/src/Utility/Words64Naive (real: 1.41, user: 0.49, sys: 0.19, mem: 346980 ko) +bedrock2/bedrock2/src/BytedumpTest (real: 1.52, user: 0.49, sys: 0.25, mem: 411496 ko) +bedrock2/bedrock2/src/BytedumpTestα (real: 1.52, user: 0.49, sys: 0.25, mem: 411496 ko) +bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32 (real: 1.64, user: 0.55, sys: 0.23, mem: 376020 ko) +bedrock2/bedrock2/src/Semantics (real: 1.81, user: 0.66, sys: 0.26, mem: 441912 ko) +bedrock2/deps/riscv-coq/src/Spec/Decode (real: 2.09, user: 0.71, sys: 0.28, mem: 446048 ko) +bedrock2/deps/riscv-coq/src/Platform/Memory (real: 2.06, user: 0.71, sys: 0.27, mem: 449484 ko) +bedrock2/bedrock2/src/Map/SeparationLogic (real: 4.20, user: 1.76, sys: 0.27, mem: 433996 ko) +bedrock2/deps/riscv-coq/src/Spec/Machine (real: 1.50, user: 0.49, sys: 0.24, mem: 375808 ko) +bedrock2/bedrock2/src/WeakestPrecondition (real: 1.67, user: 0.56, sys: 0.24, mem: 410516 ko) +bedrock2/deps/riscv-coq/src/Platform/RiscvMachine (real: 1.48, user: 0.48, sys: 0.24, mem: 370692 ko) +bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth (real: 1.44, user: 0.49, sys: 0.21, mem: 360632 ko) +bedrock2/bedrock2/src/Array (real: 3.30, user: 1.35, sys: 0.27, mem: 457132 ko) +bedrock2/deps/riscv-coq/src/Spec/VirtualMemory (real: 1.33, user: 0.43, sys: 0.22, mem: 321032 ko) +bedrock2/bedrock2/src/BasicC64Syntax (real: 1.40, user: 0.47, sys: 0.21, mem: 321560 ko) +bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine (real: 1.49, user: 0.48, sys: 0.24, mem: 362608 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteM (real: 1.62, user: 0.53, sys: 0.26, mem: 387416 ko) +bedrock2/bedrock2/src/Examples/Trace (real: 2.96, user: 1.14, sys: 0.29, mem: 449412 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteM64 (real: 1.64, user: 0.52, sys: 0.25, mem: 375816 ko) +bedrock2/bedrock2/src/Examples/StructAccess (real: 1.12, user: 0.35, sys: 0.19, mem: 272888 ko) +bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions (real: 1.40, user: 0.47, sys: 0.21, mem: 338992 ko) +bedrock2/bedrock2/src/BasicCSyntax (real: 1.40, user: 0.50, sys: 0.18, mem: 322924 ko) +expr + = fun (p : parameters) (add mul : bopname) (base : expr) => + inr + (Bytes 1, + expr.op add + (expr.op add + (expr.op add base + (expr.op mul (expr.literal 1) (expr.literal 30))) + (expr.literal 15)) + (expr.op mul (expr.literal 2) (expr.literal 1))) + : forall p : parameters, + bopname -> bopname -> expr -> PathError expr + type * expr +COQC bedrock2/bedrock2/src/Markers.v +COQC bedrock2/bedrock2/src/string2ident.v +COQC bedrock2/bedrock2/src/Hexdump.v +COQC bedrock2/bedrock2/src/ZNamesSyntax.v +COQC bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem.v +COQC bedrock2/bedrock2/src/Variables.v +COQC bedrock2/deps/riscv-coq/src/Utility/runsToNonDet.v +COQC bedrock2/deps/riscv-coq/src/Utility/ZBitOps.v +COQC bedrock2/bedrock2/src/StringNamesSyntax.v +COQC bedrock2/bedrock2/src/Bytedump.v +COQC bedrock2/bedrock2/src/Memory.v +COQC bedrock2/deps/riscv-coq/src/Utility/Utility.v +COQC bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise.v +COQC bedrock2/bedrock2/src/Map/Separation.v +COQC bedrock2/bedrock2/src/StructNotations.v +COQC bedrock2/deps/riscv-coq/src/Utility/Words32Naive.v +COQC bedrock2/bedrock2/src/ToCString.v +COQC bedrock2/deps/riscv-coq/src/Utility/Words64Naive.v +COQC bedrock2/bedrock2/src/BytedumpTest.v +COQC bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32.v + +
!"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ +COQC bedrock2/bedrock2/src/Semantics.v +COQC bedrock2/deps/riscv-coq/src/Spec/Decode.v +COQC bedrock2/bedrock2/src/Map/SeparationLogic.v +COQC bedrock2/deps/riscv-coq/src/Platform/Memory.v +COQC bedrock2/deps/riscv-coq/src/Spec/Machine.v +COQC bedrock2/bedrock2/src/WeakestPrecondition.v +COQC bedrock2/deps/riscv-coq/src/Platform/RiscvMachine.v +COQC bedrock2/bedrock2/src/Array.v +COQC bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth.v +COQC bedrock2/deps/riscv-coq/src/Spec/VirtualMemory.v +COQC bedrock2/bedrock2/src/BasicC64Syntax.v +COQC bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine.v +COQC bedrock2/bedrock2/src/Examples/Trace.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteM.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteM64.v +squarer_correct + : forall (m : Semantics.mem) (l : Semantics.locals), + exec map.empty squarer [] m l + (fun (t' : trace) (_ : Semantics.mem) (_ : Semantics.locals) => + squarer_trace t') +squarer_correct + : forall (m : Semantics.mem) (l : Semantics.locals), + exec map.empty squarer [] m l + (fun (t' : trace) (_ : Semantics.mem) (_ : Semantics.locals) => + squarer_trace t') +COQC bedrock2/bedrock2/src/Examples/StructAccess.v +COQC bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions.v +COQC bedrock2/bedrock2/src/BasicCSyntax.v +COQC bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions.v +COQC bedrock2/bedrock2/src/WeakestPreconditionFile "bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions.v", line 10, characters 0-70: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope ilist_scope.". [undeclared-scope,deprecated] +bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions (real: 1.33, user: 0.43, sys: 0.21, mem: 313976 ko) +bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64 (real: 1.59, user: 0.52, sys: 0.25, mem: 375840 ko) +bedrock2/deps/riscv-coq/src/Utility/Encode (real: 2.03, user: 0.67, sys: 0.31, mem: 446648 ko) +bedrock2/deps/riscv-coq/src/Spec/Primitives (real: 2.21, user: 0.72, sys: 0.34, mem: 457772 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteI (real: 2.60, user: 0.94, sys: 0.32, mem: 454504 ko) +bedrock2/deps/riscv-coq/src/Spec/ExecuteI64 (real: 1.85, user: 0.55, sys: 0.28, mem: 401008 ko) +bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives (real: 2.20, user: 0.76, sys: 0.30, mem: 459200 ko) +bedrock2/deps/riscv-coq/src/Spec/Execute (real: 1.43, user: 0.44, sys: 0.24, mem: 336624 ko) +bedrock2/deps/riscv-coq/src/Utility/InstructionNotations (real: 1.41, user: 0.44, sys: 0.24, mem: 340268 ko) +bedrock2/deps/riscv-coq/src/Platform/Run (real: 1.69, user: 0.52, sys: 0.27, mem: 374676 ko) +File "bedrock2/bedrock2/src/WeakestPreconditionProperties.v", line 193, characters 2-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/bedrock2/src/WeakestPreconditionProperties (real: 19.56, user: 9.19, sys: 0.41, mem: 663884 ko) +bedrock2/bedrock2/src/FE310CSemantics (real: 8.23, user: 3.64, sys: 0.34, mem: 472892 ko) +File "bedrock2/bedrock2/src/TailRecursion.v", line 16, characters 2-67: +Warning: Notation "_ /\ _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "{ _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "{ ' _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 47, characters 2-14: +Warning: Notation "( _ , _ , .. , _ )" was already used in scope core_scope. +[notation-overridden,parsing] +File "bedrock2/bedrock2/src/TailRecursion.v", line 138, characters 2-49: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/bedrock2/src/TailRecursion (real: 3.43, user: 1.34, sys: 0.32, mem: 461368 ko) +bedrock2/deps/riscv-coq/src/Platform/Minimal (real: 14.97, user: 6.99, sys: 0.33, mem: 482444 ko) +File "bedrock2/bedrock2/src/ptsto_bytes.v", line 151, characters 6-173: +Warning: Unused introduction patterns: R IH [unused-intro-pattern,tactics] +File "bedrock2/bedrock2/src/ptsto_bytes.v", line 163, characters 6-132: +Warning: Unused introduction patterns: R IH [unused-intro-pattern,tactics] +bedrock2/bedrock2/src/ptsto_bytes (real: 4.33, user: 1.80, sys: 0.31, mem: 461200 ko) +bedrock2/bedrock2/src/Examples/MultipleReturnValues (real: 1.64, user: 0.54, sys: 0.23, mem: 310296 ko) +bedrock2/bedrock2/src/Examples/ARPResponder (real: 4.88, user: 2.06, sys: 0.33, mem: 465924 ko) +bedrock2/bedrock2/src/Examples/chacha20 (real: 3.11, user: 1.25, sys: 0.26, mem: 435736 ko) +Properties.v +COQC bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64.v +COQC bedrock2/deps/riscv-coq/src/Utility/Encode.v +COQC bedrock2/deps/riscv-coq/src/Spec/Primitives.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteI.v +COQC bedrock2/deps/riscv-coq/src/Spec/ExecuteI64.v +COQC bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives.v +COQC bedrock2/deps/riscv-coq/src/Spec/Execute.v +COQC bedrock2/deps/riscv-coq/src/Utility/InstructionNotations.v +COQC bedrock2/deps/riscv-coq/src/Platform/Run.v +COQC bedrock2/deps/riscv-coq/src/Platform/Minimal.v +COQC bedrock2/bedrock2/src/FE310CSemantics.v +COQC bedrock2/bedrock2/src/TailRecursion.v +COQC bedrock2/bedrock2/src/ptsto_bytes.v +COQC bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO.v +COQC bedrock2/bedrock2/src/Examples/MultipleReturnValues.v +COQC bedrock2/bedrock2/src/Examples/ARPResponder.v +COQC bedrock2/bedrock2/src/Examples/chacha20.v +COQC bedrock2/bedrock2/src/Examples/Demos.v +allProgs@{bedrock2.Examples.Demos.686 bedrock2.Examples.Demos.687} = +[("bsearch", + ([left; right; target], [left], + (while (right - left) {{ + mid = left + (right - left) >> 4 << 3;; + (if (*(uintptr_t*) mid < target) {{ + left = mid + 8 + }} else {{ + right = mid + }});; + cmd.unset mid + }})%bedrock_cmd)); +("listsum", +([], [sumreg], +(sumreg = 0;; + n = *(uint32_t*) 1024;; + ListSum.i = 0;; + while (ListSum.i < n) {{ + ListSum.a = *(uint32_t*) (1024 + 4 + 4 * ListSum.i);; + sumreg = sumreg + ListSum.a;; + ListSum.i = ListSum.i + 1 + }})%bedrock_cmd)); +("fibonacci", +([], [b], +(a = 0;; + b = 1;; + i = 0;; + while (i < 6) {{ + c = a + b;; + a = b;; + b = c;; + i = i + 1 + }})%bedrock_cmd))] + : list Prog +allProgs@{bedrock2.Examples.Demos.135 bedrock2.Examples.Demos.136 +bedrock2.Examples.Demos.137 bedrock2.Examples.Demos.146 +bedrock2.Examples.Demos.171 bedrock2.Examples.Demos.345 +bedrock2.Examples.Demos.515 bedrock2.Examples.Demos.686 +bedrock2.Examples.Demos.687} = +fun (p : Syntax.parameters) (bsearchNames : BinarySearch.Names) + (listsumNames : ListSum.Names) (fibonacciNames : Fibonacci.Names) => +[("bsearch", + ([BinarySearch.left; BinarySearch.right; BinarySearch.target], + [BinarySearch.left], + cmd.while + (expr.op bopname.sub (var BinarySearch.right) (var BinarySearch.left)) + (cmd.seq + (cmd.set BinarySearch.mid + (expr.op bopname.add (var BinarySearch.left) + (expr.op bopname.slu + (expr.op bopname.sru + (expr.op bopname.sub (var BinarySearch.right) + (var BinarySearch.left)) (literal 4)) + (literal 3)))) + (cmd.seq + (cmd.cond + (expr.op bopname.ltu + (expr.load access_size.word (var BinarySearch.mid)) + (var BinarySearch.target)) + (cmd.set BinarySearch.left + (expr.op bopname.add (var BinarySearch.mid) (literal 8))) + (cmd.set BinarySearch.right (var BinarySearch.mid))) + (cmd.unset BinarySearch.mid))))); +("listsum", +([], [ListSum.sumreg], +cmd.seq (cmd.set ListSum.sumreg (literal 0)) + (cmd.seq (cmd.set ListSum.n (expr.load access_size.four (literal 1024))) + (cmd.seq (cmd.set ListSum.i (literal 0)) + (cmd.while (expr.op bopname.ltu (var ListSum.i) (var ListSum.n)) + (cmd.seq + (cmd.set ListSum.a + (expr.load access_size.four + (expr.op bopname.add (literal (1024 + 4)) + (expr.op bopname.mul (literal 4) (var ListSum.i))))) + (cmd.seq + (cmd.set ListSum.sumreg + (expr.op bopname.add (var ListSum.sumreg) (var ListSum.a))) + bedrock2/bedrock2/src/Examples/Demos (real: 1.93, user: 0.69, sys: 0.23, mem: 353168 ko) +bedrock2/bedrock2/src/BasicC32Semantics (real: 1.66, user: 0.55, sys: 0.25, mem: 387552 ko) +bedrock2/bedrock2/src/BasicC64Semantics (real: 1.74, user: 0.57, sys: 0.27, mem: 403188 ko) +bedrock2/bedrock2/src/Scalars (real: 3.04, user: 1.18, sys: 0.30, mem: 457564 ko) +bedrock2/bedrock2/src/TODO_absint (real: 2.93, user: 1.13, sys: 0.30, mem: 457912 ko) + (cmd.set ListSum.i + (expr.op bopname.add (var ListSum.i) (literal 1)))))))))); +("fibonacci", +([], [Fibonacci.b], +cmd.seq (cmd.set Fibonacci.a (literal 0)) + (cmd.seq (cmd.set Fibonacci.b (literal 1)) + (cmd.seq (cmd.set Fibonacci.i (literal 0)) + (cmd.while (expr.op bopname.ltu (var Fibonacci.i) (literal 6)) + (cmd.seq + (cmd.set Fibonacci.c + (expr.op bopname.add (var Fibonacci.a) (var Fibonacci.b))) + (cmd.seq (cmd.set Fibonacci.a (var Fibonacci.b)) + (cmd.seq (cmd.set Fibonacci.b (var Fibonacci.c)) + (cmd.set Fibonacci.i + (expr.op bopname.add (var Fibonacci.i) (literal 1)))))))))))] + : forall p : Syntax.parameters, + BinarySearch.Names -> ListSum.Names -> Fibonacci.Names -> list Prog + +Arguments p, bsearchNames, listsumNames, fibonacciNames are implicit and +maximally inserted +allProgsAsCStrings@{} = +["uintptr_t bsearch(uintptr_t left, uintptr_t right, uintptr_t target) { + uintptr_t mid; + while ((right)-(left)) { + mid = (left)+((((right)-(left))>>((uintptr_t)4ULL))<<((uintptr_t)3ULL)); + if ((*(uintptr_t*)(mid))<(target)) { + left = (mid)+((uintptr_t)8ULL); + } else { + right = mid; + } + // unset mid + } + return left; +} +"; +"uintptr_t listsum() { + uintptr_t n, sumreg, a, i; + sumreg = (uintptr_t)0ULL; + n = *(uint32_t*)((uintptr_t)1024ULL); + i = (uintptr_t)0ULL; + while ((i)<(n)) { + a = *(uint32_t*)(((uintptr_t)1028ULL)+(((uintptr_t)4ULL)*(i))); + sumreg = (sumreg)+(a); + i = (i)+((uintptr_t)1ULL); + } + return sumreg; +} +"; +"uintptr_t fibonacci() { + uintptr_t a, b, c, i; + a = (uintptr_t)0ULL; + b = (uintptr_t)1ULL; + i = (uintptr_t)0ULL; + while ((i)<((uintptr_t)6ULL)) { + c = (a)+(b); + a = b; + b = c; + i = (i)+((uintptr_t)1ULL); + } + return b; +} +"] + : list string +allProgsWithZNames@{bedrock2.Examples.Demos.721} = +[("bsearch", + ([1; 2; 3], [1], + cmd.while (expr.op bopname.sub (expr.var 2) (expr.var 1)) + (cmd.seq + (cmd.set 4 + (expr.op bopname.add (expr.var 1) + (expr.op bopname.slu + (expr.op bopname.sru + (expr.op bopname.sub (expr.var 2) (expr.var 1)) + (expr.literal 4)) (expr.literal 3)))) + (cmd.seq + (cmd.cond + (expr.op bopname.ltu (expr.load access_size.word (expr.var 4)) + (expr.var 3)) + (cmd.set 1 (expr.op bopname.add (expr.var 4) (expr.literal 8))) + (cmd.set 2 (expr.var 4))) (cmd.unset 4))))); +("listsum", +([], [3], +cmd.seq (cmd.set 3 (expr.literal 0)) + (cmd.seq (cmd.set 1 (expr.load access_size.four (expr.literal 1024))) + (cmd.seq (cmd.set 2 (expr.literal 0)) + (cmd.while (expr.op bopname.ltu (expr.var 2) (expr.var 1)) + (cmd.seq + (cmd.set 4 + (expr.load access_size.four + (expr.op bopname.add (expr.literal 1028) + (expr.op bopname.mul (expr.literal 4) (expr.var 2))))) + (cmd.seq + (cmd.set 3 (expr.op bopname.add (expr.var 3) (expr.var 4))) + (cmd.set 2 + (expr.op bopname.add (expr.var 2) (expr.literal 1)))))))))); +("fibonacci", +([], [2], +cmd.seq (cmd.set 1 (expr.literal 0)) + (cmd.seq (cmd.set 2 (expr.literal 1)) + (cmd.seq (cmd.set 4 (expr.literal 0)) + (cmd.while (expr.op bopname.ltu (expr.var 4) (expr.literal 6)) + (cmd.seq + (cmd.set 3 (expr.op bopname.add (expr.var 1) (expr.var 2))) + (cmd.seq (cmd.set 1 (expr.var 2)) + (cmd.seq (cmd.set 2 (expr.var 3)) + (cmd.set 4 + (expr.op bopname.add (expr.var 4) (expr.literal 1)))))))))))] + : list (string * (list Z * list Z * cmd)) +COQC bedrock2/bedrock2/src/BasicC32Semantics.v +COQC bedrock2/bedrock2/src/BasicC64Semantics.v +COQC bedrock2/bedrock2/src/Scalars.v +COQC bedrock2/bedrock2/src/TODO_absint.v +bedrock2/bedrock2/src/ProgramLogic (real: 1.65, user: 0.52, sys: 0.25, mem: 371960 ko) +File "bedrock2/bedrock2/src/Examples/lightbulb.v", line 48, characters 0-36: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/bedrock2/src/Examples/lightbulb (real: 44.98, user: 21.59, sys: 0.37, mem: 525428 ko) +File "bedrock2/bedrock2/src/Examples/swap.v", line 31, characters 24-60: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +bedrock2/bedrock2/src/Examples/swap (real: 8.68, user: 3.88, sys: 0.33, mem: 478956 ko) +bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO (real: 140.04, user: 67.92, sys: 0.50, mem: 590104 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence (real: 19.81, user: 9.16, sys: 0.36, mem: 495544 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R (real: 13.71, user: 6.32, sys: 0.36, mem: 478812 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic (real: 18.82, user: 8.68, sys: 0.36, mem: 494004 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I (real: 14.67, user: 6.82, sys: 0.30, mem: 485168 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57 (real: 13.83, user: 6.36, sys: 0.32, mem: 478692 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66 (real: 40.12, user: 19.20, sys: 0.36, mem: 526372 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system (real: 10.48, user: 4.71, sys: 0.33, mem: 470712 ko) +bedrock2/bedrock2/src/Examples/bsearch (real: 208.32, user: 101.50, sys: 0.51, mem: 564436 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S (real: 25.56, user: 12.11, sys: 0.34, mem: 518652 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB (real: 55.25, user: 26.55, sys: 0.40, mem: 632108 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U (real: 9.99, user: 4.46, sys: 0.31, mem: 468412 ko) +bedrock2/bedrock2/src/Examples/FE310CompilerDemo (real: 83.94, user: 40.64, sys: 0.41, mem: 588832 ko) +bedrock2/bedrock2/src/Examples/ipow (real: 19.97, user: 9.35, sys: 0.30, mem: 496100 ko) +/bin/sh: 1: hexdump: not found +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ (real: 39.56, user: 19.19, sys: 0.35, mem: 580040 ko) +bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI (real: 14.48, user: 6.72, sys: 0.31, mem: 485544 ko) +bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run (real: 1.66, user: 0.58, sys: 0.23, mem: 408744 ko) +bedrock2/deps/riscv-coq/src/Platform/MinimalLogging (real: 2.10, user: 0.74, sys: 0.27, mem: 460380 ko) +bedrock2/deps/riscv-coq/src/Platform/MetricMinimal (real: 24.74, user: 11.74, sys: 0.31, mem: 501100 ko) +COQC bedrock2/bedrock2/src/ProgramLogic.v +COQC bedrock2/bedrock2/src/Examples/lightbulb.v + = "uintptr_t lightbulb(uintptr_t packet, uintptr_t len) { + uintptr_t ethertype, protocol, mmio_val, command, r; + ethertype = ((*(uint8_t*)((packet)+((uintptr_t)12ULL)))<<((uintptr_t)8ULL))|(*(uint8_t*)((packet)+((uintptr_t)13ULL))); + if (((uintptr_t)1535ULL)<(ethertype)) { + protocol = *(uint8_t*)((packet)+((uintptr_t)23ULL)); + if ((protocol)==((uintptr_t)17ULL)) { + command = *(uint8_t*)((packet)+((uintptr_t)42ULL)); + mmio_val = MMIOREAD((uintptr_t)268509192ULL); + MMIOWRITE((uintptr_t)268509192ULL, (mmio_val)|(((uintptr_t)1ULL)<<((uintptr_t)23ULL))); + mmio_val = MMIOREAD((uintptr_t)268509196ULL); + MMIOWRITE((uintptr_t)268509196ULL, (mmio_val)|((command)<<((uintptr_t)23ULL))); + r = (uintptr_t)0ULL; + } else { + r = (uintptr_t)-1ULL; + } + } else { + r = (uintptr_t)-1ULL; + } + return r; +} +" + : string +COQC bedrock2/bedrock2/src/Examples/swap.v +static void swap(uintptr_t a, uintptr_t b); + +void swap_swap(uintptr_t a, uintptr_t b) { + swap(a, b); + swap(a, b); + return; +} + +static void swap(uintptr_t a, uintptr_t b) { + uintptr_t t; + t = *(uintptr_t*)(b); + *(uintptr_t*)(b) = *(uintptr_t*)(a); + *(uintptr_t*)(a) = t; + return; +} + +COQC bedrock2/bedrock2/src/Examples/bsearch.v +H19 +H13 +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S.v +COQC bedrock2/bedrock2/src/Examples/FE310CompilerDemo.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U.v +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ.v +COQC bedrock2/bedrock2/src/Examples/ipow.v +make[3]: Leaving directory 'bedrock2/bedrock2' +make src/BytedumpTest.out +make[3]: Entering directory 'bedrock2/bedrock2' +coqc -q -Q src bedrock2 -Q bedrock2/deps/coqutil/src coqutil src/BytedumpTest.v | head --bytes -1 > src/BytedumpTest.out.tmp +hexdump < /dev/null && \ + hexdump -C src/BytedumpTest.golden.bin > src/BytedumpTest.golden.hex && \ + hexdump -C src/BytedumpTest.out.tmp > src/BytedumpTest.out.hex && \ + diff -u src/BytedumpTest.golden.hex src/BytedumpTest.out.hex && \ + rm src/BytedumpTest.golden.hex src/BytedumpTest.out.hex || true +diff -u src/BytedumpTest.golden.bin src/BytedumpTest.out.tmp +mv src/BytedumpTest.out.tmp src/BytedumpTest.out +make[3]: Leaving directory 'bedrock2/bedrock2' +make[2]: Leaving directory 'bedrock2/bedrock2' +COQC bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI.v +COQC bedrock2/deps/riscv-coq/src/Proofs/EncodeBound.v +COQC bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run.v +COQC bedrock2/deps/riscv-coq/src/Platform/MinimalLogging.v +COQC bedrock2/deps/riscv-coq/src/Platform/MetricMinimal.v +COQC bedrock2/deps/riscv-coq/src/Platform/Example.v + = [({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; Sbedrock2/deps/riscv-coq/src/Platform/Example (real: 4.13, user: 1.62, sys: 0.27, mem: 468188 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver (real: 2.54, user: 0.94, sys: 0.29, mem: 450352 ko) +bedrock2/deps/riscv-coq/src/Platform/Example64Literal (real: 2.12, user: 0.76, sys: 0.28, mem: 409784 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64 (real: 55.42, user: 26.45, sys: 0.45, mem: 605916 ko) +bedrock2/deps/riscv-coq/src/Proofs/EncodeBound (real: 103.45, user: 50.15, sys: 0.41, mem: 573560 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64 (real: 53.82, user: 25.80, sys: 0.43, mem: 650288 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA (real: 60.04, user: 28.68, sys: 0.44, mem: 639092 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR (real: 215.18, user: 104.22, sys: 0.79, mem: 997556 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64 (real: 21.95, user: 9.77, sys: 0.34, mem: 523092 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM (real: 47.35, user: 22.60, sys: 0.37, mem: 589708 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI (real: 226.75, user: 139.56, sys: 1.26, mem: 1730872 ko) +bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode (real: 0.81, user: 0.42, sys: 0.18, mem: 374624 ko) +ortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 32 (IInstruction (Addi 9 9 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 28 (IInstruction (Addi 18 21 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 24 (IInstruction (Addi 20 18 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 20 (IInstruction (Add 21 20 18)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 36 (IInstruction (Blt 9 19 (-16))), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 16 (IInstruction (Jal 0 20)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 12 (IInstruction (Addi 9 0 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 8 (IInstruction (Addi 18 0 1)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 4 (IInstruction (Addi 20 0 0)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, [])); + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, + EvLoadWord 0 (IInstruction (Addi 19 0 6)), [], + ({| SortedList.value := []; SortedList._value_ok := eq_refl |}, []))] + : list (LogItem LogEvent) +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver.v +COQC bedrock2/deps/riscv-coq/src/Platform/Example64Literal.v + = {| unsigned := 1073745919; _unsigned_in_range := eq_refl |} + : word64 +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM.v +COQC bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode.v +make[3]: Leaving directory 'bedrock2/deps/riscv-coq' +make[2]: Leaving directory 'bedrock2/deps/riscv-coq' +make -C bedrock2/compiler +make -C bedrock2/deps/kami +make[2]: Entering directory 'bedrock2/compiler' +printf -- '-Q ../bedrock2/src bedrock2\n-Q bedrock2/deps/coqutil/src coqutil\n-Q bedrock2/deps/riscv-coq/src riscv\n-Q ./lib lib\n-Q ./src compiler\n' > _CoqProject +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = bedrock2 -arg "-async-proofs-tac-j 1" bedrock2/compiler/src/EmitsValid.v bedrock2/compiler/src/util/Misc.v bedrock2/compiler/src/util/Learning.v bedrock2/compiler/src/util/Tactics.v bedrock2/compiler/src/util/MyOmega.v bedrock2/compiler/src/util/ListLib.v bedrock2/compiler/src/util/Set.v bedrock2/compiler/src/util/SetSolverTests.v bedrock2/compiler/src/util/Common.v bedrock2/compiler/src/util/LogGoal.v bedrock2/compiler/src/SeparationLogic.v bedrock2/compiler/src/ExprImp.v bedrock2/compiler/src/FlatToRiscv32.v bedrock2/compiler/src/FlatToRiscv.v bedrock2/compiler/src/on_hyp_containing.v bedrock2/compiler/src/Basic32Semantics.v bedrock2/compiler/src/Simp.v bedrock2/compiler/src/FlatToRiscvDef.v bedrock2/compiler/src/RegAlloc3.v bedrock2/compiler/src/RegAllocAnnotatedNotations.v bedrock2/compiler/src/UnmappedMemForExtSpec.v bedrock2/compiler/src/RegAlloc2.v bedrock2/compiler/src/NoActionSyntaxParams.v bedrock2/compiler/src/Pipeline.v bedrock2/compiler/src/RiscvWordProperties.v bedrock2/compiler/src/GoFlatToRiscv.v bedrock2/compiler/src/Rem4.v bedrock2/compiler/src/SimplWordExpr.v bedrock2/compiler/src/ZNameGen.v bedrock2/compiler/src/NameGen.v bedrock2/compiler/src/FlatImp.v bedrock2/compiler/src/FlattenExpr.v bedrock2/compiler/src/eqexact.v bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump.v bedrock2/compiler/src/examples/TestExprImp.v bedrock2/compiler/src/examples/highlevel/FuncMut.v bedrock2/compiler/src/examples/highlevel/For.v bedrock2/compiler/src/examples/InlineAssemblyMacro.v bedrock2/compiler/src/examples/CompileExamples.v bedrock2/compiler/src/examples/toposort.v bedrock2/compiler/src/examples/FE310Compiler.v bedrock2/compiler/src/examples/EditDistExample.v bedrock2/compiler/src/examples/Fibonacci.v bedrock2/compiler/src/examples/TestFlatImp.v bedrock2/compiler/src/examples/MMIO.v bedrock2/compiler/lib/LibTacticsMin.v bedrock2/compiler/lib/fiat_crypto_tactics/Not.v bedrock2/compiler/lib/fiat_crypto_tactics/Test.v bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose.v bedrock2/compiler/lib/LibTactics.v -o Makefile.coq.all +make[2]: Entering directory 'bedrock2/deps/kami' +printf -- '-R Kami Kami\n-Q bedrock2/deps/Warning: ../bedrock2/src (used in -R or -Q) is not a subdirectory of the current directory + +Warning: bedrock2/deps/riscv-coq/src (used in -R or -Q) is not a subdirectory of the current directory + +Warning: no common logical root +Warning: in such case INSTALLDEFAULTROOT must be defined +Warning: the install-doc target is going to install files +Warning: in orphan_riscv_coqutil_Kami +bedrock2/compiler/lib/fiat_crypto_tactics/Test (real: 0.17, user: 0.04, sys: 0.04, mem: 55660 ko) +File "bedrock2/compiler/lib/LibTacticsMin.v", line 76, characters 0-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/lib/LibTacticsMin.v", line 121, characters 0-42: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope ltac_scope.". [undeclared-scope,deprecated] +File "bedrock2/compiler/lib/LibTacticsMin.v", line 463, characters 0-16: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/compiler/lib/LibTacticsMin (real: 0.92, user: 0.31, sys: 0.14, mem: 301996 ko) +bedrock2/compiler/src/NoActionSyntaxParams (real: 0.17, user: 0.04, sys: 0.03, mem: 57364 ko) +bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose (real: 0.16, user: 0.04, sys: 0.03, mem: 57340 ko) +File "./Kami/Lib/StringAsOT.v", line 86, characters 2-38: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/StringAsOT (real: 1.80, user: 0.70, sys: 0.19, mem: 423260 ko) +bedrock2/compiler/src/Simp (real: 1.02, user: 0.36, sys: 0.13, mem: 298624 ko) +bedrock2/compiler/src/util/Misc (real: 0.19, user: 0.05, sys: 0.04, mem: 70976 ko) +bedrock2/compiler/src/util/Learning (real: 0.16, user: 0.04, sys: 0.03, mem: 58420 ko) +File "./Kami/Lib/CommonTactics.v", line 276, characters 0-39: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/CommonTactics.v", line 277, characters 0-92: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/CommonTactics (real: 1.03, user: 0.38, sys: 0.13, mem: 319992 ko) +bedrock2/compiler/src/util/MyOmega (real: 0.97, user: 0.33, sys: 0.14, mem: 289700 ko) +bedrock2/compiler/src/util/LogGoal (real: 0.15, user: 0.03, sys: 0.03, mem: 54716 ko) +Kami/Lib/StringEq (real: 1.50, user: 0.55, sys: 0.18, mem: 413664 ko) +File "bedrock2/compiler/src/SeparationLogic.v", line 10, characters 0-29: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope sep_scope.". [undeclared-scope,deprecated] +bedrock2/compiler/src/SeparationLogic (real: 1.37, user: 0.48, sys: 0.16, mem: 352200 ko) +Kami/Lib/Nomega (real: 1.17, user: 0.38, sys: 0.19, mem: 363832 ko) +Kami/Lib/DepEq (real: 0.46, user: 0.14, sys: 0.08, mem: 160816 ko) +Kami/Lib/VectorFacts (real: 0.56, user: 0.17, sys: 0.09, mem: 180940 ko) +bedrock2/compiler/src/Rem4 (real: 1.86, user: 0.68, sys: 0.21, mem: 447424 ko) +bedrock2/compiler/src/SimplWordExpr (real: 1.85, user: 0.67, sys: 0.22, mem: 446424 ko) +Kami/Lib/StringAsList (real: 2.62, user: 1.08, sys: 0.20, mem: 421756 ko) +Kami/Lib/FinNotations (real: 0.43, user: 0.13, sys: 0.07, mem: 142092 ko) +bedrock2/compiler/src/RiscvWordProperties (real: 1.24, user: 0.43, sys: 0.18, mem: 362292 ko) +bedrock2/compiler/src/eqexact (real: 0.15, user: 0.04, sys: 0.03, mem: 56364 ko) +bedrock2/compiler/src/on_hyp_containing (real: 0.15, user: 0.04, sys: 0.03, mem: 56680 ko) +Kami/Lib/Reflection (real: 1.00, user: 0.34, sys: 0.15, mem: 328692 ko) +Kami/Lib/Concat (real: 1.06, user: 0.36, sys: 0.16, mem: 338456 ko) +bedrock2/compiler/src/Basic32Semantics (real: 1.46, user: 0.50, sys: 0.20, mem: 385968 ko) +riscv-coq/src riscv\n-Q bedrock2/deps/coqutil/src coqutil\n' > _CoqProject +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/compiler' +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject Kami/Lib/StringStringAsOT.v Kami/Lib/FMap.v Kami/Lib/ilist.v Kami/Lib/Indexer.v Kami/Lib/DepEq.v Kami/Lib/Nomega.v Kami/Lib/StringEq.v Kami/Lib/Misc.v Kami/Lib/Word.v Kami/Lib/FinNotations.v Kami/Lib/Reflection.v Kami/Lib/NatLib.v Kami/Lib/StringAsList.v Kami/Lib/Concat.v Kami/Lib/ListSupport.v Kami/Lib/VectorFacts.v Kami/Lib/StringAsOT.v Kami/Lib/CommonTactics.v Kami/Lib/WordSupport.v Kami/Lib/BasicLogic.v Kami/Lib/DepEqNat.v Kami/Lib/Struct.v Kami/SemFacts.v Kami/ParametricInlineLtac.v Kami/PartialInlineFacts.v Kami/Wf.v Kami/Semantics.v Kami/ParametricSyntax.v Kami/Inline.v Kami/StepDet.v Kami/InlineFacts.v Kami/Amortization.v Kami/Tutorial.v Kami/Label.v Kami/MapReifyEx.v Kami/ParametricEquiv.v Kami/ParametricInline.v Kami/Notations.v Kami/Substitute.v Kami/ParametricWf.v Kami/ParamDup.v Kami/SymEval.v Kami/Syntax.v Kami/ModuleBoundEx.v Kami/Tactics.v Kami/SymEvalTac.v Kami/ModularFacts.v Kami/Synthesize.v Kami/RefinementFacts.v Kami/Decomposition.v Kami/Renaming.v Kami/Kami.v Kami/Duplicate.v Kami/ModuleBound.v Kami/Specialize.v Kami/Ex/ProcThreeStage.v Kami/Ex/SimpleFifoCorrect.v Kami/Ex/IsaRv32PgmExt.v Kami/Ex/ProcThreeStInv.v Kami/Ex/Divider32.v Kami/Ex/SC.v Kami/Ex/Names.v Kami/Ex/OneEltFifo.v Kami/Ex/Multiplier64.v Kami/Ex/Multiplier32.v Kami/Ex/ProcFDInv.v Kami/Ex/ProcDec.v Kami/Ex/ProcFourStDec.v Kami/Ex/IsaRv32.v Kami/Ex/MemAtomic.v Kami/Ex/ProcFDInl.v Kami/Ex/IsaRv32Pgm.v Kami/Ex/Divider64.v Kami/Ex/Fifo.v Kami/Ex/ProcThreeStInl.v Kami/Ex/ProcDecSC.v Kami/Ex/ProcDecSCN.v Kami/Ex/NativeFifo.v Kami/Ex/FifoCorrect.v Kami/Ex/ProcThreeStDec.v Kami/Ex/RegFile.v Kami/Ex/InDepthTutorial.v Kami/Ex/ProcDecInv.v Kami/Ex/ProcFetchDecode.v Kami/Ex/SCMMInl.v Kami/Ex/ProcFDCorrect.v Kami/Ex/MemTypes.v Kami/Ex/ProcDecInl.v Kami/Ex/IsaRv32/PgmFact.v Kami/Ex/IsaRv32/PgmMatMulReport.v Kami/Ex/IsaRv32/PgmBankerWorker3.v Kami/Ex/IsaRv32/PgmGcd.v Kami/Ex/IsaRv32/PgmMatMulInit.v Kami/Ex/IsaRv32/PgmPeterson2.v Kami/Ex/IsaRv32/PgmHanoi.v Kami/Ex/IsaRv32/PgmBankerWorker1.v Kami/Ex/IsaRv32/PgmPeterson1.v Kami/Ex/IsaRv32/PgmBankerInit.v Kami/Ex/IsaRv32/PgmMatMulNormal1.v Kami/Ex/IsaRv32/PgmDekker1.v Kami/Ex/IsaRv32/PgmBankerWorker2.v Kami/Ex/IsaRv32/PgmBsort.v Kami/Ex/IsaRv32/PgmMatMulNormal2.v Kami/Ex/IsaRv32/PgmDekker2.v Kami/Ext/Extraction.v Kami/Ext/BSyntax.v -o Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/deps/kami' +COQDEP VFILES +COQDEP VFILES +COQC bedrock2/compiler/lib/fiat_crypto_tactics/Test.v +COQC bedrock2/compiler/lib/LibTacticsMin.v +COQC Kami/Lib/StringAsOT.v +COQC bedrock2/compiler/src/NoActionSyntaxParams.v +COQC bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose.v +COQC bedrock2/compiler/src/Simp.v +COQC Kami/Lib/CommonTactics.v +COQC bedrock2/compiler/src/util/Misc.v +COQC bedrock2/compiler/src/util/Learning.v +COQC bedrock2/compiler/src/util/MyOmega.v +COQC Kami/Lib/StringEq.v +COQC bedrock2/compiler/src/util/LogGoal.v +COQC bedrock2/compiler/src/SeparationLogic.v +COQC Kami/Lib/Nomega.v +COQC bedrock2/compiler/src/Rem4.v +COQC Kami/Lib/DepEq.v +COQC Kami/Lib/VectorFacts.v +COQC Kami/Lib/StringAsList.v +COQC bedrock2/compiler/src/SimplWordExpr.v +COQC bedrock2/compiler/src/RiscvWordProperties.v +COQC Kami/Lib/FinNotations.v +COQC Kami/Lib/Reflection.v +COQC bedrock2/compiler/src/eqexact.v +COQC bedrock2/compiler/src/on_hyp_containing.v +COQC bedrock2/compiler/src/Basic32Semantics.v +COQC Kami/Lib/Concat.v +COQC Kami/LKami/Lib/ListSupport (real: 1.09, user: 0.37, sys: 0.15, mem: 353524 ko) +File "bedrock2/compiler/src/UnmappedMemForExtSpec.v", line 45, characters 2-49: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/src/UnmappedMemForExtSpec.v", line 47, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/BasicLogic (real: 0.24, user: 0.07, sys: 0.03, mem: 87856 ko) +Kami/Lib/DepEqNat (real: 0.22, user: 0.06, sys: 0.03, mem: 76484 ko) +bedrock2/compiler/src/UnmappedMemForExtSpec (real: 1.68, user: 0.61, sys: 0.21, mem: 446012 ko) +Kami/Ex/Names (real: 1.02, user: 0.36, sys: 0.13, mem: 271052 ko) +bedrock2/compiler/src/NameGen (real: 0.95, user: 0.32, sys: 0.15, mem: 286108 ko) +bedrock2/compiler/src/examples/highlevel/For (real: 0.15, user: 0.04, sys: 0.02, mem: 55764 ko) +Kami/Lib/StringStringAsOT (real: 1.73, user: 0.63, sys: 0.19, mem: 420276 ko) +bedrock2/compiler/src/examples/toposort (real: 2.47, user: 0.98, sys: 0.21, mem: 426872 ko) +File "bedrock2/compiler/lib/LibTactics.v", line 55, characters 0-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/lib/LibTactics.v", line 100, characters 0-42: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope ltac_scope.". [undeclared-scope,deprecated] +File "bedrock2/compiler/lib/LibTactics.v", line 581, characters 0-16: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/lib/LibTactics.v", line 4771, characters 0-28: +Warning: skip_axiom is declared as a local axiom [local-declaration,scope] +File "bedrock2/compiler/lib/LibTactics.v", line 4998, characters 0-196: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope let_scope.". [undeclared-scope,deprecated] +Kami/Lib/NatLib (real: 3.58, user: 1.52, sys: 0.22, mem: 429812 ko) +bedrock2/compiler/lib/LibTactics (real: 2.73, user: 1.10, sys: 0.23, mem: 419492 ko) +bedrock2/compiler/lib/fiat_crypto_tactics/Not (real: 0.17, user: 0.05, sys: 0.03, mem: 56680 ko) +bedrock2/compiler/src/util/Tactics (real: 1.16, user: 0.40, sys: 0.17, mem: 282384 ko) +Kami/Lib/ilist (real: 2.17, user: 0.82, sys: 0.23, mem: 422368 ko) +bedrock2/compiler/src/util/Common (real: 1.69, user: 0.59, sys: 0.22, mem: 371952 ko) +Kami/Lib/Indexer (real: 2.29, user: 0.90, sys: 0.21, mem: 421100 ko) +bedrock2/compiler/src/util/ListLib (real: 2.24, user: 0.88, sys: 0.22, mem: 427540 ko) +Kami/Lib/Misc (real: 1.05, user: 0.35, sys: 0.16, mem: 299684 ko) +bedrock2/compiler/src/util/Set (real: 0.96, user: 0.30, sys: 0.14, mem: 282580 ko) +File "./Kami/Lib/Word.v", line 19, characters 0-35: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope word_scope.". [undeclared-scope,deprecated] +File "./Kami/Lib/Word.v", line 147, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/Word.v", line 400, characters 0-45: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/Word.v", line 1090, characters 0-43: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/Word.v", line 1217, characters 0-42: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 407, characters 4-639: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 464, characters 4-57: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 464, characters 4-57: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 491, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 491, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 491, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 533, characters 4-108: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 533, characters 4-108: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/ExprImp.v", line 533, characters 4-108: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +ib/ListSupport.v +COQC bedrock2/compiler/src/UnmappedMemForExtSpec.v +COQC Kami/Lib/BasicLogic.v +COQC Kami/Lib/DepEqNat.v +COQC Kami/Ex/Names.v +COQC bedrock2/compiler/src/NameGen.v +COQC Kami/Lib/StringStringAsOT.v +COQC bedrock2/compiler/src/examples/highlevel/For.v +COQC bedrock2/compiler/src/examples/toposort.v +COQC Kami/Lib/NatLib.v +COQC bedrock2/compiler/lib/LibTactics.v +COQC Kami/Lib/ilist.v +COQC bedrock2/compiler/lib/fiat_crypto_tactics/Not.v +COQC bedrock2/compiler/src/util/Tactics.v +COQC bedrock2/compiler/src/util/Common.v +COQC Kami/Lib/Indexer.v +COQC bedrock2/compiler/src/util/ListLib.v +COQC Kami/Lib/Misc.v +COQC bedrock2/compiler/src/util/Set.v +COQC Kami/Lib/Word.v +COQC bedrock2/compiler/src/ExprImp.v +End of ExprImp.v +total time: 8.389s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 49.5% 44 0.222s +─preprocess_impl ----------------------- 0.7% 39.2% 44 0.177s +─abstract_unrecogs --------------------- 16.3% 34.8% 44 0.161s +─set_solver_generic -------------------- 0.2% 15.1% 30 0.405s +─<Coq.Init.Tauto.with_uniform_flags> --- 0.0% 14.9% 34 0.400s +─t_tauto_intuit ------------------------ 3.0% 14.9% 93 0.400s +─remember_unrecogs --------------------- 3.1% 12.3% 548 0.016s +─<Coq.Init.Tauto.simplif> -------------- 9.4% 12.1% 93 0.334s +─map_solver_core ----------------------- 0.5% 10.2% 29 0.085s +─map_solver_core_impl ------------------ 0.3% 9.6% 2 0.084s +─inversion H --------------------------- 9.4% 9.4% 74 0.061s +─inversion_lemma ----------------------- 0.1% 6.2% 9 0.217s +─inversionss --------------------------- 0.1% 6.0% 10 0.226s +─inverts (var) ------------------------- 0.1% 5.9% 63 0.030s +─inverts_tactic ------------------------ 0.2% 5.8% 63 0.030s +─unrecogs_in_prop ---------------------- 5.7% 5.7% 0 0.027s +─map_specialize ------------------------ 0.0% 5.1% 29 0.041s +─map_specialize_step ------------------- 3.7% 5.1% 35 0.036s +─congruence ---------------------------- 4.5% 4.5% 117 0.027s +─invert keep (var) --------------------- 0.1% 4.5% 63 0.028s +─remember P as name eqn:a -------------- 4.5% 4.5% 197 0.012s +─eauto (int_or_var_opt) (int_or_var_opt) 4.3% 4.5% 53 0.055s +─apply mk_Abstracted in a -------------- 3.8% 3.8% 264 0.002s +─replace (uconstr) with (constr) (clause 0.8% 3.6% 21 0.032s +─econstructor -------------------------- 2.8% 2.8% 49 0.010s +─maps_propositional -------------------- 0.1% 2.8% 45 0.043s +─pose proof IH as IH' ------------------ 2.6% 2.6% 3724 0.006s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─map_solver ---------------------------- 0.0% 49.5% 44 0.222s + ├─preprocess_impl --------------------- 0.7% 39.2% 44 0.177s + │└abstract_unrecogs ------------------- 16.3% 34.8% 44 0.161s + │ ├─remember_unrecogs ----------------- 3.1% 12.3% 548 0.016s + │ │ ├─remember P as name eqn:a -------- 4.5% 4.5% 197 0.012s + │ │ └─apply mk_Abstracted in a -------- bedrock2/compiler/src/ExprImp (real: 23.40, user: 10.90, sys: 0.52, mem: 540624 ko) +bedrock2/compiler/src/ZNameGen (real: 1.33, user: 0.46, sys: 0.18, mem: 351756 ko) +bedrock2/compiler/src/examples/TestExprImp (real: 2.02, user: 0.72, sys: 0.26, mem: 458732 ko) +bedrock2/compiler/src/examples/highlevel/FuncMut (real: 1.61, user: 0.55, sys: 0.23, mem: 420416 ko) +File "bedrock2/compiler/src/FlatImp.v", line 418, characters 6-59: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "./Kami/Lib/Word.v", line 2154, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/Word (real: 55.47, user: 26.60, sys: 0.45, mem: 741048 ko) +File "./Kami/Lib/Struct.v", line 151, characters 0-57: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/Struct (real: 2.57, user: 0.99, sys: 0.21, mem: 435576 ko) +File "bedrock2/compiler/src/FlatImp.v", line 474, characters 6-210: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/FlatImp.v", line 474, characters 6-210: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/FlatImp.v", line 474, characters 6-210: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +Kami/Lib/WordSupport (real: 1.56, user: 0.56, sys: 0.20, mem: 432120 ko) +File "./Kami/Lib/FMap.v", line 563, characters 2-19: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 567, characters 2-51: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 595, characters 2-43: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 618, characters 2-44: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 626, characters 2-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 876, characters 2-45: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 913, characters 2-46: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 1328, characters 2-43: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 1475, characters 2-45: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 2482, characters 0-44: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope fmap_scope.". [undeclared-scope,deprecated] +File "./Kami/Lib/FMap.v", line 2681, characters 0-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Lib/FMap.v", line 2682, characters 0-48: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Lib/FMap (real: 20.44, user: 9.56, sys: 0.30, mem: 537308 ko) +File "bedrock2/compiler/src/FlatImp.v", line 624, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "bedrock2/compiler/src/FlatImp.v", line 624, characters 4-95: +Warning: Ltac Profiler cannot yet handle backtracking into multi-success +tactics; profiling results may be wildly inaccurate. +[profile-backtracking,ltac] +File "./Kami/Syntax.v", line 1139, characters 2-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Syntax.v", line 1309, characters 0-121: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Syntax.v", line 1315, characters 0-84: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_struct_scope.". [undeclared-scope,deprecated] +File "./Kami/Syntax.v", line 1317, characters 0-54: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_scope.". [undeclared-scope,deprecated] +Kami/Syntax (real: 4.38, user: 1.89, sys: 0.23, mem: 479116 ko) +3.8% 3.8% 264 0.002s + │ └─unrecogs_in_prop ------------------ 5.7% 5.7% 0 0.027s + └─map_solver_core --------------------- 0.5% 10.2% 29 0.085s + â””map_solver_core_impl ---------------- 0.3% 9.6% 2 0.084s + ├─map_specialize -------------------- 0.0% 5.1% 29 0.041s + │└map_specialize_step --------------- 3.7% 5.1% 35 0.036s + └─maps_propositional ---------------- 0.1% 2.8% 45 0.043s +─set_solver_generic -------------------- 0.2% 15.1% 30 0.405s +â””<Coq.Init.Tauto.with_uniform_flags> --- 0.0% 14.0% 30 0.400s +â””t_tauto_intuit ------------------------ 3.0% 14.0% 89 0.400s +â””<Coq.Init.Tauto.simplif> -------------- 8.8% 11.3% 89 0.334s +─inversion_lemma ----------------------- 0.1% 6.2% 9 0.217s +â””inversionss --------------------------- 0.0% 3.3% 9 0.084s +â””inverts (var) ------------------------- 0.0% 3.2% 32 0.020s +â””inverts_tactic ------------------------ 0.1% 3.2% 32 0.020s +â””invert keep (var) --------------------- 0.0% 2.5% 32 0.018s +─inversion H --------------------------- 6.0% 6.0% 11 0.061s +─replace (uconstr) with (constr) (clause 0.8% 3.6% 21 0.032s +â””congruence ---------------------------- 2.8% 2.8% 21 0.027s +─eauto (int_or_var_opt) (int_or_var_opt) 3.2% 3.3% 44 0.023s +─econstructor -------------------------- 2.8% 2.8% 49 0.010s +─inversionss --------------------------- 0.1% 2.7% 1 0.226s +â””inverts (var) ------------------------- 0.0% 2.6% 31 0.030s +â””inverts_tactic ------------------------ 0.1% 2.6% 31 0.030s +â””invert keep (var) --------------------- 0.0% 2.0% 31 0.028s +─pose proof IH as IH' ------------------ 2.6% 2.6% 3724 0.006s + +COQC bedrock2/compiler/src/ZNameGen.v +COQC bedrock2/compiler/src/examples/TestExprImp.v +COQC bedrock2/compiler/src/examples/highlevel/FuncMut.v +COQC bedrock2/compiler/src/FlatImp.v +COQC Kami/Lib/Struct.v +COQC Kami/Lib/WordSupport.v +COQC Kami/Lib/FMap.v +COQC Kami/Syntax.v +COQC Kami/Semantics.v +End of FlatImp.v +total time: 26.926s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─simp ---------------------------------- 0.0% 71.8% 97 2.046s +─simp_step ----------------------------- 0.1% 71.8% 209 0.530s +─unique_inversion ---------------------- 71.4% 71.4% 3388 0.529s +─inversion H --------------------------- 66.5% 66.5% 686 0.199s +─equalities ---------------------------- 0.3% 57.3% 3 10.539s +─map_solver ---------------------------- 0.0% 11.2% 30 0.277s +─preprocess_impl ----------------------- 0.2% 8.1% 30 0.215s +─abstract_unrecogs --------------------- 2.9% 7.0% 30 0.198s +─protect_equalities -------------------- 2.0% 3.8% 593 0.011s +─congruence ---------------------------- 3.6% 3.6% 187 0.043s +─map_solver_core ----------------------- 0.1% 3.1% 25 0.077s +─map_solver_core_impl ------------------ 0.1% 3.0% 2 0.076s +─pose proof IH as IH' ------------------ 2.5% 2.5% 11247 0.004s +─remember_unrecogs --------------------- 0.6% 2.5% 303 0.016s +─inversion_lemma ----------------------- 0.0% 2.3% 11 0.208s +─inversionss --------------------------- 0.0% 2.2% 12 0.246s +─inverts (var) ------------------------- 0.0% 2.2% 81 0.023s +─inverts_tactic ------------------------ 0.1% 2.1% 81 0.023s +─assert (H : e1 = e2) by congruence ---- 0.1% 2.1% 80 0.026s + + tactic bedrock2/compiler/src/FlatImp (real: 62.83, user: 30.21, sys: 0.60, mem: 608088 ko) +bedrock2/compiler/src/util/SetSolverTests (real: 1.00, user: 0.30, sys: 0.15, mem: 290132 ko) +bedrock2/compiler/src/RegAlloc2 (real: 1.61, user: 0.53, sys: 0.21, mem: 386872 ko) +File "./Kami/Semantics.v", line 947, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Semantics (real: 13.71, user: 6.50, sys: 0.26, mem: 501300 ko) +Kami/Inline (real: 1.93, user: 0.70, sys: 0.23, mem: 469696 ko) +Kami/SymEval (real: 3.58, user: 1.48, sys: 0.24, mem: 476176 ko) +File "./Kami/Wf.v", line 16, characters 2-22: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Wf (real: 6.87, user: 3.06, sys: 0.29, mem: 499932 ko) +File "./Kami/SemFacts.v", line 1666, characters 0-20: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/SemFacts (real: 76.97, user: 37.08, sys: 0.39, mem: 601836 ko) +File "./Kami/ModularFacts.v", line 42, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/ModularFacts (real: 68.49, user: 32.76, sys: 0.55, mem: 885880 ko) +Kami/StepDet (real: 19.67, user: 9.26, sys: 0.28, mem: 504428 ko) +Kami/Label (real: 7.13, user: 3.17, sys: 0.27, mem: 486656 ko) +Kami/RefinementFacts (real: 18.99, user: 8.98, sys: 0.27, mem: 511956 ko) +Kami/InlineFacts (real: 83.55, user: 40.29, sys: 0.46, mem: 668564 ko) +File "./Kami/Renaming.v", line 16, characters 0-25: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Renaming.v", line 185, characters 2-44: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Renaming.v", line 203, characters 2-58: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Renaming (real: 81.06, user: 39.12, sys: 0.38, mem: 563328 ko) +Kami/Substitute (real: 2.10, user: 0.72, sys: 0.26, mem: 473852 ko) +Kami/Decomposition (real: 11.95, user: 5.56, sys: 0.26, mem: 507520 ko) +Kami/Amortization (real: 11.22, user: 5.12, sys: 0.29, mem: 505436 ko) +Kami/SymEvalTac (real: 1.93, user: 0.67, sys: 0.23, mem: 474056 ko) +Kami/PartialInlineFacts (real: 13.41, user: 6.24, sys: 0.29, mem: 509232 ko) +Kami/ParametricSyntax (real: 31.00, user: 14.78, sys: 0.34, mem: 561068 ko) +File "./Kami/Specialize.v", line 858, characters 2-44: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Specialize.v", line 1194, characters 0-130: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Specialize (real: 45.09, user: 21.68, sys: 0.30, mem: 506640 ko) +Kami/ParametricWf (real: 5.32, user: 2.19, sys: 0.29, mem: 489072 ko) +File "./Kami/ParametricEquiv.v", line 10, characters 2-22: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/ParametricEquiv (real: 6.90, user: 3.10, sys: 0.28, mem: 492424 ko) +File "./Kami/Notations.v", line 28, characters 0-81: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_expr_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 89, characters 0-169: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope init_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 110, characters 0-190: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_action_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 263, characters 0-212: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_sin_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 404, characters 0-247: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_gen_scope.". [undeclared-scope,deprecated] +File "./Kami/Notations.v", line 663, characters 0-260: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope kami_meta_scope.". [undeclared-scope,deprecated] +Kami/Notations (real: 2.42, user: 0.87, sys: 0.28, mem: 460284 ko) +Kami/Duplicate (real: 5.46, user: 2.39, sys: 0.28, mem: 487424 ko) +Kami/Synthesize (real: 1.72, user: 0.59, sys: 0.24, mem: 442252 ko) +Kami/Ex/MemTypes (real: 1.99, user: 0.71, sys: 0.23, mem: 452980 ko) +Kami/Ext/BSyntax (real: 2.19, user: 0.79, sys: 0.27, mem: 477872 ko) +Kami/ParametricInline (real: 9.22, user: 4.19, sys: 0.30, mem: 509168 ko) +Kami/ModuleBound (real: 3.21, user: 1.29, sys: 0.27, mem: 485936 ko) +File "./Kami/ModuleBoundEx.v", line 25, characters 2-71: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope namebound_scope.". [undeclared-scope,deprecated] +File "./Kami/ModuleBoundEx.v", line 332, characters 2-71: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope namebound_scope.". [undeclared-scope,deprecated] +Kami/ModuleBoundEx (real: 7.16, user: 3.17, sys: 0.30, mem: 492768 ko) +Kami/ParamDup (real: 5.47, user: 2.42, sys: 0.25, mem: 489812 ko) +File "./Kami/Tactics.v", line 923, characters 0-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Tactics.v", line 924, characters 0-77: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Tactics.v", line 984, characters 0-543: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope mapping_scope.". [undeclared-scope,deprecated] +Kami/Tactics (real: 2.58, user: 0.89, sys: 0.26, mem: 484828 ko) +Kami/ParametricInlineLtac (real: 2.11, user: 0.77, sys: 0.26, mem: 486708 ko) +Kami/MapReifyEx (real: 4.56, user: 1.94, sys: 0.29, mem: 494008 ko) +File "./Kami/Ex/SC.v", line 432, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/SC.v", line 441, characters 2-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/SC.v", line 460, characters 0-72: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/SC (real: 8.37, user: 3.81, sys: 0.27, mem: 510132 ko) +File "./Kami/Ex/OneEltFifo.v", line 85, characters 0-50: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/OneEltFifo.v", line 86, characters 0-56: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/OneEltFifo.v", line 87, characters 0-56: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/OneEltFifo (real: 2.92, user: 1.15, sys: 0.26, mem: 487776 ko) +File "./Kami/Ex/Fifo.v", line 197, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 202, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 207, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 212, characters 2-36: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 266, characters 0-167: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/Fifo.v", line 270, characters 0-175: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/Fifo (real: 16.06, user: 7.55, sys: 0.28, mem: 534616 ko) +File "./Kami/Ex/NativeFifo.v", line 174, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 181, characters 2-41: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 188, characters 2-36: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 195, characters 2-42: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 273, characters 0-215: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/NativeFifo.v", line 277, characters 0-223: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/NativeFifo (real: 4.03, user: 1.70, sys: 0.27, mem: 490720 ko) +File "./Kami/Ex/IsaRv32.v", line 88, characters 0-79: +Warning: Notation "$ _" was already used in scope kami_expr_scope. +[notation-overridden,parsing] +Kami/Ex/IsaRv32 (real: 3.31, user: 1.30, sys: 0.26, mem: 509008 ko) +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiXq cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiXq cannot be defined because the projection ndiXq was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiX cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: HndiX cannot be defined because the projection ndiX was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiD cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: HndiD cannot be defined because the projection ndiD was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiDp cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDp cannot be defined because the projection ndiDp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiDn cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDn cannot be defined because the projection ndiDn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +ndiCnt cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiCnt cannot be defined because the projection ndiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDdp cannot be defined because the projections ndiDp, ndiD were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiDdn cannot be defined because the projections ndiDn, ndiDp were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider32.v", line 1058, characters 2-1168: +Warning: +HndiInv cannot be defined because the projections ndiD, ndiCnt, ndiXq, ndiX, +ndiD were not defined. [cannot-define-projection,records] +Kami/Ex/Divider32 (real: 125.49, user: 60.73, sys: 0.58, mem: 847228 ko) +File "./Kami/Ex/Multiplier64.v", line 399, characters 2-24: +Warning: Use of “Require†inside a section is deprecated. +[require-in-section,deprecated] +File "./Kami/Ex/Multiplier64.v", line 431, characters 4-143: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bword_scope.". [undeclared-scope,deprecated] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiM cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HbsiM cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiR cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HbsiR cannot be defined because the projection bsiR was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiMp cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMp cannot be defined because the projection bsiMp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiMn cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMn cannot be defined because the projection bsiMn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiP cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HbsiP cannot be defined because the projection bsiP was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +bsiCnt cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiCnt cannot be defined because the projection bsiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMmp cannot be defined because the projections bsiMp, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiMmn cannot be defined because the projections bsiMn, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: HmInv cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier64.v", line 1125, characters 2-1192: +Warning: +HbsiInv cannot be defined because the projections bsiCnt, bsiP, bsiM, bsiR +were not defined. [cannot-define-projection,records] +Kami/Ex/Multiplier64 (real: 430.88, user: 206.96, sys: 1.70, mem: 1980772 ko) +File "./Kami/Ex/Multiplier32.v", line 399, characters 2-24: +Warning: Use of “Require†inside a section is deprecated. +[require-in-section,deprecated] +File "./Kami/Ex/Multiplier32.v", line 431, characters 4-143: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope bword_scope.". [undeclared-scope,deprecated] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiM cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HbsiM cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiR cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HbsiR cannot be defined because the projection bsiR was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiMp cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMp cannot be defined because the projection bsiMp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiMn cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMn cannot be defined because the projection bsiMn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiP cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HbsiP cannot be defined because the projection bsiP was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +bsiCnt cannot be defined because it is informative and BoothMultiplierInv is +not. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiCnt cannot be defined because the projection bsiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMmp cannot be defined because the projections bsiMp, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiMmn cannot be defined because the projections bsiMn, bsiM were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: HmInv cannot be defined because the projection bsiM was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Multiplier32.v", line 1125, characters 2-1192: +Warning: +HbsiInv cannot be defined because the projections bsiCnt, bsiP, bsiM, bsiR +were not defined. [cannot-define-projection,records] + local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─equalities ---------------------------- 0.3% 57.3% 3 10.539s + ├─simp -------------------------------- 0.0% 54.9% 77 2.046s + │└simp_step --------------------------- 0.0% 54.9% 160 0.530s + │└unique_inversion -------------------- 54.6% 54.6% 2632 0.529s + │ ├─inversion H ----------------------- 47.8% 47.8% 454 0.170s + │ └─protect_equalities ---------------- 1.7% 3.3% 454 0.010s + └─assert (H : e1 = e2) by congruence -- 0.1% 2.1% 80 0.026s + â””congruence -------------------------- 2.0% 2.0% 80 0.025s +─simp ---------------------------------- 0.0% 17.0% 20 0.417s +â””simp_step ----------------------------- 0.0% 17.0% 49 0.396s +â””unique_inversion ---------------------- 16.8% 16.8% 756 0.395s +â””inversion H --------------------------- 15.4% 15.4% 139 0.199s +─map_solver ---------------------------- 0.0% 11.2% 30 0.277s + ├─preprocess_impl --------------------- 0.2% 8.1% 30 0.215s + │└abstract_unrecogs ------------------- 2.9% 7.0% 30 0.198s + │└remember_unrecogs ------------------- 0.6% 2.5% 303 0.016s + └─map_solver_core --------------------- 0.1% 3.1% 25 0.077s + â””map_solver_core_impl ---------------- 0.1% 3.0% 2 0.076s +─pose proof IH as IH' ------------------ 2.5% 2.5% 11247 0.004s +─inversion_lemma ----------------------- 0.0% 2.3% 11 0.208s + +COQC bedrock2/compiler/src/util/SetSolverTests.v +COQC bedrock2/compiler/src/RegAlloc2.v +COQC bedrock2/compiler/src/FlattenExpr.v +COQC Kami/Inline.v +COQC Kami/SymEval.v +COQC Kami/Wf.v +COQC Kami/SemFacts.v +COQC Kami/ModularFacts.v +COQC Kami/StepDet.v +COQC Kami/Label.v +COQC Kami/RefinementFacts.v +COQC Kami/InlineFacts.v +COQC Kami/Renaming.v +COQC Kami/Substitute.v +COQC Kami/Decomposition.v +COQC Kami/Amortization.v +COQC Kami/SymEvalTac.v +COQC Kami/PartialInlineFacts.v +COQC Kami/ParametricSyntax.v +COQC Kami/Specialize.v +COQC Kami/ParametricWf.v +COQC Kami/ParametricEquiv.v +COQC Kami/Notations.v +COQC Kami/Duplicate.v +COQC Kami/Synthesize.v +COQC Kami/Ex/MemTypes.v +COQC Kami/Ext/BSyntax.v +COQC Kami/ParametricInline.v +COQC Kami/ModuleBound.v +COQC Kami/ModuleBoundEx.v +COQC Kami/ParamDup.v +COQC Kami/Tactics.v +COQC Kami/ParametricInlineLtac.v +COQC Kami/MapReifyEx.v +COQC Kami/Ex/SC.v +COQC Kami/Ex/OneEltFifo.v +COQC Kami/Ex/Fifo.v +COQC Kami/Ex/NativeFifo.v +COQC Kami/Ex/IsaRv32.v +COQC Kami/Ex/Divider32.v +COQC Kami/Ex/Multiplier64.v +COQC Kami/Ex/Multiplier32.v +End of FlattenExpr.v +total time: 587.422s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─maps ---------------------------------- 0.0% 88.3% 84 17.968s +─map_solver ---------------------------- 0.0% 54.8% 95 9.899s +─map_solver_core ----------------------- 0.1% 42.7% 92 9.552s +─map_solver_core_impl ------------------ 0.0% 42.6% 13 9.549s +─default_flattenBooleanExpr ------------ 0.0% 37.3% 21 36.430s +─map_specialize ------------------------ 0.0% 36.3% 92 7.801s +─map_specialize_step ------------------- 24.9% 36.3% 1911 5.056s +─pose_flatten_var_ineqs ---------------- 4.0% 34.0% 86 10.352s +─unique eapply (constr) in copy of (iden 1.0% 30.1% 59814 0.049s +─unshelve (tactic1) -------------------- 0.7% 26.8% 59814 0.048s +─eapply p in H' ------------------------ 26.2% 26.2% 59814 0.048s +─preprocess_impl ----------------------- 0.0% 12.1% 95 2.152s +─abstract_unrecogs --------------------- 7.0% 11.1% 95 2.057s +─simp ---------------------------------- 0.0% 6.3% 78 3.196s +─simp_step ----------------------------- 0.0% 6.3% 644 1.145s +─maps_propositional -------------------- 0.0% 6.0% 480 7.295s +─unique_inversion ---------------------- 3.9% 3.9% 5338 1.144s +─maps_leaf_tac ------------------------- 0.1% 3.5% 2100 0.035s +─inversion H --------------------------- 3.4% 3.4% 1097 1.070s +─congruence ---------------------------- 3.2% 3.2% 2495 0.085s +─pose proof H as H' -------------------- 3.1% 3.1% 185783 0.026s +─canonicalize_map_hyp ------------------ 0.6% 2.9% 37401 0.022s +─specialize (constr_with_bindings) ----- 2.5% 2.5% 166250 0.022s +─destruct_unique_match ----------------- 2.4% 2.4% 821 0.389s +─remember_unrecogs --------------------- 0.9% 2.4% 2727 0.644s +─ensure_no_body ------------------------ 1.0% 2.3% 161949 0.015s +─propositional_cheap_step -------------- 2.2% 2.3% 3800 0.016s +─auto (int_or_var_opt) (auto_using) (hin 1.8% 2.1% 3290 0.023s +─assert_fails -------------------------- 0.6% 2.0% 196767 0.023s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─maps ---------------------------------- 0.0% 52.5% 53 17.968s + ├─map_solver -------------------------- 0.0% 30.3% 64 9.899s + │ ├─map_solver_core ------------------- 0.0% 22.4% 64 9.552s + │ │└map_solver_core_impl -------------- 0.0% 22.4% 1 9.549s + │ │ ├─map_specialize ------------------ 0.0% 17.8% 64 5.088s + │ │ │└map_specialize_step ------------- 12.7% 17.8% 1057 4.472s + │ │ └─maps_propositional -------------- 0.0% 4.4% 350 7.295s + │ │ â””maps_leaf_tac ------------------- 0.0% 2.5% 1634 0.025s + │ └─preprocess_impl ------------------- 0.0% 7.9% 64 2.152s + │ â””abstract_unrecogs ----------------- 4.6% 7.3% 64 2.057s + └─pose_flatten_var_ineqs -------------- 2.5% 22.1% 53 10.352s + â””unique eapply (constr) in copy of (id 0.6% 19.7% 36953 0.049s + â””unshelve (tactic1) ------------------ 0.4% 17.8% 36953 0.048s + â””eapply p in H' ---------------------- 17.4% 17.4% 36953 0.048s +─default_flattenBooleanExpr ------------ 0.0% 37.3% 21 36.430s + ├─maps -------------------------------- 0.0% 35.0% 30 12.207s + │ ├─map_solver ------------------------ 0.0% 24.0% 30 9.184s + │ │ ├─map_solver_core ----------------- 0.0% 20.1% 27 7.870s + │ │ │└map_solver_core_impl ------------ 0.0% 20.1% 12 7.859s + │ │ │└map_specialize ------------------ 0.0% 18.3% 27 7.801s + │ │ │└map_specialize_step ------------- 12.1% 18.3% 845 5.056s + │ │ └─preprocess_impl ----------------- 0.0% 3.9% 30 1.349s + │ │ â””abstract_unrecogs --------------- 2.3% 3.6% 30 1.238s + │ └─pose_flatten_var_ineqs ------------ 1.4% 11.0% 30 3.250s + │ â””unique eapply (constr) in copy of ( 0.4% 9.6% 21011 0.027s + │ â””unshelve (tactic1) ---------------- 0.2% 8.3% 21011 0.027s + │ â””eapply p in H' -------------------- 8.1% 8.1% 21011 0.027s + └─simp -------------------------------- 0.0% 2.2% 21 1.839s + â””simp_step --------------------------- 0.0% 2.1% 243 0.174s +─simp ---------------------------------- 0.0% 4.2% 57 3.196s +â””simp_step ----------------------------- 0.0% 4.2% 401 1.145s +â””unique_inversion --------bedrock2/compiler/src/FlattenExpr (real: 1225.77, user: 593.01, sys: 9.58, mem: 1060368 ko) +bedrock2/compiler/src/examples/TestFlatImp (real: 4.39, user: 0.71, sys: 0.28, mem: 459820 ko) +bedrock2/compiler/src/FlatToRiscvDef (real: 2.44, user: 0.69, sys: 0.24, mem: 466532 ko) +bedrock2/compiler/src/RegAlloc3 (real: 1.44, user: 0.50, sys: 0.18, mem: 389304 ko) +bedrock2/compiler/src/EmitsValid (real: 49.36, user: 23.66, sys: 0.35, mem: 610544 ko) +bedrock2/compiler/src/RegAllocAnnotatedNotations (real: 1.73, user: 0.45, sys: 0.18, mem: 350576 ko) +bedrock2/compiler/src/GoFlatToRiscv (real: 15.43, user: 6.89, sys: 0.27, mem: 480324 ko) +bedrock2/compiler/src/FlatToRiscv32 (real: 17.62, user: 8.26, sys: 0.29, mem: 505664 ko) +Kami/Ex/Multiplier32 (real: 214.00, user: 104.11, sys: 0.86, mem: 1131272 ko) +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiXq cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiXq cannot be defined because the projection ndiXq was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiX cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: HndiX cannot be defined because the projection ndiX was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiD cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: HndiD cannot be defined because the projection ndiD was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiDp cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDp cannot be defined because the projection ndiDp was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiDn cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDn cannot be defined because the projection ndiDn was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +ndiCnt cannot be defined because it is informative and NrDividerInv is not. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiCnt cannot be defined because the projection ndiCnt was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDdp cannot be defined because the projections ndiDp, ndiD were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiDdn cannot be defined because the projections ndiDn, ndiDp were not +defined. [cannot-define-projection,records] +File "./Kami/Ex/Divider64.v", line 1058, characters 2-1168: +Warning: +HndiInv cannot be defined because the projections ndiD, ndiCnt, ndiXq, ndiX, +ndiD were not defined. [cannot-define-projection,records] +Kami/Ex/Divider64 (real: 271.33, user: 131.59, sys: 1.01, mem: 1411224 ko) +bedrock2/compiler/src/FlatToRiscv (real: 415.73, user: 202.44, sys: 0.75, mem: 899104 ko) +bedrock2/compiler/src/Pipeline (real: 5.85, user: 2.50, sys: 0.27, mem: 505076 ko) +Kami/Ex/FifoCorrect (real: 125.57, user: 61.07, sys: 0.56, mem: 798376 ko) +File "./Kami/Ex/RegFile.v", line 132, characters 0-66: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/RegFile.v", line 133, characters 0-69: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/RegFile (real: 4.25, user: 1.81, sys: 0.24, mem: 495792 ko) +Kami/Ex/SCMMInl (real: 11.10, user: 5.07, sys: 0.30, mem: 561800 ko) +Kami/Kami (real: 2.25, user: 0.74, sys: 0.24, mem: 485920 ko) +File "./Kami/Ex/MemAtomic.v", line 121, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +bedrock2/compiler/src/examples/MMIO (real: 32.79, user: 15.63, sys: 0.31, mem: 555732 ko) +File "./Kami/Ex/MemAtomic.v", line 128, characters 2-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/MemAtomic.v", line 137, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/MemAtomic.v", line 144, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/MemAtomic.v", line 166, characters 0-146: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/MemAtomic (real: 3.50, user: 1.47, sys: 0.24, mem: 497260 ko) +bedrock2/compiler/src/examples/InlineAssemblyMacro (real: 1.97, user: 0.71, sys: 0.26, mem: 483356 ko) +bedrock2/compiler/src/examples/CompileExamples (real: 2.52, user: 0.74, sys: 0.21, mem: 501084 ko) +bedrock2/compiler/src/examples/Fibonacci (real: 7.21, user: 3.30, sys: 0.23, mem: 510956 ko) +-------------- 3.2% 3.2% 3570 1.144s +â””inversion H --------------------------- 2.7% 2.7% 626 1.070s + +COQC bedrock2/compiler/src/examples/TestFlatImp.v +COQC bedrock2/compiler/src/FlatToRiscvDef.v +COQC bedrock2/compiler/src/RegAlloc3.v +COQC bedrock2/compiler/src/EmitsValid.v +COQC bedrock2/compiler/src/RegAllocAnnotatedNotations.v +COQC bedrock2/compiler/src/GoFlatToRiscv.v +COQC bedrock2/compiler/src/FlatToRiscv32.v +COQC bedrock2/compiler/src/FlatToRiscv.v +COQC Kami/Ex/Divider64.v +COQC Kami/Ex/FifoCorrect.v +COQC bedrock2/compiler/src/Pipeline.v +COQC bedrock2/compiler/src/examples/MMIO.v +compiled@{} = +[[Lui addr 268582912; Addi addr addr 0; Lw i addr 0; +Beq i 0 16; Mul s i i; Sw addr s 0; Jal 0 (-16)]] + : list Instruction +COQC Kami/Ex/RegFile.v +COQC Kami/Ex/SCMMInl.v +COQC Kami/Kami.v +COQC Kami/Ex/MemAtomic.v +COQC bedrock2/compiler/src/examples/InlineAssemblyMacro.v +COQC Kami/Ex/SimpleFifoCorrect.v +compiled@{} = +[[Lw 9 1 0; Mul 4 2 3; Add 5 2 3; Sub 6 2 3; Auipc 31 0; +Add 31 31 9; Jalr 0 31 8; Addi 7 4 0; Jal 0 20; Addi 7 5 0; +Jal 0 12; Addi 7 6 0; Jal 0 4]] + : list Instruction +COQC bedrock2/compiler/src/examples/CompileExamples.v +COQC bedrock2/compiler/src/examples/Fibonacci.v +fib_ExprImp@{compiler.examples.Fibonacci.17} = +fun n : Z => +cmd.seq (cmd.set 1 (expr.literal 0)) + (cmd.seq (cmd.set 2 (expr.literal 1)) + (cmd.seq (cmd.set 4 (expr.literal 0)) + (cmd.while (expr.op ltu (expr.var 4) (expr.literal n)) + (cmd.seq (cmd.set 3 (expr.op add (expr.var 1) (expr.var 2))) + (cmd.seq (cmd.set 1 (expr.var 2)) + (cmd.seq (cmd.set 2 (expr.var 3)) + (cmd.set 4 (expr.op add (expr.var 4) (expr.literal 1))))))))) + : Z -> cmd + +Argument scope is [Z_scope] + = SSeq (SLit 1 0) + (SSeq (SLit 2 1) + (SSeq (SLit 4 0) + (SLoop (SSeq SSkip (SLit 5 6)) (CondBinary BLtu 4 5) + (SSeq (SSeq SSkip (SSeq SSkip (SOp 3 add 1 2))) + (SSeq (SSet 1 2) + (SSeq (SSet 2 3) + (SSeq SSkip (SSeq (SLit 6 1) (SOp 4 add 4 6))))))))) + : stmt +Finished transaction in 0.012 secs (0.007u,0.s) (successful) +fib6_riscv@{} = +[Addi 1 0 0; Addi 2 0 1; Addi 4 0 0; Addi 5 0 6; Bgeu 4 5 28; +Add 3 1 2; Add 1 0 2; Add 2 0 3; Addi 6 0 1; Add 4 4 6; +Jal 0 (-28)] + : list Instruction +fib6_riscv@{} = +RISCV: + addi x1, x0, 0 + addi x2, x0, 1 + addi x4, x0, 0 + addi x5, x0, 6 + bgeu x4, x5, 28 + add x3, x1, x2 + add x1, x0, x2 + add x2, x0, x3 + addi x6, x0, 1 + add x4, x4, x6 + jal x0, -28 + : list Instruction +93000000 13011000 13020000 93026000 637e5200 b3812000 b3002000 33013000 +13031000 33026200 6ff05ffe + = {| Naive.unsigned := 13; Naive._unsigned_in_range := eq_refl |} + : word +COQC bedrock2/compiler/src/examples/FE310Compiler.v +Finished transaction in 0.063 secs (0.028u,0.001s) (successful) +Axioms: +AdmitAxiom.proof_admitted : False + used in map_ok_subproof5 to prove: forall (m1 m2 : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get m2 k = Some v -> + map.get (map.putmany m1 m2) k = Some v + used in map_ok_subproof4 to prove: forall (m1 m2 : map p ok) + (k : parameters.key), + map.get m2 k = None -> + map.get (map.putmany m1 m2) k = + map.get m1 k + used in map_ok_subproof3 to prove: forall (m : map p ok) + (k k' : parameters.key), + k <> k' -> + map.get (map.remove m k') k = map.get m k + used in map_ok_subproof2 to prove: forall (m : map p ok) + (k : parameters.key), + map.get (map.remove m k) k = None + used in map_ok_subproof1 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value) + (k' : parameters.key), + k <> k' -> + map.get (map.put m k' v) k = map.get m k + used in map_ok_subproof0 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get (map.put m k v) k = Some v + used in map_ok_subproof to prove: forall m1 m2 : map p ok, + (forall k : parameters.key, + map.get m1 k = map.get m2 k) -> + m1 = m2 +ext_spec_Proper : forall + (trace : list + (mem * actname * list Semantics.word * + (mem * list Semantics.word))) + (m : mem) (act : actname) (args : list Semantics.word), + Morphisms.Proper + (Morphisms.respectful + (Morphisms.pointwise_relation mem + (Morphisms.pointwise_relation + (list Semantics.word) Basics.impl)) Basics.impl) + (ext_spec trace m act args) +Axioms: +FlatToRiscv.word_eq_dec : forall p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + DecidableEq word +undef_on_unchecked_store_byte_tuple_list : forall + (n : nat) + (l : list (HList.tuple word8 n)) + (start : word32), + map.undef_on + (unchecked_store_byte_tuple_list + start l map.empty) + (fun x : word32 => + ~ + word.unsigned start <= + word.unsigned x < + word.unsigned start + + Z.of_nat n * Zlength l) +store_program_empty : forall (prog : list Instruction) (addr : word), + GoFlatToRiscv.program addr prog + (unchecked_store_program addr prog map.empty) +FlatToRiscv.reduce_eq_to_sub_and_lt : forall + p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + forall (y z : word) + (T : Type) + (thenVal elseVal : T), + (if word.eqb y z + then thenVal + else elseVal) = + (if + word.ltu (word.sub y z) (word.of_Z 1) + then thenVal + else elseVal) +real_ext_spec_implies_simple_ext_spec : forall (p : MMIO.parameters) + (t : trace) + (m : MMIO.mem) + (a : MMIOAction) + (args : list MMIO.word) + (post : + MMIO.mem -> + list MMIO.word -> Prop), + real_ext_spec t m a args post -> + simple_ext_spec t m a args post +FlatToRiscv.put_put_same : forall (K V : Type) (M : map.map K V) + (k : K) (v1 v2 : V) (m : M), + map.put (map.put m k v1) k v2 = map.put m k v2 +PropExtensionality.propositional_extensionality : +forall P Q : Prop, P <-> Q -> P = Q +AdmitAxiom.proof_admitted : False + used in map_ok_subproof5 to prove: forall (m1 m2 : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get m2 k = Some v -> + map.get (map.putmany m1 m2) k = Some v + used in map_ok_subproof4 to prove: forall (m1 m2 : map p ok) + (k : parameters.key), + map.get m2 k = None -> + map.get (map.putmany m1 m2) k = + map.get m1 k + used in map_ok_subproof3 to prove: forall (m : map p ok) + (k k' : parameters.key), + k <> k' -> + map.get (map.remove m k') k = map.get m k + used in map_ok_subproof2 to prove: forall (m : map p ok) + (k : parameters.key), + map.get (map.remove m k) k = None + used in map_ok_subproof1 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value) + (k' : parameters.key), + k <> k' -> + map.get (map.put m k' v) k = map.get m k + used in map_ok_subproof0 to prove: forall (m : map p ok) + (k : parameters.key) + (v : parameters.value), + map.get (map.put m k v) k = Some v + used in map_ok_subproof to prove: forall m1 m2 : map p ok, + (forall k : parameters.key, + map.get m1 k = map.get m2 k) -> + m1 = m2 +max_ext_call_code_size_bound : forall (p : FlattenExpr.parameters) + (f : FlattenExpr.actname), + 0 <= FlattenExpr.max_ext_call_code_size f <= 7 +map_undef_on_weaken : forall (P Q : PropSet.set word32) (m : Mem), + map.undef_on m Q -> + PropSet.subset P Q -> map.undef_on m P +FlatImp.exec.map_split_diff : forall pp : Semantics.parameters, + FlatImp.env -> + forall m m1 m2 m3 : mem, + map.split m m2 m1 -> + map.split m m3 m1 -> m2 = m3 +load4bytes_in_MMIO_is_None : forall (p : MMIO.parameters) + (m : MMIO.mem) (addr : MMIO.word), + map.undef_on m isMMIOAddr -> + isMMIOAddr addr -> load_bytes 4 m addr = None +FunctionalExtensionality.functional_extensionality_dep : +forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), +(forall x : A, f x = g x) -> f = g +FlatImp.exec.ext_spec_intersect : forall (pp : Semantics.parameters) + (t : list + (mem * actname * + list Semantics.word * + (mem * list Semantics.word))) + (mGive1 mGive2 : mem) + (a : actname) + (args : list Semantics.word) + (post1 + post2 : mem -> + list Semantics.word -> Prop), + ext_spec t mGive1 a args post1 -> + ext_spec t mGive2 a args post2 -> + mGive1 = mGive2 /\ + ext_spec t mGive1 a args + (fun (mReceive : mem) + (resvals : list Semantics.word) => + post1 mReceive resvals /\ + post2 mReceive resvals) +ext_spec_Proper : forall + (trace : list + (mem * actname * list Semantics.word * + (mem * list Semantics.word))) + (m : mem) (act : actname) (args : list Semantics.word), + Morphisms.Proper + (Morphisms.respectful + (Morphisms.pointwise_relation mem + (Morphisms.pointwise_relation + (list Semantics.word) Basics.impl)) Basics.impl) + (ext_spec trace m act args) +FlatToRiscv.divisibleBy4_admit : forall + p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + forall x y : word, + FlatToRiscv.divisibleBy4 x -> + FlatToRiscv.divisibleBy4 y +compile_lit_new_size : forall iset : InstructionSet, + FlatToRiscvDef.FlatToRiscvDef.parameters -> + forall (x : Register) (v : Z), + 0 <= + Zlength (FlatToRiscvDef.compile_lit_new iset x v) <= + 15 +FlatToRiscv.compile_lit_correct_full : forall + p : FlatToRiscv.FlatToRiscv.parameters, + FlatToRiscv.FlatToRiscv.assumptions -> + forall + (initialL : + RiscvMachine.RiscvMachine + Syntax.varname + FlatToRiscvDef.FlatToRiscvDef.actname) + (post : RiscvMachine.RiscvMachine + Register + FlatToRiscvDef.FlatToRiscvDef.actname -> + Prop) + (x : Syntax.varname) + (v : Z) + (R : FlatToRiscv.FlatToRiscv.mem -> + Prop), + getNextPc initialL = + add (getPc initialL) (ZToReg 4) -> + let insts := + FlatToRiscvDef.compile_stmt + FlatToRiscv.FlatToRiscv.iset + (FlatImp.SLit x v) in + let d := + mul (ZToReg 4) + (ZToReg (Zlength insts)) in + Separation.sep + (GoFlatToRiscv.program + (getPc initialL) insts) R + (getMem initialL) -> + FlatToRiscvDef.valid_registers + (FlatImp.SLit x v) -> + FlatToRiscv.runsTo + (withRegs + (map.put + (getRegs inibedrock2/compiler/src/examples/FE310Compiler (real: 42.80, user: 20.27, sys: 0.35, mem: 610324 ko) +bedrock2/compiler/src/examples/EditDistExample (real: 2.19, user: 0.80, sys: 0.26, mem: 499980 ko) +bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump (real: 2.04, user: 0.74, sys: 0.23, mem: 505316 ko) +Kami/Ex/IsaRv32Pgm (real: 2.28, user: 0.82, sys: 0.26, mem: 507796 ko) +File "./Kami/Ex/ProcDec.v", line 279, characters 2-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDec.v", line 289, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDec.v", line 301, characters 2-31: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDec.v", line 314, characters 0-76: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcDec (real: 9.01, user: 4.13, sys: 0.26, mem: 512264 ko) +Kami/Ext/Extraction (real: 2.36, user: 0.79, sys: 0.24, mem: 488532 ko) +Kami/Ex/SimpleFifoCorrect (real: 74.95, user: 37.44, sys: 0.37, mem: 672092 ko) +File "./Kami/Tutorial.v", line 72, characters 0-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 801, characters 2-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Tutorial (real: 7.47, user: 3.39, sys: 0.25, mem: 517872 ko) +File "./Kami/Ex/ProcThreeStage.v", line 806, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 811, characters 2-35: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 816, characters 2-38: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 821, characters 2-38: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 831, characters 2-36: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 839, characters 2-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 844, characters 2-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/IsaRv32/PgmGcd (real: 4.45, user: 1.88, sys: 0.27, mem: 521816 ko) +File "./Kami/Ex/ProcThreeStage.v", line 855, characters 2-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStage.v", line 871, characters 0-251: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcThreeStage (real: 12.09, user: 5.62, sys: 0.28, mem: 535096 ko) +Kami/Ex/IsaRv32/PgmFact (real: 4.26, user: 1.83, sys: 0.25, mem: 522312 ko) +Kami/Ex/IsaRv32/PgmBsort (real: 4.09, user: 1.75, sys: 0.23, mem: 521896 ko) +Kami/Ex/IsaRv32/PgmHanoi (real: 4.05, user: 1.74, sys: 0.23, mem: 522080 ko) +Kami/Ex/IsaRv32/PgmDekker1 (real: 4.24, user: 1.78, sys: 0.27, mem: 520604 ko) +Kami/Ex/IsaRv32/PgmDekker2 (real: 4.29, user: 1.83, sys: 0.25, mem: 524584 ko) +Kami/Ex/IsaRv32/PgmPeterson1 (real: 4.23, user: 1.80, sys: 0.27, mem: 519680 ko) +Kami/Ex/IsaRv32/PgmPeterson2 (real: 4.14, user: 1.80, sys: 0.24, mem: 519696 ko) +Kami/Ex/IsaRv32/PgmMatMulInit (real: 4.29, user: 1.81, sys: 0.25, mem: 521416 ko) +Kami/Ex/IsaRv32/PgmMatMulNormal1 (real: 4.30, user: 1.83, sys: 0.26, mem: 519240 ko) +Kami/Ex/IsaRv32/PgmMatMulNormal2 (real: 4.21, user: 1.81, sys: 0.24, mem: 519724 ko) +Kami/Ex/IsaRv32/PgmMatMulReport (real: 4.32, user: 1.87, sys: 0.25, mem: 519908 ko) +Kami/Ex/IsaRv32/PgmBankerInit (real: 4.21, user: 1.81, sys: 0.24, mem: 522124 ko) +Kami/Ex/IsaRv32/PgmBankerWorker1 (real: 4.43, user: 1.87, sys: 0.27, mem: 522776 ko) +Kami/Ex/IsaRv32/PgmBankerWorker2 (real: 4.24, user: 1.80, sys: 0.25, mem: 520460 ko) +Kami/Ex/ProcThreeStInl (real: 2.03, user: 0.75, sys: 0.23, mem: 490144 ko) +Kami/Ex/IsaRv32/PgmBankerWorker3 (real: 4.25, user: 1.85, sys: 0.24, mem: 520188 ko) +File "./Kami/Ex/ProcFetchDecode.v", line 333, characters 2-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcFetchDecode.v", line 342, characters 2-32: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcFetchDecode.v", line 356, characters 0-68: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcFetchDecode (real: 4.85, user: 2.11, sys: 0.24, mem: 508168 ko) +tialL) x + (ZToReg v)) + (withPc + (add (getPc initialL) d) + (withNextPc + (add (getNextPc initialL) d) + initialL))) post -> + FlatToRiscv.runsTo initialL post +assume_riscv_word_properties : forall p : MMIO.parameters, + RiscvWordProperties.word.riscv_ok MMIO.word +COQC bedrock2/compiler/src/examples/EditDistExample.v +COQC bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump.v +37250200 1305c5fe 03210500 b7850010 93850500 37060040 13060600 9306f001 +3377d100 93070001 3318f700 b3680601 23a01501 13031000 37390110 13098901 +93090027 23203901 373a0110 130a8a00 23206a00 b73a0110 938aca00 23a06a00 +372b0110 130b8b03 b70b0300 938b0b00 23207b01 9303e002 b3007000 33027340 +630c0206 b7020080 93820200 33015000 b3047340 33fc2400 b37c5c00 638c0c00 +373d0110 130d4d00 03210d00 b3846440 6ff05ffe 37340110 13040400 b3015000 +b3047340 b3fd3400 33fe5d00 63080e00 83210400 b3846440 6ff0dffe 23201400 +b3002000 33026240 63967000 33424200 6f004000 6ff0dff8 +make[3]: Leaving directory 'bedrock2/compiler' +make[2]: Leaving directory 'bedrock2/compiler' +COQC Kami/Ex/IsaRv32Pgm.v +COQC Kami/Ex/ProcDec.v +COQC Kami/Ext/Extraction.v +COQC Kami/Tutorial.v +COQC Kami/Ex/ProcThreeStage.v +COQC Kami/Ex/IsaRv32/PgmGcd.v +COQC Kami/Ex/IsaRv32/PgmFact.v +COQC Kami/Ex/IsaRv32/PgmBsort.v +COQC Kami/Ex/IsaRv32/PgmHanoi.v +COQC Kami/Ex/IsaRv32/PgmDekker1.v +COQC Kami/Ex/IsaRv32/PgmDekker2.v +COQC Kami/Ex/IsaRv32/PgmPeterson1.v +COQC Kami/Ex/IsaRv32/PgmPeterson2.v +COQC Kami/Ex/IsaRv32/PgmMatMulInit.v +COQC Kami/Ex/IsaRv32/PgmMatMulNormal1.v +COQC Kami/Ex/IsaRv32/PgmMatMulNormal2.v +COQC Kami/Ex/IsaRv32/PgmMatMulReport.v +COQC Kami/Ex/IsaRv32/PgmBankerInit.v +COQC Kami/Ex/IsaRv32/PgmBankerWorker1.v +COQC Kami/Ex/IsaRv32/PgmBankerWorker2.v +COQC Kami/Ex/IsaRv32/PgmBankerWorker3.v +COQC Kami/Ex/ProcThreeStInl.v +COQC Kami/Ex/ProcFetchDecode.v +COQC Kami/Ex/ProcDecInl.v +COQC Kami/Ex/InDepthTutorial.v +Inductive Modules : Type := + RegFile : string -> + list string -> + string -> + forall (IdxBits : nat) (Data : Kind), + ConstT (Vector Data IdxBits) -> Modules + | Mod : list RegInitT -> + list (Struct.Attribute (Action Void)) -> list DefMethT -> Modules + | ConcatMod : Modules -> Modules -> Modules + +For RegFile: Arguments IdxBits, Data are implicit +For RegFile: Argument scopes are [string_scope list_scope string_scope + nat_scope _ _] +For Mod: Argument scopes are [list_scope list_scope list_scope] +Inductive ActionT (ty : Kind -> Type) (lretT : Kind) : Type := + MCall : string -> + forall s : SignatureT, + (arg s) @ (ty) -> + (ty (ret s) -> ActionT ty lretT) -> ActionT ty lretT + | Let_ : forall lretT' : FullKind, + Expr ty lretT' -> + (fullType ty lretT' -> ActionT ty lretT) -> ActionT ty lretT + | ReadNondet : forall k : FullKind, + (fullType ty k -> ActionT ty lretT) -> ActionT ty lretT + | ReadReg : string -> + forall k : FullKind, + (fullType ty k -> ActionT ty lretT) -> ActionT ty lretT + | WriteReg : string -> + forall k : FullKind, + Expr ty k -> ActionT ty lretT -> ActionT ty lretT + | IfElse : (Bool) @ (ty) -> + forall k : Kind, + ActionT ty k -> + ActionT ty k -> (ty k -> ActionT ty lretT) -> ActionT ty lretT + | Assert_ : (Bool) @ (ty) -> ActionT ty lretT -> ActionT ty lretT + | Displ : list (Disp ty) -> ActionT ty lretT -> ActionT ty lretT + | Return : (lretT) @ (ty) -> ActionT ty lretT + +For MCall: Arguments ty, lretT are implicit +For Let_: Arguments ty, lretT, lretT' are implicit +For ReadNondet: Arguments ty, lretT are implicit +For ReadReg: Arguments ty, lretT are implicit +For WriteReg: Arguments ty, lretT, k are implicit +For IfElse: Arguments ty, lretT, k are implicit +For Assert_: Arguments ty, lretT are implicit +For Displ: Arguments ty, lretT are implicit +For Return: Arguments ty, lretT are implicit +For ActionT: Argument scopes are [function_scope _] +For MCall: Argument scopes are [function_scope _ string_scope _ _ + function_scope] +For Let_: Argument scopes are [function_scope _ _ _ function_scope] +For ReadNondet: Argument scopes are [function_scope _ _ function_scope] +For ReadReg: Argument scopes are [function_scope _ string_scope _ + function_scope] +For WriteReg: Argument scopes are [function_scope _ string_scope _ _ _] +For IfElse: Argument scopes are [function_scope _ _ _ _ _ function_scope] +For Assert_: Argument scopes are [function_scope _ _ _] +For Displ: Argument scopes are [function_scope _ list_scope _] +For Return: Argument scopes are [function_scope _ _] +Inductive Expr (ty : Kind -> Type) : FullKind -> Type := + Var : forall k : FullKind, fullType ty k -> Expr ty k + | Const : forall k : Kind, ConstT k -> (k) @ (ty) + | UniBool : UniBoolOp -> (Bool) @ (ty) -> (Bool) @ (ty) + | BinBool : BinBoolOp -> (Bool) @ (ty) -> (Bool) @ (ty) -> (Bool) @ (ty) + | UniBit : forall n1 n2 : nat, + UniBitOp n1 n2 -> (Bit n1) @ (ty) -> (Bit n2) @ (ty) + | BinBit : forall n1 n2 n3 : nat, + BinBitOp n1 n2 n3 -> + (Bit n1) @ (ty) -> (Bit n2) @ (ty) -> (Bit n3) @ (ty) + | BinBitBool : forall n1 n2 : nat, + BinBitBoolOp n1 n2 -> + (Bit n1) @ (ty) -> (Bit n2) @ (ty) -> (Bool) @ (ty) + | ITE : forall k : FullKind, + (Bool) @ (ty) -> Expr ty k -> Expr ty k -> Expr ty k + | Eq : forall k : Kind, (k) @ (ty) -> (k) @ (ty) -> (Bool) @ (ty) + | ReadIndex : forall (i : nat) (k : Kind), + (Bit i) @ (ty) -> (Vector k i) @ (ty) -> (k) @ (ty) + | ReadField : forall (n : nat) (ls : Vector.t (Struct.Attribute Kind) n) + (i : Fin.t n), + (Struct ls) @ (ty) -> + (Vector.nth (Vector.map (Struct.attrType (A:=Kind)) ls) i) @ + (ty) + | BuildVector : forall (n : Kind) (k : nat), + Vec (n) @ (ty) k -> (Vector n k) @ (ty) + | BuildStruct : forall (n : nat) + (attrs : Vector.t (Struct.Attribute Kind) n), + ilist.ilist + (fun a : Struct.Attribute Kind => + (Struct.attrType a) @ (ty)) attrs -> + (Struct attrs) @ (ty) + | UpdateVector : forall (i : nat) (k : Kind), + (Vector k i) @ (ty) -> + (Bit i) @ (ty) -> (k) @ (ty) -> (Vector k i) @ (ty) + | ReadArrayIndex : forall (i : nat) (k : Kind), + (Bit (Nat.log2 (2 * i))) @ (ty) -> + (Array k i) @ (ty) -> (k) @ (ty) + | BuildArray : forall (n : Kind) (k : nat), + Vector.t (n) @ (ty) (S k) -> (Array n k) @ (ty) + | UpdateArray : forall (i : nat) (k : Kind), + (Array k i) @ (ty) -> + (Bit (Nat.log2 (2 * i))) @ (ty) -> + (k) @ (ty) -> (Array k i) @ (ty) + +For Const: Argument k is implicit +For UniBool: Argument ty is implicit +For BinBool: Argument ty is implicit +For UniBit: Arguments ty, n1, n2 are implicit +For BinBit: Arguments ty, n1, n2, n3 are implicit +For BinBitBool: Arguments ty, n1, n2 are implicit +For ITE: Arguments ty, k are implicit +For Eq: Arguments ty, k are implicit +For ReadIndex: Arguments ty, i, k are implicit +For ReadField: Arguments ty, n, ls are implicit +For BuildVector: Arguments ty, n, k are implicit +For BuildStruct: Arguments ty, n, attrs are implicit +For UpdateVector: Arguments ty, i, k are implicit +For ReadArrayIndex: Arguments ty, i, k are implicit +For BuildArray: Arguments ty, n, k are implicit +For UpdateArray: Arguments ty, i, k are implicit +For Expr: Argument scopes are [function_scope _] +For Var: Argument scopes are [function_scope _ _] +For Const: Argument scopes are [function_scope _ _] +For UniBool: Argument scopes are [function_scope _ _] +For BinBool: Argument scopes are [function_scope _ _ _] +For UniBit: Argument scopes are [function_scope nat_scope nat_scope _ _] +For BinBit: Argument scopes are [function_scope nat_scope nat_scope nat_scope + _ _ _] +For BinBitBool: Argument scopes are [function_scope nat_scope nat_scope _ _ + _] +For ITE: Argument scopes are [function_scope _ _ _ _] +For Eq: Argument scopes are [function_scope _ _ _] +For ReadIndex: Argument scopes are [function_scope nat_scope _ _ _] +For ReadField: Argument scopes are [function_scope nat_scope _ _ _] +For BuildVector: Argument scopes are [function_scope _ nat_scope _] +For BuildStruct: Argument scopes are [function_scope nat_scope _ _] +For UpdateVector: Argument scopes are [function_scope nat_scope _ _ _ _] +For ReadArrayIndex: Argument scopes are [function_scope nat_scope _ _ _] +For BuildArray: Argument scopes are [function_scope _ nat_scope _] +For UpdateArray: Argument scopes are [function_scope nat_scope _ _ _ _] +evalExpr = +fix evalExpr (exprT : FullKind) (e : Expr type exprT) {struct e} : + fullType type exprT := + match e in (Expr _ exprT0) return (fullType type exprT0) with + | @Var _ _ v => v + | @Const _ k v => evalConstT v + | UniBool op e1 => evalUniBool op (evalExpr (SyntaxKind Bool) e1) + | BinBool op e1 e2 => + evalBinBool op (evalExpr (SyntaxKind Bool) e1) + (evalExpr (SyntaxKind Bool) e2) + | @UniBit _ n1 n2 op e1 => + evalUniBit op (evalExpr (SyntaxKind (Bit n1)) e1) + | @BinBit _ n1 n2 n3 op e1 e2 => + evalBinBit op (evalExpr (SyntaxKind (Bit n1)) e1) + (evalExpr (SyntaxKind (Bit n2)) e2) + | @BinBitBool _ n1 n2 op e1 e2 => + evalBinBitBool op (evalExpr (SyntaxKind (Bit n1)) e1) + (evalExpr (SyntaxKind (Bit n2)) e2) + | @ITE _ k p e1 e2 => + if evalExpr (SyntaxKind Bool) p then evalExpr k e1 else evalExpr k e2 + | @Eq _ k e1 e2 => + if isEq k (evalExpr (SyntaxKind k) e1) (evalExpr (SyntaxKind k) e2) + then true + else false + | @ReadIndex _ i0 k i f => + evalExpr (SyntaxKind (Vector k i0)) f + (evalExpr (SyntaxKind (Bit i0)) i) + | @ReadField _ n ls i e0 => + VectorFacts.Vector_nth_map (Struct.attrType (A:=Kind)) type ls + (evalExpr (SyntaxKind (Struct ls)) e0) i + | @BuildVector _ n k vec => evalVec (mapVec (evalExpr (SyntaxKind n)) vec) + | @BuildStruct _ n attrs ils => + ilist.ilist_to_fun_m (Expr type) (fullType type) + (fun sk : Struct.Attribute Kind => SyntaxKind (Struct.attrType sk)) + evalExpr ils + | @UpdateVector _ i0 k fn i v => + fun w : word i0 => + if weq w (evalExpr (SyntaxKind (Bit i0)) i) + then evalExpr (SyntaxKind k) v + else evalExpr (SyntaxKind (Vector k i0)) fn w + | @ReadArrayIndex _ i k idx vec => + evalExpr (SyntaxKind (Array k i)) vec + (natToFin i # (evalExpr (SyntaxKind (Bit (Nat.log2 (2 * i)))) idx)) + | @BuildArray _ i k vecVal => + evalArray (Vector.map (evalExpr (SyntaxKind i)) vecVal) + | @UpdateArray _ i k arr idx val => + fun fini : Fin.t (S i) => + if + Fin.eq_dec fini + (natToFin i # (evalExpr (SyntaxKind (Bit (Nat.log2 (2 * i)))) idx)) + then evalExpr (SyntaxKind k) val + else evalExpr (SyntaxKind (Array k i)) arr fini + end + : forall exprT : FullKind, Expr type exprT -> fullType type exprT + +Argument exprT is implicit +Inductive +SemAction (oldRegs : RegsT) + : forall k : Kind, ActionT type k -> UpdatesT -> MethsT -> type k -> Prop := + SemMCall : forall (meth : M.key) (s : SignatureT) + (marg : (arg s) @ (type)) (mret : type (ret s)) + (retK : Kind) (fret : type retK) + (cont : type (ret s) -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT) + (acalls : M.t {x : SignatureT & SignT x}), + (calls) @[ meth]%fmap = None -> + acalls = (calls) #[ meth |-> (evalExpr marg, mret)]%fmap -> + SemAction oldRegs (cont mret) newRegs calls fret -> + SemAction oldRegs (MCall meth s marg cont) newRegs acalls fret + | SemLet : forall (k : FullKind) (e : Expr type k) + (retK : Kind) (fret : type retK) + (cont : fullType type k -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT), + SemAction oldRegs (cont (evalExpr e)) newRegs calls fret -> + SemAction oldRegs (LET name <- e; cont name)%kami_action newRegs + calls fret + | SemReadNondet : forall (valueT : FullKind) + (valueV : fullType type valueT) + (retK : Kind) (fret : type retK) + (cont : fullType type valueT -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT), + SemAction oldRegs (cont valueV) newRegs calls fret -> + SemAction oldRegs + (Nondet name : valueT; cont name)%kami_action newRegs + calls fret + | SemReadReg : forall (r : string) (regT : FullKind) + (regV : fullType type regT) (retK : Kind) + (fret : type retK) + (cont : fullType type regT -> ActionT type retK) + (newRegs : UpdatesT) (calls : MethsT), + (oldRegs) @[ r]%fmap = + Some (existT (fullType type) regT regV) -> + SemAction oldRegs (cont regV) newRegs calls fret -> + SemAction oldRegs (Read name <- r; cont name)%kami_action + newRegs calls fret + | SemWriteReg : forall (r : string) (k : FullKind) + (e : Expr type k) (retK : Kind) + (fret : type retK) (cont : ActionT type retK) + (newRegs : M.t {x : FullKind & fullType type x}) + (calls : MethsT) + (anewRegs : M.t {x : FullKind & fullType type x}), + (newRegs) @[ r]%fmap = None -> + anewRegs = (newRegs) #[ r |-> evalExpr e]%fmap -> + SemAction oldRegs cont newRegs calls fret -> + SemAction oldRegs (Write r <- e; cont)%kami_action anewRegs + calls fret + | SemIfElseTrue : forall (p : (Bool) @ (type)) (k1 : Kind) + (a a' : ActionT type k1) (r1 : type k1) + (k2 : Kind) (cont : type k1 -> ActionT type k2) + (newRegs1 + newRegs2 : M.Map.t {x : FullKind & fullType type x}) + (calls1 calls2 : M.Map.t {x : SignatureT & SignT x}) + (r2 : type k2), + M.Disj newRegs1 newRegs2 -> + M.Disj calls1 calls2 -> + evalExpr p = true -> + SemAction oldRegs a newRegs1 calls1 r1 -> + SemAction oldRegs (cont r1) newRegs2 calls2 r2 -> + forall + (unewRegs : M.Map.t {x : FullKind & fullType type x}) + (ucalls : M.Map.t {x : SignatureT & SignT x}), + unewRegs = M.union newRegs1 newRegs2 -> + ucalls = M.union calls1 calls2 -> + SemAction oldRegs + (If p then a else a' as name; cont name)%kami_action + unewRegs ucalls r2 + | SemIfElseFalse : forall (p : (Bool) @ (type)) + (k1 : Kind) (a a' : ActionT type k1) + (r1 : type k1) (k2 : Kind) + (cont : type k1 -> ActionT type k2) + (newRegs1 + newRegs2 : M.Map.t {x : FullKind & fullType type x}) + (calls1 calls2 : M.Map.t {x : SignatureT & SignT x}) + (r2 : type k2), + M.Disj newRegs1 newRegs2 -> + M.Disj calls1 calls2 -> + evalExpr p = false -> + SemAction oldRegs a' newRegs1 calls1 r1 -> + SemAction oldRegs (cont r1) newRegs2 calls2 r2 -> + forall + (unewRegs : M.Map.t {x : FullKind & fullType type x}) + (ucalls : M.Map.t {x : SignatureT & SignT x}), + unewRegs = M.union newRegs1 newRegs2 -> + ucalls = M.union calls1 calls2 -> + SemAction oldRegs + (If p then a else a' as name; cont name)%kami_action + unewRegs ucalls r2 + | SemAssertTrue : forall (p : (Bool) @ (type)) (k2 : Kind) + (cont : ActionT type k2) (newRegs2 : UpdatesT) + (calls2 : MethsT) (r2 : type k2), + evalExpr p = true -> + SemAction oldRegs cont newRegs2 calls2 r2 -> + SemAction oldRegs (Assert p; cont)%kami_action newRegs2 + calls2 r2 + | SemDispl : forall (ls : list (Disp type)) (k2 : Kind) + (cont : ActionT type k2) (newRegs2 : UpdatesT) + (calls2 : MethsT) (r2 : type k2), + SemAction oldRegs cont newRegs2 calls2 r2 -> + SemAction oldRegs (Displ ls cont) newRegs2 calls2 r2 + | SemReturn : forall (k : Kind) (e : (k) @ (type)) + (evale : fullType type (SyntaxKind k)), + evale = evalExpr e -> + SemAction oldRegs (Ret e)%kami_action []%fmap []%fmap evale + +For SemAction: Argument k is implicit +For SemMCall: Arguments oldRegs, meth, s, mret, retK, fret, newRegs, calls, + acalls are implicit +For SemLet: Arguments oldRegs, k, retK, fret, newRegs, calls are implicit +For SemReadNondet: Arguments oldRegs, retK, fret, newRegs, calls are implicit +For SemReadReg: Arguments oldRegs, regT, regV, retK, fret, newRegs, calls + are implicit +For SemWriteReg: Arguments oldRegs, r, k, retK, fret, cont, newRegs, calls, + anewRegs are implicit +For SemIfElseTrue: Arguments oldRegs, k1, a, r1, k2, newRegs1, newRegs2, + calls1, calls2, r2, unewRegs, ucalls are implicit +For SemIfElseFalse: Arguments oldRegs, k1, a', r1, k2, newRegs1, newRegs2, + calls1, calls2, r2, unewRegs, ucalls are implicit +For SemAssertTrue: Arguments oldRegs, k2, cont, newRegs2, calls2, r2 + are implicit +For SemDispl: Arguments oldRegs, k2, cont, newRegs2, calls2, r2 are implicit +For SemReturn: Arguments k, evale are implicit +For SemMCall: Argument scopes are [_ _ _ _ _ _ _ function_scope _ _ _ _ _ _] +For SemLet: Argument scopes are [_ _ _ _ _ function_scope _ _ _] +For SemReadNondet: Argument scopes are [_ _ _ _ _ function_scope _ _ _] +For SemReadReg: Argument scopes are [_ string_scope _ _ _ _ function_scope _ + _ _ _] +For SemWriteReg: Argument scopes are [_ string_scope _ _ _ _ _ _ _ _ _ _ _] +For SemIfElseTrue: Argument scopes are [_ _ _ _ _ _ _ function_scope _ _ _ _ + _ _ _ _ _ _ _ _ _ _] +For SemIfElseFalse: Argument scopes are [_ _ _ _ _ _ _ function_scope _ _ _ _ + _ _ _ _ _ _ _ _ _ _] +For SemDispl: Argument scopes are [_ list_scope _ _ _ _ _ _] +Record LabelT : Type := Build_LabelT + { annot : option (option string); defs : MethsT; calls : MethsT } +Inductive +Substep (m : Modules) (o : RegsT) + : UpdatesT -> UnitLabel -> MethsT -> Prop := + EmptyRule : Substep m o []%fmap (Rle None) []%fmap + | EmptyMeth : Substep m o []%fmap (Meth None) []%fmap + | SingleRule : forall (k : string) (a : Action Void), + In (k :: a)%struct (getRules m) -> + forall (u : UpdatesT) (cs : MethsT), + SemAction o (a type) u cs WO -> + Substep m o u (Rle (Some k)) cs + | SingleMeth : forall f : DefMethT, + In f (getDefsBodies m) -> + forall (u : UpdatesT) (cs : MethsT) + (argV : type (arg (projT1 (Struct.attrType f)))) + (retV : type (ret (projT1 (Struct.attrType f)))), + SemAction o (projT2 (Struct.attrType f) type argV) u cs retV -> + forall sig : Struct.Attribute {x : SignatureT & SignT x}, + sig = + (Struct.attrName f + :: existT SignT (projT1 (Struct.attrType f)) (argV, retV))%struct -> + Substep m o u (Meth (Some sig)) cs + +For SingleRule: Arguments o, u, cs are implicit +For SingleMeth: Arguments o, u, cs, argV, retV, sig are implicit +For SingleRule: Argument scopes are [_ _ string_scope _ _ _ _ _] +Inductive +SubstepsInd (m : Modules) (o : RegsT) : UpdatesT -> LabelT -> Prop := + SubstepsNil : SubstepsInd m o []%fmap + {| annot := None; defs := []%fmap; calls := []%fmap |} + | SubstepsCons : forall (u : UpdatesT) (l : LabelT), + SubstepsInd m o u l -> + forall (su : UpdatesT) (scs : MethsT) (sul : UnitLabel), + Substep m o su sul scs -> + CanCombineUUL u l su scs sul -> + forall (uu : M.Map.t {x : FullKind & fullType type x}) + (ll : LabelT), + uu = M.union u su -> + ll = mergeLabel (getLabel sul scs) l -> + SubstepsInd m o uu ll + +For SubstepsCons: Arguments m, o, u, l, su, scs, sul, uu, ll are implicit +Inductive StepInd (m : Modules) (o : RegsT) : UpdatesT -> LabelT -> Prop := + StepIndIntro : forall (u : UpdatesT) (l : LabelT), + SubstepsInd m o u l -> + wellHidden m (hide l) -> StepInd m o u (hide l) + +For StepIndIntro: Arguments m, o, u, l are implicit +Inductive Multistep (m : Modules) : RegsT -> RegsT -> list LabelT -> Prop := + NilMultistep : forall o1 o2 : RegsT, o1 = o2 -> Multistep m o1 o2 nil + | Multi : forall (o : RegsT) (a : list LabelT) (n : RegsT), + Multistep m o n a -> + forall (u : UpdatesT) (l : LabelT), + Step m n u l -> Multistep m o (M.union u n) (l :: a) + +For NilMultistep: Arguments o1, o2 are implicit +For Multi: Arguments m, o, a, n, u, l are implicit +For Multistep: Argument scopes are [_ _ _ list_scope] +For Multi: Argument scopes are [_ _ list_scope _ _ _ _ _] +Inductive Behavior (m : Modules) : RegsT -> LabelSeqT -> Prop := + BehaviorIntro : forall (a : list LabelT) (n : RegsT), + Multistep m (initRegs (getRegInits m)) n a -> + Behavior m n a + +For BehaviorIntro: Arguments m, a, n are implicit +For BehaviorIntro: Argument scopes are [_ list_scope _ _] +traceRefines = +fun (p : MethsT -> MethsT) (m1 m2 : Modules) => +forall (s1 : RegsT) (sig1 : LabelSeqT), +Behavior m1 s1 sig1 -> +exists (s2 : RegsT) (sig2 : LabelSeqT), + Behavior m2 s2 sig2 /\ equivalentLabelSeq p sig1 sig2 + : (MethsT -> MethsT) -> Modules -> Modules -> Prop + +Argument scopes are [function_scope _ _] +traceRefines_refl + : forall m : Modules, traceRefines id m m +traceRefines_trans + : forall (ma mb mc : Modules) (p q : MethsT -> MethsT), + traceRefines p ma mb -> + traceRefines q mb mc -> traceRefines (fun f : MethsT => q (p f)) ma mc +traceRefines_comm + : forall ma mb : Modules, + NoDup (Struct.namesOf (getRegInits (ma ++ mb)%kami)) -> + traceRefines id (ma ++ mb)%kami (mb ++ ma)%kami +traceRefines_assoc_1 + : forall ma mb mc : Modules, + traceRefines id ((ma ++ mb) ++ mc)%kami (ma ++ mb ++ mc)%kami +traceRefines_assoc_2 + : forall ma mb mc : Modules, + traceRefines id (ma ++ mb ++ mc)%kami ((ma ++ mb) ++ mc)%kami +traceRefines_modular_noninteracting + : forall ma mb mc md : Modules, + ModEquiv type typeUT ma -> + ModEquiv type typeUT mb -> + ModEquiv type typeUT mc -> + ModEquiv type typeUT md -> + DisjList (Struct.namesOf (getRegInits ma)) + (Struct.namesOf (getRegInits mc)) -> + DisjList (Struct.namesOf (getRegInits mb)) + (Struct.namesOf (getRegInits md)) -> + ValidRegsModules type (ma ++ mc)%kami -> + ValidRegsModules type (mb ++ md)%kami -> + DisjList (getDefs ma) (getDefs mc) -> + DisjList (getCalls ma) (getCalls mc) -> + DisjList (getDefs mb) (getDefs md) -> + DisjList (getCalls mb) (getCalls md) -> + forall + vp : M.key -> + {x : SignatureT & SignT x} -> option {x : SignatureT & SignT x}, + NonInteracting ma mc -> + NonInteracting mb md -> + (ma <<=[ vp ] mb) -> + (mc <<=[File "./Kami/Ex/InDepthTutorial.v", line 229, characters 0-58: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 232, characters 0-26: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 241, characters 0-55: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 245, characters 0-25: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 274, characters 0-30: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 277, characters 0-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 357, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 360, characters 0-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 379, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 382, characters 0-27: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +datav cannot be defined because it is informative and impl12_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +Hdatav cannot be defined because the projection datav was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +eltv cannot be defined because it is informative and impl12_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: Heltv cannot be defined because the projection eltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 408, characters 0-334: +Warning: +Hinv cannot be defined because the projections eltv, datav were not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 527, characters 0-29: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 530, characters 0-28: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 554, characters 0-33: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +datav cannot be defined because it is informative and impl123_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +Hdatav cannot be defined because the projection datav was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +eltv cannot be defined because it is informative and impl123_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: Heltv cannot be defined because the projection eltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/InDepthTutorial.v", line 557, characters 0-343: +Warning: +Hinv cannot be defined because the projections eltv, datav were not defined. +[cannot-define-projection,records] +Kami/Ex/ProcDecInl (real: 36.23, user: 17.33, sys: 0.37, mem: 724164 ko) +Kami/Ex/IsaRv32PgmExt (real: 2.54, user: 0.92, sys: 0.31, mem: 550756 ko) +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +sbv0 cannot be defined because it is informative and p3st_scoreboard_waw_inv +is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: Hsbv0 cannot be defined because the projection sbv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +d2eeltv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hd2eeltv0 cannot be defined because the projection d2eeltv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +d2efullv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hd2efullv0 cannot be defined because the projection d2efullv0 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +e2weltv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +He2weltv0 cannot be defined because the projection e2weltv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +e2wfullv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +He2wfullv0 cannot be defined because the projection e2wfullv0 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +stallv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hstallv0 cannot be defined because the projection stallv0 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +stalledv0 cannot be defined because it is informative and +p3st_scoreboard_waw_inv is not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hstalledv0 cannot be defined because the projection stalledv0 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 155, characters 2-1108: +Warning: +Hinv0 cannot be defined because the projections d2efullv0, d2eeltv0, +e2wfullv0, e2weltv0, stallv0, stalledv0, sbv0 were not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +d2eeltv1 cannot be defined because it is informative and p3st_raw_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2eeltv1 cannot be defined because the projection d2eeltv1 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +d2efullv1 cannot be defined because it is informative and p3st_raw_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2efullv1 cannot be defined because the projection d2efullv1 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +e2weltv1 cannot be defined because it is informative and p3st_raw_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +He2weltv1 cannot be defined because the projection e2weltv1 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +e2wfullv1 cannot be defined because it is informative and p3st_raw_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +He2wfullv1 cannot be defined because the projection e2wfullv1 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +stallv1 cannot be defined because it is informative and p3st_raw_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hstallv1 cannot be defined because the projection stallv1 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +stalledv1 cannot be defined because it is informative and p3st_raw_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hstalledv1 cannot be defined because the projection stalledv1 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2einv1 cannot be defined because the projections d2efullv1, stallv1, +d2eeltv1, stalledv1 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +He2winv1 cannot be defined because the projections e2wfullv1, stallv1, +e2weltv1, stalledv1 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 192, characters 2-1091: +Warning: +Hd2winv1 cannot be defined because the projections d2efullv1, e2wfullv1, +d2eeltv1, e2weltv1 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +pgmv2 cannot be defined because it is informative and p3st_decode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hpgmv2 cannot be defined because the projection pgmv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +rfv2 cannot be defined because it is informative and p3st_decode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: Hrfv2 cannot be defined because the projection rfv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +d2eeltv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hd2eeltv2 cannot be defined because the projection d2eeltv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +d2efullv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hd2efullv2 cannot be defined because the projection d2efullv2 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +e2weltv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +He2weltv2 cannot be defined because the projection e2weltv2 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +e2wfullv2 cannot be defined because it is informative and p3st_decode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +He2wfullv2 cannot be defined because the projection e2wfullv2 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +Hd2einv2 cannot be defined because the projections pgmv2, rfv2, d2eeltv2, +d2efullv2 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 238, characters 2-1015: +Warning: +He2winv2 cannot be defined because the projections pgmv2, rfv2, e2weltv2, +e2wfullv2 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +pgmv3 cannot be defined because it is informative and p3st_stalled_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hpgmv3 cannot be defined because the projection pgmv3 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +rfv3 cannot be defined because it is informative and p3st_stalled_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: Hrfv3 cannot be defined because the projection rfv3 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +stallv3 cannot be defined because it is informative and p3st_stalled_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hstallv3 cannot be defined because the projection stallv3 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +stalledv3 cannot be defined because it is informative and p3st_stalled_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hstalledv3 cannot be defined because the projection stalledv3 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 272, characters 2-641: +Warning: +Hinv3 cannot be defined because the projections pgmv3, rfv3, stallv3, +stalledv3 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +pcv4 cannot be defined because it is informative and p3st_exec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: Hpcv4 cannot be defined because the projection pcv4 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +rfv4 cannot be defined because it is informative and p3st_exec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: Hrfv4 cannot be defined because the projection rfv4 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +e2weltv4 cannot be defined because it is informative and p3st_exec_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +He2weltv4 cannot be defined because the projection e2weltv4 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +e2wfullv4 cannot be defined because it is informative and p3st_exec_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +He2wfullv4 cannot be defined because the projection e2wfullv4 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 299, characters 2-621: +Warning: +Hinv4 cannot be defined because the projections pcv4, rfv4, e2wfullv4, +e2weltv4 were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +pcv5 cannot be defined because it is informative and p3st_epochs_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: Hpcv5 cannot be defined because the projection pcv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +fepochv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hfepochv5 cannot be defined because the projection fepochv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +d2eeltv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hd2eeltv5 cannot be defined because the projection d2eeltv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +d2efullv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hd2efullv5 cannot be defined because the projection d2efullv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +w2deltv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hw2deltv5 cannot be defined because the projection w2deltv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +w2dfullv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hw2dfullv5 cannot be defined because the projection w2dfullv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +e2weltv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +He2weltv5 cannot be defined because the projection e2weltv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +e2wfullv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +He2wfullv5 cannot be defined because the projection e2wfullv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +stallv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hstallv5 cannot be defined because the projection stallv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +stalledv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hstalledv5 cannot be defined because the projection stalledv5 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +eepochv5 cannot be defined because it is informative and p3st_epochs_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Heepochv5 cannot be defined because the projection eepochv5 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 340, characters 2-1704: +Warning: +Hinv5 cannot be defined because the projections fepochv5, eepochv5, +d2efullv5, e2wfullv5, w2dfullv5, stallv5, pcv5, d2eeltv5, e2weltv5, stalledv5 +were not defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +pcv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: Hpcv6 cannot be defined because the projection pcv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +fepochv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hfepochv6 cannot be defined because the projection fepochv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +d2eeltv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hd2eeltv6 cannot be defined because the projection d2eeltv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +d2efullv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hd2efullv6 cannot be defined because the projection d2efullv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +w2dfullv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hw2dfullv6 cannot be defined because the projection w2dfullv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +e2weltv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +He2weltv6 cannot be defined because the projection e2weltv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +e2wfullv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +He2wfullv6 cannot be defined because the projection e2wfullv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +stallv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hstallv6 cannot be defined because the projection stallv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +stalledv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hstalledv6 cannot be defined because the projection stalledv6 was not +defined. [cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +eepochv6 cannot be defined because it is informative and p3st_pc_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Heepochv6 cannot be defined because the projection eepochv6 was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcThreeStInv.v", line 398, characters 2-1469: +Warning: +Hinv6 cannot be defined because the projections fepochv6, eepochv6, +d2efullv6, e2wfullv6, w2dfullv6, stallv6, pcv6, d2eeltv6, e2weltv6, stalledv6 +were not defined. [cannot-define-projection,records] +Kami/Ex/ProcThreeStInv (real: 3.48, user: 1.44, sys: 0.25, mem: 498104 ko) +File "./Kami/Ex/InDepthTutorial.v", line 680, characters 0-16: +Warning: The spelling "OCaml" should be used instead of "Ocaml". +[deprecated-ocaml-spelling,deprecated] +Kami/Ex/InDepthTutorial (real: 47.16, user: 22.68, sys: 0.34, mem: 653084 ko) +File "./Kami/Ex/ProcThreeStDec.v", line 120, characters 2-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcThreeStDec.v", line 121, characters 2-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcThreeStDec (real: 2.97, user: 1.19, sys: 0.25, mem: 495240 ko) +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +pcv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hpcv cannot be defined because the projection pcv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +rfv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hrfv cannot be defined because the projection rfv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +pgmv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hpgmv cannot be defined because the projection pgmv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +stallv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hstallv cannot be defined because the projection stallv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +iev cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hiev cannot be defined because the projection iev was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ifv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hifv cannot be defined because the projection ifv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ienqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hienqpv cannot be defined because the projection ienqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ideqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hideqpv cannot be defined because the projection ideqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ieltv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hieltv cannot be defined because the projection ieltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +oev cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hoev cannot be defined because the projection oev was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +ofv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: Hofv cannot be defined because the projection ofv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +oenqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hoenqpv cannot be defined because the projection oenqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +odeqpv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hodeqpv cannot be defined because the projection odeqpv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +oeltv cannot be defined because it is informative and procDec_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hoeltv cannot be defined because the projection oeltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcDecInv.v", line 82, characters 2-2422: +Warning: +Hinv cannot be defined because the projections stallv, iev, ienqpv, ideqpv, +oev, oenqpv, odeqpv, stallv, iev, ienqpv, ideqpv, oev, oenqpv, odeqpv, pgmv, +pcv, rfv, iev, ieltv, ideqpv, stallv, iev, ienqpv, ideqpv, oev, oenqpv, +odeqpv were not defined. [cannot-define-projection,records] +Kami/Ex/ProcDecInv (real: 4.24, user: 1.78, sys: 0.26, mem: 495196 ko) +File "./Kami/Ex/ProcDecSC.v", line 46, characters 2-59: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcDecSC.v", line 47, characters 2-61: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcDecSC (real: 4.07, user: 0.93, sys: 0.30, mem: 493232 ko) +Kami/Ex/ProcDecSCN (real: 2.30, user: 0.81, sys: 0.29, mem: 488468 ko) +Kami/Ex/ProcFDInl (real: 81.62, user: 68.57, sys: 0.68, mem: 1312068 ko) +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +pcv cannot be defined because it is informative and fetchDecode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: Hpcv cannot be defined because the projection pcv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +pgmv cannot be defined because it is informative and fetchDecode_inv is not. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: Hpgmv cannot be defined because the projection pgmv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +fepochv cannot be defined because it is informative and fetchDecode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hfepochv cannot be defined because the projection fepochv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +f2dfullv cannot be defined because it is informative and fetchDecode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hf2dfullv cannot be defined because the projection f2dfullv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +f2deltv cannot be defined because it is informative and fetchDecode_inv is +not. [cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hf2deltv cannot be defined because the projection f2deltv was not defined. +[cannot-define-projection,records] +File "./Kami/Ex/ProcFDInv.v", line 103, characters 2-743: +Warning: +Hinv cannot be defined because the projections pcv, pgmv, fepochv, f2dfullv, +f2deltv were not defined. [cannot-define-projection,records] +Kami/Ex/ProcFDInv (real: 2.76, user: 2.42, sys: 0.23, mem: 526316 ko) +File "./Kami/Ex/ProcFDCorrect.v", line 96, characters 2-73: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./Kami/Ex/ProcFDCorrect.v", line 97, characters 2-75: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +Kami/Ex/ProcFDCorrect (real: 1.11, user: 0.83, sys: 0.23, mem: 526908 ko) +Kami/Ex/ProcFourStDec (real: 1.06, user: 0.80, sys: 0.23, mem: 527136 ko) +Warning: bedrock2/deps/coqutil/src (used in -R or -Q) is not a subdirectory of the current directory + +bedrock2/processor/src/KamiWord (real: 1.30, user: 0.45, sys: 0.16, mem: 358800 ko) +bedrock2/processor/src/Test (real: 3.56, user: 1.51, sys: 0.22, mem: 473632 ko) +bedrock2/processor/src/KamiRiscv (real: 27.54, user: 25.47, sys: 0.35, mem: 729768 ko) + vp ] md) -> (ma ++ mc)%kami <<=[ vp ] (mb ++ md)%kami +simpleFifo + : string -> nat -> Kind -> Modules + = Mod + [("data" :: RegInitDefault (SyntaxKind (Bit dataSize)))%struct; + ("elt.fifo1" + :: RegInitCustom + (existT ConstFullT (list (word dataSize)) #< (nil)%kami_expr + (NativeConst nil nil)))%struct] + [("produce" + :: (fun type : Kind -> Type => + (Read a : Bit dataSize <- "data"; + LET a0 : Bit dataSize <- # (a); + Read a1 <- "elt.fifo1"; + Write "elt.fifo1" <- + Var type (list (type (Bit dataSize))) #< (nil) + ((fix app (l m : list (type (Bit dataSize))) {struct l} : + list (type (Bit dataSize)) := + match l with + | nil => m + | a2 :: l1 => a2 :: app l1 m + end) a1 [a0]); + LET _ : Void <- $$ (WO); + Write "data" : Bit dataSize <- # (a) + $$ ($ (1)); + Ret $$ (WO))%kami_action))%struct; + ("doDouble" + :: (fun type : Kind -> Type => + (LET _ : Void <- $$ (WO); + Read a0 <- "elt.fifo1"; + Assert ! + $$ + (match a0 with + | nil => true + | _ :: _ => false + end); + Write "elt.fifo1" <- + Var type (list (type (Bit dataSize))) #< (nil) + match a0 with + | nil => nil + | _ :: t => t + end; + LET ak : Bit dataSize <- + match a0 with + | nil => $$ (getDefaultConstBit dataSize) + | h :: _ => # (h) + end; + LET a1 : Bit dataSize <- $$ ($ (2)) * # (ak); + CallM _ : Void <- "enq.fifo2" (# (a1) : + Bit dataSize); Ret $$ (WO))%kami_action))%struct] nil + : Modules +COQC Kami/Ex/IsaRv32PgmExt.v +COQC Kami/Ex/ProcThreeStInv.v +COQC Kami/Ex/ProcFDInl.v +impl = +fun dataSize : nat => +(stage1 dataSize ++ + fifo1 dataSize ++ stage2 dataSize ++ fifo2 dataSize ++ stage3 dataSize)%kami + : nat -> Modules + +Argument scope is [nat_scope] +COQC Kami/Ex/ProcThreeStDec.v +COQC Kami/Ex/ProcDecInv.v +COQC Kami/Ex/ProcDecSC.v +COQC Kami/Ex/ProcDecSCN.v +COQC Kami/Ex/ProcFDInv.v +COQC Kami/Ex/ProcFDCorrect.v +COQC Kami/Ex/ProcFourStDec.v +make[3]: Leaving directory 'bedrock2/deps/kami' +make[2]: Leaving directory 'bedrock2/deps/kami' +make -C bedrock2/processor +make[2]: Entering directory 'bedrock2/processor' +printf -- '-Q bedrock2/deps/coqutil/src coqutil\n-Q bedrock2/deps/riscv-coq/src riscv\n-R bedrock2/deps/kami/Kami/ Kami\n-Q ./src processor\n' > _CoqProject +/builds/coq/coq/_install_ci/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = bedrock2 -arg "-async-proofs-tac-j 1" bedrock2/processor/src/Test.v bedrock2/processor/src/KamiWord.v bedrock2/processor/src/KamiRiscv.v -o Makefile.coq.all +make -f Makefile.coq.all +make[3]: Entering directory 'bedrock2/processor' +COQDEP VFILES +COQC bedrock2/processor/src/Test.v +COQC bedrock2/processor/src/KamiWord.v +COQC bedrock2/processor/src/KamiRiscv.v +make[3]: Leaving directory 'bedrock2/processor' +make[2]: Leaving directory 'bedrock2/processor' +make[1]: Leaving directory 'bedrock2' diff --git a/test-suite/micromega/example_nia.v b/test-suite/micromega/example_nia.v index 8de631aa6a..485c24f0c9 100644 --- a/test-suite/micromega/example_nia.v +++ b/test-suite/micromega/example_nia.v @@ -435,6 +435,12 @@ Goal forall (R : sz + d * sz - sz * x >= 1), False. Proof. + (* Manual proof. + assert (H : sz >= 2) by GE + R. + assert (GEd : x - d >= 1 by GE / H + assert (Rd : 1 + d - x >= 1 by R / H) + 1 >= 2 by GEd + Rd + *) intros. assert (x - d >= 1) by nia. nia. diff --git a/test-suite/micromega/rsyntax.v b/test-suite/micromega/rsyntax.v new file mode 100644 index 0000000000..02b98b562f --- /dev/null +++ b/test-suite/micromega/rsyntax.v @@ -0,0 +1,75 @@ +Require Import ZArith. +Require Import Lra. +Require Import Reals. + +Goal (1 / (1 - 1) = 0)%R. + Fail lra. (* division by zero *) +Abort. + +Goal (0 / (1 - 1) = 0)%R. + lra. (* 0 * x = 0 *) +Qed. + +Goal (10 ^ 2 = 100)%R. + lra. (* pow is reified as a constant *) +Qed. + +Goal (2 / (1/2) ^ 2 = 8)%R. + lra. (* pow is reified as a constant *) +Qed. + + +Goal ( IZR (Z.sqrt 4) = 2)%R. +Proof. + Fail lra. +Abort. + +Require Import DeclConstant. + +Instance Dsqrt : DeclaredConstant Z.sqrt := {}. + +Goal ( IZR (Z.sqrt 4) = 2)%R. +Proof. + lra. +Qed. + +Require Import QArith. +Require Import Qreals. + +Goal (Q2R (1 # 2) = 1/2)%R. +Proof. + lra. +Qed. + +Goal ( 1 ^ (2 + 2) = 1)%R. +Proof. + Fail lra. +Abort. + +Instance Dplus : DeclaredConstant Init.Nat.add := {}. + +Goal ( 1 ^ (2 + 2) = 1)%R. +Proof. + lra. +Qed. + +Require Import Lia. + +Goal ( 1 ^ (2 + 2) = 1)%Z. +Proof. + Fail lia. + reflexivity. +Qed. + +Instance DZplus : DeclaredConstant Z.add := {}. + +Goal ( 1 ^ (2 + 2) = 1)%Z. +Proof. + lia. +Qed. + + +Goal (1 / IZR (Z.pow_pos 10 25) = 1 / 10 ^ 25)%R. +Proof. + lra. +Qed. diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 239bc69360..55691f553c 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -82,11 +82,48 @@ Proof. lia. Qed. +Section S. + Variables x y: Z. + Variables XGe : x >= 0. + Variables YGt : y > 0. + Variables YLt : y < 0. + + Goal False. + Proof using - XGe. + lia. + Qed. + + Goal False. + Proof using YGt YLt x y. + lia. + Qed. + + End S. + (* Bug 5073 *) Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. Proof. lia. Qed. +Lemma ex_pos : forall x, exists z t, x = z - t /\ z >= 0 /\ t >= 0. +Proof. + intros. + destruct (dec_Zge x 0). + exists x, 0. + lia. + exists 0, (-x). + lia. +Qed. - +Goal forall + (b q r : Z) + (H : b * q + r <= 0) + (H5 : - b < r) + (H6 : r <= 0) + (H2 : 0 <= b), + b = 0 -> False. +Proof. + intros b q r. + lia. +Qed. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index 36992e4dda..7429a521b3 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -7,6 +7,8 @@ Require Import QMicromega. Require Import RMicromega. Recursive Extraction - List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + List.map simpl_cone (*map_cone indexes*) + denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/test-suite/output/NumeralNotations.out b/test-suite/output/NumeralNotations.out new file mode 100644 index 0000000000..cb49e66ed7 --- /dev/null +++ b/test-suite/output/NumeralNotations.out @@ -0,0 +1,186 @@ +The command has indeed failed with message: +Unexpected term (nat -> nat) while parsing a numeral notation. +The command has indeed failed with message: +Unexpected non-option term opaque4 while parsing a numeral notation. +The command has indeed failed with message: +Unexpected term (fun (A : Type) (x : A) => x) while parsing a numeral +notation. +let v := 0%ppp in v : punit + : punit +let v := 0%ppp in v : punit + : punit +let v := 0%ppp in v : punit + : punit +let v := 0%ppp in v : punit + : punit +let v := 0%uto in v : unit + : unit +The command has indeed failed with message: +Cannot interpret this number as a value of type unit +The command has indeed failed with message: +Cannot interpret this number as a value of type unit +let v := 0%upp in v : unit + : unit +let v := 0%upp in v : unit + : unit +let v := 0%upp in v : unit + : unit +let v := 0%ppps in v : punit + : punit +File "stdin", line 91, characters 2-46: +Warning: To avoid stack overflow, large numbers in punit are interpreted as +applications of pto_punits. [abstract-large-number,numbers] +The command has indeed failed with message: +In environment +v := pto_punits (Decimal.D1 Decimal.Nil) : punit +The term "v" has type "punit@{Set}" while it is expected to have type + "punit@{u}". +S + : nat -> nat +S (ack 4 4) + : nat +let v := 0%wnat in v : wnat + : wnat +0%wnat + : wnat +{| unwrap := ack 4 4 |} + : wnat +{| Test6.unwrap := 0 |} + : Test6.wnat +let v := 0%wnat in v : Test6.wnat + : Test6.wnat +let v := 0%wuint in v : wuint + : wuint +let v := 1%wuint in v : wuint + : wuint +let v := 0%wuint8 in v : wuint + : wuint +let v := 0 in v : nat + : nat +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "wuint". + = {| unwrap := Decimal.D0 Decimal.Nil |} + : wuint +let v := 0%wuint8' in v : wuint + : wuint +let v := 0%wuint9 in v : wuint + : wuint +let v := 0%wuint9' in v : wuint + : wuint +let v := 0 in v : nat + : nat +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "wuint". +File "stdin", line 202, characters 2-72: +Warning: The 'abstract after' directive has no effect when the parsing +function (of_uint) targets an option type. +[abstract-large-number-no-op,numbers] +The command has indeed failed with message: +The 'abstract after' directive has no effect when the parsing function +(of_uint) targets an option type. [abstract-large-number-no-op,numbers] +The command has indeed failed with message: +The reference of_uint was not found in the current environment. +The command has indeed failed with message: +The reference of_uint was not found in the current environment. +let v := of_uint (Decimal.D1 Decimal.Nil) in v : unit + : unit +let v := 0%test13 in v : unit + : unit +The command has indeed failed with message: +to_uint' is bound to a notation that does not denote a reference. +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +to_uint'' is bound to a notation that does not denote a reference. +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +let v := 0%test14' in v : unit + : unit +let v := 0%test14' in v : unit + : unit +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +let v := 0%test14' in v : unit + : unit +The command has indeed failed with message: +This command does not support the Global option in sections. +let v := 0%test14'' in v : unit + : unit +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +The command has indeed failed with message: +In environment +v := 0 : nat +The term "v" has type "nat" while it is expected to have type "unit". +let v := 0%test15 in v : unit + : unit +let v := 0%test15 in v : unit + : unit +let v := 0%test15 in v : unit + : unit +let v := foo a.t in v : Foo + : Foo +The command has indeed failed with message: +Cannot interpret in test16_scope because NumeralNotations.Test16.F.Foo could not be found in the current environment. +let v := 0%test17 in v : myint63 + : myint63 +let v := 0%Q in v : Q + : Q +let v := 1%Q in v : Q + : Q +let v := 2%Q in v : Q + : Q +let v := 3%Q in v : Q + : Q +let v := 4%Q in v : Q + : Q + = (0, 1) + : nat * nat + = (1, 1) + : nat * nat + = (2, 1) + : nat * nat + = (3, 1) + : nat * nat + = (4, 1) + : nat * nat +let v := (-1)%Zlike in v : Zlike + : Zlike +let v := 0%Zlike in v : Zlike + : Zlike +let v := 1%Zlike in v : Zlike + : Zlike +let v := 2%Zlike in v : Zlike + : Zlike +let v := 3%Zlike in v : Zlike + : Zlike +let v := 4%Zlike in v : Zlike + : Zlike +2%Zlike + : Zlike +0%Zlike + : Zlike diff --git a/test-suite/success/NumeralNotations.v b/test-suite/output/NumeralNotations.v index 7b857c70c5..fcfdd82dcc 100644 --- a/test-suite/success/NumeralNotations.v +++ b/test-suite/output/NumeralNotations.v @@ -1,5 +1,7 @@ (* Test that we fail, rather than raising anomalies, on opaque terms during interpretation *) +Declare Scope opaque_scope. + (* https://github.com/coq/coq/pull/8064#discussion_r202497516 *) Module Test1. Axiom hold : forall {A B C}, A -> B -> C. @@ -19,6 +21,8 @@ Module Test2. Fail Check 1%opaque. End Test2. +Declare Scope silly_scope. + Module Test3. Inductive silly := SILLY (v : Decimal.uint) (f : forall A, A -> A). Definition to_silly (v : Decimal.uint) := SILLY v (fun _ x => x). @@ -28,8 +32,18 @@ Module Test3. Fail Check 1%silly. End Test3. - Module Test4. + Declare Scope opaque_scope. + Declare Scope silly_scope. + Declare Scope pto. + Declare Scope ppo. + Declare Scope ptp. + Declare Scope ppp. + Declare Scope uto. + Declare Scope upo. + Declare Scope utp. + Declare Scope upp. + Declare Scope ppps. Polymorphic NonCumulative Inductive punit := ptt. Polymorphic Definition pto_punit (v : Decimal.uint) : option punit := match Nat.of_uint v with O => Some ptt | _ => None end. Polymorphic Definition pto_punit_all (v : Decimal.uint) : punit := ptt. @@ -102,6 +116,7 @@ Module Test6. Definition to_uint (x : wnat) : Decimal.uint := Nat.to_uint x. Definition of_uint (x : Decimal.uint) : wnat := Nat.of_uint x. Module Export Scopes. + Declare Scope wnat_scope. Delimit Scope wnat_scope with wnat. End Scopes. Module Export Notations. @@ -123,6 +138,7 @@ End Test6_2. Module Test7. Local Set Primitive Projections. Record wuint := wrap { unwrap : Decimal.uint }. + Declare Scope wuint_scope. Delimit Scope wuint_scope with wuint. Numeral Notation wuint wrap unwrap : wuint_scope. Check let v := 0%wuint in v : wuint. @@ -132,6 +148,8 @@ End Test7. Module Test8. Local Set Primitive Projections. Record wuint := wrap { unwrap : Decimal.uint }. + Declare Scope wuint8_scope. + Declare Scope wuint8'_scope. Delimit Scope wuint8_scope with wuint8. Delimit Scope wuint8'_scope with wuint8'. Section with_var. @@ -152,6 +170,8 @@ Module Test8. End Test8. Module Test9. + Declare Scope wuint9_scope. + Declare Scope wuint9'_scope. Delimit Scope wuint9_scope with wuint9. Delimit Scope wuint9'_scope with wuint9'. Section with_let. @@ -175,6 +195,8 @@ Module Test10. Definition to_uint (v : unit) := Nat.to_uint 0. Definition of_uint (v : Decimal.uint) := match Nat.of_uint v with O => Some tt | _ => None end. Definition of_any_uint (v : Decimal.uint) := tt. + Declare Scope unit_scope. + Declare Scope unit2_scope. Delimit Scope unit_scope with unit. Delimit Scope unit2_scope with unit2. Numeral Notation unit of_uint to_uint : unit_scope (abstract after 1). @@ -188,6 +210,7 @@ End Test10. Module Test11. (* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) Inductive unit11 := tt11. + Declare Scope unit11_scope. Delimit Scope unit11_scope with unit11. Goal True. evar (to_uint : unit11 -> Decimal.uint). @@ -201,6 +224,7 @@ End Test11. Module Test12. (* Test for numeral notations on context variables *) + Declare Scope test12_scope. Delimit Scope test12_scope with test12. Section test12. Context (to_uint : unit -> Decimal.uint) (of_uint : Decimal.uint -> unit). @@ -212,6 +236,9 @@ End Test12. Module Test13. (* Test for numeral notations on notations which do not denote references *) + Declare Scope test13_scope. + Declare Scope test13'_scope. + Declare Scope test13''_scope. Delimit Scope test13_scope with test13. Delimit Scope test13'_scope with test13'. Delimit Scope test13''_scope with test13''. @@ -232,6 +259,10 @@ Module Test14. (* Test that numeral notations follow [Import], not [Require], and also test that [Local Numeral Notation]s do not escape modules nor sections. *) + Declare Scope test14_scope. + Declare Scope test14'_scope. + Declare Scope test14''_scope. + Declare Scope test14'''_scope. Delimit Scope test14_scope with test14. Delimit Scope test14'_scope with test14'. Delimit Scope test14''_scope with test14''. @@ -263,6 +294,7 @@ End Test14. Module Test15. (** Test module include *) + Declare Scope test15_scope. Delimit Scope test15_scope with test15. Module Inner. Definition to_uint (x : unit) : Decimal.uint := Nat.to_uint O. @@ -280,6 +312,7 @@ End Test15. Module Test16. (** Test functors *) + Declare Scope test16_scope. Delimit Scope test16_scope with test16. Module Type A. Axiom T : Set. @@ -305,9 +338,71 @@ Require Import Coq.Numbers.Cyclic.Int63.Int63. Module Test17. (** Test int63 *) Declare Scope test17_scope. + Declare Scope test17_scope. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. Numeral Notation myint63 of_int to_int : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. + +Module Test18. + (** Test https://github.com/coq/coq/issues/9840 *) + Record Q := { num : nat ; den : nat ; reduced : Nat.gcd num den = 1 }. + Declare Scope Q_scope. + Delimit Scope Q_scope with Q. + + Definition nat_eq_dec (x y : nat) : {x = y} + {x <> y}. + Proof. decide equality. Defined. + + Definition transparentify {A} (D : {A} + {not A}) (H : A) : A := + match D with + | left pf => pf + | right npf => match npf H with end + end. + + Axiom gcd_good : forall x, Nat.gcd x 1 = 1. + + Definition Q_of_nat (x : nat) : Q := {| num := x ; den := 1 ; reduced := transparentify (nat_eq_dec _ _) (gcd_good _) |}. + Definition nat_of_Q (x : Q) : option nat + := if Nat.eqb x.(den) 1 then Some (x.(num)) else None. + Definition Q_of_uint (x : Decimal.uint) : Q := Q_of_nat (Nat.of_uint x). + Definition uint_of_Q (x : Q) : option Decimal.uint + := option_map Nat.to_uint (nat_of_Q x). + + Numeral Notation Q Q_of_uint uint_of_Q : Q_scope. + + Check let v := 0%Q in v : Q. + Check let v := 1%Q in v : Q. + Check let v := 2%Q in v : Q. + Check let v := 3%Q in v : Q. + Check let v := 4%Q in v : Q. + Compute let v := 0%Q in (num v, den v). + Compute let v := 1%Q in (num v, den v). + Compute let v := 2%Q in (num v, den v). + Compute let v := 3%Q in (num v, den v). + Compute let v := 4%Q in (num v, den v). +End Test18. + +Require Import Coq.Lists.List. +Require Import Coq.ZArith.ZArith. +Module Test19. + (** Test another thing related to https://github.com/coq/coq/issues/9840 *) + Record Zlike := { summands : list Z }. + Declare Scope Zlike_scope. + Delimit Scope Zlike_scope with Zlike. + + Definition Z_of_Zlike (x : Zlike) := List.fold_right Z.add 0%Z (summands x). + Definition Zlike_of_Z (x : Z) := {| summands := cons x nil |}. + + Numeral Notation Zlike Zlike_of_Z Z_of_Zlike : Zlike_scope. + + Check let v := (-1)%Zlike in v : Zlike. + Check let v := 0%Zlike in v : Zlike. + Check let v := 1%Zlike in v : Zlike. + Check let v := 2%Zlike in v : Zlike. + Check let v := 3%Zlike in v : Zlike. + Check let v := 4%Zlike in v : Zlike. + Check {| summands := (cons 1 (cons 2 (cons (-1) nil)))%Z |}. + Check {| summands := nil |}. +End Test19. diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 2713e6a188..35f36e87d7 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -1,5 +1,6 @@ Set Printing Projections. +Set Primitive Projections. Class HostFunction := host_func : Type. diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out new file mode 100644 index 0000000000..2a7ce806d7 --- /dev/null +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -0,0 +1,33 @@ +File "stdin", line 10, characters 0-28: +Warning: Ambiguous paths: [ac; cd] : A >-> D [ambiguous-paths,typechecker] +[ab] : A >-> B +[ab; bd] : A >-> D +[ac] : A >-> C +[bd] : B >-> D +[cd] : C >-> D +[B_A] : B >-> A +[C_A] : C >-> A +[D_B] : D >-> B +[D_A] : D >-> A +[D_C] : D >-> C +[A'_A] : A' >-> A +[B_A'] : B >-> A' +[B_A'; A'_A] : B >-> A +[C_A'] : C >-> A' +[C_A'; A'_A] : C >-> A +[D_B; B_A'] : D >-> A' +[D_A] : D >-> A +[D_B] : D >-> B +[D_C] : D >-> C +File "stdin", line 103, characters 0-86: +Warning: Ambiguous paths: [D_C; C_A'] : D >-> A' +[ambiguous-paths,typechecker] +[A'_A] : A' >-> A +[B_A'] : B >-> A' +[B_A'; A'_A] : B >-> A +[C_A'] : C >-> A' +[C_A'; A'_A] : C >-> A +[D_B; B_A'] : D >-> A' +[D_A] : D >-> A +[D_B] : D >-> B +[D_C] : D >-> C diff --git a/test-suite/output/relaxed_ambiguous_paths.v b/test-suite/output/relaxed_ambiguous_paths.v new file mode 100644 index 0000000000..a4af27539c --- /dev/null +++ b/test-suite/output/relaxed_ambiguous_paths.v @@ -0,0 +1,109 @@ +Module test1. +Section test1. + +Variable (A B C D : Type). +Variable (ab : A -> B) (bd : B -> D) (ac : A -> C) (cd : C -> D). + +Local Coercion ab : A >-> B. +Local Coercion bd : B >-> D. +Local Coercion ac : A >-> C. +Local Coercion cd : C >-> D. + +Print Graph. + +End test1. +End test1. + +Module test2. +Section test2. +Variable (A : Type) (P Q : A -> Prop). + +Record B := { + B_A : A; + B_P : P B_A }. + +Record C := { + C_A : A; + C_Q : Q C_A }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion B_A : B >-> A. +Local Coercion C_A : C >-> A. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B := Build_B (D_A d) (D_P d). +Local Coercion D_C (d : D) : C := Build_C (D_A d) (D_Q d). + +Print Graph. + +End test2. +End test2. + +Module test3. +Section test3. + +Variable (A : Type) (P Q : A -> Prop). + +Definition A' (x : bool) := A. + +Record B (x : bool) := { + B_A' : A' x; + B_P : P B_A' }. + +Record C (x : bool) := { + C_A' : A' x; + C_Q : Q C_A' }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion A'_A (x : bool) (a : A' x) : A := a. +Local Coercion B_A' : B >-> A'. +Local Coercion C_A' : C >-> A'. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B false := Build_B false (D_A d) (D_P d). +Local Coercion D_C (d : D) : C true := Build_C true (D_A d) (D_Q d). + +Print Graph. + +End test3. +End test3. + +Module test4. +Section test4. + +Variable (A : Type) (P Q : A -> Prop). + +Record A' (x : bool) := { A'_A : A }. + +Record B (x : bool) := { + B_A' : A' x; + B_P : P (A'_A x B_A') }. + +Record C (x : bool) := { + C_A' : A' x; + C_Q : Q (A'_A x C_A') }. + +Record D := { + D_A : A; + D_P : P D_A; + D_Q : Q D_A }. + +Local Coercion A'_A : A' >-> A. +Local Coercion B_A' : B >-> A'. +Local Coercion C_A' : C >-> A'. +Local Coercion D_A : D >-> A. +Local Coercion D_B (d : D) : B false := + Build_B false (Build_A' false (D_A d)) (D_P d). +Local Coercion D_C (d : D) : C true := + Build_C true (Build_A' true (D_A d)) (D_Q d). + +Print Graph. + +End test4. +End test4. diff --git a/test-suite/ssr/elim_noquant.v b/test-suite/ssr/elim_noquant.v new file mode 100644 index 0000000000..e6662203e9 --- /dev/null +++ b/test-suite/ssr/elim_noquant.v @@ -0,0 +1,29 @@ +Require Import ssreflect. + + +Axiom app : forall T, list T -> list T -> list T. +Arguments app {_}. +Infix "++" := app. + +Lemma test (aT rT : Type) + (pmap : (aT -> option rT) -> list aT -> list rT) + (perm_eq : list rT -> list rT -> Prop) + (f : aT -> option rT) + (g : rT -> aT) + (s t : list aT) + (E : forall T : list aT -> Type, + (forall s1 s2 s3 : list aT, + T (s1 ++ s2 ++ s3) -> T (s2 ++ s1 ++ s3)) -> + T s -> T t) : + perm_eq (pmap f s) (pmap f t). +Proof. +elim/E: (t). +Admitted. + + +Lemma test2 (a b : nat) : a = b -> b = 1. +Proof. +elim. +match goal with |- a = 1 => idtac end. +Admitted. + diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 9a815d2a7e..63f907e567 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1835,36 +1835,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Implicit Types e : elt. Definition empty : t elt := Bst (empty_bst elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). - Definition mem x m : bool := Raw.mem x m.(this). - Definition find x m : option elt := Raw.find x m.(this). - Definition map f m : t elt' := Bst (map_bst f m.(is_bst)). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Bst (add_bst x e (is_bst m)). + Definition remove x m : t elt := Bst (remove_bst x (is_bst m)). + Definition mem x m : bool := Raw.mem x (this m). + Definition find x m : option elt := Raw.find x (this m). + Definition map f m : t elt' := Bst (map_bst f (is_bst m)). Definition mapi (f:key->elt->elt') m : t elt' := - Bst (mapi_bst f m.(is_bst)). + Bst (mapi_bst f (is_bst m)). Definition map2 f m (m':t elt') : t elt'' := - Bst (map2_bst f m.(is_bst) m'.(is_bst)). - Definition elements m : list (key*elt) := Raw.elements m.(this). - Definition cardinal m := Raw.cardinal m.(this). - Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). + Bst (map2_bst f (is_bst m) (is_bst m')). + Definition elements m : list (key*elt) := Raw.elements (this m). + Definition cardinal m := Raw.cardinal (this m). + Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f (this m) i. + Definition equal cmp m m' : bool := Raw.equal cmp (this m) (this m'). - Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). - Definition In x m : Prop := Raw.In0 x m.(this). - Definition Empty m : Prop := Empty m.(this). + Definition MapsTo x e m : Prop := Raw.MapsTo x e (this m). + Definition In x m : Prop := Raw.In0 x (this m). + Definition Empty m : Prop := Empty (this m). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. + Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. @@ -1876,9 +1876,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_1 _ (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_2 _ (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. @@ -1890,22 +1890,22 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. + Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@find_2 elt m.(this)). Qed. + Proof. intros m; exact (@find_2 elt (this m)). Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). @@ -1920,13 +1920,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. + Proof. intro m; exact (@elements_cardinal elt (this m)). Qed. Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := @@ -1962,7 +1962,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed. Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. @@ -1973,7 +1973,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. @@ -1987,8 +1987,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') @@ -1997,8 +1997,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. End IntMake. @@ -2124,7 +2124,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (* Proofs about [eq] and [lt] *) Definition selements (m1 : t) := - LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). + LO.MapS.Build_slist (P.elements_sort (is_bst m1)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 7bc9edff8d..b23885154b 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -466,39 +466,39 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Implicit Types e : elt. Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). - Definition is_empty m : bool := is_empty m.(this). + Definition is_empty m : bool := is_empty (this m). Definition add x e m : t elt := - Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). + Bbst (add_bst x e (is_bst m)) (add_avl x e (is_avl m)). Definition remove x m : t elt := - Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). - Definition mem x m : bool := mem x m.(this). - Definition find x m : option elt := find x m.(this). + Bbst (remove_bst x (is_bst m)) (remove_avl x (is_avl m)). + Definition mem x m : bool := mem x (this m). + Definition find x m : option elt := find x (this m). Definition map f m : t elt' := - Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). + Bbst (map_bst f (is_bst m)) (map_avl f (is_avl m)). Definition mapi (f:key->elt->elt') m : t elt' := - Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). + Bbst (mapi_bst f (is_bst m)) (mapi_avl f (is_avl m)). Definition map2 f m (m':t elt') : t elt'' := - Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). - Definition elements m : list (key*elt) := elements m.(this). - Definition cardinal m := cardinal m.(this). - Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this). + Bbst (map2_bst f (is_bst m) (is_bst m')) (map2_avl f (is_avl m) (is_avl m')). + Definition elements m : list (key*elt) := elements (this m). + Definition cardinal m := cardinal (this m). + Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f (this m) i. + Definition equal cmp m m' : bool := equal cmp (this m) (this m'). - Definition MapsTo x e m : Prop := MapsTo x e m.(this). - Definition In x m : Prop := In0 x m.(this). - Definition Empty m : Prop := Empty m.(this). + Definition MapsTo x e m : Prop := MapsTo x e (this m). + Definition In x m : Prop := In0 x (this m). + Definition Empty m : Prop := Empty (this m). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. + Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. @@ -510,9 +510,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_1 _ (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_2 _ (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. @@ -524,22 +524,22 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. - apply m.(is_bst). + apply (is_bst m). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. + Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. + Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@find_2 elt m.(this)). Qed. + Proof. intros m; exact (@find_2 elt (this m)). Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). @@ -554,13 +554,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). - Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. + Proof. intro m; exact (@elements_cardinal elt (this m)). Qed. Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := @@ -596,7 +596,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed. Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. @@ -607,7 +607,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. @@ -621,8 +621,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') @@ -631,8 +631,8 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. - apply m.(is_bst). - apply m'.(is_bst). + apply (is_bst m). + apply (is_bst m'). Qed. End IntMake. @@ -655,7 +655,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: match D.compare e e' with EQ _ => true | _ => false end. Definition elements (m:t) := - LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). + LO.MapS.Build_slist (Raw.Proofs.elements_sort (is_bst m)). (** * As comparison function, we propose here a non-structural version faithful to the code of Ocaml's Map library, instead of @@ -750,7 +750,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (* Proofs about [eq] and [lt] *) Definition selements (m1 : t) := - LO.MapS.Build_slist (elements_sort m1.(is_bst)). + LO.MapS.Build_slist (elements_sort (is_bst m1)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 4febd64842..335fdc3232 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1037,106 +1037,106 @@ Section Elt. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_sorted elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e). + Definition find x m : option elt := Raw.find x (this m). + Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x). + Definition mem x m : bool := Raw.mem x (this m). + Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f). + Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f). Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). - Definition elements m : list (key*elt) := @Raw.elements elt m.(this). - Definition cardinal m := length m.(this). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). + Build_slist (Raw.map2_sorted f (sorted m) (sorted m')). + Definition elements m : list (key*elt) := @Raw.elements elt (this m). + Definition cardinal m := length (this m). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. + Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - Definition Empty m : Prop := Raw.Empty m.(this). + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). + Definition In x m : Prop := Raw.PX.In x (this m). + Definition Empty m : Prop := Raw.Empty (this m). Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed. + Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed. Lemma empty_1 : Empty empty. Proof. exact (@Raw.empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. + Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. + Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. + Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), @@ -1144,14 +1144,14 @@ Section Elt. find x (map2 f m m') = f (find x m) (find x m'). Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). + exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). + exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x). Qed. End Make. @@ -1182,7 +1182,7 @@ Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := | _, _ => False end. -Definition eq m m' := eq_list m.(this) m'.(this). +Definition eq m m' := eq_list (this m) (this m'). Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := match m, m' with @@ -1197,7 +1197,7 @@ Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := end end. -Definition lt m m' := lt_list m.(this) m'.(this). +Definition lt m m' := lt_list (this m) (this m'). Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. Proof. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index a923f4e6f9..12550ddf9a 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -882,102 +882,102 @@ Section Elt. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). - Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). + Definition is_empty m : bool := Raw.is_empty (this m). + Definition add x e m : t elt := Build_slist (Raw.add_NoDup (NoDup m) x e). + Definition find x m : option elt := Raw.find x (this m). + Definition remove x m : t elt := Build_slist (Raw.remove_NoDup (NoDup m) x). + Definition mem x m : bool := Raw.mem x (this m). + Definition map f m : t elt' := Build_slist (Raw.map_NoDup (NoDup m) f). + Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup (NoDup m) f). Definition map2 f m (m':t elt') : t elt'' := - Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). - Definition elements m : list (key*elt) := @Raw.elements elt m.(this). - Definition cardinal m := length m.(this). - Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. - Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - Definition Empty m : Prop := Raw.Empty m.(this). + Build_slist (Raw.map2_NoDup f (NoDup m) (NoDup m')). + Definition elements m : list (key*elt) := @Raw.elements elt (this m). + Definition cardinal m := length (this m). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i. + Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m'). + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m). + Definition In x m : Prop := Raw.PX.In x (this m). + Definition Empty m : Prop := Raw.Empty (this m). Definition Equal m m' := forall y, find y m = find y m'. Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m'). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed. + Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. - Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.mem_1 elt (this m) (NoDup m)). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.mem_2 elt (this m) (NoDup m)). Qed. Lemma empty_1 : Empty empty. Proof. exact (@Raw.empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). - Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.remove_1 elt (this m) (NoDup m)). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.remove_2 elt (this m) (NoDup m)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.remove_3 elt (this m) (NoDup m)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.find_1 elt (this m) (NoDup m)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed. Lemma elements_3w : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. + Proof. intros m; exact (@Raw.elements_3w elt (this m) (NoDup m)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. + Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed. Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. - Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. + Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. + Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (NoDup m) (this m') (NoDup m')). Qed. End Elt. Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed. Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. + Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), @@ -985,14 +985,14 @@ Section Elt. find x (map2 f m m') = f (find x m) (find x m'). Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). + exact (@Raw.map2_1 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros elt elt' elt'' m m' x f; - exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). + exact (@Raw.map2_2 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x). Qed. End Make. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 59b2f789ab..3f8840529e 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -170,7 +170,7 @@ Qed. Lemma equal_cardinal: equal s s'=true -> cardinal s=cardinal s'. Proof. -auto with set. +auto with set fset. Qed. (* Properties of [subset] *) @@ -268,7 +268,7 @@ Proof. intros; apply bool_1; split; intros. rewrite MP.cardinal_1; simpl; auto with set. assert (cardinal s = 0) by (apply zerob_true_elim; auto). -auto with set. +auto with set fset. Qed. (** Properties of [singleton] *) @@ -551,7 +551,7 @@ End Fold. Lemma add_cardinal_1: forall s x, mem x s=true -> cardinal (add x s)=cardinal s. Proof. -auto with set. +auto with set fset. Qed. Lemma add_cardinal_2: @@ -846,9 +846,9 @@ Lemma sum_plus : Proof. unfold sum. intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto. +assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto with fset. assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. -assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto. +assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto with fset. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 17f0e25e7a..6b6546f82d 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -21,8 +21,8 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op Proper respectful : core. -Hint Extern 1 (Equivalence _) => constructor; congruence : core. +Hint Unfold transpose compat_op Proper respectful : fset. +Hint Extern 1 (Equivalence _) => constructor; congruence : fset. (** First, a functor for Weak Sets in functorial version. *) @@ -708,7 +708,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. Proof. - intros; rewrite cardinal_fold; apply fold_1; auto. + intros; rewrite cardinal_fold; apply fold_1; auto with fset. Qed. Lemma cardinal_2 : @@ -716,7 +716,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ => S) x). - apply fold_2; auto. + apply fold_2; auto with fset. Qed. (** ** Cardinal and (non-)emptiness *) @@ -732,7 +732,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. - Hint Resolve cardinal_inv_1 : core. + Hint Resolve cardinal_inv_1 : fset. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. @@ -757,7 +757,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry. remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. induction n; intros. - apply cardinal_1; rewrite <- H; auto. + apply cardinal_1; rewrite <- H; auto with fset. destruct (cardinal_inv_2 Heqn) as (x,H2). revert Heqn. rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. @@ -769,13 +769,13 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). exact Equal_cardinal. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : fset. (** ** Cardinal and set operators *) Lemma empty_cardinal : cardinal empty = 0. Proof. - rewrite cardinal_fold; apply fold_1; auto with set. + rewrite cardinal_fold; apply fold_1; auto with set fset. Qed. Hint Immediate empty_cardinal cardinal_1 : set. @@ -795,7 +795,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma union_cardinal: @@ -804,7 +804,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. - apply fold_union; auto. + apply fold_union; auto with fset. Qed. Lemma subset_cardinal : @@ -838,7 +838,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. do 4 rewrite cardinal_fold. do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@Logic.eq nat); auto. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma union_cardinal_inter : @@ -860,7 +860,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. - auto with set. + auto with set fset. Qed. Lemma add_cardinal_2 : @@ -869,7 +869,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. do 2 rewrite cardinal_fold. change S with ((fun _ => S) x); - apply fold_add with (eqA:=@Logic.eq nat); auto. + apply fold_add with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma remove_cardinal_1 : @@ -878,16 +878,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. do 2 rewrite cardinal_fold. change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with fset. Qed. Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. Proof. - auto with set. + auto with set fset. Qed. - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : fset. End WProperties_fun. @@ -952,7 +952,7 @@ Module OrdProperties (M:S). red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. - Hint Resolve gtb_compat leb_compat : core. + Hint Resolve gtb_compat leb_compat : fset. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. @@ -1047,7 +1047,7 @@ Module OrdProperties (M:S). (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. case_eq (max_elt s); intros. apply X0 with (remove e s) e; auto with set. apply IHn. @@ -1068,7 +1068,7 @@ Module OrdProperties (M:S). (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset. case_eq (min_elt s); intros. apply X0 with (remove e s) e; auto with set. apply IHn. diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 86894cd1f2..4576ff4cbe 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -74,8 +74,8 @@ Record retract_cond : Prop := (** The dependent elimination above implies the axiom of choice: *) -Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a. -Proof. intros r. exact r.(inv2). Qed. +Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a. +Proof. intros r. exact (inv2 r). Qed. End Retracts. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 0ba2799bfb..6a18f59fc4 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -445,7 +445,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Arguments Mkt this {is_ok}. Hint Resolve is_ok : typeclass_instances. - Definition In (x : elt)(s : t) := M.In x s.(this). + Definition In (x : elt)(s : t) := M.In x (this s). Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'. Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'. Definition Empty (s : t) := forall a : elt, ~ In a s. diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index e66130b347..d16b5a3020 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -82,7 +82,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs elim (Hyp eps eps_pos) ; intros delta Hyp2. assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0). clear-a lb ub a_encad delta. - apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. + apply Rmin_pos ; [exact ((cond_pos delta)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond). intros h h_neq h_encad. replace (g (a + h) - g a) with (f (a + h) - f a). @@ -120,7 +120,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs elim (Hyp eps eps_pos) ; intros delta Hyp2. assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0). clear-a lb ub a_encad delta. - apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. + apply Rmin_pos ; [exact ((cond_pos delta)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition. exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond). intros h h_neq h_encad. replace (f (a + h) - f a) with (g (a + h) - g a). @@ -696,7 +696,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. intros deltatemp' Htemp'. exists deltatemp'. split. - exact deltatemp'.(cond_pos). + exact (cond_pos deltatemp'). intros htemp cond. apply (Htemp' htemp). exact (proj1 cond). @@ -721,7 +721,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. assert (mydelta_pos : mydelta > 0). unfold mydelta, Rmin. case (Rle_dec delta alpha). - intro ; exact (delta.(cond_pos)). + intro ; exact ((cond_pos delta)). intro ; exact alpha_pos. elim (g_cont mydelta mydelta_pos). intros delta' new_g_cont. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 59e0148625..e17f02bb6e 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -15,7 +15,6 @@ Require Import Rbase. Require Import R_Ifp. -Require Import Lra. Local Open Scope R_scope. Implicit Type r : R. @@ -357,7 +356,9 @@ Qed. Lemma Rle_abs : forall x:R, x <= Rabs x. Proof. - intro; unfold Rabs; case (Rcase_abs x); intros; lra. + intro; unfold Rabs; case (Rcase_abs x); intros;auto with real. + apply Rminus_le; rewrite <- Rplus_0_r; + unfold Rminus; rewrite Ropp_involutive; auto with real. Qed. Definition RRle_abs := Rle_abs. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index b6b72de889..2bfd99ebc7 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -136,7 +136,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') eps > 0 -> exists alp : R, alp > 0 /\ - (forall x:Base X, D x /\ X.(dist) x x0 < alp -> X'.(dist) (f x) l < eps). + (forall x:Base X, D x /\ (dist X) x x0 < alp -> (dist X') (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -165,9 +165,9 @@ Lemma tech_limit : Proof. intros f D l x0 H H0. case (Rabs_pos (f x0 - l)); intros H1. - absurd (R_met.(@dist) (f x0) l < R_met.(@dist) (f x0) l). + absurd ((@dist R_met) (f x0) l < (@dist R_met) (f x0) l). apply Rlt_irrefl. - case (H0 (R_met.(@dist) (f x0) l)); auto. + case (H0 ((@dist R_met) (f x0) l)); auto. intros alpha1 [H2 H3]; apply H3; auto; split; auto. case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto. case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 346c300ee5..4591c7ed94 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -128,9 +128,9 @@ Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. [EqualityType] and [DecidableType] *) Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. - Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _). - Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _). - Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _). + Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. + Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. + Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. End BackportEq. Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 854dd25b75..3d07661d56 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -34,6 +34,24 @@ def reformat_time_string(time): minutes, seconds = divmod(seconds, 60) return '%dm%02d.%ss' % (minutes, seconds, milliseconds) +def get_file_lines(file_name): + if file_name == '-': + if hasattr(sys.stdin, 'buffer'): + lines = sys.stdin.buffer.readlines() + else: + lines = sys.stdin.readlines() + else: + with open(file_name, 'rb') as f: + lines = f.readlines() + for line in lines: + try: + yield line.decode('utf-8') + except UnicodeDecodeError: # invalid utf-8 + pass + +def get_file(file_name): + return ''.join(get_file_lines(file_name)) + def get_times(file_name): ''' Reads the contents of file_name, which should be the output of @@ -41,11 +59,7 @@ def get_times(file_name): names to compile durations, as strings. Removes common prefixes using STRIP_REG and STRIP_REP. ''' - if file_name == '-': - lines = sys.stdin.read() - else: - with open(file_name, 'r', encoding="utf-8") as f: - lines = f.read() + lines = get_file(file_name) reg = re.compile(r'^([^\s]+) \([^\)]*?user: ([0-9\.]+)[^\)]*?\)\s*$', re.MULTILINE) times = reg.findall(lines) if all(time in ('0.00', '0.01') for name, time in times): @@ -61,11 +75,7 @@ def get_single_file_times(file_name): 'coqc -time', and parses it to construct a dict mapping lines to to compile durations, as strings. ''' - if file_name == '-': - lines = sys.stdin.read() - else: - with open(file_name, 'r', encoding="utf-8") as f: - lines = f.read() + lines = get_file(file_name) reg = re.compile(r'^Chars ([0-9]+) - ([0-9]+) ([^ ]+) ([0-9\.]+) secs (.*)$', re.MULTILINE) times = reg.findall(lines) if len(times) == 0: return dict() @@ -209,11 +219,10 @@ def make_table_string(times_dict, def print_or_write_table(table, files): if len(files) == 0 or '-' in files: - try: - binary_stdout = sys.stdout.buffer - except AttributeError: - binary_stdout = sys.stdout - print(table.encode("utf-8"), file=binary_stdout) + if hasattr(sys.stdout, 'buffer'): + sys.stdout.buffer.write(table.encode("utf-8")) + else: + sys.stdout.write(table.encode("utf-8")) for file_name in files: if file_name != '-': with open(file_name, 'w', encoding="utf-8") as f: diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 3fe6ad0718..416ea88c1b 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -85,7 +85,7 @@ let ensure_exists f = let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Proof_global.get_all_proof_names () in + let pfs = Vernacstate.Proof_global.get_all_proof_names () in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index d4107177a7..fd4c515209 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -46,8 +46,9 @@ let coqc_main () = outputstate copts; flush_all(); + if opts.Coqargs.output_context then begin - let sigma, env = Pfedit.get_current_context () in + let sigma, env = let e = Global.env () in Evd.from_env e, e in Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 1094fc86b4..b3de8dd85f 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -191,8 +191,8 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Proof_global.get_current_proof_name ())) ^ " < " - with Proof_global.NoCurrentProof -> + (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " + with Vernacstate.Proof_global.NoCurrentProof -> "Coq < " (* the coq prompt added to the default one when in emacs mode @@ -353,7 +353,7 @@ let print_anyway c = let top_goal_print ~doc c oldp newp = try let proof_changed = not (Option.equal cproof oldp newp) in - let print_goals = proof_changed && Proof_global.there_are_pending_proofs () || + let print_goals = proof_changed && Vernacstate.Proof_global.there_are_pending_proofs () || print_anyway c in if not !Flags.quiet && print_goals then begin let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index ef1dc6993b..038ff54bf6 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -70,7 +70,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Proof_global.give_me_the_proof_opt () in + let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird @@ -91,7 +91,8 @@ let load_vernac_core ~echo ~check ~interactive ~state file = let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in let in_pa = - Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile file)) + (Stream.of_channel in_chan) in let open State in (* ids = For beautify, list of parsed sids *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 1981e24ae4..6a67a1b5d0 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -31,7 +31,7 @@ open Entries let refine_instance = ref false let () = Goptions.(declare_bool_option { - optdepr = false; + optdepr = true; optname = "definition of instances by refining"; optkey = ["Refine";"Instance";"Mode"]; optread = (fun () -> !refine_instance); @@ -144,7 +144,7 @@ let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps (ConstRef cst) -let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = +let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if program_mode then let hook _ _ vis gr = @@ -163,33 +163,44 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id in let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context sigma in - ignore (Obligations.add_definition id ?term:constr - ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls) + let _progress = Obligations.add_definition id ?term:constr + ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls in + pstate else - Flags.silently (fun () -> + Some Flags.(silently (fun () -> (* spiwack: it is hard to reorder the actions to do 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 - Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) + let pstate = Lemmas.start_proof ~ontop:pstate id ~pl:decl kind sigma (EConstr.of_constr termtype) ~hook:(Lemmas.mk_hook - (fun _ _ _ -> instance_hook k pri global imps ?hook)); + (fun _ _ _ -> instance_hook k pri global imps ?hook)) in (* spiwack: I don't know what to do with the status here. *) - if not (Option.is_empty term) then - let init_refine = - Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); - Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); - Tactics.New.reduce_after_refine; - ] - in - ignore (Pfedit.by init_refine) - else ignore (Pfedit.by (Tactics.auto_intros_tac ids)); - (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) () + let pstate = + if not (Option.is_empty term) then + let init_refine = + Tacticals.New.tclTHENLIST [ + Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); + Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); + Tactics.New.reduce_after_refine; + ] + in + let pstate, _ = Pfedit.by init_refine pstate in + pstate + else + let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in + pstate + in + match tac with + | Some tac -> + let pstate, _ = Pfedit.by tac pstate in + pstate + | None -> + pstate) ()) -let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -269,12 +280,14 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in - if not (Evd.has_undefined sigma) && not (Option.is_empty props) then - declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype - else if program_mode || refine || Option.is_empty props then - declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype - else CErrors.user_err Pp.(str "Unsolved obligations remaining."); - id + let pstate = + if not (Evd.has_undefined sigma) && not (Option.is_empty props) then + (declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype; + None) + else if program_mode || refine || Option.is_empty props then + declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype + else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in + id, pstate let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in @@ -318,7 +331,7 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode +let new_instance ~pstate ?(global=false) ?(refine= !refine_instance) ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -334,7 +347,7 @@ let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode + do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props let declare_new_instance ?(global=false) ~program_mode poly ctx (instid, bk, cl) pri = @@ -358,7 +371,7 @@ let named_of_rel_context l = l ([], []) in ctx -let context poly l = +let context ~pstate poly l = let env = Global.env() in let sigma = Evd.from_env env in let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in @@ -426,12 +439,12 @@ let context poly l = let decl = (Discharge, poly, Definitional) in let nstatus = match b with | None -> - pi3 (ComAssumption.declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl + pi3 (ComAssumption.declare_assumption ~pstate false decl (t, univs) UnivNames.empty_binders [] impl Declaremods.NoInline (CAst.make id)) | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in - let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] in + let _gr = DeclareDef.declare_definition ~ontop:pstate id decl entry UnivNames.empty_binders [] in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/classes.mli b/vernac/classes.mli index 7e0ec42625..73e4b024ef 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -40,6 +40,7 @@ val declare_instance_constant : unit val new_instance : + pstate:Proof_global.t option -> ?global:bool (** Not global by default. *) -> ?refine:bool (** Allow refinement *) -> program_mode:bool -> @@ -51,7 +52,8 @@ val new_instance : ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr -> - Id.t + (* May open a proof *) + Id.t * Proof_global.t option val declare_new_instance : ?global:bool (** Not global by default. *) -> @@ -74,4 +76,8 @@ val id_of_class : typeclass -> Id.t (** returns [false] if, for lack of section, it declares an assumption (unless in a module type). *) -val context : Decl_kinds.polymorphic -> local_binder_expr list -> bool +val context + : pstate:Proof_global.t option + -> Decl_kinds.polymorphic + -> local_binder_expr list + -> bool diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 37a33daf8f..d7bd64067b 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -42,7 +42,7 @@ let should_axiom_into_instance = function true | Global | Local -> !axiom_into_instance -let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = +let declare_assumption ~pstate is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with @@ -53,7 +53,7 @@ match local with let _ = declare_variable ident decl in let () = assumption_message ident in let () = - if not !Flags.quiet && Proof_global.there_are_pending_proofs () then + if not !Flags.quiet && Option.has_some pstate then Feedback.msg_info Pp.(str"Variable" ++ spc () ++ Id.print ident ++ strbrk " is not visible from current goals") in @@ -96,11 +96,11 @@ let next_uctx = | Polymorphic_entry _ as uctx -> uctx | Monomorphic_entry _ -> empty_uctx -let declare_assumptions idl is_coe k (c,uctx) pl imps nl = +let declare_assumptions ~pstate idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = List.fold_left (fun (refs,status,uctx) id -> let ref',u',status' = - declare_assumption is_coe k (c,uctx) pl imps false nl id in + declare_assumption ~pstate is_coe k (c,uctx) pl imps false nl id in (ref',u')::refs, status' && status, next_uctx uctx) ([],true,uctx) idl in @@ -132,7 +132,7 @@ let process_assumptions_udecls kind l = in udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l -let do_assumptions ~program_mode kind nl l = +let do_assumptions ~pstate ~program_mode kind nl l = let open Context.Named.Declaration in let env = Global.env () in let udecl, l = process_assumptions_udecls kind l in @@ -173,7 +173,7 @@ let do_assumptions ~program_mode kind nl l = let ubinders = Evd.universe_binders sigma in pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in - let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in + let refs, status' = declare_assumptions ~pstate idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 2b794b001a..32914cc11b 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -17,8 +17,13 @@ open Decl_kinds (** {6 Parameters/Assumptions} *) -val do_assumptions : program_mode:bool -> locality * polymorphic * assumption_object_kind -> - Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool +val do_assumptions + : pstate:Proof_global.t option + -> program_mode:bool + -> locality * polymorphic * assumption_object_kind + -> Declaremods.inline + -> (ident_decl list * constr_expr) with_coercion list + -> bool (************************************************************************) (** Internal API *) @@ -28,10 +33,16 @@ val do_assumptions : program_mode:bool -> locality * polymorphic * assumption_ob (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> - types in_universes_entry -> - UnivNames.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Declaremods.inline -> variable CAst.t -> - GlobRef.t * Univ.Instance.t * bool +val declare_assumption + : pstate:Proof_global.t option + -> coercion_flag + -> assumption_kind + -> types in_universes_entry + -> UnivNames.universe_binders + -> Impargs.manual_implicits + -> bool (** implicit *) + -> Declaremods.inline + -> variable CAst.t + -> GlobRef.t * Univ.Instance.t * bool val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 28773a3965..feaf47df18 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -90,7 +90,7 @@ let check_definition ~program_mode (ce, evd, _, imps) = check_evars_are_solved ~program_mode env evd; ce -let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = +let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = interp_definition ~program_mode univdecl bl (pi2 k) red_option c ctypopt in @@ -114,4 +114,4 @@ let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - ignore(DeclareDef.declare_definition ident k ?hook_data ce (Evd.universe_binders evd) imps ) + ignore(DeclareDef.declare_definition ~ontop ident k ?hook_data ce (Evd.universe_binders evd) imps) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 9cb6190fcc..12853d83e0 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -16,11 +16,18 @@ open Constrexpr (** {6 Definitions/Let} *) -val do_definition : program_mode:bool -> - ?hook:Lemmas.declaration_hook -> - Id.t -> definition_kind -> universe_decl_expr option -> - local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> unit +val do_definition + : ontop:Proof_global.t option + -> program_mode:bool + -> ?hook:Lemmas.declaration_hook + -> Id.t + -> definition_kind + -> universe_decl_expr option + -> local_binder_expr list + -> red_expr option + -> constr_expr + -> constr_expr option + -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 2f00b41b7c..2aadbd224f 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,7 +255,8 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = +let declare_fixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = + let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -265,8 +266,9 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None + Some + (Lemmas.start_proof_with_initialization ~ontop (local,poly,DefinitionBody Fixpoint) + evd pl (Some(false,indexes,init_tac)) thms None) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -282,15 +284,18 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; - end; + None + end in (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + pstate -let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = +let declare_cofixpoint ~ontop local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = + let pstate = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -300,8 +305,8 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None + Some (Lemmas.start_proof_with_initialization ~ontop (Global,poly, DefinitionBody CoFixpoint) + evd pl (Some(true,[],init_tac)) thms None) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -314,13 +319,15 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + ignore (List.map4 (DeclareDef.declare_fix ~ontop (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) - cofixpoint_message fixnames - end; + cofixpoint_message fixnames; + None + end in (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + pstate let extract_decreasing_argument limit = function | (na,CStructRec) -> na @@ -348,16 +355,18 @@ let check_safe () = let flags = Environ.typing_flags (Global.env ()) in flags.check_universes && flags.check_guarded -let do_fixpoint local poly l = +let do_fixpoint ~ontop local poly l = let fixl, ntns = extract_fixpoint_components true l in let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences info in - declare_fixpoint local poly fix possible_indexes ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + let pstate = declare_fixpoint ~ontop local poly fix possible_indexes ntns in + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); + pstate -let do_cofixpoint local poly l = +let do_cofixpoint ~ontop local poly l = let fixl,ntns = extract_cofixpoint_components l in let cofix = interp_fixpoint ~cofix:true fixl ntns in - declare_cofixpoint local poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + let pstate = declare_cofixpoint ~ontop local poly cofix ntns in + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); + pstate diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 9bcb53697b..15ff5f4498 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,12 +19,14 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : + ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t option val do_cofixpoint : + ontop:Proof_global.t option -> (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t option (************************************************************************) (** Internal API *) @@ -81,15 +83,20 @@ val interp_fixpoint : (** [Not used so far] *) val declare_fixpoint : + ontop:Proof_global.t option -> locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - Proof_global.lemma_possible_guards -> decl_notation list -> unit + Proof_global.lemma_possible_guards -> decl_notation list -> + Proof_global.t option -val declare_cofixpoint : locality -> polymorphic -> +val declare_cofixpoint : + ontop:Proof_global.t option -> + locality -> polymorphic -> recursive_preentry * UState.universe_decl * UState.t * (Constr.rel_context * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit + decl_notation list -> + Proof_global.t option (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 7dcd098183..052832244b 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -33,12 +33,12 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_definition ident (local, p, k) ?hook_data ce pl imps = +let declare_definition ~ontop ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with | Discharge when Lib.sections_are_opened () -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in - let () = if Proof_global.there_are_pending_proofs () then warn_definition_not_visible ident in + let () = if Option.has_some ontop then warn_definition_not_visible ident in VarRef ident | Discharge | Local | Global -> let local = get_locality ident ~kind:"definition" local in @@ -57,9 +57,9 @@ let declare_definition ident (local, p, k) ?hook_data ce pl imps = end; gr -let declare_fix ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = +let declare_fix ~ontop ?(opaque = false) ?hook_data (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - declare_definition f kind ?hook_data ce pl imps + declare_definition ~ontop f kind ?hook_data ce pl imps let check_definition_evars ~allow_evars sigma = let env = Global.env () in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 3f95ec7107..8e4f4bf7fb 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -14,7 +14,8 @@ open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition - : Id.t + : ontop:Proof_global.t option + -> Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> Safe_typing.private_constants Entries.definition_entry @@ -23,7 +24,8 @@ val declare_definition -> GlobRef.t val declare_fix - : ?opaque:bool + : ontop:Proof_global.t option + -> ?opaque:bool -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) -> definition_kind -> UnivNames.universe_binders diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 1a07d74a0e..f1a08cc9b3 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -247,10 +247,10 @@ type (_, _) entry = | TTReference : ('self, qualid) entry | TTBigint : ('self, Constrexpr.raw_natural_number) entry | TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry -| TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry +| TTConstrList : prod_info * string Tok.p list * 'r target -> ('r, 'r list) entry | TTPattern : int -> ('self, cases_pattern_expr) entry | TTOpenBinderList : ('self, local_binder_expr list) entry -| TTClosedBinderList : Tok.t list -> ('self, local_binder_expr list list) entry +| TTClosedBinderList : string Tok.p list -> ('self, local_binder_expr list list) entry type _ any_entry = TTAny : ('s, 'r) entry -> 's any_entry @@ -319,41 +319,49 @@ let is_binder_level from e = match e with let make_sep_rules = function | [tk] -> Atoken tk | tkl -> - let rec mkrule : Tok.t list -> string rules = function - | [] -> Rules ({ norec_rule = Stop }, fun _ -> (* dropped anyway: *) "") + let rec mkrule : 'a Tok.p list -> 'a rules = function + | [] -> Rules (Stop, fun _ -> (* dropped anyway: *) "") | tkn :: rem -> - let Rules ({ norec_rule = r }, f) = mkrule rem in - let r = { norec_rule = Next (r, Atoken tkn) } in + let Rules (r, f) = mkrule rem in + let r = NextNoRec (r, Atoken tkn) in Rules (r, fun _ -> f) in let r = mkrule (List.rev tkl) in Arules [r] -let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) symbol = fun custom p assoc from forpat -> - if custom = InConstrEntry && is_binder_level from p then Aentryl (target_entry InConstrEntry forpat, "200") - else if is_self from p then Aself +type ('s, 'a) mayrec_symbol = +| MayRecNo : ('s, norec, 'a) symbol -> ('s, 'a) mayrec_symbol +| MayRecMay : ('s, mayrec, 'a) symbol -> ('s, 'a) mayrec_symbol + +let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) mayrec_symbol = fun custom p assoc from forpat -> + if custom = InConstrEntry && is_binder_level from p then MayRecNo (Aentryl (target_entry InConstrEntry forpat, "200")) + else if is_self from p then MayRecMay Aself else let g = target_entry custom forpat in let lev = adjust_level assoc from p in begin match lev with - | None -> Aentry g - | Some None -> Anext - | Some (Some (lev, cur)) -> Aentryl (g, string_of_int lev) + | None -> MayRecNo (Aentry g) + | Some None -> MayRecMay Anext + | Some (Some (lev, cur)) -> MayRecNo (Aentryl (g, string_of_int lev)) end -let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) symbol = fun assoc from typ -> match typ with +let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with | TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat | TTConstrList (typ', [], forpat) -> - Alist1 (symbol_of_target InConstrEntry typ' assoc from forpat) + begin match symbol_of_target InConstrEntry typ' assoc from forpat with + | MayRecNo s -> MayRecNo (Alist1 s) + | MayRecMay s -> MayRecMay (Alist1 s) end | TTConstrList (typ', tkl, forpat) -> - Alist1sep (symbol_of_target InConstrEntry typ' assoc from forpat, make_sep_rules tkl) -| TTPattern p -> Aentryl (Constr.pattern, string_of_int p) -| TTClosedBinderList [] -> Alist1 (Aentry Constr.binder) -| TTClosedBinderList tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl) -| TTName -> Aentry Prim.name -| TTOpenBinderList -> Aentry Constr.open_binders -| TTBigint -> Aentry Prim.bigint -| TTReference -> Aentry Constr.global + begin match symbol_of_target InConstrEntry typ' assoc from forpat with + | MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl)) + | MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end +| TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p)) +| TTClosedBinderList [] -> MayRecNo (Alist1 (Aentry Constr.binder)) +| TTClosedBinderList tkl -> MayRecNo (Alist1sep (Aentry Constr.binder, make_sep_rules tkl)) +| TTName -> MayRecNo (Aentry Prim.name) +| TTOpenBinderList -> MayRecNo (Aentry Constr.open_binders) +| TTBigint -> MayRecNo (Aentry Prim.bigint) +| TTReference -> MayRecNo (Aentry Constr.global) let interp_entry forpat e = match e with | ETProdName -> TTAny TTName @@ -406,8 +414,8 @@ match e with | TTConstrList _ -> { subst with constrlists = v :: subst.constrlists } type (_, _) ty_symbol = -| TyTerm : Tok.t -> ('s, string) ty_symbol -| TyNonTerm : 's target * ('s, 'a) entry * ('s, 'a) symbol * bool -> ('s, 'a) ty_symbol +| TyTerm : string Tok.p -> ('s, string) ty_symbol +| TyNonTerm : 's target * ('s, 'a) entry * ('s, 'a) mayrec_symbol * bool -> ('s, 'a) ty_symbol type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule @@ -444,11 +452,23 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> in ty_eval rem f { env with constrs; constrlists; } -let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function -| TyStop -> Stop +type ('s, 'a, 'r) mayrec_rule = +| MayRecRNo : ('s, Extend.norec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule +| MayRecRMay : ('s, Extend.mayrec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule + +let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) mayrec_rule = function +| TyStop -> MayRecRNo Stop | TyMark (_, _, _, r) -> ty_erase r -| TyNext (rem, TyTerm tok) -> Next (ty_erase rem, Atoken tok) -| TyNext (rem, TyNonTerm (_, _, s, _)) -> Next (ty_erase rem, s) +| TyNext (rem, TyTerm tok) -> + begin match ty_erase rem with + | MayRecRNo rem -> MayRecRMay (Next (rem, Atoken tok)) + | MayRecRMay rem -> MayRecRMay (Next (rem, Atoken tok)) end +| TyNext (rem, TyNonTerm (_, _, s, _)) -> + begin match ty_erase rem, s with + | MayRecRNo rem, MayRecNo s -> MayRecRMay (Next (rem, s)) + | MayRecRNo rem, MayRecMay s -> MayRecRMay (Next (rem, s)) + | MayRecRMay rem, MayRecNo s -> MayRecRMay (Next (rem, s)) + | MayRecRMay rem, MayRecMay s -> MayRecRMay (Next (rem, s)) end type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -485,7 +505,7 @@ let rec pure_sublevels' custom assoc from forpat level = function let rem = pure_sublevels' custom assoc from forpat level rem in let push where p rem = match symbol_of_target custom p assoc from forpat with - | Aentryl (_,i) when level <> Some (int_of_string i) -> (where,int_of_string i) :: rem + | MayRecNo (Aentryl (_,i)) when level <> Some (int_of_string i) -> (where,int_of_string i) :: rem | _ -> rem in (match e with | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem @@ -507,7 +527,6 @@ let extend_constr state forpat ng = let (entry, level) = interp_constr_entry_key custom forpat n in let fold (accu, state) pt = let AnyTyRule r = make_ty_rule assoc n forpat pt in - let symbs = ty_erase r in let pure_sublevels = pure_sublevels' custom assoc n forpat level pt in let isforpat = target_to_bool forpat in let needed_levels, state = register_empty_levels state isforpat pure_sublevels in @@ -515,7 +534,11 @@ let extend_constr state forpat ng = let empty_rules = List.map (prepare_empty_levels forpat) needed_levels in let empty = { constrs = []; constrlists = []; binders = []; binderlists = [] } in let act = ty_eval r (make_act forpat ng.notgram_notation) empty in - let rule = (name, p4assoc, [Rule (symbs, act)]) in + let rule = + let r = match ty_erase r with + | MayRecRNo symbs -> Rule (symbs, act) + | MayRecRMay symbs -> Rule (symbs, act) in + name, p4assoc, [r] in let r = ExtendRule (entry, reinit, (pos, [rule])) in (accu @ empty_rules @ [r], state) in diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 89caff847f..bc58993a2e 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -19,17 +19,17 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - ('a raw_abstract_argument_type * ('s, 'a) symbol) Loc.located -> 's grammar_prod_item + ('a raw_abstract_argument_type * ('s, _, 'a) symbol) Loc.located -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) -type ('self, _, 'r) ty_rule = -| TyStop : ('self, 'r, 'r) ty_rule -| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option -> - ('self, 'b -> 'a, 'r) ty_rule +type ('self, 'tr, _, 'r) ty_rule = +| TyStop : ('self, Extend.norec, 'r, 'r) ty_rule +| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Extend.symbol * 'b ty_arg option -> + ('self, Extend.mayrec, 'b -> 'a, 'r) ty_rule type ('self, 'r) any_ty_rule = -| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule +| AnyTyRule : ('self, _, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule let rec ty_rule_of_gram = function | [] -> AnyTyRule TyStop @@ -44,13 +44,13 @@ let rec ty_rule_of_gram = function let r = TyNext (rem, tok, inj) in AnyTyRule r -let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function +let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Extend.rule = function | TyStop -> Extend.Stop | TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r -let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +let rec ty_eval : type s tr a. (s, tr, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f | TyNext (rem, tok, Some inj) -> fun f x -> diff --git a/vernac/egramml.mli b/vernac/egramml.mli index 3689f60383..1cf75a55b1 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : ('a Genarg.raw_abstract_argument_type * - ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item + ('s, _, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : extend_name -> vernac_expr Pcoq.Entry.t option -> diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 0d0732cbb4..1c7cc5e636 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -213,8 +213,11 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let default_thm_id = Id.of_string "Unnamed_thm" -let fresh_name_for_anonymous_theorem () = - let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in +let fresh_name_for_anonymous_theorem ~pstate = + let avoid = match pstate with + | None -> Id.Set.empty + | Some pstate -> Id.Set.of_list (Proof_global.get_all_proof_names pstate) + in next_global_ident_away default_thm_id avoid let check_name_freshness locality {CAst.loc;v=id} : unit = @@ -224,7 +227,7 @@ let check_name_freshness locality {CAst.loc;v=id} : unit = then user_err ?loc (Id.print id ++ str " already exists.") -let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in let k = IsAssumption Conjectural in match body with @@ -260,7 +263,6 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) | _ -> - let sigma, env = Pfedit.get_current_context () in anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in let body_i = body_i body in match locality with @@ -333,7 +335,7 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : declaration_hook option) c = +let start_proof ~ontop id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard @@ -344,7 +346,7 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : | None -> initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - Proof_global.start_proof sigma id ?pl kind goals terminator + Proof_global.start_proof ~ontop sigma id ?pl kind goals terminator let rec_tac_initializer finite guard thms snl = if finite then @@ -360,7 +362,7 @@ let rec_tac_initializer finite guard thms snl = | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = +let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms snl = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> @@ -386,18 +388,20 @@ let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = let norm c = EConstr.to_constr (Evd.from_ctx ctx) c in let body = Option.map EConstr.of_constr body in let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in - List.map_i (save_remaining_recthms kind norm uctx body opaq) 1 other_thms in + let env = Global.env () in + List.map_i (save_remaining_recthms env sigma kind norm uctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in - start_proof id ~pl:decl kind sigma t ~hook ~compute_guard:guard; - ignore (Proof_global.with_current_proof (fun _ p -> + let pstate = start_proof ~ontop id ~pl:decl kind sigma t ~hook ~compute_guard:guard in + let pstate, _ = Proof_global.with_current_proof (fun _ p -> match init_tac with | None -> p,(true,[]) - | Some tac -> Proof.run_tactic Global.(env ()) tac p)) + | Some tac -> Proof.run_tactic Global.(env ()) tac p) pstate in + pstate -let start_proof_com ~program_mode ?inference_hook ?hook kind thms = +let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in @@ -429,7 +433,7 @@ let start_proof_com ~program_mode ?inference_hook ?hook kind thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization ?hook kind evd decl recguard thms snl + start_proof_with_initialization ~ontop ?hook kind evd decl recguard thms snl (* Saving a proof *) @@ -444,58 +448,65 @@ let () = optread = (fun () -> !keep_admitted_vars); optwrite = (fun b -> keep_admitted_vars := b) } -let save_proof ?proof = function - | Vernacexpr.Admitted -> - let pe = - let open Proof_global in - match proof with - | Some ({ id; entries; persistence = k; universes }, _) -> - if List.length entries <> 1 then - user_err Pp.(str "Admitted does not support multiple statements"); - let { const_entry_secctx; const_entry_type } = List.hd entries in - if const_entry_type = None then - user_err Pp.(str "Admitted requires an explicit statement"); - let typ = Option.get const_entry_type in - let ctx = UState.univ_entry ~poly:(pi2 k) universes in - let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in - Admitted(id, k, (sec_vars, (typ, ctx), None), universes) - | None -> - let pftree = Proof_global.give_me_the_proof () in - let gk = Proof_global.get_current_persistence () in - let Proof.{ name; poly; entry } = Proof.data pftree in - let typ = match Proofview.initial_goals entry with - | [typ] -> snd typ - | _ -> - CErrors.anomaly - ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") - in - let typ = EConstr.Unsafe.to_constr typ in - let universes = Proof.((data pftree).initial_euctx) in - (* This will warn if the proof is complete *) - let pproofs, _univs = - Proof_global.return_proof ~allow_partial:true () in - let sec_vars = - if not !keep_admitted_vars then None - else match Proof_global.get_used_variables(), pproofs with - | Some _ as x, _ -> x - | None, (pproof, _) :: _ -> - let env = Global.env () in - let ids_typ = Environ.global_vars_set env typ in - let ids_def = Environ.global_vars_set env pproof in - Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) - | _ -> None in - let decl = Proof_global.get_universe_decl () in - let ctx = UState.check_univ_decl ~poly universes decl in - Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) - in - Proof_global.apply_terminator (Proof_global.get_terminator ()) pe - | Vernacexpr.Proved (opaque,idopt) -> - let (proof_obj,terminator) = - match proof with - | None -> - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) - | Some proof -> proof +let save_proof_admitted ?proof ~pstate = + let pe = + let open Proof_global in + match proof with + | Some ({ id; entries; persistence = k; universes }, _) -> + if List.length entries <> 1 then + user_err Pp.(str "Admitted does not support multiple statements"); + let { const_entry_secctx; const_entry_type } = List.hd entries in + if const_entry_type = None then + user_err Pp.(str "Admitted requires an explicit statement"); + let typ = Option.get const_entry_type in + let ctx = UState.univ_entry ~poly:(pi2 k) universes in + let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in + Admitted(id, k, (sec_vars, (typ, ctx), None), universes) + | None -> + let pftree = Proof_global.give_me_the_proof pstate in + let gk = Proof_global.get_current_persistence pstate in + let Proof.{ name; poly; entry } = Proof.data pftree in + let typ = match Proofview.initial_goals entry with + | [typ] -> snd typ + | _ -> + CErrors.anomaly + ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") in - (* if the proof is given explicitly, nothing has to be deleted *) - if Option.is_empty proof then Proof_global.discard_current (); - Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))) + let typ = EConstr.Unsafe.to_constr typ in + let universes = Proof.((data pftree).initial_euctx) in + (* This will warn if the proof is complete *) + let pproofs, _univs = + Proof_global.return_proof ~allow_partial:true pstate in + let sec_vars = + if not !keep_admitted_vars then None + else match Proof_global.get_used_variables pstate, pproofs with + | Some _ as x, _ -> x + | None, (pproof, _) :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + let ids_def = Environ.global_vars_set env pproof in + Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) + | _ -> None in + let decl = Proof_global.get_universe_decl pstate in + let ctx = UState.check_univ_decl ~poly universes decl in + Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) + in + Proof_global.apply_terminator (Proof_global.get_terminator pstate) pe + +let save_proof_proved ?proof ?pstate ~opaque ~idopt = + (* Invariant (uh) *) + if Option.is_empty pstate && Option.is_empty proof then + user_err (str "No focused proof (No proof-editing in progress)."); + let (proof_obj,terminator) = + match proof with + | None -> + (* XXX: The close_proof and proof state API should be refactored + so it is possible to insert proofs properly into the state *) + let pstate = Option.get pstate in + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pstate + | Some proof -> proof + in + (* if the proof is given explicitly, nothing has to be deleted *) + let pstate = if Option.is_empty proof then Proof_global.discard_current Option.(get pstate) else pstate in + Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))); + pstate diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 72c666e903..1f70cfa1ad 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -37,30 +37,32 @@ val call_hook -> ?fix_exn:Future.fix_exn -> hook_type -val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> +val start_proof : ontop:Proof_global.t option -> Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> unit + ?hook:declaration_hook -> EConstr.types -> Proof_global.t -val start_proof_com : - program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> - ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list -> - unit +val start_proof_com + : program_mode:bool + -> ontop:Proof_global.t option + -> ?inference_hook:Pretyping.inference_hook + -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list + -> Proof_global.t -val start_proof_with_initialization : +val start_proof_with_initialization : ontop:Proof_global.t option -> ?hook:declaration_hook -> goal_kind -> Evd.evar_map -> UState.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * - (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> - int list option -> unit + (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + -> int list option -> Proof_global.t val standard_proof_terminator : ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator -val fresh_name_for_anonymous_theorem : unit -> Id.t +val fresh_name_for_anonymous_theorem : pstate:Proof_global.t option -> Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) @@ -69,4 +71,14 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val (** {6 ... } *) -val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit +val save_proof_admitted + : ?proof:Proof_global.closed_proof + -> pstate:Proof_global.t + -> unit + +val save_proof_proved + : ?proof:Proof_global.closed_proof + -> ?pstate:Proof_global.t + -> opaque:Proof_global.opacity_flag + -> idopt:Names.lident option + -> Proof_global.t option diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 3da12e7714..b5e9e1b0d5 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -23,7 +23,6 @@ open Libobject open Constrintern open Vernacexpr open Libnames -open Tok open Notation open Nameops @@ -575,20 +574,20 @@ let is_not_small_constr = function | _ -> false let rec define_keywords_aux = function - | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l + | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(Tok.PIDENT (Some k)) :: l when is_not_small_constr e -> Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); CLexer.add_keyword k; - n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l + n1 :: GramConstrTerminal(Tok.PKEYWORD k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l | [] -> [] (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function - | GramConstrTerminal(IDENT k)::l -> + | GramConstrTerminal(Tok.PIDENT (Some k))::l -> Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); CLexer.add_keyword k; - GramConstrTerminal(KEYWORD k) :: define_keywords_aux l + GramConstrTerminal(Tok.PKEYWORD k) :: define_keywords_aux l | l -> define_keywords_aux l let distribute a ll = List.map (fun l -> a @ l) ll diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 9aca48f529..07194578c1 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -456,7 +456,7 @@ let obligation_substitution expand prg = let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints -let declare_definition prg = +let declare_definition ~ontop prg = let varsubst = obligation_substitution true prg in let body, typ = subst_prog varsubst prg in let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) @@ -475,7 +475,7 @@ let declare_definition prg = let () = progmap_remove prg in let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition prg.prg_name + DeclareDef.declare_definition ~ontop prg.prg_name prg.prg_kind ce ubinders prg.prg_implicits ?hook_data let rec lam_index n t acc = @@ -554,16 +554,14 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let univs = UState.univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 - (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) - fixnames fixdecls fixtypes fiximps - in - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; - Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; - let gr = List.hd kns in - Lemmas.call_hook ?hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; - List.iter progmap_remove l; gr + let kns = List.map4 (DeclareDef.declare_fix ~ontop:None ~opaque (local, poly, kind) UnivNames.empty_binders univs) + fixnames fixdecls fixtypes fiximps in + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; + Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; + let gr = List.hd kns in + Lemmas.call_hook ?hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; + List.iter progmap_remove l; gr let decompose_lam_prod c ty = let open Context.Rel.Declaration in @@ -763,7 +761,7 @@ let update_obls prg obls rem = else ( match prg'.prg_deps with | [] -> - let kn = declare_definition prg' in + let kn = declare_definition ~ontop:None prg' in progmap_remove prg'; Defined kn | l -> @@ -948,7 +946,7 @@ let obligation_hook prg obl num auto ctx' _ _ gr = ignore (auto (Some prg.prg_name) None deps) end -let rec solve_obligation prg num tac = +let rec solve_obligation ~ontop prg num tac = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in @@ -967,20 +965,21 @@ let rec solve_obligation prg num tac = let auto n tac oblset = auto_solve_obligations n ~oblset tac in let terminator ?hook guard = Proof_global.make_terminator - (obligation_terminator ?hook prg.prg_name num guard auto) in + (obligation_terminator prg.prg_name num guard ?hook auto) in let hook = Lemmas.mk_hook (obligation_hook prg obl num auto) in - let () = Lemmas.start_proof ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in - let _ = Pfedit.by !default_tactic in - Option.iter (fun tac -> Proof_global.set_endline_tactic tac) tac + let pstate = Lemmas.start_proof ~ontop ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in + let pstate = fst @@ Pfedit.by !default_tactic pstate in + let pstate = Option.cata (fun tac -> Proof_global.set_endline_tactic tac pstate) pstate tac in + pstate -and obligation (user_num, name, typ) tac = +and obligation ~ontop (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in let obls, rem = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with - None -> solve_obligation prg num tac + | None -> solve_obligation ~ontop prg num tac | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) @@ -1113,7 +1112,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); - let cst = declare_definition prg in + let cst = declare_definition ~ontop:None prg in Defined cst) else ( let len = Array.length obls in @@ -1180,7 +1179,7 @@ let admit_obligations n = let prg = get_prog_err n in admit_prog prg -let next_obligation n tac = +let next_obligation ~ontop n tac = let prg = match n with | None -> get_any_prog_err () | Some _ -> get_prog_err n @@ -1191,7 +1190,7 @@ let next_obligation n tac = | Some i -> i | None -> anomaly (Pp.str "Could not find a solvable obligation.") in - solve_obligation prg i tac + solve_obligation ~ontop prg i tac let check_program_libraries () = Coqlib.check_required_library Coqlib.datatypes_module_name; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index c5720363b4..b1b7b1ec90 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -85,10 +85,17 @@ val add_mutual_definitions : notations -> fixpoint_kind -> unit -val obligation : int * Names.Id.t option * Constrexpr.constr_expr option -> - Genarg.glob_generic_argument option -> unit - -val next_obligation : Names.Id.t option -> Genarg.glob_generic_argument option -> unit +val obligation + : ontop:Proof_global.t option + -> int * Names.Id.t option * Constrexpr.constr_expr option + -> Genarg.glob_generic_argument option + -> Proof_global.t + +val next_obligation + : ontop:Proof_global.t option + -> Names.Id.t option + -> Genarg.glob_generic_argument option + -> Proof_global.t val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 994fad85f0..d474ef8637 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -55,7 +55,7 @@ module Vernac_ = let act_vernac v loc = Some CAst.(make ~loc v) in let act_eoi _ loc = None in let rule = [ - Rule (Next (Stop, Atoken Tok.EOI), act_eoi); + Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); Rule (Next (Stop, Aentry vernac_control), act_vernac); ] in Pcoq.grammar_extend main_entry None (None, [None, None, rule]) diff --git a/vernac/record.ml b/vernac/record.ml index 23274040b0..cb67548667 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -443,7 +443,7 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in let build = ConstructRef cstr in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in - let () = Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs) in + let () = Recordops.declare_structure(cstr, List.rev kinds, List.rev sp_projs) in rsp in List.mapi map record_data diff --git a/vernac/search.ml b/vernac/search.ml index 6610789626..e41378908f 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -59,11 +59,16 @@ let iter_constructors indsp u fn env nconstr = let iter_named_context_name_type f = List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) +let get_current_or_goal_context ?pstate glnum = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_goal_context p glnum + (* General search over hypothesis of a goal *) -let iter_hypothesis glnum (fn : GlobRef.t -> env -> constr -> unit) = +let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in let iter_hyp idh typ = fn (VarRef idh) env typ in - let evmap,e = Pfedit.get_goal_context glnum in + let evmap,e = get_current_or_goal_context ?pstate glnum in let pfctxt = named_context e in iter_named_context_name_type iter_hyp pfctxt @@ -99,10 +104,10 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = try Declaremods.iter_all_segments iter_obj with Not_found -> () -let generic_search glnumopt fn = +let generic_search ?pstate glnumopt fn = (match glnumopt with | None -> () - | Some glnum -> iter_hypothesis glnum fn); + | Some glnum -> iter_hypothesis ?pstate glnum fn); iter_declarations fn (** This module defines a preference on constrs in the form of a @@ -221,7 +226,7 @@ let search_about_filter query gr env typ = match query with (** SearchPattern *) -let search_pattern gopt pat mods pr_search = +let search_pattern ?pstate gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && @@ -231,7 +236,7 @@ let search_pattern gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** SearchRewrite *) @@ -243,7 +248,7 @@ let rewrite_pat1 pat = let rewrite_pat2 pat = PApp (PRef (eq ()), [| PMeta None; PMeta None; pat |]) -let search_rewrite gopt pat mods pr_search = +let search_rewrite ?pstate gopt pat mods pr_search = let pat1 = rewrite_pat1 pat in let pat2 = rewrite_pat2 pat in let blacklist_filter = blacklist_filter_aux () in @@ -256,11 +261,11 @@ let search_rewrite gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** Search *) -let search_by_head gopt pat mods pr_search = +let search_by_head ?pstate gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && @@ -270,11 +275,11 @@ let search_by_head gopt pat mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter (** SearchAbout *) -let search_about gopt items mods pr_search = +let search_about ?pstate gopt items mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in @@ -286,7 +291,7 @@ let search_about gopt items mods pr_search = let iter ref env typ = if filter ref env typ then pr_search ref env typ in - generic_search gopt iter + generic_search ?pstate gopt iter type search_constraint = | Name_Pattern of Str.regexp @@ -301,7 +306,7 @@ type 'a coq_object = { coq_object_object : 'a; } -let interface_search = +let interface_search ?pstate = let rec extract_flags name tpe subtpe mods blacklist = function | [] -> (name, tpe, subtpe, mods, blacklist) | (Name_Pattern regexp, b) :: l -> @@ -371,7 +376,7 @@ let interface_search = let iter ref env typ = if filter_function ref env typ then print_function ref env typ in - let () = generic_search glnum iter in + let () = generic_search ?pstate glnum iter in !ans let blacklist_filter ref env typ = diff --git a/vernac/search.mli b/vernac/search.mli index ecbb02bc68..0f94ddc5b6 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -39,13 +39,13 @@ val search_about_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : int option -> (bool * glob_search_about_item) list +val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -66,12 +66,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : int option -> display_function -> unit +val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 4250ddb02c..d2ba882521 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -44,6 +44,28 @@ let vernac_pperr_endline pp = (* Misc *) +let there_are_pending_proofs ~pstate = + not Option.(is_empty pstate) + +let check_no_pending_proof ~pstate = + if there_are_pending_proofs ~pstate then + user_err Pp.(str "Command not supported (Open proofs remain)") + +let vernac_require_open_proof ~pstate f = + match pstate with + | Some pstate -> f ~pstate + | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") + +let get_current_or_global_context ~pstate = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_current_context p + +let get_goal_or_global_context ~pstate glnum = + match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Pfedit.get_goal_context p glnum + let cl_of_qualid = function | FunClass -> Classops.CL_FUN | SortClass -> Classops.CL_SORT @@ -72,30 +94,37 @@ end (*******************) (* "Show" commands *) -let show_proof () = +let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) - let p = Proof_global.give_me_the_proof () in - let sigma, env = Pfedit.get_current_context () in - let pprf = Proof.partial_proof p in - Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + try + let pstate = Option.get pstate in + let p = Proof_global.give_me_the_proof pstate in + let sigma, env = Pfedit.get_current_context pstate in + let pprf = Proof.partial_proof p in + Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + (* We print nothing if there are no goals left *) + with + | Pfedit.NoSuchGoal + | Option.IsNone -> + user_err (str "No goals to show.") -let show_top_evars () = +let show_top_evars ~pstate = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = Proof_global.give_me_the_proof () in + let pfts = Proof_global.give_me_the_proof pstate in let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) -let show_universes () = - let pfts = Proof_global.give_me_the_proof () in +let show_universes ~pstate = + let pfts = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pfts in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx (* Simulate the Intro(s) tactic *) -let show_intro all = +let show_intro ~pstate all = let open EConstr in - let pf = Proof_global.give_me_the_proof() in + let pf = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pf in if not (List.is_empty goals) then begin let gl = {Evd.it=List.hd goals ; sigma = sigma; } in @@ -224,7 +253,7 @@ let print_modtype qid = with Not_found -> user_err (str"Unknown Module Type or Module " ++ pr_qualid qid) -let print_namespace ns = +let print_namespace ~pstate ns = let ns = List.rev (Names.DirPath.repr ns) in (* [match_dirpath], [match_modulpath] are helpers for [matches] which checks whether a constant is in the namespace [ns]. *) @@ -272,10 +301,10 @@ let print_namespace ns = let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in print_list Id.print qn in - let print_constant k body = + let print_constant ~pstate k body = (* FIXME: universes *) let t = body.Declarations.const_type in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_or_global_context ~pstate in print_kn k ++ str":" ++ spc() ++ Printer.pr_type_env env sigma t in let matches mp = match match_modulepath ns mp with @@ -285,7 +314,7 @@ let print_namespace ns = Environ.fold_constants (fun c body acc -> let kn = Constant.user c in if matches (KerName.modpath kn) - then acc++fnl()++hov 2 (print_constant kn body) + then acc++fnl()++hov 2 (print_constant ~pstate kn body) else acc) (Global.env ()) (str"") in @@ -515,7 +544,7 @@ let () = (***********) (* Gallina *) -let start_proof_and_print ~program_mode ?hook k l = +let start_proof_and_print ~program_mode ~pstate ?hook k l = let inference_hook = if program_mode then let hook env sigma ev = @@ -537,7 +566,7 @@ let start_proof_and_print ~program_mode ?hook k l = in Some hook else None in - start_proof_com ~program_mode ?inference_hook ?hook k l + start_proof_com ~program_mode ~ontop:pstate ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> @@ -548,7 +577,7 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None -let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = +let vernac_definition ~atts ~pstate discharge kind ({loc;v=id}, pl) def = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in @@ -563,41 +592,47 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = let program_mode = atts.program in let name = match id with - | Anonymous -> fresh_name_for_anonymous_theorem () + | Anonymous -> fresh_name_for_anonymous_theorem ~pstate | Name n -> n in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print ~program_mode (local, atts.polymorphic, DefinitionBody kind) - ?hook [(CAst.make ?loc name, pl), (bl, t)] + Some (start_proof_and_print ~program_mode ~pstate (local, atts.polymorphic, DefinitionBody kind) + ?hook [(CAst.make ?loc name, pl), (bl, t)]) | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with - | None -> None - | Some r -> - let sigma, env = Pfedit.get_current_context () in - Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode name - (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook) - -let vernac_start_proof ~atts kind l = + | None -> None + | Some r -> + let sigma, env = get_current_or_global_context ~pstate in + Some (snd (Hook.get f_interp_redexp env sigma r)) in + ComDefinition.do_definition ~ontop:pstate ~program_mode name + (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook; + pstate + ) + +let vernac_start_proof ~atts ~pstate kind l = let open DefAttributes in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l + Some (start_proof_and_print ~pstate ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l) -let vernac_end_proof ?proof = function - | Admitted -> save_proof ?proof Admitted - | Proved (_,_) as e -> save_proof ?proof e +let vernac_end_proof ?pstate ?proof = function + | Admitted -> + vernac_require_open_proof ~pstate (save_proof_admitted ?proof); + pstate + | Proved (opaque,idopt) -> + save_proof_proved ?pstate ?proof ~opaque ~idopt -let vernac_exact_proof c = +let vernac_exact_proof ~pstate c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) - let status = Pfedit.by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Proof_global.Opaque,None))); - if not status then Feedback.feedback Feedback.AddedAxiom + let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in + let pstate = save_proof_proved ?proof:None ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate -let vernac_assumption ~atts discharge kind l nl = +let vernac_assumption ~atts ~pstate discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in @@ -607,7 +642,7 @@ let vernac_assumption ~atts discharge kind l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in + let status = ComAssumption.do_assumptions ~pstate ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let is_polymorphic_inductive_cumulativity = @@ -772,28 +807,28 @@ let vernac_inductive ~atts cum lo finite indl = in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] *) -let vernac_fixpoint ~atts discharge l = +let vernac_fixpoint ~atts ~pstate discharge l : Proof_global.t option = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; (* XXX: Switch to the attribute system and match on ~atts *) let do_fixpoint = if atts.program then - ComProgramFixpoint.do_fixpoint + fun local sign l -> ComProgramFixpoint.do_fixpoint local sign l; None else - ComFixpoint.do_fixpoint + ComFixpoint.do_fixpoint ~ontop:pstate in do_fixpoint local atts.polymorphic l -let vernac_cofixpoint ~atts discharge l = +let vernac_cofixpoint ~atts ~pstate discharge l = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; let do_cofixpoint = if atts.program then - ComProgramFixpoint.do_cofixpoint + fun local sign l -> ComProgramFixpoint.do_cofixpoint local sign l; None else - ComFixpoint.do_cofixpoint + ComFixpoint.do_cofixpoint ~ontop:pstate in do_cofixpoint local atts.polymorphic l @@ -851,14 +886,14 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export -let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = +let vernac_define_module ~pstate export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> - Proof_global.check_no_pending_proof (); + check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -898,13 +933,13 @@ let vernac_end_module export {loc;v=id} = Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export -let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = +let vernac_declare_module_type ~pstate {loc;v=id} binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with | [] -> - Proof_global.check_no_pending_proof (); + check_no_pending_proof ~pstate; let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -951,8 +986,8 @@ let vernac_include l = (* Sections *) -let vernac_begin_section ({v=id} as lid) = - Proof_global.check_no_pending_proof (); +let vernac_begin_section ~pstate ({v=id} as lid) = + check_no_pending_proof ~pstate; Dumpglob.dump_definition lid true "sec"; Lib.open_section id @@ -965,8 +1000,8 @@ let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) -let vernac_end_segment ({v=id} as lid) = - Proof_global.check_no_pending_proof (); +let vernac_end_segment ~pstate ({v=id} as lid) = + check_no_pending_proof ~pstate; match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1031,7 +1066,7 @@ let vernac_instance ~atts sup inst props pri = let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = atts.program in - ignore(Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri) + Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri let vernac_declare_instance ~atts sup inst pri = let open DefAttributes in @@ -1039,8 +1074,8 @@ let vernac_declare_instance ~atts sup inst pri = Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri -let vernac_context ~poly l = - if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~pstate ~poly l = + if not (Classes.context ~pstate poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_existing_instance ~section_local insts = let glob = not section_local in @@ -1061,21 +1096,19 @@ let focus_command_cond = Proof.no_cond command_focus there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) -let vernac_solve_existential = Pfedit.instantiate_nth_evar_com +let vernac_solve_existential ~pstate i e = Pfedit.instantiate_nth_evar_com i e pstate -let vernac_set_end_tac tac = +let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in - if not (Proof_global.there_are_pending_proofs ()) then - user_err Pp.(str "Unknown command of the non proof-editing mode."); - Proof_global.set_endline_tactic tac - (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables e = +let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = - List.map snd (initial_goals (Proof_global.give_me_the_proof ())) in + List.map snd (initial_goals (Proof_global.give_me_the_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1084,10 +1117,10 @@ let vernac_set_used_variables e = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - ignore (Proof_global.set_used_variables l); - Proof_global.with_current_proof begin fun _ p -> + let _, pstate = Proof_global.set_used_variables pstate l in + fst @@ Proof_global.with_current_proof begin fun _ p -> (p, ()) - end + end pstate (*****************************) (* Auxiliary file management *) @@ -1132,12 +1165,10 @@ let vernac_chdir = function (* State management *) let vernac_write_state file = - Proof_global.discard_all (); let file = CUnix.make_suffix file ".coq" in States.extern_state file let vernac_restore_state file = - Proof_global.discard_all (); let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in States.intern_state file @@ -1730,9 +1761,14 @@ let vernac_print_option key = try print_option_value key with Not_found -> error_undeclared_key key -let get_current_context_of_args = function - | Some n -> Pfedit.get_goal_context n - | None -> Pfedit.get_current_context () +let get_current_context_of_args ~pstate = + match pstate with + | None -> fun _ -> + let env = Global.env () in Evd.(from_env env, env) + | Some pstate -> + function + | Some n -> Pfedit.get_goal_context pstate n + | None -> Pfedit.get_current_context pstate let query_command_selector ?loc = function | None -> None @@ -1740,9 +1776,9 @@ let query_command_selector ?loc = function | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ~atts redexp glopt rc = +let vernac_check_may_eval ~pstate ~atts redexp glopt rc = let glopt = query_command_selector glopt in - let (sigma, env) = get_current_context_of_args glopt in + let sigma, env = get_current_context_of_args ~pstate glopt in let sigma, c = interp_open_constr env sigma rc in let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Evarconv.check_problems_are_solved env sigma; @@ -1796,27 +1832,33 @@ let vernac_global_check c = pr_universe_ctx_set sigma uctx -let get_nth_goal n = - let pf = Proof_global.give_me_the_proof() in +let get_nth_goal ~pstate n = + let pf = Proof_global.give_me_the_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl exception NoHyp + (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) -let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = +let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let open Context.Named.Declaration in try + (* Fallback early to globals *) + let pstate = match pstate with + | None -> raise Not_found + | Some pstate -> pstate + in (* FIXME error on non None udecl if we find the hyp. *) let glnumopt = query_command_selector ?loc glopt in let gl,id = match glnumopt, ref_or_by_not.v with | None,AN qid when qualid_is_ident qid -> (* goal number not given, catch any failure *) - (try get_nth_goal 1, qualid_basename qid with _ -> raise NoHyp) + (try get_nth_goal ~pstate 1, qualid_basename qid with _ -> raise NoHyp) | Some n,AN qid when qualid_is_ident qid -> (* goal number given, catch if wong *) - (try get_nth_goal n, qualid_basename qid + (try get_nth_goal ~pstate n, qualid_basename qid with Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) @@ -1826,15 +1868,16 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Pfedit.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> - let sigma, env = Pfedit.get_current_context () in + let sigma, env = get_current_or_global_context ~pstate in print_about env sigma ref_or_by_not udecl -let vernac_print ~atts env sigma = +let vernac_print ~(pstate : Proof_global.t option) ~atts = + let sigma, env = get_current_or_global_context ~pstate in function | PrintTables -> print_tables () | PrintFullContext-> print_full_context_typ env sigma @@ -1845,7 +1888,7 @@ let vernac_print ~atts env sigma = | PrintModules -> print_modules () | PrintModule qid -> print_module qid | PrintModuleType qid -> print_modtype qid - | PrintNamespace ns -> print_namespace ns + | PrintNamespace ns -> print_namespace ~pstate ns | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () | PrintDebugGC -> Mltop.print_gc () @@ -1862,7 +1905,13 @@ let vernac_print ~atts env sigma = | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) - | PrintHintGoal -> Hints.pr_applicable_hint () + | PrintHintGoal -> + begin match pstate with + | Some pstate -> + Hints.pr_applicable_hint pstate + | None -> + str "No proof in progress" + end | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma | PrintScopes -> @@ -1872,7 +1921,7 @@ let vernac_print ~atts env sigma = | PrintVisibility s -> Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> - print_about_hyp_globs ref_or_by_not udecl glnumopt + print_about_hyp_globs ~pstate ref_or_by_not udecl glnumopt | PrintImplicit qid -> dump_global qid; print_impargs qid @@ -1937,16 +1986,16 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let vernac_search ~atts s gopt r = +let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> (* 1st goal by default if it exists, otherwise no goal at all *) - (try snd (Pfedit.get_goal_context 1) , Some 1 + (try snd (get_goal_or_global_context ~pstate 1) , Some 1 with _ -> Global.env (),None) (* if goal selector is given and wrong, then let exceptions be raised. *) - | Some g -> snd (Pfedit.get_goal_context g) , Some g + | Some g -> snd (get_goal_or_global_context ~pstate g) , Some g in let get_pattern c = snd (intern_constr_pattern env Evd.(from_env env) c) in let pr_search ref env c = @@ -1961,21 +2010,21 @@ let vernac_search ~atts s gopt r = in match s with | SearchPattern c -> - (Search.search_pattern gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_pattern ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchRewrite c -> - (Search.search_rewrite gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> - (Search.search_by_head gopt (get_pattern c) r |> Search.prioritize_search) pr_search + (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchAbout sl -> - (Search.search_about gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> + (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search -let vernac_locate = function +let vernac_locate ~pstate = function | LocateAny {v=AN qid} -> print_located_qualid qid | LocateTerm {v=AN qid} -> print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> - let _, env = Pfedit.get_current_context () in + let _, env = get_current_or_global_context ~pstate in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc | LocateLibrary qid -> print_located_library qid @@ -1983,9 +2032,9 @@ let vernac_locate = function | LocateOther (s, qid) -> print_located_other s qid | LocateFile f -> locate_file f -let vernac_register qid r = +let vernac_register ~pstate qid r = let gr = Smartlocate.global_with_alias qid in - if Proof_global.there_are_pending_proofs () then + if there_are_pending_proofs ~pstate then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); match r with | RegisterInline -> @@ -2029,8 +2078,8 @@ let vernac_unfocus () = (fun _ p -> Proof.unfocus command_focus p ()) (* Checks that a proof is fully unfocused. Raises an error if not. *) -let vernac_unfocused () = - let p = Proof_global.give_me_the_proof () in +let vernac_unfocused ~pstate = + let p = Proof_global.give_me_the_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else @@ -2060,25 +2109,39 @@ let vernac_bullet (bullet : Proof_bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> Proof_bullet.put p bullet) -let vernac_show = function - | ShowScript -> assert false (* Only the stm knows the script *) - | ShowGoal goalref -> - let proof = Proof_global.give_me_the_proof () in - begin match goalref with - | OpenSubgoals -> pr_open_subgoals ~proof - | NthGoal n -> pr_nth_open_subgoal ~proof n - | GoalId id -> pr_goal_by_id ~proof id +let vernac_show ~pstate = + match pstate with + (* Show functions that don't require a proof state *) + | None -> + begin function + | ShowProof -> show_proof ~pstate + | ShowMatch id -> show_match id + | ShowScript -> assert false (* Only the stm knows the script *) + | _ -> + user_err (str "This command requires an open proof.") end - | ShowProof -> show_proof () - | ShowExistentials -> show_top_evars () - | ShowUniverses -> show_universes () - | ShowProofNames -> - pr_sequence Id.print (Proof_global.get_all_proof_names()) - | ShowIntros all -> show_intro all - | ShowMatch id -> show_match id - -let vernac_check_guard () = - let pts = Proof_global.give_me_the_proof () in + (* Show functions that require a proof state *) + | Some pstate -> + begin function + | ShowGoal goalref -> + let proof = Proof_global.give_me_the_proof pstate in + begin match goalref with + | OpenSubgoals -> pr_open_subgoals ~proof + | NthGoal n -> pr_nth_open_subgoal ~proof n + | GoalId id -> pr_goal_by_id ~proof id + end + | ShowExistentials -> show_top_evars ~pstate + | ShowUniverses -> show_universes ~pstate + | ShowProofNames -> + pr_sequence Id.print (Proof_global.get_all_proof_names pstate) + | ShowIntros all -> show_intro ~pstate all + | ShowProof -> show_proof ~pstate:(Some pstate) + | ShowMatch id -> show_match id + | ShowScript -> assert false (* Only the stm knows the script *) + end + +let vernac_check_guard ~pstate = + let pts = Proof_global.give_me_the_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try @@ -2097,8 +2160,9 @@ exception End_of_input the way the proof mode is set there makes the task non trivial without a considerable amount of refactoring. *) -let vernac_load interp fname = - if Proof_global.there_are_pending_proofs () then +let vernac_load ~st interp fname = + let pstate = st.Vernacstate.proof in + if there_are_pending_proofs ~pstate then CErrors.user_err Pp.(str "Load is not supported inside proofs."); let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing (fun po -> @@ -2111,22 +2175,22 @@ let vernac_load interp fname = let input = let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in - Pcoq.Parsable.make ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in - begin - try while true do - let proof_mode = - if Proof_global.there_are_pending_proofs () then - Some (get_default_proof_mode ()) - else - None - in - interp (parse_sentence proof_mode input).CAst.v; - done - with End_of_input -> () - end; + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile longfname)) (Stream.of_channel in_chan) in + let rec load_loop ~pstate = + try + let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) pstate in + let pstate = interp ~st:{ st with Vernacstate.proof = pstate } + (parse_sentence proof_mode input).CAst.v in + load_loop ~pstate + with + End_of_input -> + pstate + in + let pstate = load_loop ~pstate in (* If Load left a proof open, we fail too. *) - if Proof_global.there_are_pending_proofs () then - CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs.") + if there_are_pending_proofs ~pstate then + CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); + pstate let with_locality ~atts f = let local = Attributes.(parse locality atts) in @@ -2151,7 +2215,8 @@ let with_def_attributes ~atts f = * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ~atts ~st c = +let interp ?proof ~atts ~st c : Proof_global.t option = + let pstate = st.Vernacstate.proof in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2175,145 +2240,309 @@ let interp ?proof ~atts ~st c = (* Syntax *) | VernacSyntaxExtension (infix, sl) -> - with_module_locality ~atts vernac_syntax_extension infix sl - | VernacDeclareScope sc -> with_module_locality ~atts vernac_declare_scope sc - | VernacDelimiters (sc,lr) -> with_module_locality ~atts vernac_delimiters sc lr - | VernacBindScope (sc,rl) -> with_module_locality ~atts vernac_bind_scope sc rl - | VernacOpenCloseScope (b, s) -> with_section_locality ~atts vernac_open_close_scope (b,s) - | VernacInfix (mv,qid,sc) -> with_module_locality ~atts vernac_infix mv qid sc - | VernacNotation (c,infpl,sc) -> with_module_locality ~atts vernac_notation c infpl sc + with_module_locality ~atts vernac_syntax_extension infix sl; + pstate + | VernacDeclareScope sc -> + with_module_locality ~atts vernac_declare_scope sc; + pstate + | VernacDelimiters (sc,lr) -> + with_module_locality ~atts vernac_delimiters sc lr; + pstate + | VernacBindScope (sc,rl) -> + with_module_locality ~atts vernac_bind_scope sc rl; + pstate + | VernacOpenCloseScope (b, s) -> + with_section_locality ~atts vernac_open_close_scope (b,s); + pstate + | VernacInfix (mv,qid,sc) -> + with_module_locality ~atts vernac_infix mv qid sc; + pstate + | VernacNotation (c,infpl,sc) -> + with_module_locality ~atts vernac_notation c infpl sc; + pstate | VernacNotationAddFormat(n,k,v) -> unsupported_attributes atts; - Metasyntax.add_notation_extra_printing_rule n k v + Metasyntax.add_notation_extra_printing_rule n k v; + pstate | VernacDeclareCustomEntry s -> - with_module_locality ~atts vernac_custom_entry s + with_module_locality ~atts vernac_custom_entry s; + pstate (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> - with_def_attributes ~atts vernac_definition discharge kind lid d - | VernacStartTheoremProof (k,l) -> with_def_attributes vernac_start_proof ~atts k l - | VernacEndProof e -> unsupported_attributes atts; vernac_end_proof ?proof e - | VernacExactProof c -> unsupported_attributes atts; vernac_exact_proof c + with_def_attributes ~atts vernac_definition ~pstate discharge kind lid d + | VernacStartTheoremProof (k,l) -> + with_def_attributes ~atts vernac_start_proof ~pstate k l + | VernacEndProof e -> + unsupported_attributes atts; + vernac_end_proof ?proof ?pstate e + | VernacExactProof c -> + unsupported_attributes atts; + vernac_require_open_proof ~pstate (vernac_exact_proof c) | VernacAssumption ((discharge,kind),nl,l) -> - with_def_attributes vernac_assumption ~atts discharge kind l nl - | VernacInductive (cum, priv, finite, l) -> vernac_inductive ~atts cum priv finite l - | VernacFixpoint (discharge, l) -> with_def_attributes vernac_fixpoint ~atts discharge l - | VernacCoFixpoint (discharge, l) -> with_def_attributes vernac_cofixpoint ~atts discharge l - | VernacScheme l -> unsupported_attributes atts; vernac_scheme l - | VernacCombinedScheme (id, l) -> unsupported_attributes atts; vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe ~poly:(only_polymorphism atts) l - | VernacConstraint l -> vernac_constraint ~poly:(only_polymorphism atts) l + with_def_attributes ~atts vernac_assumption ~pstate discharge kind l nl; + pstate + | VernacInductive (cum, priv, finite, l) -> + vernac_inductive ~atts cum priv finite l; + pstate + | VernacFixpoint (discharge, l) -> + with_def_attributes ~atts vernac_fixpoint ~pstate discharge l + | VernacCoFixpoint (discharge, l) -> + with_def_attributes ~atts vernac_cofixpoint ~pstate discharge l + | VernacScheme l -> + unsupported_attributes atts; + vernac_scheme l; + pstate + | VernacCombinedScheme (id, l) -> + unsupported_attributes atts; + vernac_combined_scheme id l; + pstate + | VernacUniverse l -> + vernac_universe ~poly:(only_polymorphism atts) l; + pstate + | VernacConstraint l -> + vernac_constraint ~poly:(only_polymorphism atts) l; + pstate (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> - unsupported_attributes atts; vernac_declare_module export lid bl mtyo + unsupported_attributes atts; + vernac_declare_module export lid bl mtyo; + pstate | VernacDefineModule (export,lid,bl,mtys,mexprl) -> - unsupported_attributes atts; vernac_define_module export lid bl mtys mexprl + unsupported_attributes atts; + vernac_define_module ~pstate export lid bl mtys mexprl; + pstate | VernacDeclareModuleType (lid,bl,mtys,mtyo) -> - unsupported_attributes atts; vernac_declare_module_type lid bl mtys mtyo + unsupported_attributes atts; + vernac_declare_module_type ~pstate lid bl mtys mtyo; + pstate | VernacInclude in_asts -> - unsupported_attributes atts; vernac_include in_asts + unsupported_attributes atts; + vernac_include in_asts; + pstate (* Gallina extensions *) - | VernacBeginSection lid -> unsupported_attributes atts; vernac_begin_section lid + | VernacBeginSection lid -> + unsupported_attributes atts; + vernac_begin_section ~pstate lid; + pstate - | VernacEndSegment lid -> unsupported_attributes atts; vernac_end_segment lid + | VernacEndSegment lid -> + unsupported_attributes atts; + vernac_end_segment ~pstate lid; + pstate - | VernacNameSectionHypSet (lid, set) -> unsupported_attributes atts; vernac_name_sec_hyp lid set + | VernacNameSectionHypSet (lid, set) -> + unsupported_attributes atts; + vernac_name_sec_hyp lid set; + pstate - | VernacRequire (from, export, qidl) -> unsupported_attributes atts; vernac_require from export qidl - | VernacImport (export,qidl) -> unsupported_attributes atts; vernac_import export qidl - | VernacCanonical qid -> unsupported_attributes atts; vernac_canonical qid - | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t + | VernacRequire (from, export, qidl) -> + unsupported_attributes atts; + vernac_require from export qidl; + pstate + | VernacImport (export,qidl) -> + unsupported_attributes atts; + vernac_import export qidl; + pstate + | VernacCanonical qid -> + unsupported_attributes atts; + vernac_canonical qid; + pstate + | VernacCoercion (r,s,t) -> + vernac_coercion ~atts r s t; + pstate | VernacIdentityCoercion ({v=id},s,t) -> - vernac_identity_coercion ~atts id s t + vernac_identity_coercion ~atts id s t; + pstate (* Type classes *) | VernacInstance (sup, inst, props, info) -> - with_def_attributes vernac_instance ~atts sup inst props info + snd @@ with_def_attributes ~atts (vernac_instance ~pstate sup inst props info) | VernacDeclareInstance (sup, inst, info) -> - with_def_attributes vernac_declare_instance ~atts sup inst info - | VernacContext sup -> vernac_context ~poly:(only_polymorphism atts) sup - | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts - | VernacExistingClass id -> unsupported_attributes atts; vernac_existing_class id + with_def_attributes ~atts vernac_declare_instance sup inst info; + pstate + | VernacContext sup -> + let () = vernac_context ~pstate ~poly:(only_polymorphism atts) sup in + pstate + | VernacExistingInstance insts -> + with_section_locality ~atts vernac_existing_instance insts; + pstate + | VernacExistingClass id -> + unsupported_attributes atts; + vernac_existing_class id; + pstate (* Solving *) - | VernacSolveExistential (n,c) -> unsupported_attributes atts; vernac_solve_existential n c + | VernacSolveExistential (n,c) -> + unsupported_attributes atts; + Some (vernac_require_open_proof ~pstate (vernac_solve_existential n c)) (* Auxiliary file and library management *) - | VernacAddLoadPath (isrec,s,alias) -> unsupported_attributes atts; vernac_add_loadpath isrec s alias - | VernacRemoveLoadPath s -> unsupported_attributes atts; vernac_remove_loadpath s - | VernacAddMLPath (isrec,s) -> unsupported_attributes atts; vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> with_locality ~atts vernac_declare_ml_module l - | VernacChdir s -> unsupported_attributes atts; vernac_chdir s + | VernacAddLoadPath (isrec,s,alias) -> + unsupported_attributes atts; + vernac_add_loadpath isrec s alias; + pstate + | VernacRemoveLoadPath s -> + unsupported_attributes atts; + vernac_remove_loadpath s; + pstate + | VernacAddMLPath (isrec,s) -> + unsupported_attributes atts; + vernac_add_ml_path isrec s; + pstate + | VernacDeclareMLModule l -> + with_locality ~atts vernac_declare_ml_module l; + pstate + | VernacChdir s -> + unsupported_attributes atts; + vernac_chdir s; + pstate (* State management *) - | VernacWriteState s -> unsupported_attributes atts; vernac_write_state s - | VernacRestoreState s -> unsupported_attributes atts; vernac_restore_state s + | VernacWriteState s -> + unsupported_attributes atts; + vernac_write_state s; + pstate + | VernacRestoreState s -> + unsupported_attributes atts; + vernac_restore_state s; + pstate (* Commands *) | VernacCreateHintDb (dbname,b) -> - with_module_locality ~atts vernac_create_hintdb dbname b + with_module_locality ~atts vernac_create_hintdb dbname b; + pstate | VernacRemoveHints (dbnames,ids) -> - with_module_locality ~atts vernac_remove_hints dbnames ids + with_module_locality ~atts vernac_remove_hints dbnames ids; + pstate | VernacHints (dbnames,hints) -> - vernac_hints ~atts dbnames hints + vernac_hints ~atts dbnames hints; + pstate | VernacSyntacticDefinition (id,c,b) -> - with_module_locality ~atts vernac_syntactic_definition id c b + with_module_locality ~atts vernac_syntactic_definition id c b; + pstate | VernacArguments (qid, args, more_implicits, nargs, flags) -> - with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags - | VernacReserve bl -> unsupported_attributes atts; vernac_reserve bl - | VernacGeneralizable gen -> with_locality ~atts vernac_generalizable gen - | VernacSetOpacity qidl -> with_locality ~atts vernac_set_opacity qidl - | VernacSetStrategy l -> with_locality ~atts vernac_set_strategy l - | VernacSetOption (export, key,v) -> vernac_set_option ~local:(only_locality atts) export key v - | VernacUnsetOption (export, key) -> vernac_unset_option ~local:(only_locality atts) export key - | VernacRemoveOption (key,v) -> unsupported_attributes atts; vernac_remove_option key v - | VernacAddOption (key,v) -> unsupported_attributes atts; vernac_add_option key v - | VernacMemOption (key,v) -> unsupported_attributes atts; vernac_mem_option key v - | VernacPrintOption key -> unsupported_attributes atts; vernac_print_option key + with_section_locality ~atts vernac_arguments qid args more_implicits nargs flags; + pstate + | VernacReserve bl -> + unsupported_attributes atts; + vernac_reserve bl; + pstate + | VernacGeneralizable gen -> + with_locality ~atts vernac_generalizable gen; + pstate + | VernacSetOpacity qidl -> + with_locality ~atts vernac_set_opacity qidl; + pstate + | VernacSetStrategy l -> + with_locality ~atts vernac_set_strategy l; + pstate + | VernacSetOption (export, key,v) -> + vernac_set_option ~local:(only_locality atts) export key v; + pstate + | VernacUnsetOption (export, key) -> + vernac_unset_option ~local:(only_locality atts) export key; + pstate + | VernacRemoveOption (key,v) -> + unsupported_attributes atts; + vernac_remove_option key v; + pstate + | VernacAddOption (key,v) -> + unsupported_attributes atts; + vernac_add_option key v; + pstate + | VernacMemOption (key,v) -> + unsupported_attributes atts; + vernac_mem_option key v; + pstate + | VernacPrintOption key -> + unsupported_attributes atts; + vernac_print_option key; + pstate | VernacCheckMayEval (r,g,c) -> - Feedback.msg_notice @@ vernac_check_may_eval ~atts r g c - | VernacDeclareReduction (s,r) -> with_locality ~atts vernac_declare_reduction s r + Feedback.msg_notice @@ + vernac_check_may_eval ~pstate ~atts r g c; + pstate + | VernacDeclareReduction (s,r) -> + with_locality ~atts vernac_declare_reduction s r; + pstate | VernacGlobalCheck c -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_global_check c + Feedback.msg_notice @@ vernac_global_check c; + pstate | VernacPrint p -> - let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice @@ vernac_print ~atts env sigma p - | VernacSearch (s,g,r) -> unsupported_attributes atts; vernac_search ~atts s g r + Feedback.msg_notice @@ vernac_print ~pstate ~atts p; + pstate + | VernacSearch (s,g,r) -> + unsupported_attributes atts; + vernac_search ~pstate ~atts s g r; + pstate | VernacLocate l -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_locate l - | VernacRegister (qid, r) -> unsupported_attributes atts; vernac_register qid r - | VernacPrimitive (id, prim, typopt) -> unsupported_attributes atts; ComAssumption.do_primitive id prim typopt - | VernacComments l -> unsupported_attributes atts; - Flags.if_verbose Feedback.msg_info (str "Comments ok\n") + Feedback.msg_notice @@ vernac_locate ~pstate l; + pstate + | VernacRegister (qid, r) -> + unsupported_attributes atts; + vernac_register ~pstate qid r; + pstate + | VernacPrimitive (id, prim, typopt) -> + unsupported_attributes atts; + ComAssumption.do_primitive id prim typopt; + pstate + | VernacComments l -> + unsupported_attributes atts; + Flags.if_verbose Feedback.msg_info (str "Comments ok\n"); + pstate (* Proof management *) - | VernacFocus n -> unsupported_attributes atts; vernac_focus n - | VernacUnfocus -> unsupported_attributes atts; vernac_unfocus () - | VernacUnfocused -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_unfocused () - | VernacBullet b -> unsupported_attributes atts; vernac_bullet b - | VernacSubproof n -> unsupported_attributes atts; vernac_subproof n - | VernacEndSubproof -> unsupported_attributes atts; vernac_end_subproof () - | VernacShow s -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_show s - | VernacCheckGuard -> unsupported_attributes atts; - Feedback.msg_notice @@ vernac_check_guard () - | VernacProof (tac, using) -> unsupported_attributes atts; + | VernacFocus n -> + unsupported_attributes atts; + Option.map (vernac_focus n) pstate + | VernacUnfocus -> + unsupported_attributes atts; + Option.map (vernac_unfocus ()) pstate + | VernacUnfocused -> + unsupported_attributes atts; + Option.iter (fun pstate -> Feedback.msg_notice @@ vernac_unfocused ~pstate) pstate; + pstate + | VernacBullet b -> + unsupported_attributes atts; + Option.map (vernac_bullet b) pstate + | VernacSubproof n -> + unsupported_attributes atts; + Option.map (vernac_subproof n) pstate + | VernacEndSubproof -> + unsupported_attributes atts; + Option.map (vernac_end_subproof ()) pstate + | VernacShow s -> + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_show ~pstate s; + pstate + | VernacCheckGuard -> + unsupported_attributes atts; + Feedback.msg_notice @@ + vernac_require_open_proof ~pstate (vernac_check_guard); + pstate + | VernacProof (tac, using) -> + unsupported_attributes atts; let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); - Option.iter vernac_set_end_tac tac; - Option.iter vernac_set_used_variables using - | VernacProofMode mn -> unsupported_attributes atts; () + let pstate = + vernac_require_open_proof ~pstate (fun ~pstate -> + let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in + Option.cata (vernac_set_used_variables ~pstate) pstate using) + in Some pstate + | VernacProofMode mn -> + unsupported_attributes atts; + pstate (* Extensions *) | VernacExtend (opn,args) -> (* XXX: Here we are returning the state! :) *) - let _st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in - () + let st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in + st.Vernacstate.proof (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2333,12 +2562,18 @@ let () = let current_timeout = ref None -let vernac_timeout f = +let vernac_timeout (f : 'a -> 'b) (x : 'a) : 'b = match !current_timeout, !default_timeout with - | Some n, _ | None, Some n -> - let f () = f (); current_timeout := None in - Control.timeout n f () Timeout - | None, None -> f () + | Some n, _ + | None, Some n -> + let f v = + let res = f v in + current_timeout := None; + res + in + Control.timeout n f x Timeout + | None, None -> + f x let restore_timeout () = current_timeout := None @@ -2354,84 +2589,87 @@ let test_mode = ref false (* XXX STATE: this type hints that restoring the state should be the caller's responsibility *) -let with_fail st b f = - if not b - then f () - else begin try - (* If the command actually works, ignore its effects on the state. +let with_fail ~st f = + try + (* If the command actually works, ignore its effects on the state. * Note that error has to be printed in the right state, hence * within the purified function *) - try f (); raise HasNotFailed - with - | HasNotFailed as e -> raise e - | e -> - let e = CErrors.push e in - raise (HasFailed (CErrors.iprint - (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) - with e when CErrors.noncritical e -> - (* Restore the previous state XXX Careful here with the cache! *) - Vernacstate.invalidate_cache (); - Vernacstate.unfreeze_interp_state st; - let (e, _) = CErrors.push e in - match e with - | HasNotFailed -> - user_err ~hdr:"Fail" (str "The command has not failed!") - | HasFailed msg -> - if not !Flags.quiet || !test_mode then Feedback.msg_info - (str "The command has indeed failed with message:" ++ fnl () ++ msg) - | _ -> assert false - end - -let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = - let rec control = function + try let _ = f () in raise HasNotFailed + with + | HasNotFailed as e -> raise e + | e -> + let e = CErrors.push e in + raise (HasFailed (CErrors.iprint + (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) + with e when CErrors.noncritical e -> + (* Restore the previous state XXX Careful here with the cache! *) + Vernacstate.invalidate_cache (); + Vernacstate.unfreeze_interp_state st; + let (e, _) = CErrors.push e in + match e with + | HasNotFailed -> + user_err ~hdr:"Fail" (str "The command has not failed!") + | HasFailed msg -> + if not !Flags.quiet || !test_mode then Feedback.msg_info + (str "The command has indeed failed with message:" ++ fnl () ++ msg) + | _ -> assert false + +let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} : Proof_global.t option = + let rec control ~st = function | VernacExpr (atts, v) -> - aux ~atts v - | VernacFail v -> with_fail st true (fun () -> control v) + aux ~atts ~st v + | VernacFail v -> + with_fail ~st (fun () -> ignore(control ~st v)); + st.Vernacstate.proof | VernacTimeout (n,v) -> current_timeout := Some n; - control v + control ~st v | VernacRedirect (s, {v}) -> - Topfmt.with_output_to_file s control v - | VernacTime (batch, com) -> + Topfmt.with_output_to_file s (control ~st) v + | VernacTime (batch, ({v} as com)) -> let header = if batch then Topfmt.pr_cmd_header com else Pp.mt () in - System.with_time ~batch ~header control com.CAst.v; + System.with_time ~batch ~header (control ~st) v; - and aux ~atts : _ -> unit = + and aux ~atts ~st : _ -> Proof_global.t option = function | VernacLoad (_,fname) -> unsupported_attributes atts; - vernac_load control fname + vernac_load ~st control fname | c -> (* NB: we keep polymorphism and program in the attributes, we're just parsing them to do our option magic. *) try - vernac_timeout begin fun () -> - if verbosely - then Flags.verbosely (interp ?proof ~atts ~st) c - else Flags.silently (interp ?proof ~atts ~st) c; - end - with - | reraise when - (match reraise with - | Timeout -> true - | e -> CErrors.noncritical e) - -> - let e = CErrors.push reraise in - let e = locate_if_not_already ?loc e in - let () = restore_timeout () in - iraise e + vernac_timeout begin fun st -> + let pstate : Proof_global.t option = + if verbosely + then Flags.verbosely (interp ?proof ~atts ~st) c + else Flags.silently (interp ?proof ~atts ~st) c + in + pstate + end st + with + | reraise when + (match reraise with + | Timeout -> true + | e -> CErrors.noncritical e) + -> + let e = CErrors.push reraise in + let e = locate_if_not_already ?loc e in + let () = restore_timeout () in + iraise e in if verbosely - then Flags.verbosely control c - else control c + then Flags.verbosely (control ~st) c + else (control ~st) c (* Be careful with the cache here in case of an exception. *) let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try - interp ?verbosely ?proof ~st cmd; + let pstate = interp ?verbosely ?proof ~st cmd in + Vernacstate.Proof_global.set pstate; Vernacstate.freeze_interp_state ~marshallable:false with exn -> let exn = CErrors.push exn in diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index f43cec48e9..71cc29b6e1 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -33,15 +33,17 @@ val interp : val make_cases : string -> string list list -(* XXX STATE: this type hints that restoring the state should be the - caller's responsibility *) -val with_fail : Vernacstate.t -> bool -> (unit -> unit) -> unit +(** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) +val with_fail : st:Vernacstate.t -> (unit -> 'a) -> unit val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t +(** Helper *) +val vernac_require_open_proof : pstate:Proof_global.t option -> (pstate:Proof_global.t -> 'a) -> 'a + (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 4bfe5c66b5..ef06e59316 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -169,7 +169,7 @@ let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_comm | Some Refl -> untype_command ty (f v) args end -let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Extend.norec, a) Extend.symbol = let open Extend in function | TUlist1 l -> Alist1 (untype_user_symbol l) | TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index c691dc8559..77f54361da 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -28,10 +28,10 @@ module Parser = struct end type t = { - parsing: Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool; (* is the state trimmed down (libstack) *) + parsing : Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t option; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } let s_cache = ref None @@ -55,14 +55,14 @@ let do_if_not_cached rf f v = let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); - proof = update_cache s_proof (Proof_global.freeze ~marshallable); + proof = !s_proof; shallow = false; parsing = Parser.cur_state (); } let unfreeze_interp_state { system; proof; parsing } = do_if_not_cached s_cache States.unfreeze system; - do_if_not_cached s_proof Proof_global.unfreeze proof; + s_proof := proof; Pcoq.unfreeze parsing let make_shallow st = @@ -71,3 +71,75 @@ let make_shallow st = system = States.replace_lib st.system @@ Lib.drop_objects lib; shallow = true; } + +(* Compatibility module *) +module Proof_global = struct + + let get () = !s_proof + let set x = s_proof := x + + let freeze ~marshallable:_ = get () + let unfreeze x = s_proof := Some x + + exception NoCurrentProof + + let () = + CErrors.register_handler begin function + | NoCurrentProof -> + CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") + | _ -> raise CErrors.Unhandled + end + + open Proof_global + + let cc f = match !s_proof with + | None -> raise NoCurrentProof + | Some x -> f x + + let dd f = match !s_proof with + | None -> raise NoCurrentProof + | Some x -> s_proof := Some (f x) + + let there_are_pending_proofs () = !s_proof <> None + let get_open_goals () = cc get_open_goals + + let set_terminator x = dd (set_terminator x) + let give_me_the_proof_opt () = Option.map give_me_the_proof !s_proof + let give_me_the_proof () = cc give_me_the_proof + let get_current_proof_name () = cc get_current_proof_name + + let simple_with_current_proof f = + dd (simple_with_current_proof f) + + let with_current_proof f = + let pf, res = cc (with_current_proof f) in + s_proof := Some pf; res + + let install_state s = s_proof := Some s + + let return_proof ?allow_partial () = + cc (return_proof ?allow_partial) + + let close_future_proof ~opaque ~feedback_id pf = + cc (fun st -> close_future_proof ~opaque ~feedback_id st pf) + + let close_proof ~opaque ~keep_body_ucst_separate f = + cc (close_proof ~opaque ~keep_body_ucst_separate f) + + let discard_all () = s_proof := None + let update_global_env () = dd update_global_env + + let get_current_context () = cc Pfedit.get_current_context + + let get_all_proof_names () = + try cc get_all_proof_names + with NoCurrentProof -> [] + + let copy_terminators ~src ~tgt = + match src, tgt with + | None, None -> None + | Some _ , None -> None + | None, Some x -> Some x + | Some src, Some tgt -> Some (copy_terminators ~src ~tgt) + +end diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 581c23386a..b79f97796f 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -19,10 +19,10 @@ module Parser : sig end type t = { - parsing: Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool; (* is the state trimmed down (libstack) *) + parsing : Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t option; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } val freeze_interp_state : marshallable:bool -> t @@ -32,3 +32,53 @@ val make_shallow : t -> t (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit + +(* Compatibility module: Do Not Use *) +module Proof_global : sig + + open Proof_global + + (* Low-level stuff *) + val get : unit -> t option + val set : t option -> unit + + val freeze : marshallable:bool -> t option + val unfreeze : t -> unit + + exception NoCurrentProof + + val there_are_pending_proofs : unit -> bool + val get_open_goals : unit -> int + + val set_terminator : proof_terminator -> unit + val give_me_the_proof : unit -> Proof.t + val give_me_the_proof_opt : unit -> Proof.t option + val get_current_proof_name : unit -> Names.Id.t + + val simple_with_current_proof : + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit + + val with_current_proof : + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a + + val install_state : t -> unit + + val return_proof : ?allow_partial:bool -> unit -> closed_proof_output + + val close_future_proof : + opaque:opacity_flag -> + feedback_id:Stateid.t -> + closed_proof_output Future.computation -> closed_proof + + val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + + val discard_all : unit -> unit + val update_global_env : unit -> unit + + val get_current_context : unit -> Evd.evar_map * Environ.env + + val get_all_proof_names : unit -> Names.Id.t list + + val copy_terminators : src:t option -> tgt:t option -> t option + +end |